Various improvements made while working on relwiki

diff --git a/src/compiler.sml b/src/compiler.sml
index 0b6d484..6e31f5a 100644 (file)
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -141,7 +141,7 @@ struct
            val _ = TextIO.closeOut outf
            
            val outf = TextIO.openOut (outPath ^ "/.build.sml")
-           val _ = TextIO.output (outf, "Control.quotation := true;\n")
+           val _ = TextIO.output (outf, "Control.quotation := true;\nControl.printWarnings := false;\n")
            fun printMlts [] = ()
              | printMlts (h::t) =
                (TextIO.output (outf, "\"" ^ h ^ "\"");
@@ -241,6 +241,10 @@ struct
            val _ = TextIO.output (outf, "]\nend\n\nstructure Main = MainFn(Templates)\n")
            val _ = TextIO.closeOut outf
 
+           val outf = TextIO.openOut (outPath ^ "/.build.sml")
+           val _ = TextIO.output (outf, "Control.printWarnings := false;\nCM.make \"sources.cm\";\nSMLofNJ.exportFn (\"" ^ outPath ^ "/heap\", Main.main);\n")
+           val _ = TextIO.closeOut outf
+
            val outf = TextIO.openOut (outPath ^ "/sources.cm")
            val printNames = app (fn name => TextIO.output (outf, "\t" ^ name ^ "\n"))
 
@@ -268,7 +272,7 @@ struct
                 printNames outputs;
                 TextIO.output (outf, "\n\t(* Driver *)\n\n\t_main.sml\n");
                 TextIO.closeOut outf;
-                if OS.Process.system (sml ^ "/ml-build " ^ outPath ^ "/sources.cm Main.main " ^ outPath ^ "/heap") = OS.Process.success then
+                if OS.Process.system ("cat " ^ outPath ^ "/.build.sml | " ^ sml ^ "/sml") = OS.Process.success then
                     (ListPair.app makeScript (scripts, exports);
                      OS.Process.success)
                 else

diff --git a/src/lib/main.sml b/src/lib/main.sml
index 157afaa..84c47b3 100644 (file)
--- a/src/lib/main.sml
+++ b/src/lib/main.sml
@@ -29,6 +29,7 @@ struct
            val cgiFields = Cgi.cgi_fieldnames ()
            fun mapper name = (name, Cgi.cgi_field_strings name)
        in
+           Web.setHeader ("Content-type", "text/html");
            Web.pushParams (map mapper cgiFields);
            Templates.beforeFn ();
            case args of

diff --git a/src/lib/web.sig b/src/lib/web.sig
index b6b9830..71a5881 100644 (file)
--- a/src/lib/web.sig
+++ b/src/lib/web.sig
@@ -41,6 +41,7 @@ sig
 
     val html : string -> string
     val htmlNl : string -> string
+    val urlEncode : string -> string
 
     exception Format of string
     val stoi : string -> int
@@ -50,4 +51,18 @@ sig
 
     val getExn : unit -> exn
     val setExn : exn -> unit
+
+    val setHeader : string * string -> unit
+    val getHeader : string -> string option
+
+    type cookie = {name : string, value : string, expires : Date.date option,
+                  domain : string option, path : string option, secure : bool}
+    val setCookie : cookie -> unit
+    val getCookie : string -> string option
+
+    val remoteHost : unit -> string option
+
+    val minusSeconds : Time.time * int -> Time.time
+
+    val replaceUrlVar : string * string * string -> string
 end
\ No newline at end of file

diff --git a/src/lib/web.sml b/src/lib/web.sml
index a446e62..ebd49fb 100644 (file)
--- a/src/lib/web.sml
+++ b/src/lib/web.sml
@@ -78,17 +78,28 @@ struct
         ((f ()) handle ex => (popParams (); raise ex))
         before popParams ())
 
+    val headers = ref (StringMap.empty : string StringMap.map)
+    fun setHeader (n, v) = headers := StringMap.insert (!headers, n, v)
+    fun getHeader n = StringMap.find (!headers, n)
+
     val text = ref ([] : string list)
 
     fun print x = text := x :: (!text)
     fun clear () = text := []
     fun noOutput () = !text = []
     fun output () =
-       (TextIO.print "Status: 200\nContent-type: text/html\n\n";
+       (TextIO.print "Status: 200\n";
+        StringMap.appi (fn (n, v) => (TextIO.print n;
+                                      TextIO.print ": ";
+                                      TextIO.print v;
+                                      TextIO.print "\n")) (!headers);
+        TextIO.print "\n";
         TextIO.print (String.concat (List.rev (!text))))
 
     val getCgi = OS.Process.getEnv
 
+    val explode = CharVector.foldr (op::) []
+
     fun html s =
        let
            fun xch #"<" = "&lt;"
@@ -97,7 +108,7 @@ struct
              | xch #"\"" = "&quot;"
              | xch ch = str ch
        in
-           foldr op^ "" (map xch (String.explode s))
+           String.concat (map xch (explode s))
        end
 
     fun htmlNl s =
@@ -109,7 +120,26 @@ struct
              | xch #"\n" = "<br />"
              | xch ch = str ch
        in
-           foldr op^ "" (map xch (String.explode s))
+           String.concat  (map xch (explode s))
+       end
+
+    fun pad (n, ch) s =
+       if size s < n then
+           pad (n, ch) (ch ^ s)
+       else
+           s
+
+    fun urlEncode s =
+       let
+           fun xch ch =
+               if Char.isAlphaNum ch orelse ch = #"." then
+                   str ch
+               else if ch = #" " then
+                   "+"
+               else
+                   "%" ^ pad (2, "0") (Int.fmt StringCvt.HEX (ord ch))
+       in
+           String.concat (map xch (explode s))
        end
 
     exception Format of string
@@ -133,4 +163,94 @@ struct
     val exn = ref (NONE : exn option)
     fun setExn ex = exn := SOME ex
     fun getExn () = valOf (!exn)
+
+    type cookie = {name : string, value : string, expires : Date.date option,
+                  domain : string option, path : string option, secure : bool}
+
+    fun setCookie {name, value, expires, domain, path, secure} =
+       let
+           val s = name ^ "=" ^ value
+           val s =
+               case expires of
+                   NONE => s
+                 | SOME date => s ^ "; expires=" ^ Date.fmt "%a, %d-%b-%Y %H:%M:%S GMT" date
+           val s =
+               case domain of
+                   NONE => s
+                 | SOME dom => s ^ "; domain=" ^ dom
+           val s =
+               case path of
+                   NONE => s
+                 | SOME path => s ^ "; path=" ^ path
+           val s =
+               if secure then
+                   s ^ "; secure"
+               else
+                   s
+       in
+           setHeader ("Set-Cookie", s)
+       end
+
+    fun getCookie n =
+       (case getCgi "HTTP_COOKIE" of
+            NONE => NONE
+          | SOME cookies =>
+            let
+                fun search (n'::v::rest) =
+                    if n = n' then
+                        SOME v
+                    else
+                        search rest
+                  | search _ = NONE
+            in
+                search (String.tokens (fn ch => ch = #"=" orelse ch = #";" orelse ch = #" ") cookies)
+            end)
+
+    fun remoteHost () =
+       case getCgi "REMOTE_HOST" of
+           NONE => getCgi "REMOTE_ADDR"
+         | h => h
+
+    fun minusSeconds (t, s) = Time.- (t, Time.fromSeconds (LargeInt.fromInt s))
+
+    fun split (s, ch) =
+       let
+           val len = size s
+
+           fun find i =
+               if i >= len then
+                   NONE
+               else if String.sub (s, i) = ch then
+                   SOME (String.substring (s, 0, i), String.extract (s, i+1, NONE))
+               else
+                   find (i+1)
+       in
+           find 0
+       end
+
+    fun replaceUrlVar (url, n, v) =
+       case split (url, #"?") of
+           NONE => url
+         | SOME (uri, qs)  =>
+           let
+               fun doPair (nv, (L, yn)) =
+                   (case split (nv, #"=") of
+                        NONE => (nv::L, yn)
+                      | SOME (n', v') =>
+                        if n = n' then
+                            ((n ^ "=" ^ v)::L, true)
+                        else
+                            (nv::L, yn))
+               val (pairs, yn) = foldr doPair ([], false) (String.tokens (fn ch => ch = #"&") qs)
+               val pairs =
+                   if yn then
+                       pairs
+                   else
+                       (n ^ "=" ^ v) :: pairs
+           in
+               case pairs of
+                   [] => url
+                 | nv::rest => 
+                   String.concat (uri :: "?" :: nv :: foldr (fn (nv, L) => "&"::nv::L) [] rest)
+           end
 end
\ No newline at end of file

diff --git a/src/mlt.grm b/src/mlt.grm
index 6a584f5..5bb039d 100644 (file)
--- a/src/mlt.grm
+++ b/src/mlt.grm
@@ -31,6 +31,11 @@ fun addNumbers L =
                addNum (1, L)
        end
 
+fun compact' [] = []
+  | compact' (BITEM (Html_i h1, p1) :: BITEM (Html_i h2, p2) :: rest) = compact' (BITEM (Html_i (h1 ^ h2), p1) :: rest)
+  | compact' (first :: rest) = first :: compact' rest
+
+fun compact (BLOCK (items, pos)) = BLOCK (compact' items, pos)
 
 %%
 %header (functor MltLrValsFn(structure Token : TOKEN))
@@ -38,12 +43,12 @@ fun addNumbers L =
 %term 
    EOF
  | HTML of string
- | IF | THEN | ELSE
+ | IF | THEN | ELSE | ELSEIF | IFF
  | AS | WITH | OPEN | VAL | REF | TRY | CATCH
- | FN | END | RAISE
- | FOREACH | IN | DO
+ | FN | LET | IN | END | RAISE
+ | FOREACH | FOR | DO
  | SWITCH | CASE | OF | BAR | ARROW
- | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE | HASH | SEMI | CONS
+ | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE | HASH | SEMI | CONS | O
  | PLUS | MINUS | TIMES | DIVIDE | MOD | NEG | DOLLAR | AT | STRCAT
  | ASN | EQ | NEQ | GT | GTE | LT | LTE
  | ANDALSO | ORELSE
@@ -100,7 +105,7 @@ fun addNumbers L =
 
 %%
 
-file   : block                         (block)
+file   : block                         (compact block)
 
 ilist  : IDENT ilist                   (IDENT :: ilist)
        | IDENT                         ([IDENT])
@@ -108,7 +113,7 @@ ilist       : IDENT ilist                   (IDENT :: ilist)
 ivlist : IDENT EQ exp COMMA ivlist     ((IDENT, exp) :: ivlist)
        | IDENT EQ exp                  ([(IDENT, exp)])
 
-catch  : pat ARROW block               (pat, block)
+catch  : pat ARROW block               (pat, compact block)
 
 catches        : catches BAR catch             (catch::catches)
        | catch                         ([catch])
@@ -120,21 +125,24 @@ blockItem : HTML                  (BITEM (Html_i HTML, (HTMLleft, HTMLright)))
                | IDENT ASN exp         (BITEM (Assn_i (IDENT, exp), (IDENTleft, expright)))
                | exp                   (BITEM (Exp_i exp, (expleft, expright)))
                | IF exp THEN block elseOpt END
-                        (BITEM (Ifthenelse_i(exp, block, elseOpt),
+                        (BITEM (Ifthenelse_i(exp, compact block, elseOpt),
                                (IFleft, ENDright)))
-               | FOREACH IDENT IN exp DO block END
-                       (BITEM (Foreach_i (IDENT, exp, block),
+               | FOREACH pat IN exp DO block END
+                       (BITEM (Foreach_i (pat, exp, compact block),
                                (FOREACHleft, ENDright)))
-               | FOREACH IDENT IN exp DOTDOT exp DO block END
-                       (BITEM (For_i (IDENT, exp1, exp2, block),
-                               (FOREACHleft, ENDright)))
+               | FOR IDENT IN exp DOTDOT exp DO block END
+                       (BITEM (For_i (IDENT, exp1, exp2, compact block),
+                               (FORleft, ENDright)))
                | SWITCH exp OF matches END
                        (BITEM (Case_i (exp, List.rev (#1 matches)), (SWITCHleft, ENDright)))
                | TRY block WITH catches END
-                       (BITEM (TryCatch_i (block, List.rev catches), (TRYleft, ENDright)))
+                       (BITEM (TryCatch_i (compact block, List.rev catches), (TRYleft, ENDright)))
 
-elseOpt         :                       (NONE)
-                | ELSE block            (SOME block)
+elseOpt         :                                 (NONE)
+                | ELSEIF exp THEN block elseOpt  (SOME (BLOCK ([BITEM (Ifthenelse_i (exp, compact block, elseOpt),
+                                                                      (ELSEIFleft, elseOptright))],
+                                                              (ELSEIFleft, elseOptright))))
+                | ELSE block                      (SOME (compact block))
 
 block  : blockItem                     (BLOCK ([blockItem], (blockItemleft, blockItemright)))
        | blockItem SEMI block          (BLOCK (blockItem :: (unblock block), (blockItemleft, blockright)))
@@ -204,19 +212,22 @@ exp       : apps                          (apps)
        | exp GT exp                    (EXP (Gt_e (exp1, exp2), (exp1left, exp2right)))
        | exp GTE exp                   (EXP (Gte_e (exp1, exp2), (exp1left, exp2right)))
        | exp CONS exp                  (EXP (Cons_e (exp1, exp2), (exp1left, exp2right)))
+        | exp O exp                     (EXP (Compose_e (exp1, exp2), (exp1left, exp2right)))
        | exp STRCAT exp                (EXP (StrCat_e (exp1, exp2), (exp1left, exp2right)))
        | exp ORELSE exp                (EXP (Orelse_e (exp1, exp2), (exp1left, exp2right)))
        | exp ANDALSO exp               (EXP (Andalso_e (exp1, exp2), (exp1left, exp2right)))
         | CASE exp OF cases             (EXP (Case_e (exp, List.rev cases), (expleft, casesright)))
         | FN cases                      (EXP (Fn_e (List.rev cases), (FNleft, casesright)))
         | RAISE exp                     (EXP (Raise_e exp, (RAISEleft, expright)))
+        | LET block IN exp END          (EXP (Let_e (compact block, exp), (LETleft, ENDright)))
+        | IFF exp THEN exp ELSE exp     (EXP (If_e (exp1, exp2, exp3), (IFFleft, exp3right)))
 
 
 cases   : pat ARROW exp                 ([(pat, exp)])
         | cases BAR pat ARROW exp       ((pat, exp) :: cases)
 
-matches        : matches BAR pat ARROW block           (((pat, block) :: (#1 matches), (matchesleft, blockright)))
-       | pat ARROW block                       ([(pat, block)], (patleft, blockright))
+matches        : matches BAR pat ARROW block           (((pat, compact block) :: (#1 matches), (matchesleft, blockright)))
+       | pat ARROW block                       ([(pat, compact block)], (patleft, blockright))
 
 rseq   : IDENT EQ pat COMMA rseq               ((IDENT, pat) :: rseq)
        | IDENT COMMA rseq                      ((IDENT, PAT (Ident_p [IDENT], (IDENTleft, IDENTright))) :: rseq)

diff --git a/src/mlt.lex b/src/mlt.lex
index c64ea0c..62c8cc0 100644 (file)
--- a/src/mlt.lex
+++ b/src/mlt.lex
@@ -68,14 +68,17 @@ id = ([A-Za-z_][A-Za-z0-9_]*)|([:]+);
 intconst = [0-9]+;
 realconst = [0-9]+\.[0-9]*;
 ws = [\ \t\012];
-bo = [^<]+;
+bo = [^<\n]+;
 
 %%
 
-\n                    => (if isLinCom () then (linComEnd (); YYBEGIN INITIAL) else ();
+<CODE> \n             => (if isLinCom () then (linComEnd (); YYBEGIN INITIAL) else ();
                           lineNum := !lineNum + 1;
                           linePos := yypos :: ! linePos;
                           continue ());
+<INITIAL> \n          => (lineNum := !lineNum + 1;
+                          linePos := yypos :: ! linePos;
+                          Tokens.HTML (yytext, yypos, yypos + size yytext));
 
 <INITIAL> {ws}+       => (Tokens.HTML (" ", yypos, yypos + size yytext); lex ());
 
@@ -144,9 +147,12 @@ bo = [^<]+;
 <CODE> "@"         => (Tokens.AT (yypos, yypos + size yytext));
 
 <CODE> "if"        => (Tokens.IF (yypos, yypos + 2));
+<CODE> "iff"       => (Tokens.IFF (yypos, yypos + 3));
 <CODE> "then"      => (Tokens.THEN (yypos, yypos + 4));
 <CODE> "else"      => (Tokens.ELSE (yypos, yypos + 4));
+<CODE> "elseif"    => (Tokens.ELSEIF (yypos, yypos + 6));
 <CODE> "foreach"   => (Tokens.FOREACH (yypos, yypos + 7));
+<CODE> "for"       => (Tokens.FOR (yypos, yypos + 3));
 <CODE> "in"        => (Tokens.IN (yypos, yypos + 2));
 <CODE> "case"      => (Tokens.CASE (yypos, yypos + 4));
 <CODE> "as"        => (Tokens.AS (yypos, yypos + 2));
@@ -166,8 +172,11 @@ bo = [^<]+;
 <CODE> "do"        => (Tokens.DO (yypos, yypos + 2));
 <CODE> "end"       => (Tokens.END (yypos, yypos + 3));
 <CODE> "raise"     => (Tokens.RAISE (yypos, yypos + 5));
+<CODE> "let"       => (Tokens.LET (yypos, yypos + 3));
+<CODE> "in"        => (Tokens.IN (yypos, yypos + 2));
 
 <CODE> "::"        => (Tokens.CONS (yypos, yypos + 2));
+<CODE> "o"         => (Tokens.O (yypos, yypos + 1));
 <CODE> {id}        => (Tokens.IDENT (yytext, yypos, yypos + size yytext));
 <CODE> {intconst}  => (case Int.fromString yytext of
                             SOME x => Tokens.INT (x, yypos, yypos + size yytext)

diff --git a/src/mlt.sml b/src/mlt.sml
index eecf08d..b853295 100644 (file)
--- a/src/mlt.sml
+++ b/src/mlt.sml
@@ -37,6 +37,10 @@ struct
     val ppstream = PrettyPrint.mk_ppstream {consumer = TextIO.print, flush = fn () => TextIO.flushOut TextIO.stdOut,
                                            linewidth = 80}
 
+    datatype unify =
+            ExpUn of exp
+          | PatUn of pat
+
     (* States to thread throughout translation *)
     local
        datatype state = STATE of {env: StaticEnv.staticEnv,
@@ -103,7 +107,8 @@ struct
        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")
+              | Modules.CONspec {spec = Types.DATACON {typ, ...}, ...} => #1 (TypesUtil.instantiatePoly typ)
+              | _ => raise Fail ("Unexpected spec in getVal for " ^ v))
            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")
@@ -116,7 +121,7 @@ struct
            handle ModuleUtil.Unbound _ => (error (SOME pos, "Unbound constructor " ^ v);
                               errorTy)
 
-       fun unify (STATE {env, ...}) (pos, t1, t2) =
+       fun unify (STATE {env, ...}) (pos, e, t1, t2) =
            (*let
                val t1 = ModuleUtil.transType eenv t1
                val t2 = ModuleUtil.transType eenv t2
@@ -139,7 +144,8 @@ struct
                    PrettyPrint.end_block ppstream;
                    PrettyPrint.add_break ppstream (1, 0);
                    PrettyPrint.flush_ppstream ppstream;
-                   error (SOME pos, Unify.failMessage msg))
+                   error (SOME pos, Unify.failMessage msg ^ " for " ^ (case e of ExpUn e => Tree.expString e
+                                                                               | PatUn p => "<pat>")))
                                      
        fun resolvePath (getter, transer) (pos, state, path) =
            let
@@ -248,9 +254,10 @@ struct
 
     val templateTy = BasicTypes.--> (Types.CONty (BasicTypes.listTycon,
                                                  [mkTuple [BasicTypes.stringTy,
-                                                           BasicTypes.stringTy]]), BasicTypes.unitTy)
+                                                           Types.CONty (BasicTypes.listTycon,
+                                                                        [BasicTypes.stringTy])]]), BasicTypes.unitTy)
 
-    fun xexp state (EXP (e, pos)) =
+    fun xexp state (exp as EXP (e, pos)) =
        (case e of
             Int_e n =>
                 (BasicTypes.intTy, Int.toString n)
@@ -271,16 +278,29 @@ struct
 
                     val xt = mkTuple [ty1, ty2]
                 in
-                    unify state (pos, dom, xt);
+                    unify state (pos, ExpUn exp, dom, xt);
                     (ran, "(" ^ es1 ^ ") :: (" ^ es2 ^ ")")
                 end
+          | Compose_e (e1, e2) =>
+                let
+                    val (ty1, es1) = xexp state e1
+                    val (ty2, es2) = xexp state e2
+               
+                    val dom1 = newTyvar false
+                    val ran1dom2 = newTyvar false
+                    val ran2 = newTyvar false
+                in
+                    unify state (pos, ExpUn exp, ty2, BasicTypes.--> (dom1, ran1dom2));
+                    unify state (pos, ExpUn exp, ty1, BasicTypes.--> (ran1dom2, ran2));
+                    (BasicTypes.--> (dom1, ran2), "(" ^ es1 ^ ") o (" ^ 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);
+                    unify state (pos, ExpUn e1, ty1, BasicTypes.stringTy);
+                    unify state (pos, ExpUn e2, ty2, BasicTypes.stringTy);
                     (BasicTypes.stringTy, "(" ^ es1 ^ ") ^ (" ^ es2 ^ ")")
                 end
           | Orelse_e (e1, e2) =>
@@ -288,8 +308,8 @@ struct
                     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);
+                    unify state (pos, ExpUn e1, ty1, BasicTypes.boolTy);
+                    unify state (pos, ExpUn e2, ty2, BasicTypes.boolTy);
                     (BasicTypes.boolTy, "(" ^ es1 ^ ") orelse (" ^ es2 ^ ")")
                 end
           | Andalso_e (e1, e2) =>
@@ -297,8 +317,8 @@ struct
                     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);
+                    unify state (pos, ExpUn e1, ty1, BasicTypes.boolTy);
+                    unify state (pos, ExpUn e2, ty2, BasicTypes.boolTy);
                     (BasicTypes.boolTy, "(" ^ es1 ^ ") andalso (" ^ es2 ^ ")")
                 end
           | Plus_e (e1, e2) =>
@@ -306,8 +326,8 @@ struct
                     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);
+                    unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
+                    unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
                     (BasicTypes.intTy, "(" ^ es1 ^ ") + (" ^ es2 ^ ")")
                 end
           | Minus_e (e1, e2) =>
@@ -315,8 +335,8 @@ struct
                     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);
+                    unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
+                    unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
                     (BasicTypes.intTy, "(" ^ es1 ^ ") - (" ^ es2 ^ ")")
                 end
           | Times_e (e1, e2) =>
@@ -324,8 +344,8 @@ struct
                     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);
+                    unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
+                    unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
                     (BasicTypes.intTy, "(" ^ es1 ^ ") * (" ^ es2 ^ ")")
                 end
           | Divide_e (e1, e2) =>
@@ -333,8 +353,8 @@ struct
                     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);
+                    unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
+                    unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
                     (BasicTypes.intTy, "(" ^ es1 ^ ") div (" ^ es2 ^ ")")
                 end
           | Mod_e (e1, e2) =>
@@ -342,8 +362,8 @@ struct
                     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);
+                    unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
+                    unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
                     (BasicTypes.intTy, "(" ^ es1 ^ ") mod (" ^ es2 ^ ")")
                 end
           | Lt_e (e1, e2) =>
@@ -351,8 +371,8 @@ struct
                     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);
+                    unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
+                    unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
                     (BasicTypes.boolTy, "(" ^ es1 ^ ") < (" ^ es2 ^ ")")
                 end
           | Lte_e (e1, e2) =>
@@ -360,8 +380,8 @@ struct
                     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);
+                    unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
+                    unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
                     (BasicTypes.boolTy, "(" ^ es1 ^ ") <= (" ^ es2 ^ ")")
                 end
           | Gt_e (e1, e2) =>
@@ -369,8 +389,8 @@ struct
                     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);
+                    unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
+                    unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
                     (BasicTypes.boolTy, "(" ^ es1 ^ ") > (" ^ es2 ^ ")")
                 end
           | Gte_e (e1, e2) =>
@@ -378,8 +398,8 @@ struct
                     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);
+                    unify state (pos, ExpUn e1, ty1, BasicTypes.intTy);
+                    unify state (pos, ExpUn e2, ty2, BasicTypes.intTy);
                     (BasicTypes.boolTy, "(" ^ es1 ^ ") >= (" ^ es2 ^ ")")
                 end
           | Param_e => (BasicTypes.--> (BasicTypes.stringTy, BasicTypes.stringTy), "Web.getParam")
@@ -390,7 +410,7 @@ struct
                     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)")
+                    (templateTy, "(Web.withParams " ^ name ^ "_.exec)")
                 end
             else
                 (error (SOME pos, "Unknown template " ^ name);
@@ -406,8 +426,8 @@ struct
                     val (ty1, s1) = xexp state e1
                     val (ty2, s2) = xexp state e2
                 in
-                    unify state (pos, ty1, ty2);
-                    unify state (pos, ty1, newTyvar true);
+                    unify state (pos, ExpUn e1, ty1, ty2);
+                    unify state (pos, ExpUn e2, ty1, newTyvar true);
                     (BasicTypes.boolTy, "(" ^ s1 ^ ") = (" ^ s2 ^ ")")
                 end
           | Neq_e (e1, e2) =>
@@ -415,8 +435,8 @@ struct
                     val (ty1, s1) = xexp state e1
                     val (ty2, s2) = xexp state e2
                 in
-                    unify state (pos, ty1, ty2);
-                    unify state (pos, ty1, newTyvar true);
+                    unify state (pos, ExpUn e1, ty1, ty2);
+                    unify state (pos, ExpUn e2, ty1, newTyvar true);
                     (BasicTypes.boolTy, "(" ^ s1 ^ ") <> (" ^ s2 ^ ")")
                 end
           | Ident_e [] => raise Fail "Impossible empty variable path"
@@ -431,13 +451,13 @@ struct
                    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 ^ ")")
+                       if BasicTypes.isArrowType ft then
+                           (unify state (pos, ExpUn x, domain ft, xt);
+                            (range ft, "(" ^ fs ^ ") (" ^ xs ^ ")"))
+                       else
+                           (error (SOME pos, "Applying non-function");
+                            (errorTy, "<error>"))
                    end
           | Case_e (e, matches) =>
             let
@@ -447,11 +467,11 @@ struct
                     let
                         val (pty, vars', ps) = xpat state p
                                                
-                        val _ = unify state (pos, ty, pty)
+                        val _ = unify state (pos, ExpUn e, ty, pty)
                                 
                         val (ty', str') = xexp (addVars (state, vars')) e'
                     in
-                        unify state (pos, ty', bodyTy);
+                        unify state (pos, ExpUn e', ty', bodyTy);
                         (false,
                          str ^ (if first then "   " else " | ") ^ "(" ^ ps ^ ") => " ^
                          str' ^ "\n",
@@ -493,11 +513,11 @@ struct
                     let
                         val (pty, vars', ps) = xpat state p
                                                
-                        val _ = unify state (pos, dom, pty)
+                        val _ = unify state (pos, ExpUn exp, dom, pty)
                                 
                         val (ty', str') = xexp (addVars (state, vars')) e'
                     in
-                        unify state (pos, ty', ran);
+                        unify state (pos, ExpUn e', ty', ran);
                         (false,
                          str ^ (if first then "   " else " | ") ^ "(" ^ ps ^ ") => " ^
                          str' ^ "\n")
@@ -512,9 +532,26 @@ struct
             let
                 val (ty, es) = xexp state e
             in
-                unify state (pos, ty, BasicTypes.exnTy);
+                unify state (pos, ExpUn e, ty, BasicTypes.exnTy);
                 (newTyvar false, "(raise (" ^ es ^ "))")
             end
+          | Let_e (b, e) =>
+            let
+                val (state, str) = xblock state b
+                val (ty, es) = xexp state e
+            in
+                (ty, "let\n" ^ str ^ "\nin\n" ^ es ^ "\nend\n")
+            end
+          | If_e (c, t, e) =>
+            let
+                val (bty, ce) = xexp state c
+                val (ty, te) = xexp state t
+                val (ty', ee) = xexp state e
+            in
+                unify state (pos, ExpUn c, bty, BasicTypes.boolTy);
+                unify state (pos, ExpUn exp, ty, ty');
+                (ty, "(if (" ^ ce ^ ") then (" ^ te ^ ") else (" ^ ee ^ "))")
+            end
           | RecordUpd_e (e, cs) =>
                 let
                     val (ty, es) = xexp state e
@@ -532,7 +569,7 @@ struct
                                                              let
                                                                  val (ty', s) = xexp state e
                                                              in
-                                                                 unify state (pos, ty, ty');
+                                                                 unify state (pos, ExpUn e, ty, ty');
                                                                  (n + 1, str ^ ", " ^ Symbol.name id ^ " = " ^ s)
                                                              end) (0, "") cs'
 
@@ -555,7 +592,7 @@ struct
                               NONE => StringMap.insert (vars, v, ty)
                             | SOME _ => error (SOME pos, "Duplicate variable " ^ v ^ " in pattern"))) vars1 vars2
 
-    and xpat state (PAT (p, pos)) =
+    and xpat state (pat as PAT (p, pos)) =
        (case p of
             Ident_p [] => raise Fail "Impossible empty Ident_p"
           | Ident_p [id] =>
@@ -580,7 +617,7 @@ struct
                 val tyc = lookCon (state, id, pos)
                 val dom = domain tyc
             in
-                unify state (pos, dom, ty);
+                unify state (pos, PatUn p, dom, ty);
                 (range tyc, vars, id ^ " (" ^ s ^ ")")
             end
           | App_p (path as (fst::rest), p) =>
@@ -589,7 +626,7 @@ struct
                     val tyc = resolveCon (pos, state, path)
                     val dom = domain tyc
                 in
-                    unify state (pos, dom, ty);
+                    unify state (pos, PatUn p, dom, ty);
                     (range tyc, vars, foldl (fn (n, st) => st ^ "." ^ n) fst rest ^ " (" ^ s ^ ")")
                 end
           | Cons_p (p1, p2) =>
@@ -599,7 +636,7 @@ struct
 
                     val resty = Types.CONty (BasicTypes.listTycon, [ty1])
                 in
-                    unify state (pos, ty2, resty);
+                    unify state (pos, PatUn pat, ty2, resty);
                     (resty, mergePatVars pos (vars', vars''), "(" ^ s1 ^ ")::(" ^ s2 ^ ")")
                 end
           | As_p (id, p) =>
@@ -652,7 +689,7 @@ struct
             error (SOME pos, "Not done yet!!!")*))
        handle Skip => (errorTy, StringMap.empty, "<error>")
 
-    fun xblock state (BLOCK (blocks, pos)) =
+    and xblock state (BLOCK (blocks, pos)) =
        let
            fun folder (BITEM (bi, pos), (state, str)) =
                (case bi of
@@ -681,7 +718,7 @@ struct
 
                             val (ty, es) = xexp state e
                         in
-                            unify state (pos, ty, vty);
+                            unify state (pos, ExpUn e, ty, vty);
                             (state, str ^ "val _ = " ^ id ^ " := (" ^ es ^ ")\n")
                         end
                   | Val_i (p, e) =>
@@ -690,7 +727,7 @@ struct
                             val state' = addVars (state, vars)
                             val (ty, es) = xexp state e
                         in
-                            unify state (pos, pty, ty);
+                            unify state (pos, ExpUn e, pty, ty);
                             (state', str ^ "val " ^ ps ^ " = (" ^ es ^ ")\n")
                         end
                   | Exp_i e =>
@@ -714,7 +751,7 @@ struct
                             val str = str ^ "val _ = "
                             val (ty, s) = xexp state e
                             val (_, str') = xblock state b
-                            val _ = unify state (pos, ty, BasicTypes.boolTy)
+                            val _ = unify state (pos, ExpUn e, ty, BasicTypes.boolTy)
                             val str = str ^ "if (" ^ s ^ ") then let\n" ^
                                       str' ^
                                       "in () end\n"
@@ -733,20 +770,20 @@ struct
                         in
                             (state, str)
                         end
-                  | Foreach_i (id, e, b) =>
+                  | Foreach_i (p, e, b) =>
                         let
                             val parm = newTyvar false
-
+       
+                            val (pty, vars, ps) = xpat state p
                             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 _ = unify state (pos, ExpUn e, ty, Types.CONty (BasicTypes.listTycon, [parm]))
+                            val _ = unify state (pos, PatUn p, pty, parm)
 
-                            val state = addVar (state, id, VAR parm)
-                            val (_, bs) = xblock state b
-                        in
-                            (state, str ^ "fun foreach (" ^ id ^ " : " ^
+                            val state' = addVars (state, vars)
+                            val (_, bs) = xblock state' b
+                        in                          
+                            (state, str ^ "fun foreach ((" ^ ps ^ ") : " ^
                                     tyToString state parm ^ ") = let\n" ^
                              bs ^
                              "in () end\n" ^
@@ -755,10 +792,10 @@ struct
                   | For_i (id, eFrom, eTo, b) =>
                         let
                             val (ty1, es1) = xexp state eFrom
-                            val _ = unify state (pos, ty1, BasicTypes.intTy)
+                            val _ = unify state (pos, ExpUn eFrom, ty1, BasicTypes.intTy)
 
                             val (ty2, es2) = xexp state eTo
-                            val _ = unify state (pos, ty2, BasicTypes.intTy)
+                            val _ = unify state (pos, ExpUn eTo, ty2, BasicTypes.intTy)
 
                             val state = addVar (state, id, VAR BasicTypes.intTy)
                             val (_, bs) = xblock state b
@@ -776,7 +813,7 @@ struct
                                 let
                                     val (pty, vars', ps) = xpat state p
 
-                                    val _ = unify state (pos, ty, pty)
+                                    val _ = unify state (pos, PatUn p, ty, pty)
 
                                     val (_, str') = xblock (addVars (state, vars')) b
 
@@ -803,7 +840,7 @@ struct
                                     val state = addVars (state, vars)
                                     val (_, str') = xblock state b
                                 in
-                                    unify state (pos, BasicTypes.exnTy, pty);
+                                    unify state (pos, PatUn p, BasicTypes.exnTy, pty);
                                     (false,
                                      str ^ (if first then "   " else " | ") ^ "(" ^ ps ^ ") => let\n" ^
                                      str' ^

diff --git a/src/tree.sml b/src/tree.sml
index c74df19..8949dfb 100644 (file)
--- a/src/tree.sml
+++ b/src/tree.sml
@@ -49,13 +49,15 @@ struct
       | Eq_e of exp * exp | Neq_e of exp * exp
       | Gt_e of exp * exp | Gte_e of exp * exp
       | Lt_e of exp * exp | Lte_e of exp * exp
-      | Cons_e of exp * exp
+      | Cons_e of exp * exp | Compose_e of exp * exp
       | Record_e of bool * (ident * exp) list
       | RecordUpd_e of exp * (ident * exp) list
       | Proj_e of ident | App_e of exp * exp
       | Case_e of exp * (pat * exp) list
       | Fn_e of (pat * exp) list
       | Raise_e of exp
+      | Let_e of block * exp
+      | If_e of exp * exp * exp
     and exp = EXP of exp' withext
 
     and blockItem' =
@@ -67,7 +69,7 @@ struct
       | Open_i of path list                                 (* imports to top level *)
       | Ifthenelse_i of exp * block * block option          (* if statement *)
       | Case_i of exp * (pat * block) list                  (* case statement *)
-      | Foreach_i of ident * exp * block                    (* foreach statement with list *)
+      | Foreach_i of pat * exp * block                    (* foreach statement with list *)
       | For_i of ident * exp * exp * block                  (* foreach statement with integer range *)
       | TryCatch_i of block * (pat * block) list            (* try...catch exception handlers w/ pattern matching *)
     and blockItem = BITEM of blockItem' withext