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