[bpt/mlt.git] / src / mlt.sml

(*
 * 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";
		    PrettyPrint.add_break ppstream (1, 0);
		    PrettyPrint.begin_block ppstream PrettyPrint.CONSISTENT 5;
		    PPType.ppType env ppstream t1;
		    PrettyPrint.end_block ppstream;
		    PrettyPrint.add_break ppstream (1, 0);
		    PrettyPrint.add_string ppstream "and";
		    PrettyPrint.add_break ppstream (1, 0);
		    PrettyPrint.begin_block ppstream PrettyPrint.CONSISTENT 5;
		    PPType.ppType env ppstream t2;
		    PrettyPrint.end_block ppstream;
		    PrettyPrint.end_block ppstream;
		    PrettyPrint.add_break ppstream (1, 0);
		    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)
	   | Real_e n =>
		 (BasicTypes.realTy, Real.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
	   | Case_e (e, matches) =>
	     let
		 val (ty, s) = xexp state e
			       
		 fun folder ((p, e'), (first, str, bodyTy)) =
		     let
			 val (pty, vars', ps) = xpat state p
						
			 val _ = unify state (pos, ty, pty)
				 
			 val (ty', str') = xexp (addVars (state, vars')) e'
		     in
			 unify state (pos, ty', bodyTy);
			 (false,
			  str ^ (if first then "   " else " | ") ^ "(" ^ ps ^ ") => " ^
			  str' ^ "\n",
			  bodyTy)
		     end
		 val bodyTy = newTyvar false
		 val (_, str, _) =
		     foldl folder (true, "(case (" ^ s ^ ") of\n", bodyTy) matches
		 val str = str ^ ")\n"
	     in
		 (bodyTy, str)
	     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
	   | Fn_e matches =>
	     let
		 val dom = newTyvar false
		 val ran = newTyvar false
			       
		 fun folder ((p, e'), (first, str)) =
		     let
			 val (pty, vars', ps) = xpat state p
						
			 val _ = unify state (pos, dom, pty)
				 
			 val (ty', str') = xexp (addVars (state, vars')) e'
		     in
			 unify state (pos, ty', ran);
			 (false,
			  str ^ (if first then "   " else " | ") ^ "(" ^ ps ^ ") => " ^
			  str' ^ "\n")
		     end
		 val (_, str) =
		     foldl folder (true, "(fn \n") matches
		 val str = str ^ ")\n"
	     in
		 (BasicTypes.--> (dom, ran), str)
	     end
	   | Raise_e e =>
	     let
		 val (ty, es) = xexp state e
	     in
		 unify state (pos, ty, BasicTypes.exnTy);
		 (newTyvar false, "(raise (" ^ es ^ "))")
	     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>")

    and 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

    and 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)
	   | Real_p n => (BasicTypes.realTy, StringMap.empty, Real.toString n)
	   | String_p s => (BasicTypes.stringTy, StringMap.empty, "\"" ^ s ^ "\"")
	   | Char_p s => (BasicTypes.charTy, 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 (e, b, els) =>
			 let
			     val str = str ^ "val _ = "
			     val (ty, s) = xexp state e
			     val (_, str') = xblock state b
			     val _ = unify state (pos, ty, BasicTypes.boolTy)
			     val str = str ^ "if (" ^ s ^ ") then let\n" ^
				       str' ^
				       "in () end\n"
			     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 ^ " : " ^
				     tyToString state parm ^ ") = 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 _ = Web.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