diff options
| author |  Adam Chlipala <adam@chlipala.net> | 2014-08-01 15:44:17 -0400 |
|---|---|---|
| committer | Adam Chlipala <adam@chlipala.net> | 2014-08-01 15:44:17 -0400 |
| commit | b6d4f55981faff6ca7fa8b890c22ff4f33302ef2 (patch) | |
| tree | 76d0a9801c5ad0dc1e08f11635a8c2010926586b | |
| parent | 8ef3bce7ec88bb0c73a5885bca9f27526a1eae8b (diff) | |
Differentiate between HTML and normal string literals
| -rw-r--r-- | src/cjr_print.sml | 16 | ||||
| -rw-r--r-- | src/cjrize.sml | 10 | ||||
| -rw-r--r-- | src/iflow.sml | 18 | ||||
| -rw-r--r-- | src/jscomp.sml | 18 | ||||
| -rw-r--r-- | src/mono_opt.sml | 186 | ||||
| -rw-r--r-- | src/mono_reduce.sml | 10 | ||||
| -rw-r--r-- | src/monoize.sml | 707 | ||||
| -rw-r--r-- | src/pathcheck.sml | 2 | ||||
| -rw-r--r-- | src/prepare.sml | 16 | ||||
| -rw-r--r-- | src/prim.sig | 6 | ||||
| -rw-r--r-- | src/prim.sml | 16 | ||||
| -rw-r--r-- | src/shake.sml | 2 | ||||
| -rw-r--r-- | src/sql.sml | 8 | ||||
| -rw-r--r-- | src/urweb.grm | 36 |
14 files changed, 516 insertions, 535 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 9046acc8..a4cc8c54 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -203,10 +203,10 @@ fun p_patMatch (env, disc) (p, loc) = Prim.p_t_GCC (Prim.Int n), string ")"] | PPrim (Prim.String s) => box [string ("!strcmp(" ^ disc), - string ",", - space, - Prim.p_t_GCC (Prim.String s), - string ")"] + string ",", + space, + Prim.p_t_GCC (Prim.String s), + string ")"] | PPrim (Prim.Char ch) => box [string ("(" ^ disc), space, string "==", @@ -503,16 +503,16 @@ fun getPargs (e, _) = | ECase (e, [((PNone _, _), - (EPrim (Prim.String "NULL"), _)), + (EPrim (Prim.String (_, "NULL")), _)), ((PSome (_, (PVar _, _)), _), (EFfiApp (m, x, [((ERel 0, _), _)]), _))], {disc = t, ...}) => map (fn (x, y) => (x, Nullable y)) (getPargs (EFfiApp (m, x, [(e, t)]), #2 e)) | ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), - (EPrim (Prim.String "TRUE"), _)), + (EPrim (Prim.String (_, "TRUE")), _)), ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _), - (EPrim (Prim.String "FALSE"), _))], + (EPrim (Prim.String (_, "FALSE")), _))], _) => [(e, Bool)] | _ => raise Fail "CjrPrint: getPargs" @@ -2218,7 +2218,7 @@ and p_exp' par tail env (e, loc) = NONE => #nextval (Settings.currentDbms ()) {loc = loc, seqE = p_exp' false false env seq, seqName = case #1 seq of - EPrim (Prim.String s) => SOME s + EPrim (Prim.String (_, s)) => SOME s | _ => NONE} | SOME {id, query} => #nextvalPrepared (Settings.currentDbms ()) {loc = loc, id = id, diff --git a/src/cjrize.sml b/src/cjrize.sml index d153feff..6dc0299c 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -242,7 +242,7 @@ fun cifyExp (eAll as (e, loc), sm) = let fun fail msg = (ErrorMsg.errorAt loc msg; - ((L'.EPrim (Prim.String ""), loc), sm)) + ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), sm)) in case e of L.EPrim p => ((L'.EPrim p, loc), sm) @@ -632,7 +632,7 @@ fun cifyDecl ((d, loc), sm) = fun flatten e = case #1 e of L.ERecord [] => [] - | L.ERecord [(x, (L.EPrim (Prim.String v), _), _)] => [(x, v)] + | L.ERecord [(x, (L.EPrim (Prim.String (_, v)), _), _)] => [(x, v)] | L.EStrcat (e1, e2) => flatten e1 @ flatten e2 | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined"; Print.prefaces "Undetermined constraint" @@ -640,7 +640,7 @@ fun cifyDecl ((d, loc), sm) = []) val pe = case #1 pe of - L.EPrim (Prim.String s) => s + L.EPrim (Prim.String (_, s)) => s | _ => (ErrorMsg.errorAt loc "Primary key has not been fully determined"; Print.prefaces "Undetermined constraint" [("e", MonoPrint.p_exp MonoEnv.empty pe)]; @@ -662,7 +662,7 @@ fun cifyDecl ((d, loc), sm) = fun flatten e = case #1 e of L.ERecord [] => [] - | L.ERecord [(x, (L.EPrim (Prim.String v), _), _)] => [(x, v)] + | L.ERecord [(x, (L.EPrim (Prim.String (_, v)), _), _)] => [(x, v)] | L.EStrcat (e1, e2) => flatten e1 @ flatten e2 | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined"; Print.prefaces "Undetermined constraint" @@ -670,7 +670,7 @@ fun cifyDecl ((d, loc), sm) = []) val e = case #1 e of - L.EPrim (Prim.String s) => s + L.EPrim (Prim.String (_, s)) => s | _ => (ErrorMsg.errorAt loc "VIEW query has not been fully determined"; Print.prefaces "Undetermined VIEW query" [("e", MonoPrint.p_exp MonoEnv.empty e)]; diff --git a/src/iflow.sml b/src/iflow.sml index 461dc956..40cf8993 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1446,7 +1446,7 @@ fun evalExp env (e as (_, loc)) k = case es of [_, (cname, _), _, _, _] => (case #1 cname of - EPrim (Prim.String cname) => + EPrim (Prim.String (_, cname)) => St.havocCookie cname | _ => ()) | _ => () @@ -1637,7 +1637,7 @@ fun evalExp env (e as (_, loc)) k = | Update (tab, _, _) => (cs, SS.add (ts, tab))) | EFfiApp ("Basis", "set_cookie", - [_, ((EPrim (Prim.String cname), _), _), + [_, ((EPrim (Prim.String (_, cname)), _), _), _, _, _]) => (SS.add (cs, cname), ts) | _ => st} @@ -1765,7 +1765,7 @@ fun evalExp env (e as (_, loc)) k = handle Cc.Contradiction => ()) end) - | ENextval (EPrim (Prim.String seq), _) => + | ENextval (EPrim (Prim.String (_, seq)), _) => let val nv = St.nextVar () in @@ -1775,7 +1775,7 @@ fun evalExp env (e as (_, loc)) k = | ENextval _ => default () | ESetval _ => default () - | EUnurlify ((EFfiApp ("Basis", "get_cookie", [((EPrim (Prim.String cname), _), _)]), _), _, _) => + | EUnurlify ((EFfiApp ("Basis", "get_cookie", [((EPrim (Prim.String (_, cname)), _), _)]), _), _, _) => let val e = Var (St.nextVar ()) val e' = Func (Other ("cookie/" ^ cname), []) @@ -1843,9 +1843,9 @@ fun nameSubexps k (e : Mono.exp) = (e', fn e' => (EFfiApp (m, f, [(e', t)]), #2 e)) | ECase (e', ps as [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _), - (EPrim (Prim.String "TRUE"), _)), + (EPrim (Prim.String (_, "TRUE")), _)), ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _), - (EPrim (Prim.String "FALSE"), _))], q) => + (EPrim (Prim.String (_, "FALSE")), _))], q) => (e', fn e' => (ECase (e', ps, q), #2 e)) | _ => (e, fn x => x) in @@ -1907,7 +1907,7 @@ fun check (file : file) = let val ks = case #1 pk of - EPrim (Prim.String s) => + EPrim (Prim.String (_, s)) => (case String.tokens (fn ch => ch = #"," orelse ch = #" ") s of [] => [] | pk => [pk]) @@ -1974,7 +1974,7 @@ fun check (file : file) = | EFfi _ => e | EFfiApp (m, f, es) => (case (m, f, es) of - ("Basis", "set_cookie", [_, ((EPrim (Prim.String cname), _), _), _, _, _]) => + ("Basis", "set_cookie", [_, ((EPrim (Prim.String (_, cname)), _), _), _, _, _]) => cookies := SS.add (!cookies, cname) | _ => (); (EFfiApp (m, f, map (fn (e, t) => (doExp env e, t)) es), loc)) @@ -2150,7 +2150,7 @@ fun check (file : file) = | _ => raise Fail "Iflow: No New or Old in mayUpdate policy") e | PolSequence e => (case #1 e of - EPrim (Prim.String seq) => + EPrim (Prim.String (_, seq)) => let val p = AReln (Sql (String.extract (seq, 3, NONE)), [Lvar 0]) val outs = [Lvar 0] diff --git a/src/jscomp.sml b/src/jscomp.sml index bcabed0b..1a476739 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -55,7 +55,7 @@ type state = { fun strcat loc es = case es of - [] => (EPrim (Prim.String ""), loc) + [] => (EPrim (Prim.String (Prim.Normal, "")), loc) | [x] => x | x :: es' => (EStrcat (x, strcat loc es'), loc) @@ -81,7 +81,7 @@ fun process (file : file) = | (_, state) => state) (IM.empty, IM.empty) (#1 file) - fun str loc s = (EPrim (Prim.String s), loc) + fun str loc s = (EPrim (Prim.String (Prim.Normal, s)), loc) fun isNullable (t, _) = case t of @@ -149,7 +149,7 @@ fun process (file : file) = val (e', st) = quoteExp loc t ((ERel 0, loc), st) in (case #1 e' of - EPrim (Prim.String "ERROR") => raise Fail "UHOH" + EPrim (Prim.String (_, "ERROR")) => raise Fail "UHOH" | _ => (ECase (e, [((PNone t, loc), @@ -450,7 +450,7 @@ fun process (file : file) = 3) in case p of - Prim.String s => + Prim.String (_, s) => str ("\"" ^ String.translate jsChar s ^ "\"") | Prim.Char ch => str ("\"" ^ jsChar ch ^ "\"") | _ => str (Prim.toString p) @@ -519,7 +519,7 @@ fun process (file : file) = fun deStrcat level (all as (e, loc)) = case e of - EPrim (Prim.String s) => jsifyStringMulti (level, s) + EPrim (Prim.String (_, s)) => jsifyStringMulti (level, s) | EStrcat (e1, e2) => deStrcat level e1 ^ deStrcat level e2 | EFfiApp ("Basis", "jsifyString", [(e, _)]) => "\"" ^ deStrcat (level + 1) e ^ "\"" | _ => (ErrorMsg.errorAt loc "Unexpected non-constant JavaScript code"; @@ -1021,10 +1021,10 @@ fun process (file : file) = case #1 e of EPrim p => (case p of - Prim.String s => if inString {needle = "<script", haystack = s} then - foundJavaScript := true - else - () + Prim.String (_, s) => if inString {needle = "<script", haystack = s} then + foundJavaScript := true + else + () | _ => (); (e, st)) | ERel _ => (e, st) diff --git a/src/mono_opt.sml b/src/mono_opt.sml index ae306e68..d1e5ce55 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -145,7 +145,7 @@ fun checkProperty s = size s > 0 fun exp e = case e of - EPrim (Prim.String s) => + EPrim (Prim.String (Prim.Html, s)) => if CharVector.exists Char.isSpace s then let val (_, chs) = @@ -160,14 +160,14 @@ fun exp e = end) (false, []) s in - EPrim (Prim.String (String.implode (rev chs))) + EPrim (Prim.String (Prim.Html, String.implode (rev chs))) end else e | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => exp (EStrcat (e1, e2)) - - | EStrcat ((EPrim (Prim.String s1), loc), (EPrim (Prim.String s2), _)) => + + | EStrcat ((EPrim (Prim.String (Prim.Html, s1)), loc), (EPrim (Prim.String (Prim.Html, s2)), _)) => let val s = if size s1 > 0 andalso size s2 > 0 @@ -177,10 +177,13 @@ fun exp e = else s1 ^ s2 in - EPrim (Prim.String s) + EPrim (Prim.String (Prim.Html, s)) end + + | EStrcat ((EPrim (Prim.String (_, s1)), loc), (EPrim (Prim.String (_, s2)), _)) => + EPrim (Prim.String (Prim.Normal, s1 ^ s2)) - | EStrcat ((EPrim (Prim.String s1), loc), (EStrcat ((EPrim (Prim.String s2), _), rest), _)) => + | EStrcat ((EPrim (Prim.String (Prim.Html, s1)), loc), (EStrcat ((EPrim (Prim.String (Prim.Html, s2)), _), rest), _)) => let val s = if size s1 > 0 andalso size s2 > 0 @@ -190,9 +193,12 @@ fun exp e = else s1 ^ s2 in - EStrcat ((EPrim (Prim.String s), loc), rest) + EStrcat ((EPrim (Prim.String (Prim.Html, s)), loc), rest) end + | EStrcat ((EPrim (Prim.String (_, s1)), loc), (EStrcat ((EPrim (Prim.String (_, s2)), _), rest), _)) => + EStrcat ((EPrim (Prim.String (Prim.Normal, s1 ^ s2)), loc), rest) + | EStrcat ((EStrcat (e1, e2), loc), e3) => optExp (EStrcat (e1, (EStrcat (e2, e3), loc)), loc) @@ -200,27 +206,27 @@ fun exp e = ESeq ((optExp (EWrite e1, loc), loc), (optExp (EWrite e2, loc), loc)) - | ESeq ((EWrite (EPrim (Prim.String s1), _), loc), - (EWrite (EPrim (Prim.String s2), _), _)) => - EWrite (EPrim (Prim.String (s1 ^ s2)), loc) - | ESeq ((EWrite (EPrim (Prim.String s1), _), loc), - (ESeq ((EWrite (EPrim (Prim.String s2), _), _), + | ESeq ((EWrite (EPrim (Prim.String (_, s1)), _), loc), + (EWrite (EPrim (Prim.String (_, s2)), _), _)) => + EWrite (EPrim (Prim.String (Prim.Normal, s1 ^ s2)), loc) + | ESeq ((EWrite (EPrim (Prim.String (_, s1)), _), loc), + (ESeq ((EWrite (EPrim (Prim.String (_, s2)), _), _), e), _)) => - ESeq ((EWrite (EPrim (Prim.String (s1 ^ s2)), loc), loc), + ESeq ((EWrite (EPrim (Prim.String (Prim.Normal, s1 ^ s2)), loc), loc), e) | EFfiApp ("Basis", "htmlifySpecialChar", [((EPrim (Prim.Char ch), _), _)]) => - EPrim (Prim.String (htmlifySpecialChar ch)) + EPrim (Prim.String (Prim.Html, htmlifySpecialChar ch)) | EWrite (EFfiApp ("Basis", "htmlifySpecialChar", [e]), _) => EFfiApp ("Basis", "htmlifySpecialChar_w", [e]) | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "intToString", [((EPrim (Prim.Int n), _), _)]), _), _)]) => - EPrim (Prim.String (htmlifyInt n)) + EPrim (Prim.String (Prim.Html, htmlifyInt n)) | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "intToString", es), _), _)]) => EFfiApp ("Basis", "htmlifyInt", es) | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "intToString"), _), (EPrim (Prim.Int n), _)), _), _)]) => - EPrim (Prim.String (htmlifyInt n)) + EPrim (Prim.String (Prim.Html, htmlifyInt n)) | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "intToString"), _), e), loc), _)]) => EFfiApp ("Basis", "htmlifyInt", [(e, (TFfi ("Basis", "int"), loc))]) @@ -228,12 +234,12 @@ fun exp e = EFfiApp ("Basis", "htmlifyInt_w", [e]) | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "floatToString", [((EPrim (Prim.Float n), _), _)]), _), _)]) => - EPrim (Prim.String (htmlifyFloat n)) + EPrim (Prim.String (Prim.Html, htmlifyFloat n)) | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "floatToString", es), _), _)]) => EFfiApp ("Basis", "htmlifyFloat", es) | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "floatToString"), _), (EPrim (Prim.Float n), _)), _), _)]) => - EPrim (Prim.String (htmlifyFloat n)) + EPrim (Prim.String (Prim.Html, htmlifyFloat n)) | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "floatToString"), _), e), loc), _)]) => EFfiApp ("Basis", "htmlifyFloat", [(e, (TFfi ("Basis", "float"), loc))]) @@ -242,18 +248,18 @@ fun exp e = | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString", [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]), _), _)]) => - EPrim (Prim.String "True") + EPrim (Prim.String (Prim.Html, "True")) | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString", [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]), _), _)]) => - EPrim (Prim.String "False") + EPrim (Prim.String (Prim.Html, "False")) | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString", es), _), _)]) => EFfiApp ("Basis", "htmlifyBool", es) | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _), (ECon (Enum, PConFfi {con = "True", ...}, NONE), _)), _), _)]) => - EPrim (Prim.String "True") + EPrim (Prim.String (Prim.Html, "True")) | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _), (ECon (Enum, PConFfi {con = "False", ...}, NONE), _)), _), _)]) => - EPrim (Prim.String "False") + EPrim (Prim.String (Prim.Html, "False")) | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _), e), loc), _)]) => EFfiApp ("Basis", "htmlifyBool", [(e, (TFfi ("Basis", "bool"), loc))]) @@ -267,106 +273,106 @@ fun exp e = | EWrite (EFfiApp ("Basis", "htmlifyTime", [e]), _) => EFfiApp ("Basis", "htmlifyTime_w", [e]) - | EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String s), _), _)]) => - EPrim (Prim.String (htmlifyString s)) - | EWrite (EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String s), _), _)]), loc) => - EWrite (EPrim (Prim.String (htmlifyString s)), loc) + | EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String (_, s)), _), _)]) => + EPrim (Prim.String (Prim.Html, htmlifyString s)) + | EWrite (EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String (_, s)), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Html, htmlifyString s)), loc) | EWrite (EFfiApp ("Basis", "htmlifyString", [e]), _) => EFfiApp ("Basis", "htmlifyString_w", [e]) - | EFfiApp ("Basis", "htmlifyString_w", [((EPrim (Prim.String s), loc), _)]) => - EWrite (EPrim (Prim.String (htmlifyString s)), loc) + | EFfiApp ("Basis", "htmlifyString_w", [((EPrim (Prim.String (_, s)), loc), _)]) => + EWrite (EPrim (Prim.String (Prim.Html, htmlifyString s)), loc) | EWrite (EFfiApp ("Basis", "htmlifySource", [e]), _) => EFfiApp ("Basis", "htmlifySource_w", [e]) | EFfiApp ("Basis", "attrifyInt", [((EPrim (Prim.Int n), _), _)]) => - EPrim (Prim.String (attrifyInt n)) + EPrim (Prim.String (Prim.Html, attrifyInt n)) | EWrite (EFfiApp ("Basis", "attrifyInt", [((EPrim (Prim.Int n), _), _)]), loc) => - EWrite (EPrim (Prim.String (attrifyInt n)), loc) + EWrite (EPrim (Prim.String (Prim.Html, attrifyInt n)), loc) | EWrite (EFfiApp ("Basis", "attrifyInt", [e]), _) => EFfiApp ("Basis", "attrifyInt_w", [e]) | EFfiApp ("Basis", "attrifyFloat", [((EPrim (Prim.Float n), _), _)]) => - EPrim (Prim.String (attrifyFloat n)) + EPrim (Prim.String (Prim.Html, attrifyFloat n)) | EWrite (EFfiApp ("Basis", "attrifyFloat", [((EPrim (Prim.Float n), _), _)]), loc) => - EWrite (EPrim (Prim.String (attrifyFloat n)), loc) + EWrite (EPrim (Prim.String (Prim.Html, attrifyFloat n)), loc) | EWrite (EFfiApp ("Basis", "attrifyFloat", [e]), _) => EFfiApp ("Basis", "attrifyFloat_w", [e]) - | EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String s), _), _)]) => - EPrim (Prim.String (attrifyString s)) - | EWrite (EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String s), _), _)]), loc) => - EWrite (EPrim (Prim.String (attrifyString s)), loc) + | EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String (_, s)), _), _)]) => + EPrim (Prim.String (Prim.Html, attrifyString s)) + | EWrite (EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String (_, s)), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Html, attrifyString s)), loc) | EWrite (EFfiApp ("Basis", "attrifyString", [e]), _) => EFfiApp ("Basis", "attrifyString_w", [e]) | EFfiApp ("Basis", "attrifyChar", [((EPrim (Prim.Char s), _), _)]) => - EPrim (Prim.String (attrifyChar s)) + EPrim (Prim.String (Prim.Html, attrifyChar s)) | EWrite (EFfiApp ("Basis", "attrifyChar", [((EPrim (Prim.Char s), _), _)]), loc) => - EWrite (EPrim (Prim.String (attrifyChar s)), loc) + EWrite (EPrim (Prim.String (Prim.Html, attrifyChar s)), loc) | EWrite (EFfiApp ("Basis", "attrifyChar", [e]), _) => EFfiApp ("Basis", "attrifyChar_w", [e]) - | EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String s), _), _)]) => - EPrim (Prim.String s) - | EWrite (EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String s), _), _)]), loc) => - EWrite (EPrim (Prim.String s), loc) + | EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String (_, s)), _), _)]) => + EPrim (Prim.String (Prim.Html, s)) + | EWrite (EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String (_, s)), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Html, s)), loc) | EWrite (EFfiApp ("Basis", "attrifyCss_class", [e]), _) => EFfiApp ("Basis", "attrifyString_w", [e]) | EFfiApp ("Basis", "urlifyInt", [((EPrim (Prim.Int n), _), _)]) => - EPrim (Prim.String (urlifyInt n)) + EPrim (Prim.String (Prim.Normal, urlifyInt n)) | EWrite (EFfiApp ("Basis", "urlifyInt", [((EPrim (Prim.Int n), _), _)]), loc) => - EWrite (EPrim (Prim.String (urlifyInt n)), loc) + EWrite (EPrim (Prim.String (Prim.Normal, urlifyInt n)), loc) | EWrite (EFfiApp ("Basis", "urlifyInt", [e]), _) => EFfiApp ("Basis", "urlifyInt_w", [e]) | EFfiApp ("Basis", "urlifyFloat", [((EPrim (Prim.Float n), _), _)]) => - EPrim (Prim.String (urlifyFloat n)) + EPrim (Prim.String (Prim.Normal, urlifyFloat n)) | EWrite (EFfiApp ("Basis", "urlifyFloat", [((EPrim (Prim.Float n), _), _)]), loc) => - EWrite (EPrim (Prim.String (urlifyFloat n)), loc) + EWrite (EPrim (Prim.String (Prim.Normal, urlifyFloat n)), loc) | EWrite (EFfiApp ("Basis", "urlifyFloat", [e]), _) => EFfiApp ("Basis", "urlifyFloat_w", [e]) - | EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String s), _), _)]) => - EPrim (Prim.String (urlifyString s)) - | EWrite (EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String s), _), _)]), loc) => - EWrite (EPrim (Prim.String (urlifyString s)), loc) + | EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String (_, s)), _), _)]) => + EPrim (Prim.String (Prim.Normal, urlifyString s)) + | EWrite (EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String (Prim.Normal, s)), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Normal, urlifyString s)), loc) | EWrite (EFfiApp ("Basis", "urlifyString", [e]), _) => EFfiApp ("Basis", "urlifyString_w", [e]) | EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]) => - EPrim (Prim.String "1") + EPrim (Prim.String (Prim.Normal, "1")) | EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]) => - EPrim (Prim.String "0") + EPrim (Prim.String (Prim.Normal, "0")) | EWrite (EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]), loc) => - EWrite (EPrim (Prim.String "1"), loc) + EWrite (EPrim (Prim.String (Prim.Normal, "1")), loc) | EWrite (EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]), loc) => - EWrite (EPrim (Prim.String "0"), loc) + EWrite (EPrim (Prim.String (Prim.Normal, "0")), loc) | EWrite (EFfiApp ("Basis", "urlifyBool", [e]), _) => EFfiApp ("Basis", "urlifyBool_w", [e]) | EFfiApp ("Basis", "sqlifyInt", [((EPrim (Prim.Int n), _), _)]) => - EPrim (Prim.String (sqlifyInt n)) + EPrim (Prim.String (Prim.Normal, sqlifyInt n)) | EFfiApp ("Basis", "sqlifyIntN", [((ENone _, _), _)]) => - EPrim (Prim.String "NULL") + EPrim (Prim.String (Prim.Normal, "NULL")) | EFfiApp ("Basis", "sqlifyIntN", [((ESome (_, (EPrim (Prim.Int n), _)), _), _)]) => - EPrim (Prim.String (sqlifyInt n)) + EPrim (Prim.String (Prim.Normal, sqlifyInt n)) | EFfiApp ("Basis", "sqlifyFloat", [((EPrim (Prim.Float n), _), _)]) => - EPrim (Prim.String (sqlifyFloat n)) + EPrim (Prim.String (Prim.Normal, sqlifyFloat n)) | EFfiApp ("Basis", "sqlifyBool", [(b as (_, loc), _)]) => optExp (ECase (b, [((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "True", arg = NONE}, NONE), loc), - (EPrim (Prim.String (#trueString (Settings.currentDbms ()))), loc)), + (EPrim (Prim.String (Prim.Normal, #trueString (Settings.currentDbms ()))), loc)), ((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "False", arg = NONE}, NONE), loc), - (EPrim (Prim.String (#falseString (Settings.currentDbms ()))), loc))], + (EPrim (Prim.String (Prim.Normal, #falseString (Settings.currentDbms ()))), loc))], {disc = (TFfi ("Basis", "bool"), loc), result = (TFfi ("Basis", "string"), loc)}), loc) - | EFfiApp ("Basis", "sqlifyString", [((EPrim (Prim.String n), _), _)]) => - EPrim (Prim.String (sqlifyString n)) + | EFfiApp ("Basis", "sqlifyString", [((EPrim (Prim.String (_, n)), _), _)]) => + EPrim (Prim.String (Prim.Normal, sqlifyString n)) | EFfiApp ("Basis", "sqlifyChar", [((EPrim (Prim.Char n), _), _)]) => - EPrim (Prim.String (sqlifyChar n)) + EPrim (Prim.String (Prim.Normal, sqlifyChar n)) | EWrite (ECase (discE, pes, {disc, ...}), loc) => optExp (ECase (discE, @@ -388,11 +394,11 @@ fun exp e = end | EWrite (EQuery {exps, tables, state, query, - initial = (EPrim (Prim.String ""), _), - body = (EStrcat ((EPrim (Prim.String s), _), + initial = (EPrim (Prim.String (k, "")), _), + body = (EStrcat ((EPrim (Prim.String (_, s)), _), (EStrcat ((ERel 0, _), e'), _)), _)}, loc) => - if CharVector.all Char.isSpace s then + if (case k of Prim.Normal => s = "" | Prim.Html => CharVector.all Char.isSpace s) then EQuery {exps = exps, tables = tables, query = query, state = (TRecord [], loc), initial = (ERecord [], loc), @@ -401,7 +407,7 @@ fun exp e = e | EWrite (EQuery {exps, tables, state, query, - initial = (EPrim (Prim.String ""), _), + initial = (EPrim (Prim.String (_, "")), _), body}, loc) => let fun passLets (depth, (e', _), lets) = @@ -439,94 +445,94 @@ fun exp e = | EWrite (ELet (x, t, e1, e2), loc) => optExp (ELet (x, t, e1, (EWrite e2, loc)), loc) - | EWrite (EPrim (Prim.String ""), loc) => + | EWrite (EPrim (Prim.String (_, "")), loc) => ERecord [] | ESignalBind ((ESignalReturn e1, loc), e2) => optExp (EApp (e2, e1), loc) - | EFfiApp ("Basis", "blessData", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "blessData", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if checkData s then () else ErrorMsg.errorAt loc ("Invalid HTML5 data-* attribute " ^ s); se) - | EFfiApp ("Basis", "bless", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "bless", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if checkUrl s then () else ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'bless'"); se) - | EFfiApp ("Basis", "checkUrl", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "checkUrl", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if checkUrl s then ESome ((TFfi ("Basis", "string"), loc), (se, loc)) else ENone (TFfi ("Basis", "string"), loc)) - | EFfiApp ("Basis", "blessMime", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "blessMime", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if Settings.checkMime s then () else ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessMime'"); se) - | EFfiApp ("Basis", "checkMime", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "checkMime", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if Settings.checkMime s then ESome ((TFfi ("Basis", "string"), loc), (se, loc)) else ENone (TFfi ("Basis", "string"), loc)) - | EFfiApp ("Basis", "atom", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "atom", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if checkAtom s then () else ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'atom'"); se) - | EFfiApp ("Basis", "css_url", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "css_url", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if checkCssUrl s then () else ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'css_url'"); se) - | EFfiApp ("Basis", "property", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "property", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if checkProperty s then () else ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'property'"); se) - | EFfiApp ("Basis", "blessRequestHeader", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "blessRequestHeader", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if Settings.checkRequestHeader s then () else ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessRequestHeader'"); se) - | EFfiApp ("Basis", "checkRequestHeader", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "checkRequestHeader", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if Settings.checkRequestHeader s then ESome ((TFfi ("Basis", "string"), loc), (se, loc)) else ENone (TFfi ("Basis", "string"), loc)) - | EFfiApp ("Basis", "blessResponseHeader", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "blessResponseHeader", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if Settings.checkResponseHeader s then () else ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessResponseHeader'"); se) - | EFfiApp ("Basis", "checkResponseHeader", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "checkResponseHeader", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if Settings.checkResponseHeader s then ESome ((TFfi ("Basis", "string"), loc), (se, loc)) else ENone (TFfi ("Basis", "string"), loc)) - | EFfiApp ("Basis", "blessEnvVar", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "blessEnvVar", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if Settings.checkEnvVar s then () else ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessEnvVar'"); se) - | EFfiApp ("Basis", "checkEnvVar", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "checkEnvVar", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if Settings.checkEnvVar s then ESome ((TFfi ("Basis", "string"), loc), (se, loc)) else ENone (TFfi ("Basis", "string"), loc)) - | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String (_, s)), loc), _)]) => let fun uwify (cs, acc) = case cs of @@ -551,10 +557,10 @@ fun exp e = #"_" :: cs => uwify (cs, ["uw_"]) | cs => uwify (cs, []) in - EPrim (Prim.String s) + EPrim (Prim.String (Prim.Normal, s)) end - | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String (_, s)), loc), _)]) => let fun uwify (cs, acc) = case cs of @@ -576,11 +582,11 @@ fun exp e = val s = uwify (String.explode s, []) in - EPrim (Prim.String s) + EPrim (Prim.String (Prim.Normal, s)) end - | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String s), _), _)]) => - EPrim (Prim.String (unAs s)) + | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String (_, s)), _), _)]) => + EPrim (Prim.String (Prim.Normal, unAs s)) | EFfiApp ("Basis", "unAs", [(e', _)]) => let fun parts (e as (_, loc)) = @@ -589,7 +595,7 @@ fun exp e = (case (parts s1, parts s2) of (SOME p1, SOME p2) => SOME (p1 @ p2) | _ => NONE) - | EPrim (Prim.String s) => SOME [(EPrim (Prim.String (unAs s)), loc)] + | EPrim (Prim.String (_, s)) => SOME [(EPrim (Prim.String (Prim.Normal, unAs s)), loc)] | EFfiApp ("Basis", f, [_]) => if String.isPrefix "sqlify" f then SOME [e] @@ -607,7 +613,7 @@ fun exp e = end | EFfiApp ("Basis", "str1", [((EPrim (Prim.Char ch), _), _)]) => - EPrim (Prim.String (str ch)) + EPrim (Prim.String (Prim.Normal, str ch)) | EFfiApp ("Basis", "attrifyString", [((EFfiApp ("Basis", "str1", [e]), _), _)]) => EFfiApp ("Basis", "attrifyChar", [e]) | EFfiApp ("Basis", "attrifyString_w", [((EFfiApp ("Basis", "str1", [e]), _), _)]) => diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 98e81185..f1a6758d 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -190,13 +190,13 @@ fun match (env, p : pat, e : exp) = (PWild, _) => Yes env | (PVar (x, t), _) => Yes ((x, t, e) :: env) - | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) => + | (PPrim (Prim.String (_, s)), EStrcat ((EPrim (Prim.String (_, s')), _), _)) => if String.isPrefix s' s then Maybe else No - | (PPrim (Prim.String s), EStrcat (_, (EPrim (Prim.String s'), _))) => + | (PPrim (Prim.String (_, s)), EStrcat (_, (EPrim (Prim.String (_, s')), _))) => if String.isSuffix s' s then Maybe else @@ -756,8 +756,10 @@ fun reduce (file : file) = | ELet (x, t, e', b) => doLet (x, t, e', b) - | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) => - EPrim (Prim.String (s1 ^ s2)) + | EStrcat ((EPrim (Prim.String (k1, s1)), _), (EPrim (Prim.String (k2, s2)), _)) => + EPrim (Prim.String ((case (k1, k2) of + (Prim.Html, Prim.Html) => Prim.Html + | _ => Prim.Normal), s1 ^ s2)) | ESignalBind ((ESignalReturn e1, loc), e2) => #1 (reduceExp env (EApp (e2, e1), loc)) diff --git a/src/monoize.sml b/src/monoize.sml index 9182c077..a1f97184 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -515,7 +515,7 @@ fun fooifyExp fk env = let val (_, _, _, s) = Env.lookupENamed env fnam in - ((L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm) + ((L'.EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) end | L'.EClosure (fnam, args) => let @@ -531,21 +531,21 @@ fun fooifyExp fk env = in attrify (args, ft, (L'.EStrcat (e, - (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc), + (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "/")), loc), arg'), loc)), loc), fm) end | _ => (E.errorAt loc "Type mismatch encoding attribute"; (e, fm)) in - attrify (args, ft, (L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm) + attrify (args, ft, (L'.EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) end | _ => case t of - L'.TFfi ("Basis", "unit") => ((L'.EPrim (Prim.String ""), loc), fm) + L'.TFfi ("Basis", "unit") => ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), fm) | L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm) - | L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm) + | L'.TRecord [] => ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), fm) | L'.TRecord ((x, t) :: xts) => let val (se, fm) = fooify fm ((L'.EField (e, x), loc), t) @@ -555,7 +555,7 @@ fun fooifyExp fk env = val (se', fm) = fooify fm ((L'.EField (e, x), loc), t) in ((L'.EStrcat (se, - (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc), + (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "/")), loc), se'), loc)), loc), fm) end) (se, fm) xts @@ -585,14 +585,14 @@ fun fooifyExp fk env = case to of NONE => (((L'.PCon (dk, L'.PConVar n, NONE), loc), - (L'.EPrim (Prim.String x), loc)), + (L'.EPrim (Prim.String (Prim.Normal, x)), loc)), fm) | SOME t => let val (arg, fm) = fooify fm ((L'.ERel 0, loc), t) in (((L'.PCon (dk, L'.PConVar n, SOME (L'.PVar ("a", t), loc)), loc), - (L'.EStrcat ((L'.EPrim (Prim.String (x ^ "/")), loc), + (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, x ^ "/")), loc), arg), loc)), fm) end) @@ -626,10 +626,10 @@ fun fooifyExp fk env = in ((L'.ECase (e, [((L'.PNone t, loc), - (L'.EPrim (Prim.String "None"), loc)), + (L'.EPrim (Prim.String (Prim.Normal, "None")), loc)), ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc), - (L'.EStrcat ((L'.EPrim (Prim.String "Some/"), loc), + (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "Some/")), loc), body), loc))], {disc = tAll, result = (L'.TFfi ("Basis", "string"), loc)}), loc), @@ -644,9 +644,9 @@ fun fooifyExp fk env = val (arg, fm) = fooify fm ((L'.ERel 0, loc), rt) val branches = [((L'.PNone rt, loc), - (L'.EPrim (Prim.String "Nil"), loc)), + (L'.EPrim (Prim.String (Prim.Normal, "Nil")), loc)), ((L'.PSome (rt, (L'.PVar ("a", rt), loc)), loc), - (L'.EStrcat ((L'.EPrim (Prim.String "Cons/"), loc), + (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "Cons/")), loc), arg), loc))] val dom = tAll @@ -742,7 +742,7 @@ fun monoPat env (all as (p, loc)) = fun strcat loc es = case es of - [] => (L'.EPrim (Prim.String ""), loc) + [] => (L'.EPrim (Prim.String (Prim.Normal, "")), loc) | [e] => e | _ => let @@ -757,7 +757,7 @@ fun strcat loc es = fun strcatComma loc es = case es of - [] => (L'.EPrim (Prim.String ""), loc) + [] => (L'.EPrim (Prim.String (Prim.Normal, "")), loc) | [e] => e | _ => let @@ -766,11 +766,11 @@ fun strcatComma loc es = in foldr (fn (e, e') => case (e, e') of - ((L'.EPrim (Prim.String ""), _), _) => e' - | (_, (L'.EPrim (Prim.String ""), _)) => e + ((L'.EPrim (Prim.String (_, "")), _), _) => e' + | (_, (L'.EPrim (Prim.String (_, "")), _)) => e | _ => (L'.EStrcat (e, - (L'.EStrcat ((L'.EPrim (Prim.String ", "), loc), e'), loc)), loc)) + (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, ", ")), loc), e'), loc)), loc)) e1 es end @@ -788,7 +788,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val strcat = strcat loc val strcatComma = strcatComma loc - fun str s = (L'.EPrim (Prim.String s), loc) + fun str s = (L'.EPrim (Prim.String (Prim.Normal, s)), loc) + fun strH s = (L'.EPrim (Prim.String (Prim.Html, s)), loc) fun poly () = (E.errorAt loc "Unsupported expression"; @@ -1564,9 +1565,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("c", s, (L'.TFun (rt, (L'.TFun (un, un), loc)), loc), (L'.EAbs ("r", rt, (L'.TFun (un, un), loc), (L'.EAbs ("_", un, un, - (L'.EFfiApp ("Basis", "set_cookie", [((L'.EPrim (Prim.String - (Settings.getUrlPrefix ())), - loc), s), + (L'.EFfiApp ("Basis", "set_cookie", [(str (Settings.getUrlPrefix ()), s), ((L'.ERel 2, loc), s), (e, s), (fd "Expires", (L'.TOption (L'.TFfi ("Basis", "time"), loc), loc)), @@ -1583,9 +1582,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("c", s, (L'.TFun (un, un), loc), (L'.EAbs ("_", un, un, (L'.EFfiApp ("Basis", "clear_cookie", - [((L'.EPrim (Prim.String - (Settings.getUrlPrefix ())), - loc), s), + [(str (Settings.getUrlPrefix ()), s), ((L'.ERel 1, loc), s)]), loc)), loc)), loc), fm) @@ -1612,8 +1609,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end | L.ECApp ((L.EFfi ("Basis", "no_primary_key"), _), _) => - ((L'.EPrim (Prim.String ""), loc), - fm) + (str "", fm) | L.ECApp ( (L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "primary_key"), _), _), _), t), _), nm), _), @@ -1623,16 +1619,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val witnesses = (L'.TRecord (map (fn (nm, _) => (monoName env nm, (L'.TRecord [], loc))) unique), loc) in ((L'.EAbs ("_", witnesses, (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String - (String.concatWith ", " - (map (fn (x, _) => - Settings.mangleSql (monoNameLc env x) - ^ (if #textKeysNeedLengths (Settings.currentDbms ()) - andalso isBlobby t then - "(767)" - else - "")) unique))), - loc)), loc), + (str + (String.concatWith ", " + (map (fn (x, _) => + Settings.mangleSql (monoNameLc env x) + ^ (if #textKeysNeedLengths (Settings.currentDbms ()) + andalso isBlobby t then + "(767)" + else + "")) unique)))), + loc), fm) end @@ -1668,15 +1664,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val unique = (nm, t) :: unique in - ((L'.EPrim (Prim.String ("UNIQUE (" - ^ String.concatWith ", " - (map (fn (x, t) => Settings.mangleSql (monoNameLc env x) - ^ (if #textKeysNeedLengths (Settings.currentDbms ()) - andalso isBlobby t then - "(767)" - else - "")) unique) - ^ ")")), loc), + (str ("UNIQUE (" + ^ String.concatWith ", " + (map (fn (x, t) => Settings.mangleSql (monoNameLc env x) + ^ (if #textKeysNeedLengths (Settings.currentDbms ()) + andalso isBlobby t then + "(767)" + else + "")) unique) + ^ ")"), fm) end @@ -1690,7 +1686,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EFfi ("Basis", "mat_nil") => let val string = (L'.TFfi ("Basis", "string"), loc) - val stringE = (L'.EPrim (Prim.String ""), loc) + val stringE = str "" in ((L'.ERecord [("1", stringE, string), ("2", stringE, string)], loc), fm) @@ -1715,21 +1711,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (mat, mat), loc), (L'.EAbs ("m", mat, mat, (L'.ECase ((L'.EField ((L'.ERel 0, loc), "1"), loc), - [((L'.PPrim (Prim.String ""), loc), - (L'.ERecord [("1", (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm1))), - loc), string), - ("2", (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm2))), - loc), string)], loc)), + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + (L'.ERecord [("1", str (Settings.mangleSql (lowercaseFirst nm1)), + string), + ("2", str (Settings.mangleSql (lowercaseFirst nm2)), + string)], loc)), ((L'.PWild, loc), (L'.ERecord [("1", (L'.EStrcat ( - (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm1) - ^ ", ")), - loc), + str (Settings.mangleSql (lowercaseFirst nm1) + ^ ", "), (L'.EField ((L'.ERel 0, loc), "1"), loc)), loc), string), ("2", (L'.EStrcat ( - (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm2) - ^ ", ")), loc), + str (Settings.mangleSql (lowercaseFirst nm2) + ^ ", "), (L'.EField ((L'.ERel 0, loc), "2"), loc)), loc), string)], loc))], @@ -1738,10 +1733,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end - | L.ECApp ((L.EFfi ("Basis", "restrict"), _), _) => ((L'.EPrim (Prim.String "RESTRICT"), loc), fm) - | L.ECApp ((L.EFfi ("Basis", "cascade"), _), _) => ((L'.EPrim (Prim.String "CASCADE"), loc), fm) - | L.ECApp ((L.EFfi ("Basis", "no_action"), _), _) => ((L'.EPrim (Prim.String "NO ACTION"), loc), fm) - | L.ECApp ((L.EFfi ("Basis", "set_null"), _), _) => ((L'.EPrim (Prim.String "SET NULL"), loc), fm) + | L.ECApp ((L.EFfi ("Basis", "restrict"), _), _) => (str "RESTRICT", fm) + | L.ECApp ((L.EFfi ("Basis", "cascade"), _), _) => (str "CASCADE", fm) + | L.ECApp ((L.EFfi ("Basis", "no_action"), _), _) => (str "NO ACTION", fm) + | L.ECApp ((L.EFfi ("Basis", "set_null"), _), _) => (str "SET NULL", fm) | L.ECApp ( (L.ECApp ( @@ -1773,10 +1768,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fun prop (fd, kw) = (L'.ECase ((L'.EField ((L'.ERel 0, loc), fd), loc), - [((L'.PPrim (Prim.String "NO ACTION"), loc), - (L'.EPrim (Prim.String ""), loc)), + [((L'.PPrim (Prim.String (Prim.Normal, "NO ACTION")), loc), + str ""), ((L'.PWild, loc), - strcat [(L'.EPrim (Prim.String (" ON " ^ kw ^ " ")), loc), + strcat [str (" ON " ^ kw ^ " "), (L'.EField ((L'.ERel 0, loc), fd), loc)])], {disc = string, result = string}), loc) @@ -1784,13 +1779,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("m", mat, (L'.TFun (string, (L'.TFun (recd, string), loc)), loc), (L'.EAbs ("tab", string, (L'.TFun (recd, string), loc), (L'.EAbs ("pr", recd, string, - strcat [(L'.EPrim (Prim.String "FOREIGN KEY ("), loc), + strcat [str "FOREIGN KEY (", (L'.EField ((L'.ERel 2, loc), "1"), loc), - (L'.EPrim (Prim.String ") REFERENCES "), loc), + str ") REFERENCES ", (L'.ERel 1, loc), - (L'.EPrim (Prim.String " ("), loc), + str " (", (L'.EField ((L'.ERel 2, loc), "2"), loc), - (L'.EPrim (Prim.String ")"), loc), + str ")", prop ("OnDelete", "DELETE"), prop ("OnUpdate", "UPDATE")]), loc)), loc)), loc), fm) @@ -1823,7 +1818,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val string = (L'.TFfi ("Basis", "string"), loc) in ((L'.EAbs ("e", string, string, - (L'.EStrcat ((L'.EPrim (Prim.String "CHECK "), loc), + (L'.EStrcat (str "CHECK ", (L'.EFfiApp ("Basis", "checkString", [((L'.ERel 0, loc), string)]), loc)), loc)), loc), fm) @@ -1852,19 +1847,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val s = (L'.TFfi ("Basis", "string"), loc) val fields = map (fn (x, _) => (x, s)) fields val rt = (L'.TRecord fields, loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("tab", s, (L'.TFun (rt, s), loc), (L'.EAbs ("fs", rt, s, - strcat [sc "INSERT INTO ", + strcat [str "INSERT INTO ", (L'.ERel 1, loc), - sc " (", - strcatComma (map (fn (x, _) => sc (Settings.mangleSql x)) fields), - sc ") VALUES (", + str " (", + strcatComma (map (fn (x, _) => str (Settings.mangleSql x)) fields), + str ") VALUES (", strcatComma (map (fn (x, _) => (L'.EField ((L'.ERel 0, loc), x), loc)) fields), - sc ")"]), loc)), loc), + str ")"]), loc)), loc), fm) end | _ => poly ()) @@ -1876,31 +1870,30 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val s = (L'.TFfi ("Basis", "string"), loc) val changed = map (fn (x, _) => (x, s)) changed val rt = (L'.TRecord changed, loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("fs", rt, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("tab", s, (L'.TFun (s, s), loc), (L'.EAbs ("e", s, s, if #supportsUpdateAs (Settings.currentDbms ()) then - strcat [sc "UPDATE ", + strcat [str "UPDATE ", (L'.ERel 1, loc), - sc " AS T_T SET ", + str " AS T_T SET ", strcatComma (map (fn (x, _) => - strcat [sc (Settings.mangleSql x + strcat [str (Settings.mangleSql x ^ " = "), (L'.EField ((L'.ERel 2, loc), x), loc)]) changed), - sc " WHERE ", + str " WHERE ", (L'.ERel 0, loc)] else - strcat [sc "UPDATE ", + strcat [str "UPDATE ", (L'.ERel 1, loc), - sc " SET ", + str " SET ", strcatComma (map (fn (x, _) => - strcat [sc (Settings.mangleSql x + strcat [str (Settings.mangleSql x ^ " = "), (L'.EFfiApp ("Basis", "unAs", [((L'.EField @@ -1909,7 +1902,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = x), loc), s)]), loc)]) changed), - sc " WHERE ", + str " WHERE ", (L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]), loc)), loc)), loc), fm) @@ -1919,19 +1912,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "delete"), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("tab", s, (L'.TFun (s, s), loc), (L'.EAbs ("e", s, s, if #supportsDeleteAs (Settings.currentDbms ()) then - strcat [sc "DELETE FROM ", + strcat [str "DELETE FROM ", (L'.ERel 1, loc), - sc " AS T_T WHERE ", + str " AS T_T WHERE ", (L'.ERel 0, loc)] else - strcat [sc "DELETE FROM ", + strcat [str "DELETE FROM ", (L'.ERel 1, loc), - sc " WHERE ", + str " WHERE ", (L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]), loc)), loc), fm) end @@ -1991,7 +1983,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_query"), _), _), _), _), _), _), _), _), _), _) => let - fun sc s = (L'.EPrim (Prim.String s), loc) val s = (L'.TFfi ("Basis", "string"), loc) fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc) in @@ -2000,9 +1991,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = s, strcat [gf "Rows", (L'.ECase (gf "OrderBy", - [((L'.PPrim (Prim.String ""), loc), sc ""), + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), str ""), ((L'.PWild, loc), - strcat [sc " ORDER BY ", + strcat [str " ORDER BY ", gf "OrderBy"])], {disc = s, result = s}), loc), gf "Limit", @@ -2025,7 +2016,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) = sexps), _), _) => let - fun sc s = (L'.EPrim (Prim.String s), loc) val s = (L'.TFfi ("Basis", "string"), loc) val b = (L'.TFfi ("Basis", "bool"), loc) val un = (L'.TRecord [], loc) @@ -2072,7 +2062,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ("SelectExps", (L'.TRecord (map (fn (x, _) => (x, s)) sexps), loc))], loc), s, - strcat [sc "SELECT ", + strcat [str "SELECT ", (L'.ECase (gf "Distinct", [((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis", @@ -2080,41 +2070,41 @@ fun monoExp (env, st, fm) (all as (e, loc)) = con = "True", arg = NONE}, NONE), loc), - (L'.EPrim (Prim.String "DISTINCT "), loc)), + str "DISTINCT "), ((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis", datatyp = "bool", con = "False", arg = NONE}, NONE), loc), - (L'.EPrim (Prim.String ""), loc))], + str "")], {disc = b, result = s}), loc), strcatComma (map (fn (x, t) => strcat [ (L'.EField (gf "SelectExps", x), loc), - sc (" AS " ^ Settings.mangleSql x) + str (" AS " ^ Settings.mangleSql x) ]) sexps @ map (fn (x, xts) => strcatComma (map (fn (x', _) => - sc ("T_" ^ x + str ("T_" ^ x ^ "." ^ Settings.mangleSql x')) xts)) stables), (L'.ECase (gf "From", - [((L'.PPrim (Prim.String ""), loc), - sc ""), + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + str ""), ((L'.PVar ("x", s), loc), - strcat [sc " FROM ", + strcat [str " FROM ", (L'.ERel 0, loc)])], {disc = s, result = s}), loc), (L'.ECase (gf "Where", - [((L'.PPrim (Prim.String (#trueString (Settings.currentDbms ()))), + [((L'.PPrim (Prim.String (Prim.Normal, #trueString (Settings.currentDbms ()))), loc), - sc ""), + str ""), ((L'.PWild, loc), - strcat [sc " WHERE ", gf "Where"])], + strcat [str " WHERE ", gf "Where"])], {disc = s, result = s}), loc), @@ -2125,14 +2115,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) = List.all (fn (x, _) => List.exists (fn (x', _) => x' = x) xts') xts) tables then - sc "" + str "" else strcat [ - sc " GROUP BY ", + str " GROUP BY ", strcatComma (map (fn (x, xts) => strcatComma (map (fn (x', _) => - sc ("T_" ^ x + str ("T_" ^ x ^ "." ^ Settings.mangleSql x')) xts)) grouped) @@ -2140,10 +2130,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ECase (gf "Having", [((L'.PPrim (Prim.String - (#trueString (Settings.currentDbms ()))), loc), - sc ""), + (Prim.Normal, #trueString (Settings.currentDbms ()))), loc), + str ""), ((L'.PWild, loc), - strcat [sc " HAVING ", gf "Having"])], + strcat [str " HAVING ", gf "Having"])], {disc = s, result = s}), loc) ]), loc), @@ -2234,7 +2224,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = s, (L'.ECase ((L'.ERel 0, loc), [((L'.PNone t, loc), - (L'.EPrim (Prim.String "NULL"), loc)), + str "NULL"), ((L'.PSome (t, (L'.PVar ("y", t), loc)), loc), (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc))], {disc = (L'.TOption t, loc), @@ -2270,7 +2260,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.ERecord [], loc), fm) | L.ECApp ((L.EFfi ("Basis", "sql_from_nil"), _), _) => - ((L'.EPrim (Prim.String ""), loc), fm) + (str "", fm) | L.ECApp ((L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_table"), _), _), _), _), _), _), _), _), _), (L.CName name, _)) => @@ -2279,7 +2269,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EAbs ("tab", s, s, strcat [(L'.ERel 0, loc), - (L'.EPrim (Prim.String (" AS T_" ^ name)), loc)]), loc), + str (" AS T_" ^ name)]), loc), fm) end | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_query"), _), _), @@ -2287,12 +2277,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.CName name, _)) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("q", s, s, - strcat [sc "(", + strcat [str "(", (L'.ERel 0, loc), - sc (") AS T_" ^ name)]), loc), + str (") AS T_" ^ name)]), loc), fm) end | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_comma"), _), _), _), _), _), _) => @@ -2303,13 +2292,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("tab2", s, s, (L'.ECase ((L'.ERecord [("1", (L'.ERel 1, loc), s), ("2", (L'.ERel 0, loc), s)], loc), - [((L'.PRecord [("1", (L'.PPrim (Prim.String ""), loc), s)], loc), + [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 0, loc)), - ((L'.PRecord [("2", (L'.PPrim (Prim.String ""), loc), s)], loc), + ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 1, loc)), ((L'.PWild, loc), strcat [(L'.ERel 1, loc), - (L'.EPrim (Prim.String ", "), loc), + str ", ", (L'.ERel 0, loc)])], {disc = (L'.TRecord [("1", s), ("2", s)], loc), result = s}), loc)), loc)), loc), @@ -2324,24 +2313,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("on", s, s, (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s), ("2", (L'.ERel 1, loc), s)], loc), - [((L'.PRecord [("1", (L'.PPrim (Prim.String ""), loc), s)], loc), + [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 1, loc)), - ((L'.PRecord [("2", (L'.PPrim (Prim.String ""), loc), s)], loc), + ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), ((L'.PWild, loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then - [(L'.EPrim (Prim.String "("), loc)] + [str "("] else []) @ [(L'.ERel 2, loc), - (L'.EPrim (Prim.String " JOIN "), loc), + str " JOIN ", (L'.ERel 1, loc), - (L'.EPrim (Prim.String " ON "), loc), + str " ON ", (L'.ERel 0, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then - [(L'.EPrim (Prim.String ")"), loc)] + [str ")"] else [])))], {disc = (L'.TRecord [("1", s), ("2", s)], loc), @@ -2360,27 +2349,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("on", s, s, (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s), ("2", (L'.ERel 1, loc), s)], loc), - [((L'.PRecord [("1", (L'.PPrim (Prim.String ""), + [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 1, loc)), - ((L'.PRecord [("2", (L'.PPrim (Prim.String ""), + ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), ((L'.PWild, loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then - [(L'.EPrim (Prim.String "("), loc)] + [str "("] else []) @ [(L'.ERel 2, loc), - (L'.EPrim (Prim.String " LEFT JOIN "), - loc), + str " LEFT JOIN ", (L'.ERel 1, loc), - (L'.EPrim (Prim.String " ON "), loc), + str " ON ", (L'.ERel 0, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then - [(L'.EPrim (Prim.String ")"), loc)] + [str ")"] else [])))], {disc = (L'.TRecord [("1", s), ("2", s)], loc), @@ -2399,27 +2387,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("on", s, s, (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s), ("2", (L'.ERel 1, loc), s)], loc), - [((L'.PRecord [("1", (L'.PPrim (Prim.String ""), + [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 1, loc)), - ((L'.PRecord [("2", (L'.PPrim (Prim.String ""), + ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), ((L'.PWild, loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then - [(L'.EPrim (Prim.String "("), loc)] + [str "("] else []) @ [(L'.ERel 2, loc), - (L'.EPrim (Prim.String " RIGHT JOIN "), - loc), + str " RIGHT JOIN ", (L'.ERel 1, loc), - (L'.EPrim (Prim.String " ON "), loc), + str " ON ", (L'.ERel 0, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then - [(L'.EPrim (Prim.String ")"), loc)] + [str ")"] else [])))], {disc = (L'.TRecord [("1", s), ("2", s)], loc), @@ -2438,27 +2425,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("on", s, s, (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s), ("2", (L'.ERel 1, loc), s)], loc), - [((L'.PRecord [("1", (L'.PPrim (Prim.String ""), + [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 1, loc)), - ((L'.PRecord [("2", (L'.PPrim (Prim.String ""), + ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), ((L'.PWild, loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then - [(L'.EPrim (Prim.String "("), loc)] + [str "("] else []) @ [(L'.ERel 2, loc), - (L'.EPrim (Prim.String " FULL JOIN "), - loc), + str " FULL JOIN ", (L'.ERel 1, loc), - (L'.EPrim (Prim.String " ON "), loc), + str " ON ", (L'.ERel 0, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then - [(L'.EPrim (Prim.String ")"), loc)] + [str ")"] else [])))], {disc = (L'.TRecord [("1", s), ("2", s)], loc), @@ -2467,9 +2453,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) => - ((L'.EPrim (Prim.String ""), loc), fm) + (str "", fm) | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_random"), _), _), _), _) => - ((L'.EPrim (Prim.String (#randomFunction (Settings.currentDbms ()) ^ "()")), loc), fm) + (str (#randomFunction (Settings.currentDbms ()) ^ "()"), fm) | L.ECApp ( (L.ECApp ( (L.ECApp ( @@ -2481,81 +2467,80 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("d", s, (L'.TFun (s, s), loc), (L'.EAbs ("e2", s, s, (L'.ECase ((L'.ERel 0, loc), - [((L'.PPrim (Prim.String ""), loc), + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), strcat [(L'.ERel 2, loc), (L'.ERel 1, loc)]), ((L'.PWild, loc), strcat [(L'.ERel 2, loc), (L'.ERel 1, loc), - sc ", ", + str ", ", (L'.ERel 0, loc)])], {disc = s, result = s}), loc)), loc)), loc)), loc)), loc), fm) end | L.EFfi ("Basis", "sql_no_limit") => - ((L'.EPrim (Prim.String ""), loc), fm) + (str "", fm) | L.EFfiApp ("Basis", "sql_limit", [(e, t)]) => let val (e, fm) = monoExp (env, st, fm) e in (strcat [ - (L'.EPrim (Prim.String " LIMIT "), loc), + str " LIMIT ", (L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc) ], fm) end | L.EFfi ("Basis", "sql_no_offset") => - ((L'.EPrim (Prim.String ""), loc), fm) + (str "", fm) | L.EFfiApp ("Basis", "sql_offset", [(e, t)]) => let val (e, fm) = monoExp (env, st, fm) e in (strcat [ - (L'.EPrim (Prim.String " OFFSET "), loc), + str " OFFSET ", (L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc) ], fm) end | L.ECApp ((L.EFfi ("Basis", "sql_eq"), _), _) => - ((L'.EPrim (Prim.String "="), loc), fm) + (str "=", fm) | L.ECApp ((L.EFfi ("Basis", "sql_ne"), _), _) => - ((L'.EPrim (Prim.String "<>"), loc), fm) + (str "<>", fm) | L.ECApp ((L.EFfi ("Basis", "sql_lt"), _), _) => - ((L'.EPrim (Prim.String "<"), loc), fm) + (str "<", fm) | L.ECApp ((L.EFfi ("Basis", "sql_le"), _), _) => - ((L'.EPrim (Prim.String "<="), loc), fm) + (str "<=", fm) | L.ECApp ((L.EFfi ("Basis", "sql_gt"), _), _) => - ((L'.EPrim (Prim.String ">"), loc), fm) + (str ">", fm) | L.ECApp ((L.EFfi ("Basis", "sql_ge"), _), _) => - ((L'.EPrim (Prim.String ">="), loc), fm) + (str ">=", fm) | L.ECApp ((L.EFfi ("Basis", "sql_plus"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "+"), loc)), loc), fm) + str "+"), loc), fm) | L.ECApp ((L.EFfi ("Basis", "sql_minus"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "-"), loc)), loc), fm) + str "-"), loc), fm) | L.ECApp ((L.EFfi ("Basis", "sql_times"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "*"), loc)), loc), fm) + str "*"), loc), fm) | L.ECApp ((L.EFfi ("Basis", "sql_div"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "/"), loc)), loc), fm) + str "/"), loc), fm) | L.EFfi ("Basis", "sql_mod") => - ((L'.EPrim (Prim.String "%"), loc), fm) + (str "%", fm) | L.EFfi ("Basis", "sql_like") => - ((L'.EPrim (Prim.String "LIKE"), loc), fm) + (str "LIKE", fm) | L.ECApp ( (L.ECApp ( @@ -2570,21 +2555,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), - strcat [sc "(", + strcat [str "(", (L'.ERel 1, loc), - sc " ", + str " ", (L'.ERel 0, loc), - sc ")"]), loc)), loc), + str ")"]), loc)), loc), fm) end - | L.EFfi ("Basis", "sql_not") => ((L'.EPrim (Prim.String "NOT"), loc), fm) + | L.EFfi ("Basis", "sql_not") => (str "NOT", fm) | L.ECApp ((L.EFfi ("Basis", "sql_neg"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "-"), loc)), loc), fm) + str "-"), loc), fm) | L.ECApp ( (L.ECApp ( @@ -2601,22 +2585,21 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), (L'.EAbs ("e2", s, s, - strcat [sc "(", + strcat [str "(", (L'.ERel 1, loc), - sc " ", + str " ", (L'.ERel 2, loc), - sc " ", + str " ", (L'.ERel 0, loc), - sc ")"]), loc)), loc)), loc), + str ")"]), loc)), loc)), loc), fm) end - | L.EFfi ("Basis", "sql_and") => ((L'.EPrim (Prim.String "AND"), loc), fm) - | L.EFfi ("Basis", "sql_or") => ((L'.EPrim (Prim.String "OR"), loc), fm) + | L.EFfi ("Basis", "sql_and") => (str "AND", fm) + | L.EFfi ("Basis", "sql_or") => (str "OR", fm) | L.ECApp ( (L.ECApp ( @@ -2632,7 +2615,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _), _), _), _), (L.CName tab, _)), _), - (L.CName field, _)) => ((L'.EPrim (Prim.String ("T_" ^ tab ^ "." ^ Settings.mangleSql (lowercaseFirst field))), loc), fm) + (L.CName field, _)) => (str ("T_" ^ tab ^ "." ^ Settings.mangleSql (lowercaseFirst field)), fm) | L.ECApp ( (L.ECApp ( @@ -2644,7 +2627,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _), _), _), _), _), _), - (L.CName nm, _)) => ((L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm))), loc), fm) + (L.CName nm, _)) => (str (Settings.mangleSql (lowercaseFirst nm)), fm) | L.ECApp ( (L.ECApp ( @@ -2661,49 +2644,48 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in (if #nestedRelops (Settings.currentDbms ()) then (L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), (L'.EAbs ("all", (L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), (L'.EAbs ("e2", s, s, - strcat [sc "((", + strcat [str "((", (L'.ERel 1, loc), - sc ") ", + str ") ", (L'.ERel 3, loc), (L'.ECase ((L'.ERel 2, loc), [((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis", datatyp = "bool", con = "True", arg = NONE}, NONE), loc), - sc " ALL"), + str " ALL"), ((L'.PWild, loc), - sc "")], + str "")], {disc = (L'.TFfi ("Basis", "bool"), loc), result = s}), loc), - sc " (", + str " (", (L'.ERel 0, loc), - sc "))"]), loc)), loc)), loc)), loc) + str "))"]), loc)), loc)), loc)), loc) else (L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), (L'.EAbs ("all", (L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), (L'.EAbs ("e2", s, s, strcat [(L'.ERel 1, loc), - sc " ", + str " ", (L'.ERel 3, loc), (L'.ECase ((L'.ERel 2, loc), [((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis", datatyp = "bool", con = "True", arg = NONE}, NONE), loc), - sc " ALL"), + str " ALL"), ((L'.PWild, loc), - sc "")], + str "")], {disc = (L'.TFfi ("Basis", "bool"), loc), result = s}), loc), - sc " ", + str " ", (L'.ERel 0, loc)]), loc)), loc)), loc)), loc), fm) end @@ -2720,25 +2702,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("x", s, s, (L'.ERel 0, loc)), loc), fm) end - | L.EFfi ("Basis", "sql_union") => ((L'.EPrim (Prim.String "UNION"), loc), fm) + | L.EFfi ("Basis", "sql_union") => (str "UNION", fm) | L.EFfi ("Basis", "sql_intersect") => (if #onlyUnion (Settings.currentDbms ()) then ErrorMsg.errorAt loc "The DBMS you've selected doesn't support INTERSECT." else (); - ((L'.EPrim (Prim.String "INTERSECT"), loc), fm)) + (str "INTERSECT", fm)) | L.EFfi ("Basis", "sql_except") => (if #onlyUnion (Settings.currentDbms ()) then ErrorMsg.errorAt loc "The DBMS you've selected doesn't support EXCEPT." else (); - ((L'.EPrim (Prim.String "EXCEPT"), loc), fm)) + (str "EXCEPT", fm)) | L.ECApp ( (L.ECApp ( @@ -2746,8 +2727,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.EFfi ("Basis", "sql_count"), _), _), _), _), _), - _) => ((L'.EPrim (Prim.String "COUNT(*)"), loc), - fm) + _) => (str "COUNT(*)", fm) | L.ECApp ( (L.ECApp ( @@ -2762,12 +2742,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) = t) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) val main = strcat [(L'.ERel 1, loc), - sc "(", + str "(", (L'.ERel 0, loc), - sc ")"] + str ")"] in ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), main), loc)), loc), @@ -2775,8 +2754,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end | L.ECApp ((L.EFfi ("Basis", "sql_count_col"), _), _) => - ((L'.EPrim (Prim.String "COUNT"), loc), - fm) + (str "COUNT", fm) | L.EFfi ("Basis", "sql_summable_int") => ((L'.ERecord [], loc), fm) | L.EFfi ("Basis", "sql_summable_float") => ((L'.ERecord [], loc), fm) @@ -2786,12 +2764,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) | L.ECApp ((L.EFfi ("Basis", "sql_avg"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "AVG"), loc)), loc), + str "AVG"), loc), fm) | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_sum"), _), _), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "SUM"), loc)), loc)), loc), + str "SUM"), loc)), loc), fm) | L.EFfi ("Basis", "sql_arith_int") => ((L'.ERecord [], loc), fm) @@ -2811,16 +2789,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_max"), _), _), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "MAX"), loc)), loc)), loc), + str "MAX"), loc)), loc), fm) | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_min"), _), _), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "MIN"), loc)), loc)), loc), + str "MIN"), loc)), loc), fm) - | L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm) - | L.EFfi ("Basis", "sql_desc") => ((L'.EPrim (Prim.String " DESC"), loc), fm) + | L.EFfi ("Basis", "sql_asc") => (str "", fm) + | L.EFfi ("Basis", "sql_desc") => (str " DESC", fm) | L.ECApp ( (L.ECApp ( (L.ECApp ( @@ -2832,7 +2810,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm) @@ -2860,7 +2837,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end - | L.EFfi ("Basis", "sql_current_timestamp") => ((L'.EPrim (Prim.String "CURRENT_TIMESTAMP"), loc), fm) + | L.EFfi ("Basis", "sql_current_timestamp") => (str "CURRENT_TIMESTAMP", fm) | L.ECApp ( (L.ECApp ( @@ -2875,25 +2852,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("f", s, (L'.TFun (s, s), loc), (L'.EAbs ("x", s, s, strcat [(L'.ERel 1, loc), - sc "(", + str "(", (L'.ERel 0, loc), - sc ")"]), loc)), loc), + str ")"]), loc)), loc), fm) end | L.EFfi ("Basis", "sql_octet_length") => - ((L'.EPrim (Prim.String (if #supportsOctetLength (Settings.currentDbms ()) then - "octet_length" - else - "length")), loc), fm) + (str (if #supportsOctetLength (Settings.currentDbms ()) then + "octet_length" + else + "length"), fm) | L.EFfi ("Basis", "sql_lower") => - ((L'.EPrim (Prim.String "lower"), loc), fm) + (str "lower", fm) | L.EFfi ("Basis", "sql_upper") => - ((L'.EPrim (Prim.String "upper"), loc), fm) + (str "upper", fm) | L.ECApp ((L.EFfi ("Basis", "sql_known"), _), _) => ((L'.EFfi ("Basis", "sql_known"), loc), fm) @@ -2907,12 +2883,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _), _)) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("s", s, s, - strcat [sc "(", + strcat [str "(", (L'.ERel 0, loc), - sc " IS NULL)"]), loc), + str " IS NULL)"]), loc), fm) end @@ -2926,15 +2901,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _), _)) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("x1", s, (L'.TFun (s, s), loc), (L'.EAbs ("x1", s, s, - strcat [sc "COALESCE(", + strcat [str "COALESCE(", (L'.ERel 1, loc), - sc ",", + str ",", (L'.ERel 0, loc), - sc ")"]), loc)), loc), + str ")"]), loc)), loc), fm) end @@ -2948,18 +2922,17 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _), _)) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("if", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("then", s, (L'.TFun (s, s), loc), (L'.EAbs ("else", s, s, - strcat [sc "(CASE WHEN (", + strcat [str "(CASE WHEN (", (L'.ERel 2, loc), - sc ") THEN (", + str ") THEN (", (L'.ERel 1, loc), - sc ") ELSE (", + str ") ELSE (", (L'.ERel 0, loc), - sc ") END)"]), loc)), loc)), loc), + str ") END)"]), loc)), loc)), loc), fm) end @@ -2974,7 +2947,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("u", (L'.TRecord [], loc), (L'.TFun (s, s), loc), (L'.EAbs ("x", s, s, @@ -2997,13 +2969,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, s), loc), (L'.EAbs ("x", s, s, - strcat [sc "(", + strcat [str "(", (L'.ERel 0, loc), - sc ")"]), loc)), loc), + str ")"]), loc)), loc), fm) end @@ -3013,7 +2984,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.EFfi ("Basis", "sql_no_partition"), _), _), _), _), _), - _) => ((L'.EPrim (Prim.String ""), loc), fm) + _) => (str "", fm) | L.ECApp ( (L.ECApp ( (L.ECApp ( @@ -3026,7 +2997,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val s = (L'.TFfi ("Basis", "string"), loc) in - ((L'.EAbs ("e", s, s, strcat [(L'.EPrim (Prim.String "PARTITION BY "), loc), (L'.ERel 0, loc)]), loc), + ((L'.EAbs ("e", s, s, strcat [str "PARTITION BY ", (L'.ERel 0, loc)]), loc), fm) end @@ -3046,20 +3017,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ErrorMsg.errorAt loc "The DBMS you've selected doesn't support window functions." val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) val main = strcat [(L'.ERel 2, loc), - sc " OVER (", + str " OVER (", (L'.ERel 1, loc), (L'.ECase ((L'.ERel 0, loc), - [((L'.PPrim (Prim.String ""), loc), - sc ""), + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + str ""), ((L'.PWild, loc), - strcat [sc " ORDER BY ", + strcat [str " ORDER BY ", (L'.ERel 0, loc)])], {disc = s, result = s}), loc), - sc ")"] + str ")"] in ((L'.EAbs ("w", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("p", s, (L'.TFun (s, s), loc), @@ -3081,12 +3051,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) val main = strcat [(L'.ERel 1, loc), - sc "(", + str "(", (L'.ERel 0, loc), - sc ")"] + str ")"] in ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, s, main), loc)), loc), @@ -3094,9 +3063,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_window_count"), _), _), _), _), _), _) => - ((L'.EPrim (Prim.String "COUNT(*)"), loc), fm) + (str "COUNT(*)", fm) | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_rank"), _), _), _), _), _), _) => - ((L'.EPrim (Prim.String "RANK()"), loc), fm) + (str "RANK()", fm) | L.EFfiApp ("Basis", "nextval", [(e, _)]) => let @@ -3112,19 +3081,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.ESetval (e1, e2), loc), fm) end - | L.EFfi ("Basis", "null") => ((L'.EPrim (Prim.String ""), loc), fm) + | L.EFfi ("Basis", "null") => (str "", fm) | L.EFfiApp ("Basis", "classes", [(s1, _), (s2, _)]) => let val (s1, fm) = monoExp (env, st, fm) s1 val (s2, fm) = monoExp (env, st, fm) s2 in - ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc), + ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc), fm) end - | L.EFfi ("Basis", "data_kind") => ((L'.EPrim (Prim.String "data-"), loc), fm) - | L.EFfi ("Basis", "aria_kind") => ((L'.EPrim (Prim.String "aria-"), loc), fm) + | L.EFfi ("Basis", "data_kind") => (str "data-", fm) + | L.EFfi ("Basis", "aria_kind") => (str "aria-", fm) | L.EFfiApp ("Basis", "data_attr", [(sk, _), (s1, _), (s2, _)]) => let @@ -3134,9 +3103,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EStrcat (sk, (L'.EStrcat ((L'.EFfiApp ("Basis", "blessData", [(s1, (L'.TFfi ("Basis", "string"), loc))]), loc), - (L'.EStrcat ((L'.EPrim (Prim.String "=\""), loc), + (L'.EStrcat (str "=\"", (L'.EStrcat ((L'.EFfiApp ("Basis", "attrifyString", [(s2, (L'.TFfi ("Basis", "string"), loc))]), loc), - (L'.EPrim (Prim.String "\""), loc)), loc)), + str "\""), loc)), loc)), loc)), loc), fm) end @@ -3146,7 +3115,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (s1, fm) = monoExp (env, st, fm) s1 val (s2, fm) = monoExp (env, st, fm) s2 in - ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc), + ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc), fm) end @@ -3154,9 +3123,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val (s, fm) = monoExp (env, st, fm) s in - ((L'.EStrcat ((L'.EPrim (Prim.String "url("), loc), + ((L'.EStrcat (str "url(", (L'.EStrcat ((L'.EFfiApp ("Basis", "css_url", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc), - (L'.EPrim (Prim.String ")"), loc)), loc)), loc), + str ")"), loc)), loc), fm) end @@ -3165,7 +3134,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (s, fm) = monoExp (env, st, fm) s in ((L'.EStrcat ((L'.EFfiApp ("Basis", "property", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc), - (L'.EPrim (Prim.String ":"), loc)), loc), + str ":"), loc), fm) end | L.EFfiApp ("Basis", "value", [(s1, _), (s2, _)]) => @@ -3173,17 +3142,17 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (s1, fm) = monoExp (env, st, fm) s1 val (s2, fm) = monoExp (env, st, fm) s2 in - ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc), + ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc), fm) end - | L.EFfi ("Basis", "noStyle") => ((L'.EPrim (Prim.String ""), loc), fm) + | L.EFfi ("Basis", "noStyle") => (str "", fm) | L.EFfiApp ("Basis", "oneProperty", [(s1, _), (s2, _)]) => let val (s1, fm) = monoExp (env, st, fm) s1 val (s2, fm) = monoExp (env, st, fm) s2 in - ((L'.EStrcat (s1, (L'.EStrcat (s2, (L'.EPrim (Prim.String ";"), loc)), loc)), loc), + ((L'.EStrcat (s1, (L'.EStrcat (s2, str ";"), loc)), loc), fm) end @@ -3332,28 +3301,28 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fun tagStart tag' = let val t = (L'.TFfi ("Basis", "string"), loc) - val s = (L'.EPrim (Prim.String (String.concat ["<", tag'])), loc) + val s = strH (String.concat ["<", tag']) val s = (L'.EStrcat (s, (L'.ECase (class, - [((L'.PPrim (Prim.String ""), loc), - (L'.EPrim (Prim.String ""), loc)), + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + strH ""), ((L'.PVar ("x", t), loc), - (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc), + (L'.EStrcat (strH " class=\"", (L'.EStrcat ((L'.ERel 0, loc), - (L'.EPrim (Prim.String "\""), loc)), + strH "\""), loc)), loc))], {disc = t, result = t}), loc)), loc) val s = (L'.EStrcat (s, (L'.ECase (style, - [((L'.PPrim (Prim.String ""), loc), - (L'.EPrim (Prim.String ""), loc)), + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + strH ""), ((L'.PVar ("x", t), loc), - (L'.EStrcat ((L'.EPrim (Prim.String " style=\""), loc), + (L'.EStrcat (strH " style=\"", (L'.EStrcat ((L'.ERel 0, loc), - (L'.EPrim (Prim.String "\""), loc)), + strH "\""), loc)), loc))], {disc = t, result = t}), loc)), loc) @@ -3363,7 +3332,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | (("Data", e, _), (s, fm)) => ((L'.EStrcat (s, (L'.EStrcat ( - (L'.EPrim (Prim.String " "), loc), + strH " ", e), loc)), loc), fm) | ((x, e, t), (s, fm)) => @@ -3380,7 +3349,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = arg = NONE}, NONE), loc), (L'.EStrcat (s, - (L'.EPrim (Prim.String s'), loc)), loc)), + strH s'), loc)), ((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis", datatyp = "bool", @@ -3409,10 +3378,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EStrcat (s, (L'.EStrcat ( - (L'.EPrim (Prim.String s'), loc), + strH s', (L'.EStrcat ( (L'.EJavaScript (L'.Attribute, e), loc), - (L'.EPrim (Prim.String ");return false'"), loc)), loc)), + strH ");return false'"), loc)), loc)), loc), fm) end @@ -3438,14 +3407,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (e, fm) = fooify env fm (e, t) val e = case (tag, x) of - ("coption", "Value") => (L'.EStrcat ((L'.EPrim (Prim.String "x"), loc), e), loc) + ("coption", "Value") => (L'.EStrcat (strH "x", e), loc) | _ => e in ((L'.EStrcat (s, - (L'.EStrcat ((L'.EPrim (Prim.String xp), loc), + (L'.EStrcat (strH xp, (L'.EStrcat (e, - (L'.EPrim (Prim.String "\""), - loc)), + strH "\""), loc)), loc)), loc), fm) @@ -3454,7 +3422,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in (if tag = "coption" andalso List.all (fn ("Value", _, _) => false | _ => true) attrs then (L'.EStrcat (s, - (L'.EPrim (Prim.String " value=\"\""), loc)), loc) + strH " value=\"\""), loc) else s, fm) @@ -3467,8 +3435,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (ts, fm) = tagStart "input" in ((L'.EStrcat (ts, - (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\" />")), - loc)), loc), fm) + strH (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\" />")), loc), fm) end | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); raise Fail "No name passed to input tag") @@ -3488,10 +3455,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = NONE => xml | SOME extra => (L'.EStrcat (extra, xml), loc) in - ((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc), + ((L'.EStrcat ((L'.EStrcat (tagStart, strH ">"), loc), (L'.EStrcat (xml, - (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])), - loc)), loc)), + strH (String.concat ["</", tag, ">"])), loc)), loc), fm) end @@ -3511,9 +3477,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _), _), _), - (L.EPrim (Prim.String s), _)), _), NONE) => + (L.EPrim (Prim.String (_, s)), _)), _), NONE) => if CharVector.all Char.isSpace s andalso isSingleton () then - ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String " />"), loc)), loc), fm) + ((L'.EStrcat (tagStart, strH " />"), loc), fm) else normal () | _ => normal () @@ -3521,7 +3487,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fun setAttrs jexp = let - val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc) + val s = strH (String.concat ["<", tag]) val assgns = List.mapPartial (fn ("Source", _, _) => NONE @@ -3570,12 +3536,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val t = (L'.TFfi ("Basis", "string"), loc) val setClass = (L'.ECase (class, - [((L'.PPrim (Prim.String ""), loc), + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), str ""), ((L'.PVar ("x", t), loc), - (L'.EStrcat ((L'.EPrim (Prim.String "d.className=\""), loc), + (L'.EStrcat (strH "d.className=\"", (L'.EStrcat ((L'.ERel 0, loc), - (L'.EPrim (Prim.String "\";"), loc)), loc)), + strH "\";"), loc)), loc))], {disc = (L'.TOption t, loc), result = t}), loc) @@ -3594,14 +3560,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fun execify e = case e of - NONE => (L'.EPrim (Prim.String ""), loc) + NONE => strH "" | SOME e => let val e = (L'.EApp (e, (L'.ERecord [], loc)), loc) in - (L'.EStrcat ((L'.EPrim (Prim.String "exec("), loc), + (L'.EStrcat (strH "exec(", (L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc), - (L'.EPrim (Prim.String ")"), loc)), loc)), loc) + strH ")"), loc)), loc) end fun inTag tag' = case ctxOuter of @@ -3643,10 +3609,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = case attrs of [("Signal", e, _)] => ((L'.EStrcat - ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\"" - ^ pnode () ^ "\", execD(")), loc), + (strH ("<script type=\"text/javascript\">dyn(\"" + ^ pnode () ^ "\", execD("), (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), - (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc), + strH ("))</script>")), loc)), loc), fm) | _ => raise Fail "Monoize: Bad <dyn> attributes" end @@ -3655,9 +3621,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (case attrs of [("Code", e, _)] => ((L'.EStrcat - ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">active(execD(")), loc), + (strH "<script type=\"text/javascript\">active(execD(", (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), - (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc), + strH "))</script>"), loc)), loc), fm) | _ => raise Fail "Monoize: Bad <active> attributes") @@ -3665,9 +3631,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (case attrs of [("Code", e, _)] => ((L'.EStrcat - ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">execF(execD(")), loc), + (strH "<script type=\"text/javascript\">execF(execD(", (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), - (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc), + strH "))</script>"), loc)), loc), fm) | _ => raise Fail "Monoize: Bad <script> attributes") @@ -3684,8 +3650,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (ts, fm) = tagStart "input" in ((L'.EStrcat (ts, - (L'.EPrim (Prim.String (" type=\"text\" name=\"" ^ name ^ "\" />")), - loc)), loc), fm) + strH (" type=\"text\" name=\"" ^ name ^ "\" />")), + loc), fm) end | SOME (_, src, _) => (strcat [str "<script type=\"text/javascript\">inp(exec(", @@ -3705,10 +3671,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (xml, fm) = monoExp (env, st, fm) xml in ((L'.EStrcat ((L'.EStrcat (ts, - (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc), + strH (" name=\"" ^ name ^ "\">")), loc), (L'.EStrcat (xml, - (L'.EPrim (Prim.String "</textarea>"), - loc)), loc)), + strH "</textarea>"), loc)), loc), fm) end | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); @@ -3728,7 +3693,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = NONE => raise Fail "No name for radioGroup" | SOME name => normal ("input", - SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc))) + SOME (strH (" type=\"radio\" name=\"" ^ name ^ "\"")))) | "select" => (case targs of @@ -3738,11 +3703,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (xml, fm) = monoExp (env, st, fm) xml in ((L'.EStrcat ((L'.EStrcat (ts, - (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), - loc)), loc), + strH (" name=\"" ^ name ^ "\">")), loc), (L'.EStrcat (xml, - (L'.EPrim (Prim.String "</select>"), - loc)), loc)), + strH "</select>"), + loc)), loc), fm) end @@ -3756,7 +3720,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (ts, fm) = tagStart "input" in ((L'.EStrcat (ts, - (L'.EPrim (Prim.String " type=\"text\" />"), loc)), + strH " type=\"text\" />"), loc), fm) end | SOME (_, src, _) => @@ -3779,7 +3743,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (ts, fm) = tagStart "input type=\"checkbox\"" in ((L'.EStrcat (ts, - (L'.EPrim (Prim.String " />"), loc)), + strH " />"), loc), fm) end | SOME (_, src, _) => @@ -3834,7 +3798,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (ts, fm) = tagStart "textarea" in ((L'.EStrcat (ts, - (L'.EPrim (Prim.String " />"), loc)), + strH " />"), loc), fm) end | SOME (_, src, _) => @@ -3957,7 +3921,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | _ => NotFound val (func, action, fm) = case findSubmit xml of - NotFound => (0, (L'.EPrim (Prim.String ""), loc), fm) + NotFound => (0, strH "", fm) | Error => raise Fail "Not ready for multi-submit lforms yet" | Found (action, actionT) => let @@ -3969,9 +3933,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (action, fm) = urlifyExp env fm (action, actionT) in (func, - (L'.EStrcat ((L'.EPrim (Prim.String " action=\""), loc), + (L'.EStrcat (strH " action=\"", (L'.EStrcat (action, - (L'.EPrim (Prim.String "\""), loc)), loc)), loc), + strH "\""), loc)), loc), fm) end @@ -4010,12 +3974,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val sigName = getSigName () val sigSet = (L'.EFfiApp ("Basis", "sigString", [((L'.ERecord [], loc), (L'.TRecord [], loc))]), loc) - val sigSet = (L'.EStrcat ((L'.EPrim (Prim.String ("<input type=\"hidden\" name=\"" - ^ sigName - ^ "\" value=\"")), loc), + val sigSet = (L'.EStrcat (strH ("<input type=\"hidden\" name=\"" + ^ sigName + ^ "\" value=\""), sigSet), loc) val sigSet = (L'.EStrcat (sigSet, - (L'.EPrim (Prim.String "\" />"), loc)), loc) + strH "\" />"), loc) in (L'.EStrcat (sigSet, xml), loc) end @@ -4024,7 +3988,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val action = if hasUpload then (L'.EStrcat (action, - (L'.EPrim (Prim.String " enctype=\"multipart/form-data\""), loc)), loc) + strH " enctype=\"multipart/form-data\""), loc) else action @@ -4033,19 +3997,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val action = (L'.EStrcat (action, (L'.ECase (class, [((L'.PNone stt, loc), - (L'.EPrim (Prim.String ""), loc)), + strH ""), ((L'.PSome (stt, (L'.PVar ("x", stt), loc)), loc), - (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc), + (L'.EStrcat (strH " class=\"", (L'.EStrcat ((L'.ERel 0, loc), - (L'.EPrim (Prim.String "\""), loc)), loc)), loc))], + strH "\""), loc)), loc))], {disc = (L'.TOption stt, loc), result = stt}), loc)), loc) in - ((L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form method=\"post\""), loc), + ((L'.EStrcat ((L'.EStrcat (strH "<form method=\"post\"", (L'.EStrcat (action, - (L'.EPrim (Prim.String ">"), loc)), loc)), loc), + strH ">"), loc)), loc), (L'.EStrcat (xml, - (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc), + strH "</form>"), loc)), loc), fm) end @@ -4056,10 +4020,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val s = (L'.TFfi ("Basis", "string"), loc) in ((L'.EAbs ("xml", s, s, - strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".b\" value=\"" - ^ nm ^ "\" />")), loc), + strcat [strH ("<input type=\"hidden\" name=\".b\" value=\"" + ^ nm ^ "\" />"), (L'.ERel 0, loc), - (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\" />")), loc)]), + strH ("<input type=\"hidden\" name=\".e\" value=\"1\" />")]), loc), fm) end @@ -4071,10 +4035,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val s = (L'.TFfi ("Basis", "string"), loc) in ((L'.EAbs ("xml", s, s, - strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".s\" value=\"" - ^ nm ^ "\" />")), loc), + strcat [strH ("<input type=\"hidden\" name=\".s\" value=\"" + ^ nm ^ "\" />"), (L'.ERel 0, loc), - (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\" />")), loc)]), + strH ("<input type=\"hidden\" name=\".e\" value=\"1\" />")]), loc), fm) end @@ -4085,9 +4049,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val s = (L'.TFfi ("Basis", "string"), loc) in ((L'.EAbs ("xml", s, s, - strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".i\" value=\"1\" />")), loc), + strcat [strH ("<input type=\"hidden\" name=\".i\" value=\"1\" />"), (L'.ERel 0, loc), - (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\" />")), loc)]), + strH ("<input type=\"hidden\" name=\".e\" value=\"1\" />")]), loc), fm) end @@ -4175,7 +4139,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (e, fm) = monoExp (env, st, fm) e val (e, fm) = urlifyExp env fm (e, dummyTyp) in - ((L'.EStrcat ((L'.EPrim (Prim.String (Settings.getUrlPrePrefix ())), loc), e), loc), fm) + ((L'.EStrcat (str (Settings.getUrlPrePrefix ()), e), loc), fm) end | L.EApp (e1, e2) => @@ -4296,14 +4260,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (e, fm) = urlifyExp env fm (e, monoType env dom) in encodeArgs (es, ran, e - :: (L'.EPrim (Prim.String "/"), loc) + :: str "/" :: acc, fm) end | _ => raise Fail "Monoize: Not enough arguments visible in RPC function type" val (call, fm) = encodeArgs (es, ft, [], fm) val call = foldl (fn (e, call) => (L'.EStrcat (call, e), loc)) - (L'.EPrim (Prim.String name), loc) call + (str name) call val unit = (L'.TRecord [], loc) @@ -4329,6 +4293,9 @@ fun monoDecl (env, fm) (all as (d, loc)) = (E.errorAt loc "Unsupported declaration"; Print.eprefaces' [("Declaration", CorePrint.p_decl env all)]; NONE) + + fun str s = (L'.EPrim (Prim.String (Prim.Normal, s)), loc) + fun strH s = (L'.EPrim (Prim.String (Prim.Html, s)), loc) in case d of L.DCon _ => NONE @@ -4426,7 +4393,7 @@ fun monoDecl (env, fm) (all as (d, loc)) = val t = (L.CFfi ("Basis", "string"), loc) val t' = (L'.TFfi ("Basis", "string"), loc) val s = Settings.mangleSqlTable s - val e_name = (L'.EPrim (Prim.String s), loc) + val e_name = str s val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts @@ -4444,7 +4411,7 @@ fun monoDecl (env, fm) (all as (d, loc)) = val t = (L.CFfi ("Basis", "string"), loc) val t' = (L'.TFfi ("Basis", "string"), loc) val s = Settings.mangleSqlTable s - val e_name = (L'.EPrim (Prim.String s), loc) + val e_name = str s val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts @@ -4462,7 +4429,7 @@ fun monoDecl (env, fm) (all as (d, loc)) = val t = (L.CFfi ("Basis", "string"), loc) val t' = (L'.TFfi ("Basis", "string"), loc) val s = Settings.mangleSql s - val e = (L'.EPrim (Prim.String s), loc) + val e = str s in SOME (Env.pushENamed env x n t NONE s, fm, @@ -4474,7 +4441,7 @@ fun monoDecl (env, fm) (all as (d, loc)) = let val t = (L.CFfi ("Basis", "string"), loc) val t' = (L'.TFfi ("Basis", "string"), loc) - val e = (L'.EPrim (Prim.String s), loc) + val e = str s in SOME (Env.pushENamed env x n t NONE s, fm, @@ -4485,7 +4452,7 @@ fun monoDecl (env, fm) (all as (d, loc)) = let val t = (L.CFfi ("Basis", "string"), loc) val t' = (L'.TFfi ("Basis", "string"), loc) - val e = (L'.EPrim (Prim.String s), loc) + val e = strH s in SOME (Env.pushENamed env x n t NONE s, fm, @@ -4581,6 +4548,9 @@ fun monoize env file = val client = (L'.TFfi ("Basis", "client"), loc) val unit = (L'.TRecord [], loc) + fun str s = (L'.EPrim (Prim.String (Prim.Normal, s)), loc) + fun strH s = (L'.EPrim (Prim.String (Prim.Html, s)), loc) + fun calcClientish xts = foldl (fn ((x : L.con, t : L.con), st as (nullable, notNullable)) => case #1 x of @@ -4610,22 +4580,22 @@ fun monoize env file = val (nullable, notNullable) = calcClientish xts fun cond (x, v) = - (L'.EStrcat ((L'.EPrim (Prim.String (Settings.mangleSql x - ^ (case v of - Client => "" - | Channel => " >> 32") - ^ " = ")), loc), + (L'.EStrcat (str (Settings.mangleSql x + ^ (case v of + Client => "" + | Channel => " >> 32") + ^ " = "), target), loc) val e = foldl (fn ((x, v), e) => (L'.ESeq ( (L'.EDml ((L'.EStrcat ( - (L'.EPrim (Prim.String ("UPDATE " - ^ Settings.mangleSql tab - ^ " SET " - ^ Settings.mangleSql x - ^ " = NULL WHERE ")), loc), + str ("UPDATE " + ^ Settings.mangleSql tab + ^ " SET " + ^ Settings.mangleSql x + ^ " = NULL WHERE "), cond (x, v)), loc), L'.Error), loc), e), loc)) e nullable @@ -4638,12 +4608,11 @@ fun monoize env file = (L'.EDml (foldl (fn (eb, s) => (L'.EStrcat (s, - (L'.EStrcat ((L'.EPrim (Prim.String " OR "), - loc), + (L'.EStrcat (str " OR ", cond eb), loc)), loc)) - (L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM " - ^ Settings.mangleSql tab - ^ " WHERE ")), loc), + (L'.EStrcat (str ("DELETE FROM " + ^ Settings.mangleSql tab + ^ " WHERE "), cond eb), loc) ebs, L'.Error), loc), e), loc) @@ -4673,15 +4642,15 @@ fun monoize env file = [] => e | (x, _) :: ebs => (L'.ESeq ( - (L'.EDml ((L'.EPrim (Prim.String - (foldl (fn ((x, _), s) => - s ^ ", " ^ Settings.mangleSql x ^ " = NULL") - ("UPDATE uw_" - ^ tab - ^ " SET " - ^ Settings.mangleSql x + (L'.EDml (str + (foldl (fn ((x, _), s) => + s ^ ", " ^ Settings.mangleSql x ^ " = NULL") + ("UPDATE uw_" + ^ tab + ^ " SET " + ^ Settings.mangleSql x ^ " = NULL") - ebs)), loc), L'.Error), loc), + ebs), L'.Error), loc), e), loc) val e = @@ -4689,8 +4658,8 @@ fun monoize env file = [] => e | eb :: ebs => (L'.ESeq ( - (L'.EDml ((L'.EPrim (Prim.String ("DELETE FROM " - ^ Settings.mangleSql tab)), loc), L'.Error), loc), + (L'.EDml (str ("DELETE FROM " + ^ Settings.mangleSql tab), L'.Error), loc), e), loc) in e diff --git a/src/pathcheck.sml b/src/pathcheck.sml index c1bb667b..3533032e 100644 --- a/src/pathcheck.sml +++ b/src/pathcheck.sml @@ -88,7 +88,7 @@ fun checkDecl ((d, loc), (funcs, rels, cookies, styles)) = val rels = #2 (doRel s) val rels = case #1 pe of - EPrim (Prim.String "") => rels + EPrim (Prim.String (_, "")) => rels | _ => let val s' = s ^ "_Pkey" diff --git a/src/prepare.sml b/src/prepare.sml index 89cd1b43..660173f0 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -65,7 +65,7 @@ fun prepString (e, st) = SOME (#p_blank (Settings.currentDbms ()) (n + 1, t) :: ss, n + 1) in case #1 e of - EPrim (Prim.String s) => + EPrim (Prim.String (_, s)) => SOME (s :: ss, n) | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => (case prepString' (e1, ss, n) of @@ -82,16 +82,16 @@ fun prepString (e, st) = | ECase (e, [((PNone _, _), - (EPrim (Prim.String "NULL"), _)), + (EPrim (Prim.String (_, "NULL")), _)), ((PSome (_, (PVar _, _)), _), (EFfiApp (m, x, [((ERel 0, _), _)]), _))], {disc = t, ...}) => prepString' ((EFfiApp (m, x, [(e, t)]), #2 e), ss, n) | ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), - (EPrim (Prim.String "TRUE"), _)), + (EPrim (Prim.String (_, "TRUE")), _)), ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _), - (EPrim (Prim.String "FALSE"), _))], + (EPrim (Prim.String (_, "FALSE")), _))], _) => doOne Bool | _ => NONE @@ -268,14 +268,14 @@ fun prepExp (e as (_, loc), st) = if #supportsNextval (Settings.currentDbms ()) then let val s = case seq of - (EPrim (Prim.String s), loc) => - (EPrim (Prim.String ("SELECT NEXTVAL('" ^ s ^ "')")), loc) + (EPrim (Prim.String (_, s)), loc) => + (EPrim (Prim.String (Prim.Normal, "SELECT NEXTVAL('" ^ s ^ "')")), loc) | _ => let val t = (TFfi ("Basis", "string"), loc) - val s' = (EFfiApp ("Basis", "strcat", [(seq, t), ((EPrim (Prim.String "')"), loc), t)]), loc) + val s' = (EFfiApp ("Basis", "strcat", [(seq, t), ((EPrim (Prim.String (Prim.Normal, "')")), loc), t)]), loc) in - (EFfiApp ("Basis", "strcat", [((EPrim (Prim.String "SELECT NEXTVAL('"), loc), t), (s', t)]), loc) + (EFfiApp ("Basis", "strcat", [((EPrim (Prim.String (Prim.Normal, "SELECT NEXTVAL('")), loc), t), (s', t)]), loc) end in case prepString (s, st) of diff --git a/src/prim.sig b/src/prim.sig index 74147471..1da53d33 100644 --- a/src/prim.sig +++ b/src/prim.sig @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008, 2014, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -27,10 +27,12 @@ signature PRIM = sig + datatype string_mode = Normal | Html + datatype t = Int of Int64.int | Float of Real64.real - | String of string + | String of string_mode * string | Char of char val p_t : t Print.printer diff --git a/src/prim.sml b/src/prim.sml index 94801e7f..1de4fc7b 100644 --- a/src/prim.sml +++ b/src/prim.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008, 2014, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -27,10 +27,12 @@ structure Prim :> PRIM = struct +datatype string_mode = Normal | Html + datatype t = Int of Int64.int | Float of Real64.real - | String of string + | String of string_mode * string | Char of char open Print.PD @@ -40,7 +42,7 @@ fun p_t t = case t of Int n => string (Int64.toString n) | Float n => string (Real64.toString n) - | String s => box [string "\"", string (String.toString s), string "\""] + | String (_, s) => box [string "\"", string (String.toString s), string "\""] | Char ch => box [string "#\"", string (String.toString (String.str ch)), string "\""] fun int2s n = @@ -61,7 +63,7 @@ fun toString t = case t of Int n => int2s' n | Float n => float2s n - | String s => s + | String (_, s) => s | Char ch => str ch fun pad (n, ch, s) = @@ -86,14 +88,14 @@ fun p_t_GCC t = case t of Int n => string (int2s n) | Float n => string (float2s n) - | String s => box [string "\"", string (toCString s), string "\""] + | String (_, s) => box [string "\"", string (toCString s), string "\""] | Char ch => box [string "'", string (toCChar ch), string "'"] fun equal x = case x of (Int n1, Int n2) => n1 = n2 | (Float n1, Float n2) => Real64.== (n1, n2) - | (String s1, String s2) => s1 = s2 + | (String (_, s1), String (_, s2)) => s1 = s2 | (Char ch1, Char ch2) => ch1 = ch2 | _ => false @@ -108,7 +110,7 @@ fun compare (p1, p2) = | (Float _, _) => LESS | (_, Float _) => GREATER - | (String n1, String n2) => String.compare (n1, n2) + | (String (_, n1), String (_, n2)) => String.compare (n1, n2) | (String _, _) => LESS | (_, String _) => GREATER diff --git a/src/shake.sml b/src/shake.sml index 57ebec8e..051507d8 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -44,7 +44,7 @@ type free = { } val dummyt = (TRecord (CRecord ((KType, ErrorMsg.dummySpan), []), ErrorMsg.dummySpan), ErrorMsg.dummySpan) -val dummye = (EPrim (Prim.String ""), ErrorMsg.dummySpan) +val dummye = (EPrim (Prim.String (Prim.Normal, "")), ErrorMsg.dummySpan) fun tupleC cs = (CTuple cs, ErrorMsg.dummySpan) fun tupleE es = (ERecord (map (fn e => (dummyt, e, dummyt)) es), ErrorMsg.dummySpan) diff --git a/src/sql.sml b/src/sql.sml index c314eb3d..91e303c3 100644 --- a/src/sql.sml +++ b/src/sql.sml @@ -47,7 +47,7 @@ datatype chunk = fun chunkify e = case #1 e of - EPrim (Prim.String s) => [String s] + EPrim (Prim.String (_, s)) => [String s] | EStrcat (e1, e2) => let val chs1 = chunkify e1 @@ -248,7 +248,7 @@ val prim = (Option.map Prim.Int o Int64.fromString)) (opt (const "::int8"))) #1, wrap (follow (opt (const "E")) (follow string (opt (const "::text")))) - (Prim.String o #1 o #2)] + ((fn s => Prim.String (Prim.Normal, s)) o #1 o #2)] fun known' chs = case chs of @@ -263,9 +263,9 @@ fun sqlify chs = else NONE | Exp (ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _), - (EPrim (Prim.String "TRUE"), _)), + (EPrim (Prim.String (Prim.Normal, "TRUE")), _)), ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _), - (EPrim (Prim.String "FALSE"), _))], _), _) :: chs => + (EPrim (Prim.String (Prim.Normal, "FALSE")), _))], _), _) :: chs => SOME (e, chs) | _ => NONE diff --git a/src/urweb.grm b/src/urweb.grm index 862debc5..edac345f 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -282,11 +282,11 @@ fun parseValue s pos = in (EApp ((EVar (["Basis"], "css_url", Infer), pos), (EApp ((EVar (["Basis"], "bless", Infer), pos), - (EPrim (Prim.String s), pos)), pos)), pos) + (EPrim (Prim.String (Prim.Normal, s)), pos)), pos)), pos) end else (EApp ((EVar (["Basis"], "atom", Infer), pos), - (EPrim (Prim.String s), pos)), pos) + (EPrim (Prim.String (Prim.Normal, s)), pos)), pos) fun parseProperty s pos = let @@ -294,11 +294,11 @@ fun parseProperty s pos = in if Substring.isEmpty after then (ErrorMsg.errorAt pos ("Invalid CSS property syntax: " ^ s); - (EPrim (Prim.String ""), pos)) + (EPrim (Prim.String (Prim.Normal, "")), pos)) else foldl (fn (value, e) => (EApp ((EApp ((EVar (["Basis"], "value", Infer), pos), e), pos), parseValue value pos), pos)) (EApp ((EVar (["Basis"], "property", Infer), pos), - (EPrim (Prim.String (Substring.string (#2 (Substring.splitl Char.isSpace befor)))), pos)), pos) + (EPrim (Prim.String (Prim.Normal, Substring.string (#2 (Substring.splitl Char.isSpace befor)))), pos)), pos) (String.tokens Char.isSpace (Substring.string (Substring.slice (after, 1, NONE)))) end @@ -1152,8 +1152,8 @@ eapps : eterm (eterm) | eapps BANG (EDisjointApp eapps, s (eappsleft, BANGright)) eexp : eapps (case #1 eapps of - EApp ((EVar ([], "CLASS", _), _), (EPrim (Prim.String s), loc)) => parseClass s loc - | EApp ((EVar ([], "STYLE", _), _), (EPrim (Prim.String s), loc)) => parseStyle s loc + EApp ((EVar ([], "CLASS", _), _), (EPrim (Prim.String (_, s)), loc)) => parseClass s loc + | EApp ((EVar ([], "STYLE", _), _), (EPrim (Prim.String (_, s)), loc)) => parseStyle s loc | _ => eapps) | FN eargs DARROW eexp (let val loc = s (FNleft, eexpright) @@ -1347,7 +1347,7 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright)) | INT (EPrim (Prim.Int INT), s (INTleft, INTright)) | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) - | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright)) + | STRING (EPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright)) | CHAR (EPrim (Prim.Char CHAR), s (CHARleft, CHARright)) | path DOT idents (let @@ -1396,7 +1396,7 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright)) else ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\"."; (EApp ((EVar (["Basis"], "cdata", Infer), loc), - (EPrim (Prim.String ""), loc)), + (EPrim (Prim.String (Prim.Html, "")), loc)), loc) end) | XML_BEGIN_END (let @@ -1407,7 +1407,7 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright)) else ErrorMsg.errorAt loc "Initial XML tag pair aren't both tagged \"xml\"."; (EApp ((EVar (["Basis"], "cdata", Infer), loc), - (EPrim (Prim.String ""), loc)), + (EPrim (Prim.String (Prim.Html, "")), loc)), loc) end) @@ -1511,7 +1511,7 @@ pterm : SYMBOL (PVar SYMBOL, s (SYMBOLleft, SYMBOLright | UNDER (PWild, s (UNDERleft, UNDERright)) | INT (PPrim (Prim.Int INT), s (INTleft, INTright)) | MINUS INT (PPrim (Prim.Int (~INT)), s (MINUSleft, INTright)) - | STRING (PPrim (Prim.String STRING), s (STRINGleft, STRINGright)) + | STRING (PPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright)) | CHAR (PPrim (Prim.Char CHAR), s (CHARleft, CHARright)) | LPAREN pat RPAREN (pat) | LBRACE RBRACE (PRecord ([], false), s (LBRACEleft, RBRACEright)) @@ -1547,11 +1547,11 @@ xml : xmlOne xml (let xmlOpt : xml (xml) | (EApp ((EVar (["Basis"], "cdata", Infer), dummy), - (EPrim (Prim.String ""), dummy)), + (EPrim (Prim.String (Prim.Html, "")), dummy)), dummy) xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer), s (NOTAGSleft, NOTAGSright)), - (EPrim (Prim.String NOTAGS), s (NOTAGSleft, NOTAGSright))), + (EPrim (Prim.String (Prim.Html, NOTAGS)), s (NOTAGSleft, NOTAGSright))), s (NOTAGSleft, NOTAGSright)) | tag DIVIDE GT (let val pos = s (tagleft, GTright) @@ -1568,7 +1568,7 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer) (EVar (["Basis"], "cdata", Infer), pos) val cdata = (EApp (cdata, - (EPrim (Prim.String ""), pos)), + (EPrim (Prim.String (Prim.Html, "")), pos)), pos) in (EApp (#4 tag, cdata), pos) @@ -1629,7 +1629,7 @@ tag : tagHead attrs (let val e = (EVar (["Basis"], "tag", Infer), pos) val eo = case #1 attrs of NONE => (EVar (["Basis"], "null", Infer), pos) - | SOME (EPrim (Prim.String s), pos) => parseClass s pos + | SOME (EPrim (Prim.String (_, s)), pos) => parseClass s pos | SOME e => e val e = (EApp (e, eo), pos) val eo = case #2 attrs of @@ -1639,7 +1639,7 @@ tag : tagHead attrs (let val e = (EApp (e, eo), pos) val eo = case #3 attrs of NONE => (EVar (["Basis"], "noStyle", Infer), pos) - | SOME (EPrim (Prim.String s), pos) => parseStyle s pos + | SOME (EPrim (Prim.String (_, s)), pos) => parseStyle s pos | SOME e => e val e = (EApp (e, eo), pos) val eo = case #4 attrs of @@ -1656,7 +1656,7 @@ tag : tagHead attrs (let let val e = (EVar (["Basis"], "data_attr", Infer), pos) val e = (EApp (e, (EVar (["Basis"], kind ^ "_kind", Infer), pos)), pos) - val e = (EApp (e, (EPrim (Prim.String name), pos)), pos) + val e = (EApp (e, (EPrim (Prim.String (Prim.Normal, name)), pos)), pos) in (EApp (e, value), pos) end @@ -1750,7 +1750,7 @@ attr : SYMBOL EQ attrv (case SYMBOL of attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright)) | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright)) - | STRING (EPrim (Prim.String STRING), s (STRINGleft, STRINGright)) + | STRING (EPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright)) | LBRACE eexp RBRACE (eexp) query : query1 obopt lopt ofopt (let @@ -2038,7 +2038,7 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In s (INTleft, INTright))) | FLOAT (sql_inject (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))) - | STRING (sql_inject (EPrim (Prim.String STRING), + | STRING (sql_inject (EPrim (Prim.String (Prim.Normal, STRING)), s (STRINGleft, STRINGright))) | CURRENT_TIMESTAMP (sql_nfunc ("current_timestamp", s (CURRENT_TIMESTAMPleft, CURRENT_TIMESTAMPright))) |