Mercurial > urweb
changeset 838:5154a047c6bc
Lexing some more string escape sequences; JS versions of number read; fix problem with signature unification; escape < more often in Jscomp
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 02 Jun 2009 19:28:25 -0400 |
| parents | ccf22c2c77b2 |
| children | b2413e4dd109 |
| files | lib/js/urweb.js src/elaborate.sml src/jscomp.sml src/settings.sml src/urweb.grm src/urweb.lex |
| diffstat | 6 files changed, 76 insertions(+), 34 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/js/urweb.js Tue Jun 02 15:43:18 2009 -0400 +++ b/lib/js/urweb.js Tue Jun 02 19:28:25 2009 -0400 @@ -397,6 +397,22 @@ er("Can't parse float: " + s); } +function pio(s) { + var r = parseInt(s); + if (r.toString() == s) + return r; + else + return null; +} + +function pflo(s) { + var r = parseFloat(s); + if (r.toString() == s) + return r; + else + return null; +} + function uf(s) { return escape(s).replace(new RegExp ("/", "g"), "%2F"); }
--- a/src/elaborate.sml Tue Jun 02 15:43:18 2009 -0400 +++ b/src/elaborate.sml Tue Jun 02 19:28:25 2009 -0400 @@ -158,7 +158,7 @@ "U" ^ Int.toString (n - 26) in count := n + 1; - (L'.KUnif (loc, s, ref NONE), dummy) + (L'.KUnif (loc, s, ref NONE), loc) end end @@ -178,7 +178,7 @@ "U" ^ Int.toString (n - 26) in count := n + 1; - (L'.CUnif (loc, k, s, ref NONE), dummy) + (L'.CUnif (loc, k, s, ref NONE), loc) end end @@ -776,7 +776,7 @@ | orig as ([(_, r1 as ref NONE)], _, [], [(_, r2 as ref NONE)], _, []) => if List.all (fn (x1, _) => List.all (fn (x2, _) => consNeq env (x1, x2)) fs2) fs1 then let - val kr = (L'.KRecord k, dummy) + val kr = (L'.KRecord k, loc) val u = cunif (loc, kr) in r1 := SOME (L'.CConcat ((L'.CRecord (k, fs2), loc), u), loc); @@ -817,7 +817,7 @@ (*val () = eprefaces "Summaries5" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}), ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*) - val empty = (L'.CRecord (k, []), dummy) + val empty = (L'.CRecord (k, []), loc) fun failure () = raise CUnify' (CRecordFailure (unsummarize s1, unsummarize s2)) in (case (unifs1, fs1, others1, unifs2, fs2, others2) of @@ -1652,7 +1652,7 @@ val dom = cunif (loc, ktype) val ran = cunif (loc, ktype) - val t = (L'.TFun (dom, ran), dummy) + val t = (L'.TFun (dom, ran), loc) in checkCon env e1' t1 t; checkCon env e2' t2 dom; @@ -2507,7 +2507,7 @@ | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)] -and subSgn env sgn1 (sgn2 as (_, loc2)) = +and subSgn' counterparts env sgn1 (sgn2 as (_, loc2)) = ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), ("sgn2", p_sgn env sgn2)];*) case (#1 (hnormSgn env sgn1), #1 (hnormSgn env sgn2)) of @@ -2521,6 +2521,18 @@ ("sgis1", p_sgn env (L'.SgnConst sgis1, loc2)), ("sgis2", p_sgn env (L'.SgnConst sgis2, loc2))]*) + fun cpart n = IM.find (!counterparts, n) + fun cparts (n2, n1) = counterparts := IM.insert (!counterparts, n2, n1) + + val sub2 = U.Con.map {kind = fn k => k, + con = fn c => + case c of + L'.CNamed n2 => + (case cpart n2 of + NONE => c + | SOME n1 => L'.CNamed n1) + | _ => c} + fun folder (sgi2All as (sgi, loc), env) = let (*val () = prefaces "folder" [("sgis1", p_sgn env (L'.SgnConst sgis1, loc2))]*) @@ -2572,7 +2584,8 @@ SOME (if n1 = n2 then env else - E.pushCNamedAs env x n2 k2 (SOME (L'.CNamed n1, loc2))) + (cparts (n2, n1); + E.pushCNamedAs env x n2 k2 (SOME (L'.CNamed n1, loc2)))) end else NONE @@ -2616,6 +2629,8 @@ fun found (x', n1, k1, c1) = if x = x' then let + val c2 = sub2 c2 + fun good () = let val env = E.pushCNamedAs env x n2 k2 (SOME c2) @@ -2662,8 +2677,9 @@ val env = if n1 = n2 then env else - E.pushCNamedAs env x1 n2 k' - (SOME (L'.CNamed n1, loc)) + (cparts (n2, n1); + E.pushCNamedAs env x1 n2 k' + (SOME (L'.CNamed n1, loc))) in SOME env end @@ -2672,14 +2688,15 @@ val env = if n1 = n2 then env else - E.pushCNamedAs env x1 n2 k' (SOME (L'.CNamed n1, loc)) + (cparts (n2, n1); + E.pushCNamedAs env x1 n2 k' (SOME (L'.CNamed n1, loc))) val env = foldl (fn (x, env) => E.pushCRel env x k) env xs1 fun xncBad ((x1, _, t1), (x2, _, t2)) = String.compare (x1, x2) <> EQUAL orelse case (t1, t2) of (NONE, NONE) => false | (SOME t1, SOME t2) => - (unifyCons env t1 t2; false) + (unifyCons env t1 (sub2 t2); false) | _ => true in (if xs1 <> xs2 @@ -2746,6 +2763,7 @@ val env = E.pushCNamedAs env x n1 k' (SOME t1) val env = E.pushCNamedAs env x n2 k' (SOME t2) in + cparts (n2, n1); SOME env end in @@ -2765,7 +2783,12 @@ case sgi1 of L'.SgiVal (x', n1, c1) => if x = x' then - (unifyCons env c1 c2; + ((*prefaces "val" [("x", PD.string x), + ("n1", PD.string (Int.toString n1)), + ("c1", p_con env c1), + ("c2", p_con env c2), + ("c2'", p_con env (sub2 c2))];*) + unifyCons env c1 (sub2 c2); SOME env) handle CUnify (c1, c2, err) => (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); @@ -2780,7 +2803,7 @@ L'.SgiStr (x', n1, sgn1) => if x = x' then let - val () = subSgn env sgn1 sgn2 + val () = subSgn' counterparts env sgn1 sgn2 val env = E.pushStrNamedAs env x n1 sgn1 val env = if n1 = n2 then env @@ -2801,14 +2824,15 @@ L'.SgiSgn (x', n1, sgn1) => if x = x' then let - val () = subSgn env sgn1 sgn2 - val () = subSgn env sgn2 sgn1 + val () = subSgn' counterparts env sgn1 sgn2 + val () = subSgn' counterparts env sgn2 sgn1 val env = E.pushSgnNamedAs env x n2 sgn2 val env = if n1 = n2 then env else - E.pushSgnNamedAs env x n1 sgn2 + (cparts (n2, n1); + E.pushSgnNamedAs env x n1 sgn2) in SOME env end @@ -2841,7 +2865,8 @@ SOME (if n1 = n2 then env else - E.pushCNamedAs env x n2 k1 (SOME (L'.CNamed n1, loc2))) + (cparts (n2, n1); + E.pushCNamedAs env x n2 k1 (SOME (L'.CNamed n1, loc2)))) end else NONE @@ -2861,6 +2886,8 @@ handle KUnify (k1, k2, err) => sgnError env (SgiWrongKind (sgi1All, k1, sgi2All, k2, err)) + val c2 = sub2 c2 + fun good () = let val env = E.pushCNamedAs env x n2 k2 (SOME c2) @@ -2898,12 +2925,13 @@ else subStrInSgn (n2, n1) ran2 in - subSgn env dom2 dom1; - subSgn (E.pushStrNamedAs env m1 n1 dom2) ran1 ran2 + subSgn' counterparts env dom2 dom1; + subSgn' counterparts (E.pushStrNamedAs env m1 n1 dom2) ran1 ran2 end | _ => sgnError env (SgnWrongForm (sgn1, sgn2))) +and subSgn env = subSgn' (ref IM.empty) env and positive self = let
--- a/src/jscomp.sml Tue Jun 02 15:43:18 2009 -0400 +++ b/src/jscomp.sml Tue Jun 02 19:28:25 2009 -0400 @@ -523,9 +523,9 @@ "'" | #"\"" => "\\\"" | #"<" => - if mode = Script then + (*if mode = Script then "<" - else + else*) "\\074" | #"\\" => "\\\\" | #"\n" => "\\n"
--- a/src/settings.sml Tue Jun 02 15:43:18 2009 -0400 +++ b/src/settings.sml Tue Jun 02 19:28:25 2009 -0400 @@ -131,6 +131,8 @@ ("htmlifyString", "eh"), ("new_client_source", "sc"), ("set_client_source", "sv"), + ("stringToFloat", "pflo"), + ("stringToInt", "pio"), ("stringToFloat_error", "pfl"), ("stringToInt_error", "pi"), ("urlifyInt", "ts"),
--- a/src/urweb.grm Tue Jun 02 15:43:18 2009 -0400 +++ b/src/urweb.grm Tue Jun 02 19:28:25 2009 -0400 @@ -959,11 +959,6 @@ end) bind : SYMBOL LARROW eapps (SYMBOL, NONE, eapps) - | UNIT LARROW eapps (let - val loc = s (UNITleft, eappsright) - in - ("_", SOME (TRecord (CRecord [], loc), loc), eapps) - end) | eapps (let val loc = s (eappsleft, eappsright) in
--- a/src/urweb.lex Tue Jun 02 15:43:18 2009 -0400 +++ b/src/urweb.lex Tue Jun 02 19:28:25 2009 -0400 @@ -193,11 +193,15 @@ <COMMENT> "*)" => (if exitComment () then YYBEGIN INITIAL else (); continue ()); +<STRING,CHAR> "\\\"" => (str := #"\"" :: !str; continue()); +<STRING,CHAR> "\\'" => (str := #"'" :: !str; continue()); +<STRING,CHAR> "\\n" => (str := #"\n" :: !str; continue()); +<STRING,CHAR> "\\t" => (str := #"\t" :: !str; continue()); +<STRING,CHAR> "\n" => (newline yypos; + str := #"\n" :: !str; continue()); + <INITIAL> "#\"" => (YYBEGIN CHAR; strEnder := #"\""; strStart := pos yypos; str := []; continue()); -<CHAR> "\\\"" => (str := #"\"" :: !str; continue()); -<CHAR> "\\'" => (str := #"'" :: !str; continue()); -<CHAR> "\n" => (newline yypos; - str := #"\n" :: !str; continue()); + <CHAR> . => (let val ch = String.sub (yytext, 0) in @@ -220,10 +224,7 @@ <INITIAL> "\"" => (YYBEGIN STRING; strEnder := #"\""; strStart := pos yypos; str := []; continue()); <INITIAL> "'" => (YYBEGIN STRING; strEnder := #"'"; strStart := pos yypos; str := []; continue()); -<STRING> "\\\"" => (str := #"\"" :: !str; continue()); -<STRING> "\\'" => (str := #"'" :: !str; continue()); -<STRING> "\n" => (newline yypos; - str := #"\n" :: !str; continue()); + <STRING> . => (let val ch = String.sub (yytext, 0) in