From 8291a2b90d90a19fe92cd2ee8d71b62efad58ba3 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 10 Aug 2003 02:17:40 +0000 Subject: [PATCH] Template language overhaul & misc. improvements --- doc/.cvsignore | 1 + doc/Makefile | 7 +++- doc/manual.tex | 65 ++++++++++++++--------------- src/compiler.sml | 14 ++++--- src/lib/main.sml | 7 +++- src/lib/sources.cm | 4 ++ src/lib/web.sig | 21 ++++++++-- src/lib/web.sml | 80 +++++++++++++++++++++++++++++++++-- src/mlt.grm | 66 ++++++++++++++++------------- src/mlt.lex | 27 +++++++++--- src/mlt.sml | 101 ++++++++++++++++++++++++++++++++++----------- src/tree.sml | 9 ++-- 12 files changed, 293 insertions(+), 109 deletions(-) diff --git a/doc/.cvsignore b/doc/.cvsignore index 8e7d85c..5369d10 100644 --- a/doc/.cvsignore +++ b/doc/.cvsignore @@ -2,3 +2,4 @@ *.log *.dvi *.ps +manual \ No newline at end of file diff --git a/doc/Makefile b/doc/Makefile index 77428b8..819c9be 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -1,4 +1,4 @@ -all: manual.ps +all: manual.ps manual/index.html clean: rm *.aux *.dvi *.ps *.log @@ -7,4 +7,7 @@ manual.ps: manual.dvi dvips -o manual.ps manual.dvi manual.dvi: manual.tex - latex manual.tex \ No newline at end of file + latex manual.tex + +manual/index.html: manual.tex + latex2html -local_icons manual.tex \ No newline at end of file diff --git a/doc/manual.tex b/doc/manual.tex index b86c295..034e772 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -96,6 +96,18 @@ The syntax for creating records and extracting their fields is identical to SML' Where {\tt temp} is the name of a template in the current project, {\tt @temp} evaluates to a function {\tt (string * string) list -> unit} that takes in a list of name-value pairs for CGI parameters to modify and runs {\tt temp} with those changes. The Compilation Manager will prevent template calls from being used to implement any sort of recursion. +\subsubsection{Anonymous functions} + +Anonymous {\tt fn} functions are available with the SML syntax. + +\subsubsection{\tt case} + +SML {\tt case} expressions are supported. + +\subsubsection{\tt raise} + +SML {\tt raise} expressions are supported. + \subsection{Patterns} Patterns are identical to SML patterns without support for user-defined infix constructors, though {\tt ::} is supported. Record patterns can include field names with no assigned patterns (the pattern for such a field is taken to be the field name) and "flex record" {\tt ...}'s to stand for unused fields. @@ -123,31 +135,25 @@ Variables with reference type are introduced with {\tt ref} declarations, which If statements are in the usual imperative style, meaning that else clauses are optional. They are of the form: \begin{verbatim} -if (condition1) -{ +if condition1 then block1 -} -else if (condition 2) -{ +else if condition 2 then block 2 -} else -{ block 3 -} +end \end{verbatim} -The {\tt block}s are sequences of statements and declarations. Every {\tt if} statement is followed by zero or more {\tt else if}'s and one or zero {\tt else}'s. Conditions must be enclosed in parentheses. +The {\tt block}s are sequences of statements and declarations. Every {\tt if} statement is followed by zero or more {\tt else if}'s and one or zero {\tt else}'s. \subsubsection{\tt foreach} All looping is done via {\tt foreach} statements, which have two forms. One is: \begin{verbatim} -foreach (var in exp) -{ +foreach var in exp do block -} +end \end{verbatim} Where {\tt exp} has type {\tt t list}, {\tt block} is executed for each of {\tt exp}'s elements, binding {\tt var} to each of them in order from first to last. @@ -155,43 +161,34 @@ Where {\tt exp} has type {\tt t list}, {\tt block} is executed for each of {\tt There is also a shortcut integer iteration form: \begin{verbatim} -foreach (var in fromExp .. toExp) -{ +foreach var in fromExp .. toExp do block -} +end \end{verbatim} {\tt fromExp} and {\tt toExp} must have type {\tt int}. {\tt block} is evaluated with {\tt var} bound in sequence to each integer in the range defined by {\tt fromExp} and {\tt toExp}. -\subsubsection{\tt case} +\subsubsection{\tt switch} -{\tt case} statements are straightforward imperative modifications of SML {\tt case} expressions, such as: +{\tt switch} statements are imperative equivalents of {\tt case} expressions, such as: \begin{verbatim} -case (exp) -(pat1) { block1 } -(pat2) { block2 } +switch exp of + pat1 => block1 +| pat2 => block2 +end \end{verbatim} -The case object and patterns must be enclosed in parentheses. - -\subsubsection{{\tt try}..{\tt catch}} +\subsubsection{{\tt try}..{\tt with}} -This construction is to SML's {\tt handle} what template {\tt case} is to SML {\tt case}. For example: +This construction is to SML's {\tt handle} what {\tt switch} is to {\tt case}. For example: \begin{verbatim} try -{ block1 -} -catch (pat1) -{ - block2 -} -catch (pat2) -{ - block3 -} +with pat1 => block2 +| pat2 => block3 +end \end{verbatim} \end{document} \ No newline at end of file diff --git a/src/compiler.sml b/src/compiler.sml index 6ef2807..e87cb57 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -90,6 +90,7 @@ struct str (toUpper (String.sub (name, 0))) ^ String.extract (name, 1, NONE) else raise Error + val name = name ^ "_" in (name, Mlt.trans (config, env, templates, name, Parse.parse path)) end @@ -110,9 +111,9 @@ struct "mlt" => loop (smls, (path ^ "/" ^ fname) :: mlts) | ("sml"|"sig") => let - val mltName = removeExt fname ^ ".mlt" + val fname = getFname fname in - if getFname fname = "_main.sml" orelse Posix.FileSys.access (mltName, []) then + if String.sub (fname, 0) = #"_" then loop (smls, mlts) else loop ((path ^ "/" ^ fname) :: smls, mlts) @@ -133,6 +134,7 @@ struct val _ = TextIO.closeOut outf val outf = TextIO.openOut (outPath ^ "/.build.sml") + val _ = TextIO.output (outf, "Control.quotation := true;\n") fun printMlts [] = () | printMlts (h::t) = (TextIO.output (outf, "\"" ^ h ^ "\""); @@ -140,7 +142,7 @@ struct val libList = foldl (fn (l, s) => s ^ "if CM.make \"" ^ l ^ "\" then () else OS.Process.exit OS.Process.failure;\n") "" (Config.cm config) in - TextIO.output (outf, "if CM.make \"" ^ outPath ^ "/libs.cm\" then () else OS.Process.exit OS.Process.failure;\nif CM.make \"" ^ Config.compiler config ^ "\" then () else OS.Process.exit OS.Process.failure;\n"); + TextIO.output (outf, "if CM.make \"" ^ outPath ^ "/libs.cm\" then () else OS.Process.exit OS.Process.failure;\nif CM.make \"" ^ Config.compiler config ^ "\" then () else OS.Process.exit OS.Process.failure;\nif CM.make \"" ^ Config.lib config ^ "\" then () else OS.Process.exit OS.Process.failure;\n"); TextIO.output (outf, libList); TextIO.output (outf, "Compiler.compileTemplates (Config.read \"mlt.conf\" (Config.default ())) (["); printMlts mlts; @@ -153,6 +155,7 @@ struct fun compileTemplates config (mlts, smls) = let + val err_flag = ref false val _ = ErrorMsg.reset () val path = Config.inPath config @@ -180,8 +183,9 @@ struct let val _ = print ("Compiling " ^ fname ^ "....\n") val (name, output) = compileTemplate (config, env, templates) fname + val _ = err_flag := (!err_flag orelse !ErrorMsg.anyErrors) val scriptName = removeExt (getFname fname) - val outName = scriptName ^ ".sml" + val outName = "__" ^ scriptName ^ ".sml" val outf = TextIO.openOut (outPath ^ "/" ^ outName) in TextIO.output (outf, output); @@ -217,7 +221,7 @@ struct Posix.FileSys.chmod (name, cgiMode) end in - if !ErrorMsg.anyErrors then + if !err_flag then (TextIO.print "Errors compiling templates.\n"; OS.Process.failure) else diff --git a/src/lib/main.sml b/src/lib/main.sml index 0533912..b058cce 100644 --- a/src/lib/main.sml +++ b/src/lib/main.sml @@ -27,7 +27,7 @@ struct let val _ = Cgi.init () val cgiFields = Cgi.cgi_fieldnames () - fun mapper name = (name, valOf (Cgi.cgi_field_string name)) + fun mapper name = (name, Cgi.cgi_field_strings name) in Web.pushParams (map mapper cgiFields); case args of @@ -40,7 +40,10 @@ struct | SOME f => (f (); Web.output (); OS.Process.success)) - end handle ex => (print "Status: 500\nContent-type: text/plain\n\nAn exception!\n\n"; + end handle Fail msg => (print "Status: 500\nContent-type: text/plain\n\nFatal error: \n\n"; + print msg; + OS.Process.failure) + | ex => (print "Status: 500\nContent-type: text/plain\n\nAn exception!\n\n"; app (fn s => print (s ^ "\n")) (SMLofNJ.exnHistory ex); OS.Process.failure) end \ No newline at end of file diff --git a/src/lib/sources.cm b/src/lib/sources.cm index d1e717c..e602505 100644 --- a/src/lib/sources.cm +++ b/src/lib/sources.cm @@ -22,7 +22,9 @@ Library signature TEMPLATES signature MAIN signature WEB + signature SQL + structure Sql structure Web functor MainFn @@ -40,6 +42,8 @@ is web.sig web.sml + sql.sig + sql.sml main.sml \ No newline at end of file diff --git a/src/lib/web.sig b/src/lib/web.sig index c22603e..1b1e690 100644 --- a/src/lib/web.sig +++ b/src/lib/web.sig @@ -21,13 +21,28 @@ signature WEB = sig + val for : (int -> unit) -> int * int -> unit + val print : string -> unit val output : unit -> unit - val setParam : string * string -> unit + val setParam : string * string list -> unit + val setSingleParam : string * string -> unit val getParam : string -> string + val getMultiParam : string -> string list - val pushParams : (string * string) list -> unit + val pushParams : (string * string list) list -> unit val popParams : unit -> unit - val withParams : (unit -> 'a) -> (string * string) list -> 'a + val withParams : (unit -> 'a) -> (string * string list) list -> 'a + + val getCgi : string -> string option + + val html : string -> string + val htmlNl : string -> string + + exception Format of string + val stoi : string -> int + val stor : string -> real + + val summary : unit -> string end \ No newline at end of file diff --git a/src/lib/web.sml b/src/lib/web.sml index 4b256a5..6d81d5b 100644 --- a/src/lib/web.sml +++ b/src/lib/web.sml @@ -21,16 +21,47 @@ structure Web :> WEB = struct - val params : string StringMap.map ref = ref StringMap.empty + fun for f (r1, r2) = + if r1 < r2 then + let + fun loop i = + if i > r2 then + () + else + (f i; + loop (i+1)) + in + loop r1 + end + else + let + fun loop i = + if i < r2 then + () + else + (f i; + loop (i-1)) + in + loop r1 + end - val paramStack : string StringMap.map list ref = ref [] + val params : string list StringMap.map ref = ref StringMap.empty + + val paramStack : string list StringMap.map list ref = ref [] fun setParam (n, v) = params := StringMap.insert (!params, n, v) + fun setSingleParam (n, v) = setParam (n, [v]) fun getParam v = (case StringMap.find (!params, v) of NONE => "" - | SOME s => s) + | SOME [] => "" + | SOME (s::_) => s) + + fun getMultiParam v = + (case StringMap.find (!params, v) of + NONE => [] + | SOME l => l) fun pushParams nvs = (paramStack := (!params) :: (!paramStack); @@ -54,4 +85,47 @@ struct fun output () = (TextIO.print "Status: 200\nContent-type: text/html\n\n"; TextIO.print (String.concat (List.rev (!text)))) + + val getCgi = OS.Process.getEnv + + fun html s = + let + fun xch #"<" = "<" + | xch #">" = ">" + | xch #"&" = "&" + | xch #"\"" = """ + | xch ch = str ch + in + foldr op^ "" (map xch (String.explode s)) + end + + fun htmlNl s = + let + fun xch #"<" = "<" + | xch #">" = ">" + | xch #"&" = "&" + | xch #"\"" = """ + | xch #"\n" = "
" + | xch ch = str ch + in + foldr op^ "" (map xch (String.explode s)) + end + + exception Format of string + + fun stoiOpt s = Int.fromString s + fun stoi s = + (case Int.fromString s of + NONE => raise Format s + | SOME i => i) + + fun storOpt s = Real.fromString s + fun stor s = + (case Real.fromString s of + NONE => raise Format s + | SOME r => r) + + fun summary () = + StringMap.foldli (fn (n, vs, s) => foldl (fn (v, s) => s ^ " VALUE: " ^ v) (s ^ " NAME: " ^ n) vs) + "" (!params) end \ No newline at end of file diff --git a/src/mlt.grm b/src/mlt.grm index a559649..6a584f5 100644 --- a/src/mlt.grm +++ b/src/mlt.grm @@ -38,18 +38,23 @@ fun addNumbers L = %term EOF | HTML of string - | IF | THEN | ELSE | AS | WITH | OPEN | VAL | REF | TRY | CATCH - | FOREACH | IN | CASE | ORELSE | ANDALSO + | IF | THEN | ELSE + | AS | WITH | OPEN | VAL | REF | TRY | CATCH + | FN | END | RAISE + | FOREACH | IN | DO + | SWITCH | CASE | OF | BAR | ARROW | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE | HASH | SEMI | CONS | PLUS | MINUS | TIMES | DIVIDE | MOD | NEG | DOLLAR | AT | STRCAT | ASN | EQ | NEQ | GT | GTE | LT | LTE + | ANDALSO | ORELSE | IDENT of string | DOT | DOTDOT | DOTDOTDOT | COMMA | COLON | CARET | TILDE | UNDER - | INT of int | STRING of string | CHAR of string + | INT of int | STRING of string | CHAR of string | REAL of real %nonterm file of block | block of block | exp of exp + | cases of (pat * exp) list | appsL of exp list | apps of exp | term of exp @@ -59,7 +64,7 @@ fun addNumbers L = | path of ident list | pathList of ident list list | blockItem of blockItem - | ifte of ((exp * block) list * block option) withext + | elseOpt of block option | matches of (pat * block) list withext | pexp of exp | ppat of pat @@ -103,10 +108,10 @@ ilist : IDENT ilist (IDENT :: ilist) ivlist : IDENT EQ exp COMMA ivlist ((IDENT, exp) :: ivlist) | IDENT EQ exp ([(IDENT, exp)]) -catch : CATCH ppat LBRACE block RBRACE (ppat, block) +catch : pat ARROW block (pat, block) -catches : catch catches (catch::catches) - | catch ([catch]) +catches : catches BAR catch (catch::catches) + | catch ([catch]) blockItem : HTML (BITEM (Html_i HTML, (HTMLleft, HTMLright))) | REF ivlist (BITEM (Ref_i ivlist, (REFleft, ivlistright))) @@ -114,27 +119,22 @@ blockItem : HTML (BITEM (Html_i HTML, (HTMLleft, HTMLright))) | VAL pat EQ exp (BITEM (Val_i (pat, exp), (patleft, expright))) | IDENT ASN exp (BITEM (Assn_i (IDENT, exp), (IDENTleft, expright))) | exp (BITEM (Exp_i exp, (expleft, expright))) - | IF LPAREN exp RPAREN LBRACE block RBRACE ifte - (let val ((L, O), _) = ifte in - BITEM (Ifthenelse_i((exp, block) :: L, O), - (IFleft, ifteright)) - end) - | FOREACH LPAREN IDENT IN exp RPAREN LBRACE block RBRACE + | IF exp THEN block elseOpt END + (BITEM (Ifthenelse_i(exp, block, elseOpt), + (IFleft, ENDright))) + | FOREACH IDENT IN exp DO block END (BITEM (Foreach_i (IDENT, exp, block), - (FOREACHleft, RBRACEright))) - | FOREACH LPAREN IDENT IN exp DOTDOT exp RPAREN LBRACE block RBRACE + (FOREACHleft, ENDright))) + | FOREACH IDENT IN exp DOTDOT exp DO block END (BITEM (For_i (IDENT, exp1, exp2, block), - (FOREACHleft, RBRACEright))) - | CASE pexp matches - (BITEM (Case_i (pexp, #1 matches), (CASEleft, matchesright))) - | TRY LBRACE block RBRACE catches - (BITEM (TryCatch_i (block, catches), (TRYleft, catchesright))) - -ifte : ELSE LBRACE block RBRACE (([], SOME block), (ELSEleft, RBRACEright)) - | ELSE IF LPAREN exp RPAREN LBRACE block RBRACE ifte (let val ((L, O), _) = ifte in - (((exp, block) :: L, O), (ELSEleft, ifteright)) - end) - | (([], NONE), (0, 0)) + (FOREACHleft, 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))) + +elseOpt : (NONE) + | ELSE block (SOME block) block : blockItem (BLOCK ([blockItem], (blockItemleft, blockItemright))) | blockItem SEMI block (BLOCK (blockItem :: (unblock block), (blockItemleft, blockright))) @@ -180,6 +180,7 @@ term : LBRACE erseq RBRACE (EXP (Record_e (false, sortRcs erseq), (LBRACEleft, | pexp (pexp) | STRING (EXP (String_e STRING, (STRINGleft, STRINGright))) | CHAR (EXP (Char_e CHAR, (CHARleft, CHARright))) + | REAL (EXP (Real_e REAL, (REALleft, REALright))) | path (EXP (Ident_e path, (pathleft, pathright))) | INT (EXP (Int_e INT, (INTleft, INTright))) | NEG (EXP (Neg_e, (NEGleft, NEGright))) @@ -206,9 +207,16 @@ exp : apps (apps) | 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))) + + +cases : pat ARROW exp ([(pat, exp)]) + | cases BAR pat ARROW exp ((pat, exp) :: cases) -matches : ppat LBRACE block RBRACE matches (((ppat, block) :: (#1 matches), (ppatleft, matchesright))) - | ([], (0, 0)) +matches : matches BAR pat ARROW block (((pat, block) :: (#1 matches), (matchesleft, blockright))) + | pat ARROW block ([(pat, block)], (patleft, blockright)) rseq : IDENT EQ pat COMMA rseq ((IDENT, pat) :: rseq) | IDENT COMMA rseq ((IDENT, PAT (Ident_p [IDENT], (IDENTleft, IDENTright))) :: rseq) @@ -234,6 +242,8 @@ pterm : path (PAT (Ident_p path, (pathleft, pathright))) | UNDER (PAT (Wild_p, (UNDERleft, UNDERright))) | INT (PAT (Int_p INT, (INTleft, INTright))) | STRING (PAT (String_p STRING, (STRINGleft, STRINGright))) + | CHAR (PAT (Char_p CHAR, (CHARleft, CHARright))) + | REAL (PAT (Real_p REAL, (REALleft, REALright))) | LBRACE rseq RBRACE (PAT (Record_p (false, sortRcs rseq), (LBRACEleft, RBRACEright))) | LBRACE RBRACE (PAT (Record_p (false, []), (LBRACEleft, RBRACEright))) | LBRACE frseq RBRACE (PAT (FlexRecord_p (sortRcs frseq), (LBRACEleft, RBRACEright))) diff --git a/src/mlt.lex b/src/mlt.lex index 568c1a3..c64ea0c 100644 --- a/src/mlt.lex +++ b/src/mlt.lex @@ -66,6 +66,7 @@ val strStart = ref 0 id = ([A-Za-z_][A-Za-z0-9_]*)|([:]+); intconst = [0-9]+; +realconst = [0-9]+\.[0-9]*; ws = [\ \t\012]; bo = [^<]+; @@ -143,27 +144,41 @@ bo = [^<]+; "@" => (Tokens.AT (yypos, yypos + size yytext)); "if" => (Tokens.IF (yypos, yypos + 2)); + "then" => (Tokens.THEN (yypos, yypos + 4)); "else" => (Tokens.ELSE (yypos, yypos + 4)); "foreach" => (Tokens.FOREACH (yypos, yypos + 7)); "in" => (Tokens.IN (yypos, yypos + 2)); "case" => (Tokens.CASE (yypos, yypos + 4)); "as" => (Tokens.AS (yypos, yypos + 2)); + "fn" => (Tokens.FN (yypos, yypos + 2)); "with" => (Tokens.WITH (yypos, yypos + 4)); "open" => (Tokens.OPEN (yypos, yypos + 4)); "val" => (Tokens.VAL (yypos, yypos + 3)); "ref" => (Tokens.REF (yypos, yypos + 3)); "try" => (Tokens.TRY (yypos, yypos + 3)); "catch" => (Tokens.CATCH (yypos, yypos + 5)); - "or" => (Tokens.ORELSE (yypos, yypos + 5)); - "and" => (Tokens.ANDALSO (yypos, yypos + 5)); + "or" => (Tokens.ORELSE (yypos, yypos + 2)); + "and" => (Tokens.ANDALSO (yypos, yypos + 3)); + "switch" => (Tokens.SWITCH (yypos, yypos + 6)); + "of" => (Tokens.OF (yypos, yypos + 2)); + "=>" => (Tokens.ARROW (yypos, yypos + 2)); + "|" => (Tokens.BAR (yypos, yypos + 1)); + "do" => (Tokens.DO (yypos, yypos + 2)); + "end" => (Tokens.END (yypos, yypos + 3)); + "raise" => (Tokens.RAISE (yypos, yypos + 5)); "::" => (Tokens.CONS (yypos, yypos + 2)); {id} => (Tokens.IDENT (yytext, yypos, yypos + size yytext)); {intconst} => (case Int.fromString yytext of - SOME (x) => Tokens.INT (x, yypos, yypos + size yytext) - | NONE => (ErrorMsg.error (SOME (yypos, yypos)) - ("Expected number, received: " ^ yytext); - continue ())); + SOME x => Tokens.INT (x, yypos, yypos + size yytext) + | NONE => (ErrorMsg.error (SOME (yypos, yypos)) + ("Expected int, received: " ^ yytext); + continue ())); + {realconst} => (case Real.fromString yytext of + SOME x => Tokens.REAL (x, yypos, yypos + size yytext) + | NONE => (ErrorMsg.error (SOME (yypos, yypos)) + ("Expected real, received: " ^ yytext); + continue ())); "\"" {id} "\"" => (Tokens.STRING (String.substring(yytext, 1, String.size yytext - 2), yypos, yypos + size yytext)); diff --git a/src/mlt.sml b/src/mlt.sml index 38848e7..eecf08d 100644 --- a/src/mlt.sml +++ b/src/mlt.sml @@ -125,19 +125,19 @@ struct (*end*) handle Unify.Unify msg => (PrettyPrint.begin_block ppstream PrettyPrint.CONSISTENT 0; - PrettyPrint.add_string ppstream "Error unifying\n\t"; - PrettyPrint.add_break ppstream (0, 0); + PrettyPrint.add_string ppstream "Error unifying"; + PrettyPrint.add_break ppstream (1, 0); PrettyPrint.begin_block ppstream PrettyPrint.CONSISTENT 5; PPType.ppType env ppstream t1; PrettyPrint.end_block ppstream; - PrettyPrint.add_break ppstream (0, 0); - PrettyPrint.add_string ppstream "\nand\n\t"; - PrettyPrint.add_break ppstream (0, 0); + PrettyPrint.add_break ppstream (1, 0); + PrettyPrint.add_string ppstream "and"; + PrettyPrint.add_break ppstream (1, 0); PrettyPrint.begin_block ppstream PrettyPrint.CONSISTENT 5; PPType.ppType env ppstream t2; PrettyPrint.end_block ppstream; - PrettyPrint.add_string ppstream "\n"; PrettyPrint.end_block ppstream; + PrettyPrint.add_break ppstream (1, 0); PrettyPrint.flush_ppstream ppstream; error (SOME pos, Unify.failMessage msg)) @@ -254,6 +254,8 @@ struct (case e of Int_e n => (BasicTypes.intTy, Int.toString n) + | Real_e n => + (BasicTypes.realTy, Real.toString n) | String_e s => (BasicTypes.stringTy, "\"" ^ s ^ "\"") | Char_e s => @@ -437,6 +439,31 @@ struct unify state (pos, dom, xt); (ran, "(" ^ fs ^ ") (" ^ xs ^ ")") end + | Case_e (e, matches) => + let + val (ty, s) = xexp state e + + fun folder ((p, e'), (first, str, bodyTy)) = + let + val (pty, vars', ps) = xpat state p + + val _ = unify state (pos, ty, pty) + + val (ty', str') = xexp (addVars (state, vars')) e' + in + unify state (pos, ty', bodyTy); + (false, + str ^ (if first then " " else " | ") ^ "(" ^ ps ^ ") => " ^ + str' ^ "\n", + bodyTy) + end + val bodyTy = newTyvar false + val (_, str, _) = + foldl folder (true, "(case (" ^ s ^ ") of\n", bodyTy) matches + val str = str ^ ")\n" + in + (bodyTy, str) + end | Record_e (ist, cs) => let val (cs, str) = foldl (fn ((id, e), (cs, str)) => @@ -457,6 +484,37 @@ struct in (BasicTypes.recordTy cs, str) end + | Fn_e matches => + let + val dom = newTyvar false + val ran = newTyvar false + + fun folder ((p, e'), (first, str)) = + let + val (pty, vars', ps) = xpat state p + + val _ = unify state (pos, dom, pty) + + val (ty', str') = xexp (addVars (state, vars')) e' + in + unify state (pos, ty', ran); + (false, + str ^ (if first then " " else " | ") ^ "(" ^ ps ^ ") => " ^ + str' ^ "\n") + end + val (_, str) = + foldl folder (true, "(fn \n") matches + val str = str ^ ")\n" + in + (BasicTypes.--> (dom, ran), str) + end + | Raise_e e => + let + val (ty, es) = xexp state e + in + unify state (pos, ty, BasicTypes.exnTy); + (newTyvar false, "(raise (" ^ es ^ "))") + end | RecordUpd_e (e, cs) => let val (ty, es) = xexp state e @@ -491,13 +549,13 @@ struct end) handle Skip => (errorTy, "") - fun mergePatVars pos (vars1, vars2) = + and mergePatVars pos (vars1, vars2) = StringMap.foldli (fn (v, ty, vars) => (case StringMap.find (vars, v) of NONE => StringMap.insert (vars, v, ty) | SOME _ => error (SOME pos, "Duplicate variable " ^ v ^ " in pattern"))) vars1 vars2 - fun xpat state (PAT (p, pos)) = + and xpat state (PAT (p, pos)) = (case p of Ident_p [] => raise Fail "Impossible empty Ident_p" | Ident_p [id] => @@ -512,7 +570,9 @@ struct (resolveCon (pos, state, path), StringMap.empty, foldl (fn (v, st) => st ^ "." ^ v) s rest) | Wild_p => (newTyvar false, StringMap.empty, "_") | Int_p n => (BasicTypes.intTy, StringMap.empty, Int.toString n) + | Real_p n => (BasicTypes.realTy, StringMap.empty, Real.toString n) | String_p s => (BasicTypes.stringTy, StringMap.empty, "\"" ^ s ^ "\"") + | Char_p s => (BasicTypes.charTy, StringMap.empty, "#\"" ^ s ^ "\"") | App_p ([], _) => raise Fail "Impossible App_p" | App_p ([id], p) => let @@ -649,20 +709,15 @@ struct in (state, str ^ "val _ = " ^ printFn ^ " (" ^ s ^ ")\n") end - | Ifthenelse_i (ifs, els) => + | Ifthenelse_i (e, b, els) => let val str = str ^ "val _ = " - fun folder ((e, b), (first, str)) = - let - val (ty, s) = xexp state e - val (_, str') = xblock state b - in - unify state (pos, ty, BasicTypes.boolTy); - (false, str ^ (if first then "" else "else ") ^ "if (" ^ s ^ ") then let\n" ^ - str' ^ - "in () end\n") - end - val (_, str) = foldl folder (true, str) ifs + val (ty, s) = xexp state e + val (_, str') = xblock state b + val _ = unify state (pos, ty, BasicTypes.boolTy) + val str = str ^ "if (" ^ s ^ ") then let\n" ^ + str' ^ + "in () end\n" val str = case els of NONE => @@ -691,8 +746,8 @@ struct val state = addVar (state, id, VAR parm) val (_, bs) = xblock state b in - (state, str ^ "fun foreach (" ^ id ^ (*" : " ^ - Elab.tyToString (context, ivmap, pty) ^*) ") = let\n" ^ + (state, str ^ "fun foreach (" ^ id ^ " : " ^ + tyToString state parm ^ ") = let\n" ^ bs ^ "in () end\n" ^ "val _ = app foreach (" ^ es ^ ")\n") @@ -711,7 +766,7 @@ struct (state, str ^ "fun forFunc " ^ id ^ " = let\n" ^ bs ^ "in () end\n" ^ - "val _ = for forFunc (" ^ es1 ^ ", " ^ es2 ^ ")\n") + "val _ = Web.for forFunc (" ^ es1 ^ ", " ^ es2 ^ ")\n") end | Case_i (e, matches) => let diff --git a/src/tree.sml b/src/tree.sml index 05b84d6..c74df19 100644 --- a/src/tree.sml +++ b/src/tree.sml @@ -30,7 +30,7 @@ struct (* Pattern *) datatype pat' = - Wild_p | Int_p of int | String_p of string + Wild_p | Int_p of int | String_p of string | Char_p of string | Real_p of real | Ident_p of path | Record_p of bool * (ident * pat) list | FlexRecord_p of (ident * pat) list @@ -40,7 +40,7 @@ struct (* Expression *) and exp' = - Int_e of int | String_e of string | Char_e of string | Ident_e of path + Int_e of int | String_e of string | Char_e of string | Real_e of real | Ident_e of path | Plus_e of exp * exp | Minus_e of exp * exp | Times_e of exp * exp | Divide_e of exp * exp | Mod_e of exp * exp | Neg_e | Param_e | Template_e of ident @@ -53,6 +53,9 @@ struct | 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 and exp = EXP of exp' withext and blockItem' = @@ -62,7 +65,7 @@ struct | Assn_i of ident * exp (* assignment to ref *) | Exp_i of exp (* expression to be evaluated *) | Open_i of path list (* imports to top level *) - | Ifthenelse_i of (exp * block) list * block option (* if statement *) + | 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 *) | For_i of ident * exp * exp * block (* foreach statement with integer range *) -- 2.20.1