b853295019b36c59768130250c1d4db5e66e17ba
[bpt/mlt.git] / src / mlt.sml
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 datatype unify =
41 ExpUn of exp
42 | PatUn of pat
43
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)
110 | Modules.CONspec {spec = Types.DATACON {typ, ...}, ...} => #1 (TypesUtil.instantiatePoly typ)
111 | _ => raise Fail ("Unexpected spec in getVal for " ^ v))
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
124 fun unify (STATE {env, ...}) (pos, e, t1, t2) =
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;
133 PrettyPrint.add_string ppstream "Error unifying";
134 PrettyPrint.add_break ppstream (1, 0);
135 PrettyPrint.begin_block ppstream PrettyPrint.CONSISTENT 5;
136 PPType.ppType env ppstream t1;
137 PrettyPrint.end_block ppstream;
138 PrettyPrint.add_break ppstream (1, 0);
139 PrettyPrint.add_string ppstream "and";
140 PrettyPrint.add_break ppstream (1, 0);
141 PrettyPrint.begin_block ppstream PrettyPrint.CONSISTENT 5;
142 PPType.ppType env ppstream t2;
143 PrettyPrint.end_block ppstream;
144 PrettyPrint.end_block ppstream;
145 PrettyPrint.add_break ppstream (1, 0);
146 PrettyPrint.flush_ppstream ppstream;
147 error (SOME pos, Unify.failMessage msg ^ " for " ^ (case e of ExpUn e => Tree.expString e
148 | PatUn p => "<pat>")))
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,
257 Types.CONty (BasicTypes.listTycon,
258 [BasicTypes.stringTy])]]), BasicTypes.unitTy)
259
260 fun xexp state (exp as EXP (e, pos)) =
261 (case e of
262 Int_e n =>
263 (BasicTypes.intTy, Int.toString n)
264 | Real_e n =>
265 (BasicTypes.realTy, Real.toString n)
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
281 unify state (pos, ExpUn exp, dom, xt);
282 (ran, "(" ^ es1 ^ ") :: (" ^ es2 ^ ")")
283 end
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
297 | StrCat_e (e1, e2) =>
298 let
299 val (ty1, es1) = xexp state e1
300 val (ty2, es2) = xexp state e2
301 in
302 unify state (pos, ExpUn e1, ty1, BasicTypes.stringTy);
303 unify state (pos, ExpUn e2, ty2, BasicTypes.stringTy);
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
311 unify state (pos, ExpUn e1, ty1, BasicTypes.boolTy);
312 unify state (pos, ExpUn e2, ty2, BasicTypes.boolTy);
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
320 unify state (pos, ExpUn e1, ty1, BasicTypes.boolTy);
321 unify state (pos, ExpUn e2, ty2, BasicTypes.boolTy);
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
329 unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
330 unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
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
338 unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
339 unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
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
347 unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
348 unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
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
356 unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
357 unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
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
365 unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
366 unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
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
374 unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
375 unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
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
383 unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
384 unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
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
392 unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
393 unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
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
401 unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
402 unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
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
413 (templateTy, "(Web.withParams " ^ name ^ "_.exec)")
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
429 unify state (pos, ExpUn e1, ty1, ty2);
430 unify state (pos, ExpUn e2, ty1, newTyvar true);
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
438 unify state (pos, ExpUn e1, ty1, ty2);
439 unify state (pos, ExpUn e2, ty1, newTyvar true);
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
454 in
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>"))
461 end
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
470 val _ = unify state (pos, ExpUn e, ty, pty)
471
472 val (ty', str') = xexp (addVars (state, vars')) e'
473 in
474 unify state (pos, ExpUn e', ty', bodyTy);
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
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
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
516 val _ = unify state (pos, ExpUn exp, dom, pty)
517
518 val (ty', str') = xexp (addVars (state, vars')) e'
519 in
520 unify state (pos, ExpUn e', ty', ran);
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
535 unify state (pos, ExpUn e, ty, BasicTypes.exnTy);
536 (newTyvar false, "(raise (" ^ es ^ "))")
537 end
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
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
572 unify state (pos, ExpUn e, ty, ty');
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
589 and mergePatVars pos (vars1, vars2) =
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
595 and xpat state (pat as PAT (p, pos)) =
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)
610 | Real_p n => (BasicTypes.realTy, StringMap.empty, Real.toString n)
611 | String_p s => (BasicTypes.stringTy, StringMap.empty, "\"" ^ s ^ "\"")
612 | Char_p s => (BasicTypes.charTy, StringMap.empty, "#\"" ^ s ^ "\"")
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
620 unify state (pos, PatUn p, dom, ty);
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
629 unify state (pos, PatUn p, dom, ty);
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
639 unify state (pos, PatUn pat, ty2, resty);
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
692 and xblock state (BLOCK (blocks, pos)) =
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
721 unify state (pos, ExpUn e, ty, vty);
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
730 unify state (pos, ExpUn e, pty, ty);
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
749 | Ifthenelse_i (e, b, els) =>
750 let
751 val str = str ^ "val _ = "
752 val (ty, s) = xexp state e
753 val (_, str') = xblock state b
754 val _ = unify state (pos, ExpUn e, ty, BasicTypes.boolTy)
755 val str = str ^ "if (" ^ s ^ ") then let\n" ^
756 str' ^
757 "in () end\n"
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
773 | Foreach_i (p, e, b) =>
774 let
775 val parm = newTyvar false
776
777 val (pty, vars, ps) = xpat state p
778 val (ty, es) = xexp state e
779
780 val _ = unify state (pos, ExpUn e, ty, Types.CONty (BasicTypes.listTycon, [parm]))
781 val _ = unify state (pos, PatUn p, pty, parm)
782
783 val state' = addVars (state, vars)
784 val (_, bs) = xblock state' b
785 in
786 (state, str ^ "fun foreach ((" ^ ps ^ ") : " ^
787 tyToString state parm ^ ") = let\n" ^
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
795 val _ = unify state (pos, ExpUn eFrom, ty1, BasicTypes.intTy)
796
797 val (ty2, es2) = xexp state eTo
798 val _ = unify state (pos, ExpUn eTo, ty2, BasicTypes.intTy)
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" ^
806 "val _ = Web.for forFunc (" ^ es1 ^ ", " ^ es2 ^ ")\n")
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
816 val _ = unify state (pos, PatUn p, ty, pty)
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
843 unify state (pos, PatUn p, BasicTypes.exnTy, pty);
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