+(*
+ * Dynamic web page generation with Standard ML
+ * Copyright (C) 2003 Adam Chlipala
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ *)
+
+(* Translation of templates into SML source *)
+
+structure Mlt :> MLT =
+struct
+ open Tree
+
+ exception Skip
+
+ fun error (pos, msg) = (ErrorMsg.error pos msg;
+ raise Skip)
+
+ type varid = int
+
+ datatype var = VAR of Types.ty | REF of Types.ty
+
+ val errorTy = Types.WILDCARDty
+
+ val ppstream = PrettyPrint.mk_ppstream {consumer = TextIO.print, flush = fn () => TextIO.flushOut TextIO.stdOut,
+ linewidth = 80}
+
+ (* States to thread throughout translation *)
+ local
+ datatype state = STATE of {env: StaticEnv.staticEnv,
+ vars : var StringMap.map,
+ config : Config.config,
+ templates : StringSet.set}
+
+ datatype strct = STRCT of {elements: Modules.elements,
+ eenv: EntityEnv.entityEnv}
+
+ fun getElements (Modules.SIG {elements, ...}) = elements
+ | getElements _ = raise Fail "Unexpected Signature in getElements"
+
+ val bogusStamp = Stamps.special "<bogus>"
+ val errorStrct = STRCT {elements = [], eenv = EntityEnv.empty}
+ in
+ fun mkState (config, env, templates) =
+ STATE {config = config,
+ env = env,
+ vars = StringMap.empty,
+ templates = templates}
+
+ fun addVar (STATE {config, env, vars, templates}, v, ty) =
+ STATE {config = config, env = env, vars = StringMap.insert (vars, v, ty), templates = templates}
+ fun addVars (state, vars) = StringMap.foldli (fn (v, ty, state) => addVar (state, v, ty)) state vars
+
+ fun getVar (STATE {vars, ...}, v, pos) = StringMap.find (vars, v)
+ fun lookVal (STATE {env, ...}, v, pos) =
+ (case StaticEnv.look (env, Symbol.varSymbol v) of
+ Bindings.VALbind var =>
+ (case var of
+ VarCon.VALvar {typ, ...} => #1 (TypesUtil.instantiatePoly (!typ))
+ | _ => raise Fail "Unexpected var in lookVal")
+ | Bindings.CONbind (Types.DATACON {typ, ...}) => #1 (TypesUtil.instantiatePoly typ)
+ | _ => raise Fail "Unexpected binding in lookVal")
+ handle StaticEnv.Unbound => (error (SOME pos, "Unbound variable " ^ v);
+ errorTy)
+
+ fun lookCon' (STATE {env, ...}, v) =
+ (case StaticEnv.look (env, Symbol.varSymbol v) of
+ Bindings.CONbind (Types.DATACON {typ, ...}) => #1 (TypesUtil.instantiatePoly typ)
+ | _ => raise Fail "Unexpected binding in lookVal")
+ fun lookCon (env, v, pos) = (lookCon' (env, v))
+ handle ModuleUtil.Unbound _ => (error (SOME pos, "Unbound constructor " ^ v);
+ errorTy)
+ fun lookStr (STATE {env, ...}, v, pos) =
+ (case StaticEnv.look (env, Symbol.strSymbol v) of
+ Bindings.STRbind modl =>
+ (case modl of
+ Modules.STR {rlzn = {entities, ...}, sign, ...} => STRCT {elements = getElements sign,
+ eenv = entities}
+ | _=> raise Fail "Unexpected module in lookStr")
+ | _ => raise Fail "Unexpected binding in lookStr")
+ handle StaticEnv.Unbound => (error (SOME pos, "Unbound structure " ^ v);
+ errorStrct)
+
+ fun getStr (STRCT {elements, eenv, ...}, v, pos) =
+ (case ModuleUtil.getStr (elements, eenv, Symbol.strSymbol v, Access.nullAcc, II.Null) of
+ (Modules.STR {rlzn = {entities, ...}, sign = Modules.SIG {elements, ...}, ...}, _) =>
+ STRCT {elements = elements, eenv = entities}
+ | _ => raise Fail "Unexpected spec in getStr")
+ handle ModuleUtil.Unbound _ => (error (SOME pos, "Unbound structure " ^ v);
+ errorStrct)
+ fun getVal (STRCT {elements, ...}, v, pos) =
+ (case ModuleUtil.getSpec (elements, Symbol.varSymbol v) of
+ Modules.VALspec {spec, ...} => #1 (TypesUtil.instantiatePoly spec)
+ | _ => raise Fail "Unexpected spec in getVal")
+ handle ModuleUtil.Unbound _ => (case ModuleUtil.getSpec (elements, Symbol.tycSymbol v) of
+ Modules.CONspec {spec = Types.DATACON {typ, ...}, ...} => #1 (TypesUtil.instantiatePoly typ)
+ | _ => raise Fail "Unexpected spec in getVal")
+ handle ModuleUtil.Unbound _ => (error (SOME pos, "Unbound variable " ^ v);
+ errorTy)
+ fun getCon (STRCT {elements, ...}, v, pos) =
+ (case ModuleUtil.getSpec (elements, Symbol.varSymbol v) of
+ Modules.CONspec {spec = Types.DATACON {typ, ...}, ...} => #1 (TypesUtil.instantiatePoly typ)
+ | _ => raise Fail "Unexpected spec in getVal")
+ handle ModuleUtil.Unbound _ => (error (SOME pos, "Unbound constructor " ^ v);
+ errorTy)
+
+ fun unify (STATE {env, ...}) (pos, t1, t2) =
+ (*let
+ val t1 = ModuleUtil.transType eenv t1
+ val t2 = ModuleUtil.transType eenv t2
+ in*)
+ Unify.unifyTy (t1, t2)
+ (*end*)
+ handle Unify.Unify msg =>
+ (PrettyPrint.begin_block ppstream PrettyPrint.CONSISTENT 0;
+ PrettyPrint.add_string ppstream "Error unifying\n\t";
+ PrettyPrint.add_break ppstream (0, 0);
+ PrettyPrint.begin_block ppstream PrettyPrint.CONSISTENT 5;
+ PPType.ppType env ppstream t1;
+ PrettyPrint.end_block ppstream;
+ PrettyPrint.add_break ppstream (0, 0);
+ PrettyPrint.add_string ppstream "\nand\n\t";
+ PrettyPrint.add_break ppstream (0, 0);
+ PrettyPrint.begin_block ppstream PrettyPrint.CONSISTENT 5;
+ PPType.ppType env ppstream t2;
+ PrettyPrint.end_block ppstream;
+ PrettyPrint.add_string ppstream "\n";
+ PrettyPrint.end_block ppstream;
+ PrettyPrint.flush_ppstream ppstream;
+ error (SOME pos, Unify.failMessage msg))
+
+ fun resolvePath (getter, transer) (pos, state, path) =
+ let
+ fun traverse ([], _, _) = raise Fail "Impossible empty variable path in pat traverse"
+ | traverse ([v], str as STRCT {eenv, ...}, path) =
+ let
+ val ty = getter (str, v, pos)
+ val ty = transer eenv ty
+ fun folder (STRCT {eenv, ...}, ty) = transer eenv ty
+ in
+ foldl folder ty path
+ end
+ | traverse (s::rest, str, path) = traverse (rest, getStr (str, s, pos), str::path)
+ in
+ case path of
+ [] => raise Fail "Empty path to resolvePath"
+ | [_] => raise Fail "Singleton path to resolvePath"
+ | (first::rest) => traverse (rest, lookStr (state, first, pos), [])
+ end
+
+ fun resolveStructure (pos, state, path) =
+ let
+ fun look (STATE {env, ...}, v, pos) =
+ (case StaticEnv.look (env, Symbol.strSymbol v) of
+ Bindings.STRbind modl =>
+ (case modl of
+ Modules.STR {rlzn = {entities, ...}, sign, ...} => (getElements sign, entities, modl)
+ | _=> raise Fail "Unexpected module in lookStr")
+ | _ => raise Fail "Unexpected binding in lookStr")
+ handle ModuleUtil.Unbound _ => (error (SOME pos, "Unbound structure " ^ v);
+ ([], EntityEnv.empty, Modules.ERRORstr))
+
+ fun get (elements, eenv, v) =
+ let
+ val sym = Symbol.strSymbol v
+ in
+ (case ModuleUtil.getStr (elements, eenv, sym, Access.nullAcc, II.Null) of
+ (str as Modules.STR {rlzn = {entities, ...}, sign = Modules.SIG {elements, ...}, ...}, _) =>
+ (elements, entities, str)
+ | _ => raise Fail "Unexpected spec in resolveStructure")
+ handle ModuleUtil.Unbound _ => (error (SOME pos, "Unbound structure " ^ v);
+ ([], EntityEnv.empty, Modules.ERRORstr))
+ end
+
+ fun traverse ([], (_, _, str)) = str
+ | traverse ([v], (elements, eenv, _)) = #3 (get (elements, eenv, v))
+ | traverse (s::rest, (elements, eenv, _)) = traverse (rest, get (elements, eenv, s))
+ in
+ case path of
+ [] => raise Fail "Empty path to resolveStructure"
+ | (first::rest) => traverse (rest, look (state, first, pos))
+ end
+
+ fun openStructure (pos, state as STATE {config, env, vars, templates}, path) =
+ let
+ val str = resolveStructure (pos, state, path)
+ val env = ModuleUtil.openStructure (env, str)
+ in
+ STATE {config = config, env = env, vars = vars, templates = templates}
+ end
+
+ fun tyToString (STATE {env, ...}) ty =
+ PrettyPrint.pp_to_string 65535 (PPType.ppType env) ty
+
+ fun printFn (state as STATE {config, env, ...}) ty =
+ let
+ val tyname = tyToString state ty
+ in
+ Config.printFn config tyname
+ end
+
+ fun isTemplate (STATE {templates, ...}) s = StringSet.member (templates, s)
+ end
+
+ fun twiddleType f ty =
+ (case TypesUtil.headReduceType ty of
+ Types.WILDCARDty => ty
+ | _ => f ty)
+
+ val domain = twiddleType BasicTypes.domain
+ val range = twiddleType BasicTypes.range
+
+ (*val _ = (Unify.debugging := true;
+ EntityEnv.debugging := true;
+ ModuleUtil.debugging := true)*)
+
+ fun newTyvar eq = Types.VARty (Types.mkTyvar (Types.OPEN {depth = 0, eq = eq, kind = Types.META}))
+ fun newFlex elms = Types.VARty (Types.mkTyvar (Types.OPEN {depth = 0, eq = false, kind = Types.FLEX elms}))
+
+ val resolveVal = resolvePath (getVal, ModuleUtil.transType)
+ val resolveCon = resolvePath (getCon, ModuleUtil.transType)
+
+ fun escapeString s =
+ let
+ val chars = String.explode s
+ val escd = map (fn #"\"" => "\\\""
+ | #"\n" => "\\n"
+ | #"\r" => ""
+ | #"\t" => "\\t"
+ | x => str x) chars
+ in
+ String.concat escd
+ end
+
+ val mkTuple = BasicTypes.tupleTy
+
+ val templateTy = BasicTypes.--> (Types.CONty (BasicTypes.listTycon,
+ [mkTuple [BasicTypes.stringTy,
+ BasicTypes.stringTy]]), BasicTypes.unitTy)
+
+ fun xexp state (EXP (e, pos)) =
+ (case e of
+ Int_e n =>
+ (BasicTypes.intTy, Int.toString n)
+ | String_e s =>
+ (BasicTypes.stringTy, "\"" ^ s ^ "\"")
+ | Char_e s =>
+ (BasicTypes.charTy, "#\"" ^ s ^ "\"")
+ | Cons_e (e1, e2) =>
+ let
+ val (ty1, es1) = xexp state e1
+ val (ty2, es2) = xexp state e2
+
+ val parm = newTyvar false
+ val ran = Types.CONty (BasicTypes.listTycon, [parm])
+ val dom = mkTuple [parm, ran]
+
+ val xt = mkTuple [ty1, ty2]
+ in
+ unify state (pos, dom, xt);
+ (ran, "(" ^ es1 ^ ") :: (" ^ es2 ^ ")")
+ end
+ | StrCat_e (e1, e2) =>
+ let
+ val (ty1, es1) = xexp state e1
+ val (ty2, es2) = xexp state e2
+ in
+ unify state (pos, ty1, BasicTypes.stringTy);
+ unify state (pos, ty2, BasicTypes.stringTy);
+ (BasicTypes.stringTy, "(" ^ es1 ^ ") ^ (" ^ es2 ^ ")")
+ end
+ | Orelse_e (e1, e2) =>
+ let
+ val (ty1, es1) = xexp state e1
+ val (ty2, es2) = xexp state e2
+ in
+ unify state (pos, ty1, BasicTypes.boolTy);
+ unify state (pos, ty2, BasicTypes.boolTy);
+ (BasicTypes.boolTy, "(" ^ es1 ^ ") orelse (" ^ es2 ^ ")")
+ end
+ | Andalso_e (e1, e2) =>
+ let
+ val (ty1, es1) = xexp state e1
+ val (ty2, es2) = xexp state e2
+ in
+ unify state (pos, ty1, BasicTypes.boolTy);
+ unify state (pos, ty2, BasicTypes.boolTy);
+ (BasicTypes.boolTy, "(" ^ es1 ^ ") andalso (" ^ es2 ^ ")")
+ end
+ | Plus_e (e1, e2) =>
+ let
+ val (ty1, es1) = xexp state e1
+ val (ty2, es2) = xexp state e2
+ in
+ unify state (pos, ty1, BasicTypes.intTy);
+ unify state (pos, ty2, BasicTypes.intTy);
+ (BasicTypes.intTy, "(" ^ es1 ^ ") + (" ^ es2 ^ ")")
+ end
+ | Minus_e (e1, e2) =>
+ let
+ val (ty1, es1) = xexp state e1
+ val (ty2, es2) = xexp state e2
+ in
+ unify state (pos, ty1, BasicTypes.intTy);
+ unify state (pos, ty2, BasicTypes.intTy);
+ (BasicTypes.intTy, "(" ^ es1 ^ ") - (" ^ es2 ^ ")")
+ end
+ | Times_e (e1, e2) =>
+ let
+ val (ty1, es1) = xexp state e1
+ val (ty2, es2) = xexp state e2
+ in
+ unify state (pos, ty1, BasicTypes.intTy);
+ unify state (pos, ty2, BasicTypes.intTy);
+ (BasicTypes.intTy, "(" ^ es1 ^ ") * (" ^ es2 ^ ")")
+ end
+ | Divide_e (e1, e2) =>
+ let
+ val (ty1, es1) = xexp state e1
+ val (ty2, es2) = xexp state e2
+ in
+ unify state (pos, ty1, BasicTypes.intTy);
+ unify state (pos, ty2, BasicTypes.intTy);
+ (BasicTypes.intTy, "(" ^ es1 ^ ") div (" ^ es2 ^ ")")
+ end
+ | Mod_e (e1, e2) =>
+ let
+ val (ty1, es1) = xexp state e1
+ val (ty2, es2) = xexp state e2
+ in
+ unify state (pos, ty1, BasicTypes.intTy);
+ unify state (pos, ty2, BasicTypes.intTy);
+ (BasicTypes.intTy, "(" ^ es1 ^ ") mod (" ^ es2 ^ ")")
+ end
+ | Lt_e (e1, e2) =>
+ let
+ val (ty1, es1) = xexp state e1
+ val (ty2, es2) = xexp state e2
+ in
+ unify state (pos, ty1, BasicTypes.intTy);
+ unify state (pos, ty2, BasicTypes.intTy);
+ (BasicTypes.boolTy, "(" ^ es1 ^ ") < (" ^ es2 ^ ")")
+ end
+ | Lte_e (e1, e2) =>
+ let
+ val (ty1, es1) = xexp state e1
+ val (ty2, es2) = xexp state e2
+ in
+ unify state (pos, ty1, BasicTypes.intTy);
+ unify state (pos, ty2, BasicTypes.intTy);
+ (BasicTypes.boolTy, "(" ^ es1 ^ ") <= (" ^ es2 ^ ")")
+ end
+ | Gt_e (e1, e2) =>
+ let
+ val (ty1, es1) = xexp state e1
+ val (ty2, es2) = xexp state e2
+ in
+ unify state (pos, ty1, BasicTypes.intTy);
+ unify state (pos, ty2, BasicTypes.intTy);
+ (BasicTypes.boolTy, "(" ^ es1 ^ ") > (" ^ es2 ^ ")")
+ end
+ | Gte_e (e1, e2) =>
+ let
+ val (ty1, es1) = xexp state e1
+ val (ty2, es2) = xexp state e2
+ in
+ unify state (pos, ty1, BasicTypes.intTy);
+ unify state (pos, ty2, BasicTypes.intTy);
+ (BasicTypes.boolTy, "(" ^ es1 ^ ") >= (" ^ es2 ^ ")")
+ end
+ | Param_e => (BasicTypes.--> (BasicTypes.stringTy, BasicTypes.stringTy), "Web.getParam")
+ | Neg_e => (BasicTypes.--> (BasicTypes.intTy, BasicTypes.intTy), "~")
+ | Template_e name =>
+ if isTemplate state name then
+ let
+ fun toUpper ch = chr (ord ch + ord #"A" - ord #"a")
+ val name = str (toUpper (String.sub (name, 0))) ^ String.extract (name, 1, NONE)
+ in
+ (templateTy, "(Web.withParams " ^ name ^ ".exec)")
+ end
+ else
+ (error (SOME pos, "Unknown template " ^ name);
+ (errorTy, "<errorTemplate>"))
+ | Proj_e field =>
+ let
+ val carried = newTyvar false
+ in
+ (BasicTypes.--> (newFlex [(Symbol.labSymbol field, carried)], carried), "#" ^ field)
+ end
+ | Eq_e (e1, e2) =>
+ let
+ val (ty1, s1) = xexp state e1
+ val (ty2, s2) = xexp state e2
+ in
+ unify state (pos, ty1, ty2);
+ unify state (pos, ty1, newTyvar true);
+ (BasicTypes.boolTy, "(" ^ s1 ^ ") = (" ^ s2 ^ ")")
+ end
+ | Neq_e (e1, e2) =>
+ let
+ val (ty1, s1) = xexp state e1
+ val (ty2, s2) = xexp state e2
+ in
+ unify state (pos, ty1, ty2);
+ unify state (pos, ty1, newTyvar true);
+ (BasicTypes.boolTy, "(" ^ s1 ^ ") <> (" ^ s2 ^ ")")
+ end
+ | Ident_e [] => raise Fail "Impossible empty variable path"
+ | Ident_e [id] =>
+ (case getVar (state, id, SOME pos) of
+ NONE => (lookVal (state, id, pos), id)
+ | SOME (VAR ty) => (ty, id)
+ | SOME (REF ty) => (ty, "!" ^ id))
+ | Ident_e (path as (s::rest)) =>
+ (resolveVal (pos, state, path), foldl (fn (v, st) => st ^ "." ^ v) s rest)
+ | App_e (f, x) =>
+ let
+ val (ft, fs) = xexp state f
+ val (xt, xs) = xexp state x
+
+ (*val (ft, _) = TypesUtil.instantiatePoly ft*)
+ val dom = domain ft
+ val ran = range ft
+ in
+ unify state (pos, dom, xt);
+ (ran, "(" ^ fs ^ ") (" ^ xs ^ ")")
+ end
+ | Record_e (ist, cs) =>
+ let
+ val (cs, str) = foldl (fn ((id, e), (cs, str)) =>
+ let
+ val idSym = Symbol.labSymbol id
+ val _ = List.all (fn (id', _) => idSym <> id') cs
+ orelse error (SOME pos, "Duplicate label " ^ id ^ " in record")
+ val (ty, s) = xexp state e
+ in
+ ((idSym, ty) :: cs, str ^ ", " ^ id ^ " = " ^ s)
+ end) ([], "") cs
+ val cs = rev cs
+ val str =
+ case str of
+ "" => str
+ | _ => String.extract(str, 2, NONE)
+ val str = "{" ^ str ^ "}"
+ in
+ (BasicTypes.recordTy cs, str)
+ end
+ | RecordUpd_e (e, cs) =>
+ let
+ val (ty, es) = xexp state e
+
+ val cs' =
+ case TypesUtil.headReduceType ty of
+ Types.CONty (Types.RECORDtyc labs, tys) => ListPair.zip (labs, tys)
+ | _ => error (SOME pos, "Record update on non-record")
+
+ val (n, str) = foldl (fn ((id, ty), (n, str)) =>
+ case List.find (fn (id', _) => id = Symbol.labSymbol id') cs of
+ NONE => (n, str ^ ", " ^ Symbol.name id ^ " = #" ^
+ Symbol.name id ^ " " ^ "UPD'")
+ | SOME (_, e) =>
+ let
+ val (ty', s) = xexp state e
+ in
+ unify state (pos, ty, ty');
+ (n + 1, str ^ ", " ^ Symbol.name id ^ " = " ^ s)
+ end) (0, "") cs'
+
+ val _ = n = length cs
+ orelse error (SOME pos, "Updated fields in record update not found in starting expression")
+
+ val str =
+ case str of
+ "" => str
+ | _ => String.extract(str, 2, NONE)
+ val str = "let val UPD' = " ^ es ^ " in {" ^ str ^ "} end"
+ in
+ (ty, str)
+ end)
+ handle Skip => (errorTy, "<error>")
+
+ fun mergePatVars pos (vars1, vars2) =
+ StringMap.foldli (fn (v, ty, vars) =>
+ (case StringMap.find (vars, v) of
+ NONE => StringMap.insert (vars, v, ty)
+ | SOME _ => error (SOME pos, "Duplicate variable " ^ v ^ " in pattern"))) vars1 vars2
+
+ fun xpat state (PAT (p, pos)) =
+ (case p of
+ Ident_p [] => raise Fail "Impossible empty Ident_p"
+ | Ident_p [id] =>
+ ((lookCon' (state, id), StringMap.empty, id)
+ handle StaticEnv.Unbound =>
+ let
+ val ty = newTyvar false
+ in
+ (ty, StringMap.insert (StringMap.empty, id, VAR ty), id)
+ end)
+ | Ident_p (path as (s::rest)) =>
+ (resolveCon (pos, state, path), StringMap.empty, foldl (fn (v, st) => st ^ "." ^ v) s rest)
+ | Wild_p => (newTyvar false, StringMap.empty, "_")
+ | Int_p n => (BasicTypes.intTy, StringMap.empty, Int.toString n)
+ | String_p s => (BasicTypes.stringTy, StringMap.empty, "\"" ^ s ^ "\"")
+ | App_p ([], _) => raise Fail "Impossible App_p"
+ | App_p ([id], p) =>
+ let
+ val (ty, vars, s) = xpat state p
+ val tyc = lookCon (state, id, pos)
+ val dom = domain tyc
+ in
+ unify state (pos, dom, ty);
+ (range tyc, vars, id ^ " (" ^ s ^ ")")
+ end
+ | App_p (path as (fst::rest), p) =>
+ let
+ val (ty, vars, s) = xpat state p
+ val tyc = resolveCon (pos, state, path)
+ val dom = domain tyc
+ in
+ unify state (pos, dom, ty);
+ (range tyc, vars, foldl (fn (n, st) => st ^ "." ^ n) fst rest ^ " (" ^ s ^ ")")
+ end
+ | Cons_p (p1, p2) =>
+ let
+ val (ty1, vars', s1) = xpat state p1
+ val (ty2, vars'', s2) = xpat state p2
+
+ val resty = Types.CONty (BasicTypes.listTycon, [ty1])
+ in
+ unify state (pos, ty2, resty);
+ (resty, mergePatVars pos (vars', vars''), "(" ^ s1 ^ ")::(" ^ s2 ^ ")")
+ end
+ | As_p (id, p) =>
+ let
+ val (ty, vars, s) = xpat state p
+ in
+ not (Option.isSome (StringMap.find(vars, id)))
+ orelse error (SOME pos, "Duplicate variable " ^ id ^ " in pattern");
+ (ty, StringMap.insert (vars, id, VAR ty), id ^ " as (" ^ s ^ ")")
+ end
+ | Record_p (ist, cs) =>
+ let
+ val (cs, vars, str) = foldl (fn ((id, p), (cs, vars, str)) =>
+ let
+ val (ty, vars', s) = xpat state p
+ in
+ ((Symbol.labSymbol id, ty)::cs, mergePatVars pos (vars, vars'),
+ str ^ ", " ^ id ^ " = " ^ s)
+ end) ([], StringMap.empty, "") cs
+ val cs = rev cs
+ val str =
+ if String.size str >= 2 then
+ String.extract(str, 2, NONE)
+ else
+ str
+ val str = "{" ^ str ^ "}"
+ in
+ (BasicTypes.recordTy cs, vars, str)
+ end
+ | FlexRecord_p cs =>
+ let
+ val (cs, vars, str) = foldl (fn ((id, p), (cs, vars, str)) =>
+ let
+ val (ty, vars', s) = xpat state p
+ in
+ ((Symbol.labSymbol id, ty)::cs, mergePatVars pos (vars, vars'),
+ str ^ ", " ^ id ^ " = " ^ s)
+ end) ([], StringMap.empty, "") cs
+ val cs = rev cs
+ val str =
+ if String.size str >= 2 then
+ String.extract(str, 2, NONE)
+ else
+ str
+ val str = "{" ^ str ^ ", ...}"
+ in
+ (newFlex cs, vars, str)
+ end
+ (*| _ =>
+ error (SOME pos, "Not done yet!!!")*))
+ handle Skip => (errorTy, StringMap.empty, "<error>")
+
+ fun xblock state (BLOCK (blocks, pos)) =
+ let
+ fun folder (BITEM (bi, pos), (state, str)) =
+ (case bi of
+ Html_i s =>
+ (state, str ^ "val _ = Web.print (\"" ^ escapeString s ^ "\")\n")
+ | Ref_i rs =>
+ let
+ fun folder ((id, e), (state, str)) =
+ let
+ val (ty, es) = xexp state e
+
+ val state = addVar (state, id, REF ty)
+ in
+ (state, str ^ "val " ^ id ^ " = ref (" ^ es ^ ")\n")
+ end
+ in
+ foldl folder (state, str) rs
+ end
+ | Assn_i (id, e) =>
+ let
+ val vty =
+ case getVar (state, id, SOME pos) of
+ NONE => error (SOME pos, "Unbound variable " ^ id)
+ | SOME (REF vty) => vty
+ | _ => error (SOME pos, "Can't assign to non-ref variable " ^ id)
+
+ val (ty, es) = xexp state e
+ in
+ unify state (pos, ty, vty);
+ (state, str ^ "val _ = " ^ id ^ " := (" ^ es ^ ")\n")
+ end
+ | Val_i (p, e) =>
+ let
+ val (pty, vars, ps) = xpat state p
+ val state' = addVars (state, vars)
+ val (ty, es) = xexp state e
+ in
+ unify state (pos, pty, ty);
+ (state', str ^ "val " ^ ps ^ " = (" ^ es ^ ")\n")
+ end
+ | Exp_i e =>
+ let
+ val (ty, s) = xexp state e
+ val ty = TypesUtil.headReduceType ty
+ val printFn =
+ case printFn state ty of
+ NONE => (if tyToString state ty = "_" then
+ ()
+ else
+ error (SOME pos, "Unable to convert value of type " ^
+ tyToString state ty ^ " to string");
+ "<errorPrint>")
+ | SOME v => v
+ in
+ (state, str ^ "val _ = " ^ printFn ^ " (" ^ s ^ ")\n")
+ end
+ | Ifthenelse_i (ifs, els) =>
+ let
+ val str = str ^ "val _ = "
+ fun folder ((e, b), (first, str)) =
+ let
+ val (ty, s) = xexp state e
+ val (_, str') = xblock state b
+ in
+ unify state (pos, ty, BasicTypes.boolTy);
+ (false, str ^ (if first then "" else "else ") ^ "if (" ^ s ^ ") then let\n" ^
+ str' ^
+ "in () end\n")
+ end
+ val (_, str) = foldl folder (true, str) ifs
+ val str =
+ case els of
+ NONE =>
+ str ^ "else ()\n"
+ | SOME els =>
+ let
+ val (_, str') = xblock state els
+ in
+ str ^ "else let\n" ^
+ str' ^
+ "in () end\n"
+ end
+ in
+ (state, str)
+ end
+ | Foreach_i (id, e, b) =>
+ let
+ val parm = newTyvar false
+
+ val (ty, es) = xexp state e
+
+ val _ = unify state (pos, ty, Types.CONty (BasicTypes.listTycon, [parm]))
+
+ (*val _ = print ("... to " ^ tyToString (context, ivmap, pty) ^ "\n")*)
+
+ val state = addVar (state, id, VAR parm)
+ val (_, bs) = xblock state b
+ in
+ (state, str ^ "fun foreach (" ^ id ^ (*" : " ^
+ Elab.tyToString (context, ivmap, pty) ^*) ") = let\n" ^
+ bs ^
+ "in () end\n" ^
+ "val _ = app foreach (" ^ es ^ ")\n")
+ end
+ | For_i (id, eFrom, eTo, b) =>
+ let
+ val (ty1, es1) = xexp state eFrom
+ val _ = unify state (pos, ty1, BasicTypes.intTy)
+
+ val (ty2, es2) = xexp state eTo
+ val _ = unify state (pos, ty2, BasicTypes.intTy)
+
+ val state = addVar (state, id, VAR BasicTypes.intTy)
+ val (_, bs) = xblock state b
+ in
+ (state, str ^ "fun forFunc " ^ id ^ " = let\n" ^
+ bs ^
+ "in () end\n" ^
+ "val _ = for forFunc (" ^ es1 ^ ", " ^ es2 ^ ")\n")
+ end
+ | Case_i (e, matches) =>
+ let
+ val (ty, s) = xexp state e
+
+ fun folder ((p, b), (first, str)) =
+ let
+ val (pty, vars', ps) = xpat state p
+
+ val _ = unify state (pos, ty, pty)
+
+ val (_, str') = xblock (addVars (state, vars')) b
+
+ (*val _ = print ("Pattern type: " ^ tyToString (context, ivmap, pty) ^ " vs. " ^ tyToString (context, ivmap, ty) ^ "\n")*)
+ in
+ (false,
+ str ^ (if first then " " else " | ") ^ "(" ^ ps ^ ") => let\n" ^
+ str' ^
+ "in () end\n")
+ end
+ val (_, str) =
+ foldl folder (true, str ^ "val _ = (case (" ^ s ^ ") of\n") matches
+ val str = str ^ ") handle Match => ()\n"
+ in
+ (state, str)
+ end
+ | TryCatch_i (b, matches) =>
+ let
+ val (_, bs) = xblock state b
+
+ fun folder ((p, b), (first, str)) =
+ let
+ val (pty, vars, ps) = xpat state p
+ val state = addVars (state, vars)
+ val (_, str') = xblock state b
+ in
+ unify state (pos, BasicTypes.exnTy, pty);
+ (false,
+ str ^ (if first then " " else " | ") ^ "(" ^ ps ^ ") => let\n" ^
+ str' ^
+ "in () end\n")
+ end
+ val (_, str) =
+ foldl folder (true,
+ str ^ "val _ = (let\n" ^
+ bs ^
+ "in () end handle\n") matches
+ val str = str ^ ")\n"
+ in
+ (state, str)
+ end
+ | Open_i paths =>
+ let
+ fun folder (path, state) = openStructure (pos, state, path)
+
+ val str = foldl (fn (path, str) => str ^ " " ^ Tree.pathString path) (str ^ "open") paths
+ val str = str ^ "\n"
+ in
+ (foldl folder state paths, str)
+ end)
+ handle Skip => (state, str)
+ in
+ foldl folder (state, "") blocks
+ end
+
+ fun trans (config, env, templates, name, block) =
+ let
+ val state = mkState (config, env, templates)
+ val (_, str) = xblock state block
+ in
+ "(* This file generated automatically by something or other *)\n" ^
+ "\n" ^
+ "structure " ^ name ^ " :> TEMPLATE =\n" ^
+ "struct\n" ^
+ "fun exec () = let\n" ^
+ str ^
+ "in () end\n" ^
+ "end\n"
+ end
+end
+
+