Commit | Line | Data |
---|---|---|
c0a3b488 AC |
1 | (* |
2 | * Dynamic web page generation with Standard ML | |
3 | * Copyright (C) 2003 Adam Chlipala | |
4 | * | |
5 | * This library is free software; you can redistribute it and/or | |
6 | * modify it under the terms of the GNU Lesser General Public | |
7 | * License as published by the Free Software Foundation; either | |
8 | * version 2.1 of the License, or (at your option) any later version. | |
9 | * | |
10 | * This library is distributed in the hope that it will be useful, | |
11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
13 | * Lesser General Public License for more details. | |
14 | * | |
15 | * You should have received a copy of the GNU Lesser General Public | |
16 | * License along with this library; if not, write to the Free Software | |
17 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
18 | *) | |
19 | ||
20 | (* Translation of templates into SML source *) | |
21 | ||
22 | structure Mlt :> MLT = | |
23 | struct | |
24 | open Tree | |
25 | ||
26 | exception Skip | |
27 | ||
28 | fun error (pos, msg) = (ErrorMsg.error pos msg; | |
29 | raise Skip) | |
30 | ||
31 | type varid = int | |
32 | ||
33 | datatype var = VAR of Types.ty | REF of Types.ty | |
34 | ||
35 | val errorTy = Types.WILDCARDty | |
36 | ||
37 | val ppstream = PrettyPrint.mk_ppstream {consumer = TextIO.print, flush = fn () => TextIO.flushOut TextIO.stdOut, | |
38 | linewidth = 80} | |
39 | ||
16abb0f9 AC |
40 | datatype unify = |
41 | ExpUn of exp | |
42 | | PatUn of pat | |
43 | ||
c0a3b488 AC |
44 | (* States to thread throughout translation *) |
45 | local | |
46 | datatype state = STATE of {env: StaticEnv.staticEnv, | |
47 | vars : var StringMap.map, | |
48 | config : Config.config, | |
49 | templates : StringSet.set} | |
50 | ||
51 | datatype strct = STRCT of {elements: Modules.elements, | |
52 | eenv: EntityEnv.entityEnv} | |
53 | ||
54 | fun getElements (Modules.SIG {elements, ...}) = elements | |
55 | | getElements _ = raise Fail "Unexpected Signature in getElements" | |
56 | ||
57 | val bogusStamp = Stamps.special "<bogus>" | |
58 | val errorStrct = STRCT {elements = [], eenv = EntityEnv.empty} | |
59 | in | |
60 | fun mkState (config, env, templates) = | |
61 | STATE {config = config, | |
62 | env = env, | |
63 | vars = StringMap.empty, | |
64 | templates = templates} | |
65 | ||
66 | fun addVar (STATE {config, env, vars, templates}, v, ty) = | |
67 | STATE {config = config, env = env, vars = StringMap.insert (vars, v, ty), templates = templates} | |
68 | fun addVars (state, vars) = StringMap.foldli (fn (v, ty, state) => addVar (state, v, ty)) state vars | |
69 | ||
70 | fun getVar (STATE {vars, ...}, v, pos) = StringMap.find (vars, v) | |
71 | fun lookVal (STATE {env, ...}, v, pos) = | |
72 | (case StaticEnv.look (env, Symbol.varSymbol v) of | |
73 | Bindings.VALbind var => | |
74 | (case var of | |
75 | VarCon.VALvar {typ, ...} => #1 (TypesUtil.instantiatePoly (!typ)) | |
76 | | _ => raise Fail "Unexpected var in lookVal") | |
77 | | Bindings.CONbind (Types.DATACON {typ, ...}) => #1 (TypesUtil.instantiatePoly typ) | |
78 | | _ => raise Fail "Unexpected binding in lookVal") | |
79 | handle StaticEnv.Unbound => (error (SOME pos, "Unbound variable " ^ v); | |
80 | errorTy) | |
81 | ||
82 | fun lookCon' (STATE {env, ...}, v) = | |
83 | (case StaticEnv.look (env, Symbol.varSymbol v) of | |
84 | Bindings.CONbind (Types.DATACON {typ, ...}) => #1 (TypesUtil.instantiatePoly typ) | |
85 | | _ => raise Fail "Unexpected binding in lookVal") | |
86 | fun lookCon (env, v, pos) = (lookCon' (env, v)) | |
87 | handle ModuleUtil.Unbound _ => (error (SOME pos, "Unbound constructor " ^ v); | |
88 | errorTy) | |
89 | fun lookStr (STATE {env, ...}, v, pos) = | |
90 | (case StaticEnv.look (env, Symbol.strSymbol v) of | |
91 | Bindings.STRbind modl => | |
92 | (case modl of | |
93 | Modules.STR {rlzn = {entities, ...}, sign, ...} => STRCT {elements = getElements sign, | |
94 | eenv = entities} | |
95 | | _=> raise Fail "Unexpected module in lookStr") | |
96 | | _ => raise Fail "Unexpected binding in lookStr") | |
97 | handle StaticEnv.Unbound => (error (SOME pos, "Unbound structure " ^ v); | |
98 | errorStrct) | |
99 | ||
100 | fun getStr (STRCT {elements, eenv, ...}, v, pos) = | |
101 | (case ModuleUtil.getStr (elements, eenv, Symbol.strSymbol v, Access.nullAcc, II.Null) of | |
102 | (Modules.STR {rlzn = {entities, ...}, sign = Modules.SIG {elements, ...}, ...}, _) => | |
103 | STRCT {elements = elements, eenv = entities} | |
104 | | _ => raise Fail "Unexpected spec in getStr") | |
105 | handle ModuleUtil.Unbound _ => (error (SOME pos, "Unbound structure " ^ v); | |
106 | errorStrct) | |
107 | fun getVal (STRCT {elements, ...}, v, pos) = | |
108 | (case ModuleUtil.getSpec (elements, Symbol.varSymbol v) of | |
109 | Modules.VALspec {spec, ...} => #1 (TypesUtil.instantiatePoly spec) | |
16abb0f9 AC |
110 | | Modules.CONspec {spec = Types.DATACON {typ, ...}, ...} => #1 (TypesUtil.instantiatePoly typ) |
111 | | _ => raise Fail ("Unexpected spec in getVal for " ^ v)) | |
c0a3b488 AC |
112 | handle ModuleUtil.Unbound _ => (case ModuleUtil.getSpec (elements, Symbol.tycSymbol v) of |
113 | Modules.CONspec {spec = Types.DATACON {typ, ...}, ...} => #1 (TypesUtil.instantiatePoly typ) | |
114 | | _ => raise Fail "Unexpected spec in getVal") | |
115 | handle ModuleUtil.Unbound _ => (error (SOME pos, "Unbound variable " ^ v); | |
116 | errorTy) | |
117 | fun getCon (STRCT {elements, ...}, v, pos) = | |
118 | (case ModuleUtil.getSpec (elements, Symbol.varSymbol v) of | |
119 | Modules.CONspec {spec = Types.DATACON {typ, ...}, ...} => #1 (TypesUtil.instantiatePoly typ) | |
120 | | _ => raise Fail "Unexpected spec in getVal") | |
121 | handle ModuleUtil.Unbound _ => (error (SOME pos, "Unbound constructor " ^ v); | |
122 | errorTy) | |
123 | ||
16abb0f9 | 124 | fun unify (STATE {env, ...}) (pos, e, t1, t2) = |
c0a3b488 AC |
125 | (*let |
126 | val t1 = ModuleUtil.transType eenv t1 | |
127 | val t2 = ModuleUtil.transType eenv t2 | |
128 | in*) | |
129 | Unify.unifyTy (t1, t2) | |
130 | (*end*) | |
131 | handle Unify.Unify msg => | |
132 | (PrettyPrint.begin_block ppstream PrettyPrint.CONSISTENT 0; | |
8291a2b9 AC |
133 | PrettyPrint.add_string ppstream "Error unifying"; |
134 | PrettyPrint.add_break ppstream (1, 0); | |
c0a3b488 AC |
135 | PrettyPrint.begin_block ppstream PrettyPrint.CONSISTENT 5; |
136 | PPType.ppType env ppstream t1; | |
137 | PrettyPrint.end_block ppstream; | |
8291a2b9 AC |
138 | PrettyPrint.add_break ppstream (1, 0); |
139 | PrettyPrint.add_string ppstream "and"; | |
140 | PrettyPrint.add_break ppstream (1, 0); | |
c0a3b488 AC |
141 | PrettyPrint.begin_block ppstream PrettyPrint.CONSISTENT 5; |
142 | PPType.ppType env ppstream t2; | |
143 | PrettyPrint.end_block ppstream; | |
c0a3b488 | 144 | PrettyPrint.end_block ppstream; |
8291a2b9 | 145 | PrettyPrint.add_break ppstream (1, 0); |
c0a3b488 | 146 | PrettyPrint.flush_ppstream ppstream; |
16abb0f9 AC |
147 | error (SOME pos, Unify.failMessage msg ^ " for " ^ (case e of ExpUn e => Tree.expString e |
148 | | PatUn p => "<pat>"))) | |
c0a3b488 AC |
149 | |
150 | fun resolvePath (getter, transer) (pos, state, path) = | |
151 | let | |
152 | fun traverse ([], _, _) = raise Fail "Impossible empty variable path in pat traverse" | |
153 | | traverse ([v], str as STRCT {eenv, ...}, path) = | |
154 | let | |
155 | val ty = getter (str, v, pos) | |
156 | val ty = transer eenv ty | |
157 | fun folder (STRCT {eenv, ...}, ty) = transer eenv ty | |
158 | in | |
159 | foldl folder ty path | |
160 | end | |
161 | | traverse (s::rest, str, path) = traverse (rest, getStr (str, s, pos), str::path) | |
162 | in | |
163 | case path of | |
164 | [] => raise Fail "Empty path to resolvePath" | |
165 | | [_] => raise Fail "Singleton path to resolvePath" | |
166 | | (first::rest) => traverse (rest, lookStr (state, first, pos), []) | |
167 | end | |
168 | ||
169 | fun resolveStructure (pos, state, path) = | |
170 | let | |
171 | fun look (STATE {env, ...}, v, pos) = | |
172 | (case StaticEnv.look (env, Symbol.strSymbol v) of | |
173 | Bindings.STRbind modl => | |
174 | (case modl of | |
175 | Modules.STR {rlzn = {entities, ...}, sign, ...} => (getElements sign, entities, modl) | |
176 | | _=> raise Fail "Unexpected module in lookStr") | |
177 | | _ => raise Fail "Unexpected binding in lookStr") | |
178 | handle ModuleUtil.Unbound _ => (error (SOME pos, "Unbound structure " ^ v); | |
179 | ([], EntityEnv.empty, Modules.ERRORstr)) | |
180 | ||
181 | fun get (elements, eenv, v) = | |
182 | let | |
183 | val sym = Symbol.strSymbol v | |
184 | in | |
185 | (case ModuleUtil.getStr (elements, eenv, sym, Access.nullAcc, II.Null) of | |
186 | (str as Modules.STR {rlzn = {entities, ...}, sign = Modules.SIG {elements, ...}, ...}, _) => | |
187 | (elements, entities, str) | |
188 | | _ => raise Fail "Unexpected spec in resolveStructure") | |
189 | handle ModuleUtil.Unbound _ => (error (SOME pos, "Unbound structure " ^ v); | |
190 | ([], EntityEnv.empty, Modules.ERRORstr)) | |
191 | end | |
192 | ||
193 | fun traverse ([], (_, _, str)) = str | |
194 | | traverse ([v], (elements, eenv, _)) = #3 (get (elements, eenv, v)) | |
195 | | traverse (s::rest, (elements, eenv, _)) = traverse (rest, get (elements, eenv, s)) | |
196 | in | |
197 | case path of | |
198 | [] => raise Fail "Empty path to resolveStructure" | |
199 | | (first::rest) => traverse (rest, look (state, first, pos)) | |
200 | end | |
201 | ||
202 | fun openStructure (pos, state as STATE {config, env, vars, templates}, path) = | |
203 | let | |
204 | val str = resolveStructure (pos, state, path) | |
205 | val env = ModuleUtil.openStructure (env, str) | |
206 | in | |
207 | STATE {config = config, env = env, vars = vars, templates = templates} | |
208 | end | |
209 | ||
210 | fun tyToString (STATE {env, ...}) ty = | |
211 | PrettyPrint.pp_to_string 65535 (PPType.ppType env) ty | |
212 | ||
213 | fun printFn (state as STATE {config, env, ...}) ty = | |
214 | let | |
215 | val tyname = tyToString state ty | |
216 | in | |
217 | Config.printFn config tyname | |
218 | end | |
219 | ||
220 | fun isTemplate (STATE {templates, ...}) s = StringSet.member (templates, s) | |
221 | end | |
222 | ||
223 | fun twiddleType f ty = | |
224 | (case TypesUtil.headReduceType ty of | |
225 | Types.WILDCARDty => ty | |
226 | | _ => f ty) | |
227 | ||
228 | val domain = twiddleType BasicTypes.domain | |
229 | val range = twiddleType BasicTypes.range | |
230 | ||
231 | (*val _ = (Unify.debugging := true; | |
232 | EntityEnv.debugging := true; | |
233 | ModuleUtil.debugging := true)*) | |
234 | ||
235 | fun newTyvar eq = Types.VARty (Types.mkTyvar (Types.OPEN {depth = 0, eq = eq, kind = Types.META})) | |
236 | fun newFlex elms = Types.VARty (Types.mkTyvar (Types.OPEN {depth = 0, eq = false, kind = Types.FLEX elms})) | |
237 | ||
238 | val resolveVal = resolvePath (getVal, ModuleUtil.transType) | |
239 | val resolveCon = resolvePath (getCon, ModuleUtil.transType) | |
240 | ||
241 | fun escapeString s = | |
242 | let | |
243 | val chars = String.explode s | |
244 | val escd = map (fn #"\"" => "\\\"" | |
245 | | #"\n" => "\\n" | |
246 | | #"\r" => "" | |
247 | | #"\t" => "\\t" | |
248 | | x => str x) chars | |
249 | in | |
250 | String.concat escd | |
251 | end | |
252 | ||
253 | val mkTuple = BasicTypes.tupleTy | |
254 | ||
255 | val templateTy = BasicTypes.--> (Types.CONty (BasicTypes.listTycon, | |
256 | [mkTuple [BasicTypes.stringTy, | |
16abb0f9 AC |
257 | Types.CONty (BasicTypes.listTycon, |
258 | [BasicTypes.stringTy])]]), BasicTypes.unitTy) | |
c0a3b488 | 259 | |
16abb0f9 | 260 | fun xexp state (exp as EXP (e, pos)) = |
c0a3b488 AC |
261 | (case e of |
262 | Int_e n => | |
263 | (BasicTypes.intTy, Int.toString n) | |
8291a2b9 AC |
264 | | Real_e n => |
265 | (BasicTypes.realTy, Real.toString n) | |
c0a3b488 AC |
266 | | String_e s => |
267 | (BasicTypes.stringTy, "\"" ^ s ^ "\"") | |
268 | | Char_e s => | |
269 | (BasicTypes.charTy, "#\"" ^ s ^ "\"") | |
270 | | Cons_e (e1, e2) => | |
271 | let | |
272 | val (ty1, es1) = xexp state e1 | |
273 | val (ty2, es2) = xexp state e2 | |
274 | ||
275 | val parm = newTyvar false | |
276 | val ran = Types.CONty (BasicTypes.listTycon, [parm]) | |
277 | val dom = mkTuple [parm, ran] | |
278 | ||
279 | val xt = mkTuple [ty1, ty2] | |
280 | in | |
16abb0f9 | 281 | unify state (pos, ExpUn exp, dom, xt); |
c0a3b488 AC |
282 | (ran, "(" ^ es1 ^ ") :: (" ^ es2 ^ ")") |
283 | end | |
16abb0f9 AC |
284 | | Compose_e (e1, e2) => |
285 | let | |
286 | val (ty1, es1) = xexp state e1 | |
287 | val (ty2, es2) = xexp state e2 | |
288 | ||
289 | val dom1 = newTyvar false | |
290 | val ran1dom2 = newTyvar false | |
291 | val ran2 = newTyvar false | |
292 | in | |
293 | unify state (pos, ExpUn exp, ty2, BasicTypes.--> (dom1, ran1dom2)); | |
294 | unify state (pos, ExpUn exp, ty1, BasicTypes.--> (ran1dom2, ran2)); | |
295 | (BasicTypes.--> (dom1, ran2), "(" ^ es1 ^ ") o (" ^ es2 ^ ")") | |
296 | end | |
c0a3b488 AC |
297 | | StrCat_e (e1, e2) => |
298 | let | |
299 | val (ty1, es1) = xexp state e1 | |
300 | val (ty2, es2) = xexp state e2 | |
301 | in | |
16abb0f9 AC |
302 | unify state (pos, ExpUn e1, ty1, BasicTypes.stringTy); |
303 | unify state (pos, ExpUn e2, ty2, BasicTypes.stringTy); | |
c0a3b488 AC |
304 | (BasicTypes.stringTy, "(" ^ es1 ^ ") ^ (" ^ es2 ^ ")") |
305 | end | |
306 | | Orelse_e (e1, e2) => | |
307 | let | |
308 | val (ty1, es1) = xexp state e1 | |
309 | val (ty2, es2) = xexp state e2 | |
310 | in | |
16abb0f9 AC |
311 | unify state (pos, ExpUn e1, ty1, BasicTypes.boolTy); |
312 | unify state (pos, ExpUn e2, ty2, BasicTypes.boolTy); | |
c0a3b488 AC |
313 | (BasicTypes.boolTy, "(" ^ es1 ^ ") orelse (" ^ es2 ^ ")") |
314 | end | |
315 | | Andalso_e (e1, e2) => | |
316 | let | |
317 | val (ty1, es1) = xexp state e1 | |
318 | val (ty2, es2) = xexp state e2 | |
319 | in | |
16abb0f9 AC |
320 | unify state (pos, ExpUn e1, ty1, BasicTypes.boolTy); |
321 | unify state (pos, ExpUn e2, ty2, BasicTypes.boolTy); | |
c0a3b488 AC |
322 | (BasicTypes.boolTy, "(" ^ es1 ^ ") andalso (" ^ es2 ^ ")") |
323 | end | |
324 | | Plus_e (e1, e2) => | |
325 | let | |
326 | val (ty1, es1) = xexp state e1 | |
327 | val (ty2, es2) = xexp state e2 | |
328 | in | |
16abb0f9 AC |
329 | unify state (pos, ExpUn e1, ty1, BasicTypes.intTy); |
330 | unify state (pos, ExpUn e2, ty2, BasicTypes.intTy); | |
c0a3b488 AC |
331 | (BasicTypes.intTy, "(" ^ es1 ^ ") + (" ^ es2 ^ ")") |
332 | end | |
333 | | Minus_e (e1, e2) => | |
334 | let | |
335 | val (ty1, es1) = xexp state e1 | |
336 | val (ty2, es2) = xexp state e2 | |
337 | in | |
16abb0f9 AC |
338 | unify state (pos, ExpUn e1, ty1, BasicTypes.intTy); |
339 | unify state (pos, ExpUn e2, ty2, BasicTypes.intTy); | |
c0a3b488 AC |
340 | (BasicTypes.intTy, "(" ^ es1 ^ ") - (" ^ es2 ^ ")") |
341 | end | |
342 | | Times_e (e1, e2) => | |
343 | let | |
344 | val (ty1, es1) = xexp state e1 | |
345 | val (ty2, es2) = xexp state e2 | |
346 | in | |
16abb0f9 AC |
347 | unify state (pos, ExpUn e1, ty1, BasicTypes.intTy); |
348 | unify state (pos, ExpUn e2, ty2, BasicTypes.intTy); | |
c0a3b488 AC |
349 | (BasicTypes.intTy, "(" ^ es1 ^ ") * (" ^ es2 ^ ")") |
350 | end | |
351 | | Divide_e (e1, e2) => | |
352 | let | |
353 | val (ty1, es1) = xexp state e1 | |
354 | val (ty2, es2) = xexp state e2 | |
355 | in | |
16abb0f9 AC |
356 | unify state (pos, ExpUn e1, ty1, BasicTypes.intTy); |
357 | unify state (pos, ExpUn e2, ty2, BasicTypes.intTy); | |
c0a3b488 AC |
358 | (BasicTypes.intTy, "(" ^ es1 ^ ") div (" ^ es2 ^ ")") |
359 | end | |
360 | | Mod_e (e1, e2) => | |
361 | let | |
362 | val (ty1, es1) = xexp state e1 | |
363 | val (ty2, es2) = xexp state e2 | |
364 | in | |
16abb0f9 AC |
365 | unify state (pos, ExpUn e1, ty1, BasicTypes.intTy); |
366 | unify state (pos, ExpUn e2, ty2, BasicTypes.intTy); | |
c0a3b488 AC |
367 | (BasicTypes.intTy, "(" ^ es1 ^ ") mod (" ^ es2 ^ ")") |
368 | end | |
369 | | Lt_e (e1, e2) => | |
370 | let | |
371 | val (ty1, es1) = xexp state e1 | |
372 | val (ty2, es2) = xexp state e2 | |
373 | in | |
16abb0f9 AC |
374 | unify state (pos, ExpUn e1, ty1, BasicTypes.intTy); |
375 | unify state (pos, ExpUn e2, ty2, BasicTypes.intTy); | |
c0a3b488 AC |
376 | (BasicTypes.boolTy, "(" ^ es1 ^ ") < (" ^ es2 ^ ")") |
377 | end | |
378 | | Lte_e (e1, e2) => | |
379 | let | |
380 | val (ty1, es1) = xexp state e1 | |
381 | val (ty2, es2) = xexp state e2 | |
382 | in | |
16abb0f9 AC |
383 | unify state (pos, ExpUn e1, ty1, BasicTypes.intTy); |
384 | unify state (pos, ExpUn e2, ty2, BasicTypes.intTy); | |
c0a3b488 AC |
385 | (BasicTypes.boolTy, "(" ^ es1 ^ ") <= (" ^ es2 ^ ")") |
386 | end | |
387 | | Gt_e (e1, e2) => | |
388 | let | |
389 | val (ty1, es1) = xexp state e1 | |
390 | val (ty2, es2) = xexp state e2 | |
391 | in | |
16abb0f9 AC |
392 | unify state (pos, ExpUn e1, ty1, BasicTypes.intTy); |
393 | unify state (pos, ExpUn e2, ty2, BasicTypes.intTy); | |
c0a3b488 AC |
394 | (BasicTypes.boolTy, "(" ^ es1 ^ ") > (" ^ es2 ^ ")") |
395 | end | |
396 | | Gte_e (e1, e2) => | |
397 | let | |
398 | val (ty1, es1) = xexp state e1 | |
399 | val (ty2, es2) = xexp state e2 | |
400 | in | |
16abb0f9 AC |
401 | unify state (pos, ExpUn e1, ty1, BasicTypes.intTy); |
402 | unify state (pos, ExpUn e2, ty2, BasicTypes.intTy); | |
c0a3b488 AC |
403 | (BasicTypes.boolTy, "(" ^ es1 ^ ") >= (" ^ es2 ^ ")") |
404 | end | |
405 | | Param_e => (BasicTypes.--> (BasicTypes.stringTy, BasicTypes.stringTy), "Web.getParam") | |
406 | | Neg_e => (BasicTypes.--> (BasicTypes.intTy, BasicTypes.intTy), "~") | |
407 | | Template_e name => | |
408 | if isTemplate state name then | |
409 | let | |
410 | fun toUpper ch = chr (ord ch + ord #"A" - ord #"a") | |
411 | val name = str (toUpper (String.sub (name, 0))) ^ String.extract (name, 1, NONE) | |
412 | in | |
16abb0f9 | 413 | (templateTy, "(Web.withParams " ^ name ^ "_.exec)") |
c0a3b488 AC |
414 | end |
415 | else | |
416 | (error (SOME pos, "Unknown template " ^ name); | |
417 | (errorTy, "<errorTemplate>")) | |
418 | | Proj_e field => | |
419 | let | |
420 | val carried = newTyvar false | |
421 | in | |
422 | (BasicTypes.--> (newFlex [(Symbol.labSymbol field, carried)], carried), "#" ^ field) | |
423 | end | |
424 | | Eq_e (e1, e2) => | |
425 | let | |
426 | val (ty1, s1) = xexp state e1 | |
427 | val (ty2, s2) = xexp state e2 | |
428 | in | |
16abb0f9 AC |
429 | unify state (pos, ExpUn e1, ty1, ty2); |
430 | unify state (pos, ExpUn e2, ty1, newTyvar true); | |
c0a3b488 AC |
431 | (BasicTypes.boolTy, "(" ^ s1 ^ ") = (" ^ s2 ^ ")") |
432 | end | |
433 | | Neq_e (e1, e2) => | |
434 | let | |
435 | val (ty1, s1) = xexp state e1 | |
436 | val (ty2, s2) = xexp state e2 | |
437 | in | |
16abb0f9 AC |
438 | unify state (pos, ExpUn e1, ty1, ty2); |
439 | unify state (pos, ExpUn e2, ty1, newTyvar true); | |
c0a3b488 AC |
440 | (BasicTypes.boolTy, "(" ^ s1 ^ ") <> (" ^ s2 ^ ")") |
441 | end | |
442 | | Ident_e [] => raise Fail "Impossible empty variable path" | |
443 | | Ident_e [id] => | |
444 | (case getVar (state, id, SOME pos) of | |
445 | NONE => (lookVal (state, id, pos), id) | |
446 | | SOME (VAR ty) => (ty, id) | |
447 | | SOME (REF ty) => (ty, "!" ^ id)) | |
448 | | Ident_e (path as (s::rest)) => | |
449 | (resolveVal (pos, state, path), foldl (fn (v, st) => st ^ "." ^ v) s rest) | |
450 | | App_e (f, x) => | |
451 | let | |
452 | val (ft, fs) = xexp state f | |
453 | val (xt, xs) = xexp state x | |
c0a3b488 | 454 | in |
16abb0f9 AC |
455 | if BasicTypes.isArrowType ft then |
456 | (unify state (pos, ExpUn x, domain ft, xt); | |
457 | (range ft, "(" ^ fs ^ ") (" ^ xs ^ ")")) | |
458 | else | |
459 | (error (SOME pos, "Applying non-function"); | |
460 | (errorTy, "<error>")) | |
c0a3b488 | 461 | end |
8291a2b9 AC |
462 | | Case_e (e, matches) => |
463 | let | |
464 | val (ty, s) = xexp state e | |
465 | ||
466 | fun folder ((p, e'), (first, str, bodyTy)) = | |
467 | let | |
468 | val (pty, vars', ps) = xpat state p | |
469 | ||
16abb0f9 | 470 | val _ = unify state (pos, ExpUn e, ty, pty) |
8291a2b9 AC |
471 | |
472 | val (ty', str') = xexp (addVars (state, vars')) e' | |
473 | in | |
16abb0f9 | 474 | unify state (pos, ExpUn e', ty', bodyTy); |
8291a2b9 AC |
475 | (false, |
476 | str ^ (if first then " " else " | ") ^ "(" ^ ps ^ ") => " ^ | |
477 | str' ^ "\n", | |
478 | bodyTy) | |
479 | end | |
480 | val bodyTy = newTyvar false | |
481 | val (_, str, _) = | |
482 | foldl folder (true, "(case (" ^ s ^ ") of\n", bodyTy) matches | |
483 | val str = str ^ ")\n" | |
484 | in | |
485 | (bodyTy, str) | |
486 | end | |
c0a3b488 AC |
487 | | Record_e (ist, cs) => |
488 | let | |
489 | val (cs, str) = foldl (fn ((id, e), (cs, str)) => | |
490 | let | |
491 | val idSym = Symbol.labSymbol id | |
492 | val _ = List.all (fn (id', _) => idSym <> id') cs | |
493 | orelse error (SOME pos, "Duplicate label " ^ id ^ " in record") | |
494 | val (ty, s) = xexp state e | |
495 | in | |
496 | ((idSym, ty) :: cs, str ^ ", " ^ id ^ " = " ^ s) | |
497 | end) ([], "") cs | |
498 | val cs = rev cs | |
499 | val str = | |
500 | case str of | |
501 | "" => str | |
502 | | _ => String.extract(str, 2, NONE) | |
503 | val str = "{" ^ str ^ "}" | |
504 | in | |
505 | (BasicTypes.recordTy cs, str) | |
506 | end | |
8291a2b9 AC |
507 | | Fn_e matches => |
508 | let | |
509 | val dom = newTyvar false | |
510 | val ran = newTyvar false | |
511 | ||
512 | fun folder ((p, e'), (first, str)) = | |
513 | let | |
514 | val (pty, vars', ps) = xpat state p | |
515 | ||
16abb0f9 | 516 | val _ = unify state (pos, ExpUn exp, dom, pty) |
8291a2b9 AC |
517 | |
518 | val (ty', str') = xexp (addVars (state, vars')) e' | |
519 | in | |
16abb0f9 | 520 | unify state (pos, ExpUn e', ty', ran); |
8291a2b9 AC |
521 | (false, |
522 | str ^ (if first then " " else " | ") ^ "(" ^ ps ^ ") => " ^ | |
523 | str' ^ "\n") | |
524 | end | |
525 | val (_, str) = | |
526 | foldl folder (true, "(fn \n") matches | |
527 | val str = str ^ ")\n" | |
528 | in | |
529 | (BasicTypes.--> (dom, ran), str) | |
530 | end | |
531 | | Raise_e e => | |
532 | let | |
533 | val (ty, es) = xexp state e | |
534 | in | |
16abb0f9 | 535 | unify state (pos, ExpUn e, ty, BasicTypes.exnTy); |
8291a2b9 AC |
536 | (newTyvar false, "(raise (" ^ es ^ "))") |
537 | end | |
16abb0f9 AC |
538 | | Let_e (b, e) => |
539 | let | |
540 | val (state, str) = xblock state b | |
541 | val (ty, es) = xexp state e | |
542 | in | |
543 | (ty, "let\n" ^ str ^ "\nin\n" ^ es ^ "\nend\n") | |
544 | end | |
545 | | If_e (c, t, e) => | |
546 | let | |
547 | val (bty, ce) = xexp state c | |
548 | val (ty, te) = xexp state t | |
549 | val (ty', ee) = xexp state e | |
550 | in | |
551 | unify state (pos, ExpUn c, bty, BasicTypes.boolTy); | |
552 | unify state (pos, ExpUn exp, ty, ty'); | |
553 | (ty, "(if (" ^ ce ^ ") then (" ^ te ^ ") else (" ^ ee ^ "))") | |
554 | end | |
c0a3b488 AC |
555 | | RecordUpd_e (e, cs) => |
556 | let | |
557 | val (ty, es) = xexp state e | |
558 | ||
559 | val cs' = | |
560 | case TypesUtil.headReduceType ty of | |
561 | Types.CONty (Types.RECORDtyc labs, tys) => ListPair.zip (labs, tys) | |
562 | | _ => error (SOME pos, "Record update on non-record") | |
563 | ||
564 | val (n, str) = foldl (fn ((id, ty), (n, str)) => | |
565 | case List.find (fn (id', _) => id = Symbol.labSymbol id') cs of | |
566 | NONE => (n, str ^ ", " ^ Symbol.name id ^ " = #" ^ | |
567 | Symbol.name id ^ " " ^ "UPD'") | |
568 | | SOME (_, e) => | |
569 | let | |
570 | val (ty', s) = xexp state e | |
571 | in | |
16abb0f9 | 572 | unify state (pos, ExpUn e, ty, ty'); |
c0a3b488 AC |
573 | (n + 1, str ^ ", " ^ Symbol.name id ^ " = " ^ s) |
574 | end) (0, "") cs' | |
575 | ||
576 | val _ = n = length cs | |
577 | orelse error (SOME pos, "Updated fields in record update not found in starting expression") | |
578 | ||
579 | val str = | |
580 | case str of | |
581 | "" => str | |
582 | | _ => String.extract(str, 2, NONE) | |
583 | val str = "let val UPD' = " ^ es ^ " in {" ^ str ^ "} end" | |
584 | in | |
585 | (ty, str) | |
586 | end) | |
587 | handle Skip => (errorTy, "<error>") | |
588 | ||
8291a2b9 | 589 | and mergePatVars pos (vars1, vars2) = |
c0a3b488 AC |
590 | StringMap.foldli (fn (v, ty, vars) => |
591 | (case StringMap.find (vars, v) of | |
592 | NONE => StringMap.insert (vars, v, ty) | |
593 | | SOME _ => error (SOME pos, "Duplicate variable " ^ v ^ " in pattern"))) vars1 vars2 | |
594 | ||
16abb0f9 | 595 | and xpat state (pat as PAT (p, pos)) = |
c0a3b488 AC |
596 | (case p of |
597 | Ident_p [] => raise Fail "Impossible empty Ident_p" | |
598 | | Ident_p [id] => | |
599 | ((lookCon' (state, id), StringMap.empty, id) | |
600 | handle StaticEnv.Unbound => | |
601 | let | |
602 | val ty = newTyvar false | |
603 | in | |
604 | (ty, StringMap.insert (StringMap.empty, id, VAR ty), id) | |
605 | end) | |
606 | | Ident_p (path as (s::rest)) => | |
607 | (resolveCon (pos, state, path), StringMap.empty, foldl (fn (v, st) => st ^ "." ^ v) s rest) | |
608 | | Wild_p => (newTyvar false, StringMap.empty, "_") | |
609 | | Int_p n => (BasicTypes.intTy, StringMap.empty, Int.toString n) | |
8291a2b9 | 610 | | Real_p n => (BasicTypes.realTy, StringMap.empty, Real.toString n) |
c0a3b488 | 611 | | String_p s => (BasicTypes.stringTy, StringMap.empty, "\"" ^ s ^ "\"") |
8291a2b9 | 612 | | Char_p s => (BasicTypes.charTy, StringMap.empty, "#\"" ^ s ^ "\"") |
c0a3b488 AC |
613 | | App_p ([], _) => raise Fail "Impossible App_p" |
614 | | App_p ([id], p) => | |
615 | let | |
616 | val (ty, vars, s) = xpat state p | |
617 | val tyc = lookCon (state, id, pos) | |
618 | val dom = domain tyc | |
619 | in | |
16abb0f9 | 620 | unify state (pos, PatUn p, dom, ty); |
c0a3b488 AC |
621 | (range tyc, vars, id ^ " (" ^ s ^ ")") |
622 | end | |
623 | | App_p (path as (fst::rest), p) => | |
624 | let | |
625 | val (ty, vars, s) = xpat state p | |
626 | val tyc = resolveCon (pos, state, path) | |
627 | val dom = domain tyc | |
628 | in | |
16abb0f9 | 629 | unify state (pos, PatUn p, dom, ty); |
c0a3b488 AC |
630 | (range tyc, vars, foldl (fn (n, st) => st ^ "." ^ n) fst rest ^ " (" ^ s ^ ")") |
631 | end | |
632 | | Cons_p (p1, p2) => | |
633 | let | |
634 | val (ty1, vars', s1) = xpat state p1 | |
635 | val (ty2, vars'', s2) = xpat state p2 | |
636 | ||
637 | val resty = Types.CONty (BasicTypes.listTycon, [ty1]) | |
638 | in | |
16abb0f9 | 639 | unify state (pos, PatUn pat, ty2, resty); |
c0a3b488 AC |
640 | (resty, mergePatVars pos (vars', vars''), "(" ^ s1 ^ ")::(" ^ s2 ^ ")") |
641 | end | |
642 | | As_p (id, p) => | |
643 | let | |
644 | val (ty, vars, s) = xpat state p | |
645 | in | |
646 | not (Option.isSome (StringMap.find(vars, id))) | |
647 | orelse error (SOME pos, "Duplicate variable " ^ id ^ " in pattern"); | |
648 | (ty, StringMap.insert (vars, id, VAR ty), id ^ " as (" ^ s ^ ")") | |
649 | end | |
650 | | Record_p (ist, cs) => | |
651 | let | |
652 | val (cs, vars, str) = foldl (fn ((id, p), (cs, vars, str)) => | |
653 | let | |
654 | val (ty, vars', s) = xpat state p | |
655 | in | |
656 | ((Symbol.labSymbol id, ty)::cs, mergePatVars pos (vars, vars'), | |
657 | str ^ ", " ^ id ^ " = " ^ s) | |
658 | end) ([], StringMap.empty, "") cs | |
659 | val cs = rev cs | |
660 | val str = | |
661 | if String.size str >= 2 then | |
662 | String.extract(str, 2, NONE) | |
663 | else | |
664 | str | |
665 | val str = "{" ^ str ^ "}" | |
666 | in | |
667 | (BasicTypes.recordTy cs, vars, str) | |
668 | end | |
669 | | FlexRecord_p cs => | |
670 | let | |
671 | val (cs, vars, str) = foldl (fn ((id, p), (cs, vars, str)) => | |
672 | let | |
673 | val (ty, vars', s) = xpat state p | |
674 | in | |
675 | ((Symbol.labSymbol id, ty)::cs, mergePatVars pos (vars, vars'), | |
676 | str ^ ", " ^ id ^ " = " ^ s) | |
677 | end) ([], StringMap.empty, "") cs | |
678 | val cs = rev cs | |
679 | val str = | |
680 | if String.size str >= 2 then | |
681 | String.extract(str, 2, NONE) | |
682 | else | |
683 | str | |
684 | val str = "{" ^ str ^ ", ...}" | |
685 | in | |
686 | (newFlex cs, vars, str) | |
687 | end | |
688 | (*| _ => | |
689 | error (SOME pos, "Not done yet!!!")*)) | |
690 | handle Skip => (errorTy, StringMap.empty, "<error>") | |
691 | ||
16abb0f9 | 692 | and xblock state (BLOCK (blocks, pos)) = |
c0a3b488 AC |
693 | let |
694 | fun folder (BITEM (bi, pos), (state, str)) = | |
695 | (case bi of | |
696 | Html_i s => | |
697 | (state, str ^ "val _ = Web.print (\"" ^ escapeString s ^ "\")\n") | |
698 | | Ref_i rs => | |
699 | let | |
700 | fun folder ((id, e), (state, str)) = | |
701 | let | |
702 | val (ty, es) = xexp state e | |
703 | ||
704 | val state = addVar (state, id, REF ty) | |
705 | in | |
706 | (state, str ^ "val " ^ id ^ " = ref (" ^ es ^ ")\n") | |
707 | end | |
708 | in | |
709 | foldl folder (state, str) rs | |
710 | end | |
711 | | Assn_i (id, e) => | |
712 | let | |
713 | val vty = | |
714 | case getVar (state, id, SOME pos) of | |
715 | NONE => error (SOME pos, "Unbound variable " ^ id) | |
716 | | SOME (REF vty) => vty | |
717 | | _ => error (SOME pos, "Can't assign to non-ref variable " ^ id) | |
718 | ||
719 | val (ty, es) = xexp state e | |
720 | in | |
16abb0f9 | 721 | unify state (pos, ExpUn e, ty, vty); |
c0a3b488 AC |
722 | (state, str ^ "val _ = " ^ id ^ " := (" ^ es ^ ")\n") |
723 | end | |
724 | | Val_i (p, e) => | |
725 | let | |
726 | val (pty, vars, ps) = xpat state p | |
727 | val state' = addVars (state, vars) | |
728 | val (ty, es) = xexp state e | |
729 | in | |
16abb0f9 | 730 | unify state (pos, ExpUn e, pty, ty); |
c0a3b488 AC |
731 | (state', str ^ "val " ^ ps ^ " = (" ^ es ^ ")\n") |
732 | end | |
733 | | Exp_i e => | |
734 | let | |
735 | val (ty, s) = xexp state e | |
736 | val ty = TypesUtil.headReduceType ty | |
737 | val printFn = | |
738 | case printFn state ty of | |
739 | NONE => (if tyToString state ty = "_" then | |
740 | () | |
741 | else | |
742 | error (SOME pos, "Unable to convert value of type " ^ | |
743 | tyToString state ty ^ " to string"); | |
744 | "<errorPrint>") | |
745 | | SOME v => v | |
746 | in | |
747 | (state, str ^ "val _ = " ^ printFn ^ " (" ^ s ^ ")\n") | |
748 | end | |
8291a2b9 | 749 | | Ifthenelse_i (e, b, els) => |
c0a3b488 AC |
750 | let |
751 | val str = str ^ "val _ = " | |
8291a2b9 AC |
752 | val (ty, s) = xexp state e |
753 | val (_, str') = xblock state b | |
16abb0f9 | 754 | val _ = unify state (pos, ExpUn e, ty, BasicTypes.boolTy) |
8291a2b9 AC |
755 | val str = str ^ "if (" ^ s ^ ") then let\n" ^ |
756 | str' ^ | |
757 | "in () end\n" | |
c0a3b488 AC |
758 | val str = |
759 | case els of | |
760 | NONE => | |
761 | str ^ "else ()\n" | |
762 | | SOME els => | |
763 | let | |
764 | val (_, str') = xblock state els | |
765 | in | |
766 | str ^ "else let\n" ^ | |
767 | str' ^ | |
768 | "in () end\n" | |
769 | end | |
770 | in | |
771 | (state, str) | |
772 | end | |
16abb0f9 | 773 | | Foreach_i (p, e, b) => |
c0a3b488 AC |
774 | let |
775 | val parm = newTyvar false | |
16abb0f9 AC |
776 | |
777 | val (pty, vars, ps) = xpat state p | |
c0a3b488 AC |
778 | val (ty, es) = xexp state e |
779 | ||
16abb0f9 AC |
780 | val _ = unify state (pos, ExpUn e, ty, Types.CONty (BasicTypes.listTycon, [parm])) |
781 | val _ = unify state (pos, PatUn p, pty, parm) | |
c0a3b488 | 782 | |
16abb0f9 AC |
783 | val state' = addVars (state, vars) |
784 | val (_, bs) = xblock state' b | |
785 | in | |
786 | (state, str ^ "fun foreach ((" ^ ps ^ ") : " ^ | |
8291a2b9 | 787 | tyToString state parm ^ ") = let\n" ^ |
c0a3b488 AC |
788 | bs ^ |
789 | "in () end\n" ^ | |
790 | "val _ = app foreach (" ^ es ^ ")\n") | |
791 | end | |
792 | | For_i (id, eFrom, eTo, b) => | |
793 | let | |
794 | val (ty1, es1) = xexp state eFrom | |
16abb0f9 | 795 | val _ = unify state (pos, ExpUn eFrom, ty1, BasicTypes.intTy) |
c0a3b488 AC |
796 | |
797 | val (ty2, es2) = xexp state eTo | |
16abb0f9 | 798 | val _ = unify state (pos, ExpUn eTo, ty2, BasicTypes.intTy) |
c0a3b488 AC |
799 | |
800 | val state = addVar (state, id, VAR BasicTypes.intTy) | |
801 | val (_, bs) = xblock state b | |
802 | in | |
803 | (state, str ^ "fun forFunc " ^ id ^ " = let\n" ^ | |
804 | bs ^ | |
805 | "in () end\n" ^ | |
8291a2b9 | 806 | "val _ = Web.for forFunc (" ^ es1 ^ ", " ^ es2 ^ ")\n") |
c0a3b488 AC |
807 | end |
808 | | Case_i (e, matches) => | |
809 | let | |
810 | val (ty, s) = xexp state e | |
811 | ||
812 | fun folder ((p, b), (first, str)) = | |
813 | let | |
814 | val (pty, vars', ps) = xpat state p | |
815 | ||
16abb0f9 | 816 | val _ = unify state (pos, PatUn p, ty, pty) |
c0a3b488 AC |
817 | |
818 | val (_, str') = xblock (addVars (state, vars')) b | |
819 | ||
820 | (*val _ = print ("Pattern type: " ^ tyToString (context, ivmap, pty) ^ " vs. " ^ tyToString (context, ivmap, ty) ^ "\n")*) | |
821 | in | |
822 | (false, | |
823 | str ^ (if first then " " else " | ") ^ "(" ^ ps ^ ") => let\n" ^ | |
824 | str' ^ | |
825 | "in () end\n") | |
826 | end | |
827 | val (_, str) = | |
828 | foldl folder (true, str ^ "val _ = (case (" ^ s ^ ") of\n") matches | |
829 | val str = str ^ ") handle Match => ()\n" | |
830 | in | |
831 | (state, str) | |
832 | end | |
833 | | TryCatch_i (b, matches) => | |
834 | let | |
835 | val (_, bs) = xblock state b | |
836 | ||
837 | fun folder ((p, b), (first, str)) = | |
838 | let | |
839 | val (pty, vars, ps) = xpat state p | |
840 | val state = addVars (state, vars) | |
841 | val (_, str') = xblock state b | |
842 | in | |
16abb0f9 | 843 | unify state (pos, PatUn p, BasicTypes.exnTy, pty); |
c0a3b488 AC |
844 | (false, |
845 | str ^ (if first then " " else " | ") ^ "(" ^ ps ^ ") => let\n" ^ | |
846 | str' ^ | |
847 | "in () end\n") | |
848 | end | |
849 | val (_, str) = | |
850 | foldl folder (true, | |
851 | str ^ "val _ = (let\n" ^ | |
852 | bs ^ | |
853 | "in () end handle\n") matches | |
854 | val str = str ^ ")\n" | |
855 | in | |
856 | (state, str) | |
857 | end | |
858 | | Open_i paths => | |
859 | let | |
860 | fun folder (path, state) = openStructure (pos, state, path) | |
861 | ||
862 | val str = foldl (fn (path, str) => str ^ " " ^ Tree.pathString path) (str ^ "open") paths | |
863 | val str = str ^ "\n" | |
864 | in | |
865 | (foldl folder state paths, str) | |
866 | end) | |
867 | handle Skip => (state, str) | |
868 | in | |
869 | foldl folder (state, "") blocks | |
870 | end | |
871 | ||
872 | fun trans (config, env, templates, name, block) = | |
873 | let | |
874 | val state = mkState (config, env, templates) | |
875 | val (_, str) = xblock state block | |
876 | in | |
877 | "(* This file generated automatically by something or other *)\n" ^ | |
878 | "\n" ^ | |
879 | "structure " ^ name ^ " :> TEMPLATE =\n" ^ | |
880 | "struct\n" ^ | |
881 | "fun exec () = let\n" ^ | |
882 | str ^ | |
883 | "in () end\n" ^ | |
884 | "end\n" | |
885 | end | |
886 | end | |
887 | ||
888 |