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 | ||
dca24e57 AC |
37 | (*val ppstream = PrettyPrint.mk_ppstream {consumer = TextIO.print, flush = fn () => TextIO.flushOut TextIO.stdOut, |
38 | linewidth = 80}*) | |
c0a3b488 | 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") | |
dca24e57 AC |
86 | |
87 | ||
c0a3b488 AC |
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) = | |
8a545f7d | 103 | (case ModuleUtil.getStr (elements, eenv, Symbol.strSymbol v, Access.nullAcc, []) of |
c0a3b488 AC |
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) | |
16abb0f9 AC |
112 | | Modules.CONspec {spec = Types.DATACON {typ, ...}, ...} => #1 (TypesUtil.instantiatePoly typ) |
113 | | _ => raise Fail ("Unexpected spec in getVal for " ^ v)) | |
c0a3b488 AC |
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 | ||
16abb0f9 | 126 | fun unify (STATE {env, ...}) (pos, e, t1, t2) = |
c0a3b488 AC |
127 | (*let |
128 | val t1 = ModuleUtil.transType eenv t1 | |
129 | val t2 = ModuleUtil.transType eenv t2 | |
130 | in*) | |
3623aa07 | 131 | Unify.unifyTy (t1, t2, SourceMap.nullRegion, SourceMap.nullRegion) |
c0a3b488 AC |
132 | (*end*) |
133 | handle Unify.Unify msg => | |
dca24e57 AC |
134 | ((*PrettyPrint.openBox ppstream (PrettyPrint.Abs 0); |
135 | PrettyPrint.string ppstream "Error unifying"; | |
136 | PrettyPrint.newline ppstream; | |
137 | PrettyPrint.openBox ppstream (PrettyPrint.Abs 5); | |
c0a3b488 | 138 | PPType.ppType env ppstream t1; |
dca24e57 AC |
139 | PrettyPrint.closeBox ppstream; |
140 | PrettyPrint.newline ppstream; | |
141 | PrettyPrint.string ppstream "and"; | |
142 | PrettyPrint.newline ppstream; | |
143 | PrettyPrint.openBox ppstream (PrettyPrint.Abs 5); | |
c0a3b488 | 144 | PPType.ppType env ppstream t2; |
dca24e57 AC |
145 | PrettyPrint.closeBox ppstream; |
146 | PrettyPrint.closeBox ppstream; | |
147 | PrettyPrint.newline ppstream; | |
148 | PrettyPrint.flushStream ppstream;*) | |
16abb0f9 AC |
149 | error (SOME pos, Unify.failMessage msg ^ " for " ^ (case e of ExpUn e => Tree.expString e |
150 | | PatUn p => "<pat>"))) | |
c0a3b488 AC |
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 | |
8a545f7d | 187 | (case ModuleUtil.getStr (elements, eenv, sym, Access.nullAcc, []) of |
c0a3b488 AC |
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 = | |
8a545f7d | 213 | PrettyPrintNew.pp_to_string 65535 (PPType.ppType env) ty |
c0a3b488 AC |
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, | |
16abb0f9 AC |
259 | Types.CONty (BasicTypes.listTycon, |
260 | [BasicTypes.stringTy])]]), BasicTypes.unitTy) | |
c0a3b488 | 261 | |
16abb0f9 | 262 | fun xexp state (exp as EXP (e, pos)) = |
c0a3b488 AC |
263 | (case e of |
264 | Int_e n => | |
265 | (BasicTypes.intTy, Int.toString n) | |
8291a2b9 AC |
266 | | Real_e n => |
267 | (BasicTypes.realTy, Real.toString n) | |
c0a3b488 AC |
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 | |
16abb0f9 | 283 | unify state (pos, ExpUn exp, dom, xt); |
c0a3b488 AC |
284 | (ran, "(" ^ es1 ^ ") :: (" ^ es2 ^ ")") |
285 | end | |
16abb0f9 AC |
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 | |
c0a3b488 AC |
299 | | StrCat_e (e1, e2) => |
300 | let | |
301 | val (ty1, es1) = xexp state e1 | |
302 | val (ty2, es2) = xexp state e2 | |
303 | in | |
16abb0f9 AC |
304 | unify state (pos, ExpUn e1, ty1, BasicTypes.stringTy); |
305 | unify state (pos, ExpUn e2, ty2, BasicTypes.stringTy); | |
c0a3b488 AC |
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 | |
16abb0f9 AC |
313 | unify state (pos, ExpUn e1, ty1, BasicTypes.boolTy); |
314 | unify state (pos, ExpUn e2, ty2, BasicTypes.boolTy); | |
c0a3b488 AC |
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 | |
16abb0f9 AC |
322 | unify state (pos, ExpUn e1, ty1, BasicTypes.boolTy); |
323 | unify state (pos, ExpUn e2, ty2, BasicTypes.boolTy); | |
c0a3b488 AC |
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 | |
16abb0f9 AC |
331 | unify state (pos, ExpUn e1, ty1, BasicTypes.intTy); |
332 | unify state (pos, ExpUn e2, ty2, BasicTypes.intTy); | |
c0a3b488 AC |
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 | |
16abb0f9 AC |
340 | unify state (pos, ExpUn e1, ty1, BasicTypes.intTy); |
341 | unify state (pos, ExpUn e2, ty2, BasicTypes.intTy); | |
c0a3b488 AC |
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 | |
16abb0f9 AC |
349 | unify state (pos, ExpUn e1, ty1, BasicTypes.intTy); |
350 | unify state (pos, ExpUn e2, ty2, BasicTypes.intTy); | |
c0a3b488 AC |
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 | |
16abb0f9 AC |
358 | unify state (pos, ExpUn e1, ty1, BasicTypes.intTy); |
359 | unify state (pos, ExpUn e2, ty2, BasicTypes.intTy); | |
c0a3b488 AC |
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 | |
16abb0f9 AC |
367 | unify state (pos, ExpUn e1, ty1, BasicTypes.intTy); |
368 | unify state (pos, ExpUn e2, ty2, BasicTypes.intTy); | |
c0a3b488 AC |
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 | |
16abb0f9 AC |
376 | unify state (pos, ExpUn e1, ty1, BasicTypes.intTy); |
377 | unify state (pos, ExpUn e2, ty2, BasicTypes.intTy); | |
c0a3b488 AC |
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 | |
16abb0f9 AC |
385 | unify state (pos, ExpUn e1, ty1, BasicTypes.intTy); |
386 | unify state (pos, ExpUn e2, ty2, BasicTypes.intTy); | |
c0a3b488 AC |
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 | |
16abb0f9 AC |
394 | unify state (pos, ExpUn e1, ty1, BasicTypes.intTy); |
395 | unify state (pos, ExpUn e2, ty2, BasicTypes.intTy); | |
c0a3b488 AC |
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 | |
16abb0f9 AC |
403 | unify state (pos, ExpUn e1, ty1, BasicTypes.intTy); |
404 | unify state (pos, ExpUn e2, ty2, BasicTypes.intTy); | |
c0a3b488 AC |
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 | |
16abb0f9 | 415 | (templateTy, "(Web.withParams " ^ name ^ "_.exec)") |
c0a3b488 AC |
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 | |
16abb0f9 AC |
431 | unify state (pos, ExpUn e1, ty1, ty2); |
432 | unify state (pos, ExpUn e2, ty1, newTyvar true); | |
c0a3b488 AC |
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 | |
16abb0f9 AC |
440 | unify state (pos, ExpUn e1, ty1, ty2); |
441 | unify state (pos, ExpUn e2, ty1, newTyvar true); | |
c0a3b488 AC |
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 | |
c0a3b488 | 456 | in |
16abb0f9 AC |
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>")) | |
c0a3b488 | 463 | end |
8291a2b9 AC |
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 | ||
16abb0f9 | 472 | val _ = unify state (pos, ExpUn e, ty, pty) |
8291a2b9 AC |
473 | |
474 | val (ty', str') = xexp (addVars (state, vars')) e' | |
475 | in | |
16abb0f9 | 476 | unify state (pos, ExpUn e', ty', bodyTy); |
8291a2b9 AC |
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 | |
c0a3b488 AC |
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 | |
8291a2b9 AC |
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 | ||
16abb0f9 | 518 | val _ = unify state (pos, ExpUn exp, dom, pty) |
8291a2b9 AC |
519 | |
520 | val (ty', str') = xexp (addVars (state, vars')) e' | |
521 | in | |
16abb0f9 | 522 | unify state (pos, ExpUn e', ty', ran); |
8291a2b9 AC |
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 | |
16abb0f9 | 537 | unify state (pos, ExpUn e, ty, BasicTypes.exnTy); |
8291a2b9 AC |
538 | (newTyvar false, "(raise (" ^ es ^ "))") |
539 | end | |
16abb0f9 AC |
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 | |
c0a3b488 AC |
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 | |
16abb0f9 | 574 | unify state (pos, ExpUn e, ty, ty'); |
c0a3b488 AC |
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 | ||
8291a2b9 | 591 | and mergePatVars pos (vars1, vars2) = |
c0a3b488 AC |
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 | ||
16abb0f9 | 597 | and xpat state (pat as PAT (p, pos)) = |
c0a3b488 AC |
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) | |
8291a2b9 | 612 | | Real_p n => (BasicTypes.realTy, StringMap.empty, Real.toString n) |
c0a3b488 | 613 | | String_p s => (BasicTypes.stringTy, StringMap.empty, "\"" ^ s ^ "\"") |
8291a2b9 | 614 | | Char_p s => (BasicTypes.charTy, StringMap.empty, "#\"" ^ s ^ "\"") |
c0a3b488 AC |
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 | |
16abb0f9 | 622 | unify state (pos, PatUn p, dom, ty); |
c0a3b488 AC |
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 | |
16abb0f9 | 631 | unify state (pos, PatUn p, dom, ty); |
c0a3b488 AC |
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 | |
16abb0f9 | 641 | unify state (pos, PatUn pat, ty2, resty); |
c0a3b488 AC |
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 | ||
16abb0f9 | 694 | and xblock state (BLOCK (blocks, pos)) = |
c0a3b488 AC |
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 | |
16abb0f9 | 723 | unify state (pos, ExpUn e, ty, vty); |
c0a3b488 AC |
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 | |
16abb0f9 | 732 | unify state (pos, ExpUn e, pty, ty); |
c0a3b488 AC |
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 | |
8291a2b9 | 751 | | Ifthenelse_i (e, b, els) => |
c0a3b488 AC |
752 | let |
753 | val str = str ^ "val _ = " | |
8291a2b9 AC |
754 | val (ty, s) = xexp state e |
755 | val (_, str') = xblock state b | |
16abb0f9 | 756 | val _ = unify state (pos, ExpUn e, ty, BasicTypes.boolTy) |
8291a2b9 AC |
757 | val str = str ^ "if (" ^ s ^ ") then let\n" ^ |
758 | str' ^ | |
759 | "in () end\n" | |
c0a3b488 AC |
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 | |
16abb0f9 | 775 | | Foreach_i (p, e, b) => |
c0a3b488 AC |
776 | let |
777 | val parm = newTyvar false | |
16abb0f9 AC |
778 | |
779 | val (pty, vars, ps) = xpat state p | |
c0a3b488 AC |
780 | val (ty, es) = xexp state e |
781 | ||
16abb0f9 AC |
782 | val _ = unify state (pos, ExpUn e, ty, Types.CONty (BasicTypes.listTycon, [parm])) |
783 | val _ = unify state (pos, PatUn p, pty, parm) | |
c0a3b488 | 784 | |
16abb0f9 AC |
785 | val state' = addVars (state, vars) |
786 | val (_, bs) = xblock state' b | |
787 | in | |
788 | (state, str ^ "fun foreach ((" ^ ps ^ ") : " ^ | |
8291a2b9 | 789 | tyToString state parm ^ ") = let\n" ^ |
c0a3b488 AC |
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 | |
16abb0f9 | 797 | val _ = unify state (pos, ExpUn eFrom, ty1, BasicTypes.intTy) |
c0a3b488 AC |
798 | |
799 | val (ty2, es2) = xexp state eTo | |
16abb0f9 | 800 | val _ = unify state (pos, ExpUn eTo, ty2, BasicTypes.intTy) |
c0a3b488 AC |
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" ^ | |
8291a2b9 | 808 | "val _ = Web.for forFunc (" ^ es1 ^ ", " ^ es2 ^ ")\n") |
c0a3b488 AC |
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 | ||
16abb0f9 | 818 | val _ = unify state (pos, PatUn p, ty, pty) |
c0a3b488 AC |
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 | |
16abb0f9 | 845 | unify state (pos, PatUn p, BasicTypes.exnTy, pty); |
c0a3b488 AC |
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 |