src/mlt.sml

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