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