| 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 | |