From 16abb0f9dc821395f7644328a98d75a4aa97e83e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 14 Sep 2003 00:21:15 +0000 Subject: [PATCH] Various improvements made while working on relwiki --- src/compiler.sml | 8 ++- src/lib/main.sml | 1 + src/lib/web.sig | 15 ++++ src/lib/web.sml | 126 +++++++++++++++++++++++++++++++++- src/mlt.grm | 45 +++++++----- src/mlt.lex | 13 +++- src/mlt.sml | 173 ++++++++++++++++++++++++++++------------------- src/tree.sml | 6 +- 8 files changed, 293 insertions(+), 94 deletions(-) diff --git a/src/compiler.sml b/src/compiler.sml index 0b6d484..6e31f5a 100644 --- 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 --- 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 --- 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 --- 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 #"<" = "<" @@ -97,7 +108,7 @@ struct | xch #"\"" = """ | 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" = "
" | 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 --- 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 --- 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 (); + \n => (if isLinCom () then (linComEnd (); YYBEGIN INITIAL) else (); lineNum := !lineNum + 1; linePos := yypos :: ! linePos; continue ()); + \n => (lineNum := !lineNum + 1; + linePos := yypos :: ! linePos; + Tokens.HTML (yytext, yypos, yypos + size yytext)); {ws}+ => (Tokens.HTML (" ", yypos, yypos + size yytext); lex ()); @@ -144,9 +147,12 @@ bo = [^<]+; "@" => (Tokens.AT (yypos, yypos + size yytext)); "if" => (Tokens.IF (yypos, yypos + 2)); + "iff" => (Tokens.IFF (yypos, yypos + 3)); "then" => (Tokens.THEN (yypos, yypos + 4)); "else" => (Tokens.ELSE (yypos, yypos + 4)); + "elseif" => (Tokens.ELSEIF (yypos, yypos + 6)); "foreach" => (Tokens.FOREACH (yypos, yypos + 7)); + "for" => (Tokens.FOR (yypos, yypos + 3)); "in" => (Tokens.IN (yypos, yypos + 2)); "case" => (Tokens.CASE (yypos, yypos + 4)); "as" => (Tokens.AS (yypos, yypos + 2)); @@ -166,8 +172,11 @@ bo = [^<]+; "do" => (Tokens.DO (yypos, yypos + 2)); "end" => (Tokens.END (yypos, yypos + 3)); "raise" => (Tokens.RAISE (yypos, yypos + 5)); + "let" => (Tokens.LET (yypos, yypos + 3)); + "in" => (Tokens.IN (yypos, yypos + 2)); "::" => (Tokens.CONS (yypos, yypos + 2)); + "o" => (Tokens.O (yypos, yypos + 1)); {id} => (Tokens.IDENT (yytext, yypos, yypos + size yytext)); {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 --- 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 => ""))) 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, "")) 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, "") - 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 --- 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 -- 2.20.1