| 1 | ;; Copyright (C) 2005 Vesa Karvonen |
| 2 | ;; |
| 3 | ;; MLton is released under a BSD-style license. |
| 4 | ;; See the file MLton-LICENSE for details. |
| 5 | |
| 6 | (require 'esml-util) |
| 7 | |
| 8 | ;; Installation |
| 9 | ;; ============ |
| 10 | ;; |
| 11 | ;; Push the path to this file (and `esml-util.el') to `load-path' and use |
| 12 | ;; (require 'esml-gen). |
| 13 | ;; |
| 14 | ;; Ideas for future development |
| 15 | ;; ============================ |
| 16 | ;; |
| 17 | ;; - ? |
| 18 | |
| 19 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 20 | |
| 21 | (defgroup esml-gen nil |
| 22 | "Code generation functions for Standard ML." |
| 23 | :group 'sml) |
| 24 | |
| 25 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 26 | ;; Prelude |
| 27 | |
| 28 | ;; TBD: Consider moving these to another place if/when it makes sense. |
| 29 | |
| 30 | (defun esml-extract-field-names (pattern-or-type) |
| 31 | (let ((fields nil)) |
| 32 | (with-temp-buffer |
| 33 | (insert pattern-or-type) |
| 34 | (goto-char 0) |
| 35 | (skip-chars-forward " \t\n{},") |
| 36 | (while (not (eobp)) |
| 37 | (let ((start (point))) |
| 38 | (if (find (char-after) esml-sml-symbolic-chars) |
| 39 | (skip-chars-forward esml-sml-symbolic-chars) |
| 40 | (skip-chars-forward esml-sml-alphanumeric-chars)) |
| 41 | (push (buffer-substring start (point)) fields)) |
| 42 | (skip-chars-forward " \t\n") |
| 43 | (when (and (not (eobp)) |
| 44 | (= ?\: (char-after))) |
| 45 | (let ((open-parens 0)) |
| 46 | (while (not (or (eobp) |
| 47 | (and (zerop open-parens) |
| 48 | (= ?\, (char-after))))) |
| 49 | (cond ((or (= ?\( (char-after)) |
| 50 | (= ?\{ (char-after))) |
| 51 | (setq open-parens (1+ open-parens))) |
| 52 | ((or (= ?\) (char-after)) |
| 53 | (= ?\} (char-after))) |
| 54 | (setq open-parens (1- open-parens)))) |
| 55 | (forward-char 1) |
| 56 | (skip-chars-forward "^,(){}")))) |
| 57 | (skip-chars-forward " \t\n{},"))) |
| 58 | fields)) |
| 59 | |
| 60 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 61 | ;; Functional Record Update (see http://mlton.org/FunctionalRecordUpdate) |
| 62 | |
| 63 | (defcustom esml-gen-fru-setter-template |
| 64 | '("fun set f =\nlet\nfun t2r (%1) = {%2}\nfun r2t {%3} = (%4) |
| 65 | in\nRecords.wrapSet (Tuples.set%n, t2r, t2r, r2t) f\nend\n" |
| 66 | "v%i, " |
| 67 | "%f = v%i, " |
| 68 | "%f = v%i, " |
| 69 | "v%i, ") |
| 70 | "Template for `esml-gen-fru-setter'. Indentation is automatic. The last |
| 71 | two characters of a pattern are deleted at the end." |
| 72 | :type '(list :tag "Template" |
| 73 | (string :tag "Code (`%1' = 1., `%2' = 2., ..., `%n' = n)") |
| 74 | (string :tag "1. pattern (`%i' = index, `%f' = field)") |
| 75 | (string :tag "2. pattern (`%i' = index, `%f' = field)") |
| 76 | (string :tag "3. pattern (`%i' = index, `%f' = field)") |
| 77 | (string :tag "4. pattern (`%i' = index, `%f' = field)")) |
| 78 | :group 'esml-gen) |
| 79 | |
| 80 | (defun esml-gen-fru-setter (pattern-or-type) |
| 81 | "Generates a functional record update function. The parameter must be in |
| 82 | the format `[{]id[: ty][,] ...[,] id[}]' where `[]' marks optional parts." |
| 83 | (interactive "sSimple record pattern or type: ") |
| 84 | (let* ((fields (esml-extract-field-names pattern-or-type)) |
| 85 | (n (length fields))) |
| 86 | (if (< n 2) |
| 87 | (compat-error "%s" "Record must have at least two fields") |
| 88 | (let ((fields (sort fields 'string-lessp)) |
| 89 | (start (point))) |
| 90 | (labels ((format-fields |
| 91 | (fmt) |
| 92 | (with-temp-buffer |
| 93 | (loop |
| 94 | for f in fields |
| 95 | for i from 1 to n |
| 96 | do (insert |
| 97 | (let* ((result fmt) |
| 98 | (result (compat-replace-regexp-in-string |
| 99 | result "\\%f" f)) |
| 100 | (result (compat-replace-regexp-in-string |
| 101 | result "\\%i" (int-to-string i)))) |
| 102 | result))) |
| 103 | (delete-char -2) ;; TBD |
| 104 | (buffer-string)))) |
| 105 | (insert |
| 106 | (let* ((result (nth 0 esml-gen-fru-setter-template)) |
| 107 | (result (compat-replace-regexp-in-string |
| 108 | result "%1" (format-fields (nth 1 esml-gen-fru-setter-template)))) |
| 109 | (result (compat-replace-regexp-in-string |
| 110 | result "%2" (format-fields (nth 2 esml-gen-fru-setter-template)))) |
| 111 | (result (compat-replace-regexp-in-string |
| 112 | result "%3" (format-fields (nth 3 esml-gen-fru-setter-template)))) |
| 113 | (result (compat-replace-regexp-in-string |
| 114 | result "%4" (format-fields (nth 4 esml-gen-fru-setter-template)))) |
| 115 | (result (compat-replace-regexp-in-string |
| 116 | result "%n" (int-to-string n)))) |
| 117 | result)) |
| 118 | (indent-region start (point) nil)))))) |
| 119 | |
| 120 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 121 | ;; Functional Tuple Update (see http://mlton.org/FunctionalRecordUpdate) |
| 122 | |
| 123 | (defcustom esml-gen-ftu-setters-template |
| 124 | '("fun set%n f v (%1) =\nlet\ndatatype (%2) t =\n%3 |
| 125 | fun g h v =\n(%4)\nin\nf (%5) v\nend\n" |
| 126 | "v%i, " |
| 127 | "'v%i, " |
| 128 | " V%i of 'v%i |" |
| 129 | "case h v of V%i v%i => v%i | _ => v%i,\n" |
| 130 | "g V%i, ") |
| 131 | "Template for `esml-gen-ftu-setters'. Indentation is automatic. The last |
| 132 | two characters of a pattern are deleted at the end." |
| 133 | :type '(list :tag "Format" |
| 134 | (string :tag "Code (`%1' = 1., `%2' = 2., ..., `%n' = n)") |
| 135 | (string :tag "1. pattern (`%i' = index)") |
| 136 | (string :tag "2. pattern (`%i' = index)") |
| 137 | (string :tag "3. pattern (`%i' = index)") |
| 138 | (string :tag "4. pattern (`%i' = index)") |
| 139 | (string :tag "5. pattern (`%i' = index)")) |
| 140 | :group 'esml-gen) |
| 141 | |
| 142 | (defun esml-gen-ftu-setters (n) |
| 143 | "Generates functional tuple update, or `set<N>', functions." |
| 144 | (interactive "nMaximum number of fields [2-100]: ") |
| 145 | (if (not (and (<= 2 n) |
| 146 | (<= n 100))) |
| 147 | (compat-error "%s" "Number of fields must be between 2 and 100") |
| 148 | (labels ((format-fields |
| 149 | (fmt n) |
| 150 | (with-temp-buffer |
| 151 | (loop for i from 1 to n |
| 152 | do (insert |
| 153 | (let* ((result fmt) |
| 154 | (result (compat-replace-regexp-in-string |
| 155 | result "%i" (int-to-string i)))) |
| 156 | result))) |
| 157 | (delete-char -2) ;; TBD |
| 158 | (buffer-string)))) |
| 159 | (let ((start (point))) |
| 160 | (loop for i from 2 to n do |
| 161 | (unless (= i 2) |
| 162 | (insert "\n")) |
| 163 | (insert |
| 164 | (let* ((result (nth 0 esml-gen-ftu-setters-template)) |
| 165 | (result (compat-replace-regexp-in-string |
| 166 | result "%1" (format-fields (nth 1 esml-gen-ftu-setters-template) i))) |
| 167 | (result (compat-replace-regexp-in-string |
| 168 | result "%2" (format-fields (nth 2 esml-gen-ftu-setters-template) i))) |
| 169 | (result (compat-replace-regexp-in-string |
| 170 | result "%3" (format-fields (nth 3 esml-gen-ftu-setters-template) i))) |
| 171 | (result (compat-replace-regexp-in-string |
| 172 | result "%4" (format-fields (nth 4 esml-gen-ftu-setters-template) i))) |
| 173 | (result (compat-replace-regexp-in-string |
| 174 | result "%5" (format-fields (nth 5 esml-gen-ftu-setters-template) i))) |
| 175 | (result (compat-replace-regexp-in-string |
| 176 | result "%n" (int-to-string i)))) |
| 177 | result))) |
| 178 | (indent-region start (point) nil))))) |
| 179 | |
| 180 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 181 | |
| 182 | (provide 'esml-gen) |