Commit | Line | Data |
---|---|---|
7f918cf1 CE |
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) |