From 0f0d418e2290cdf5e6e392f65579756b37661be9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 12 Apr 2009 11:08:00 -0400 Subject: hello compiles with CSS --- src/corify.sml | 9 ++++---- src/elab_print.sig | 1 + src/elaborate.sml | 65 +++++++++++++++++++++++++++++++++++------------------- src/monoize.sml | 59 +++++++++++++++++++++++++++++++++++-------------- src/urweb.grm | 22 +++++++++--------- 5 files changed, 103 insertions(+), 53 deletions(-) (limited to 'src') diff --git a/src/corify.sml b/src/corify.sml index 1a5bab06..d0fc6200 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -923,10 +923,11 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = ran' as (L.CApp ((L.CApp - ((L.CApp ((L.CModProj (basis', [], "xml"), _), - (L.CRecord (_, [((L.CName "Html", _), - _)]), _)), _), _), - _), _), _))) => + ((L.CApp + ((L.CApp ((L.CModProj (basis', [], "xml"), _), + (L.CRecord (_, [((L.CName "Html", _), + _)]), _)), _), _), + _), _), _), _), _))) => let val ran = (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) val ranT = (L.CApp ((L.CModProj (basis, [], "transaction"), loc), diff --git a/src/elab_print.sig b/src/elab_print.sig index 41d72ca7..1eb832b3 100644 --- a/src/elab_print.sig +++ b/src/elab_print.sig @@ -36,6 +36,7 @@ signature ELAB_PRINT = sig val p_decl : ElabEnv.env -> Elab.decl Print.printer val p_sgn_item : ElabEnv.env -> Elab.sgn_item Print.printer val p_sgn : ElabEnv.env -> Elab.sgn Print.printer + val p_str : ElabEnv.env -> Elab.str Print.printer val p_file : ElabEnv.env -> Elab.file Print.printer val debug : bool ref diff --git a/src/elaborate.sml b/src/elaborate.sml index 922c9c32..792ab315 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -3284,30 +3284,40 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = (L'.CApp (tf, arg), _) => (case (hnormCon env tf, hnormCon env arg) of ((L'.CModProj (basis, [], "transaction"), _), - (L'.CApp (tf, arg3), _)) => + (L'.CApp (tf, arg4), _)) => (case (basis = !basis_r, - hnormCon env tf, hnormCon env arg3) of + hnormCon env tf, hnormCon env arg4) of (true, - (L'.CApp (tf, arg2), _), + (L'.CApp (tf, arg3), _), ((L'.CRecord (_, []), _))) => - (case (hnormCon env tf) of - (L'.CApp (tf, arg1), _) => - (case (hnormCon env tf, - hnormCon env arg1, - hnormCon env arg2) of - (tf, arg1, - (L'.CRecord (_, []), _)) => - let - val t = (L'.CApp (tf, arg1), loc) - val t = (L'.CApp (t, arg2), loc) - val t = (L'.CApp (t, arg3), loc) - val t = (L'.CApp ( - (L'.CModProj - (basis, [], "transaction"), loc), + (case hnormCon env tf of + (L'.CApp (tf, arg2), _) => + (case hnormCon env tf of + (L'.CApp (tf, arg1), _) => + (case (hnormCon env tf, + hnormCon env arg1, + hnormCon env arg2, + hnormCon env arg3, + hnormCon env arg4) of + (tf, + arg1, + (L'.CRecord (_, []), _), + arg2, + arg4) => + let + val t = (L'.CApp (tf, arg1), loc) + val t = (L'.CApp (t, arg2), loc) + val t = (L'.CApp (t, arg3), loc) + val t = (L'.CApp (t, arg4), loc) + + val t = (L'.CApp ( + (L'.CModProj + (basis, [], "transaction"), loc), t), loc) - in - (L'.SgiVal (x, n, makeRes t), loc) - end + in + (L'.SgiVal (x, n, makeRes t), loc) + end + | _ => all) | _ => all) | _ => all) | _ => all) @@ -3622,6 +3632,16 @@ fun elabFile basis topStr topSgn env file = [] => () | _ => raise Fail "Unresolved disjointness constraints in top.urs" val (topStr, topSgn', gs) = elabStr (env', D.empty) (L.StrConst topStr, ErrorMsg.dummySpan) + + val () = subSgn env' topSgn' topSgn + + val () = app (fn (env, k, s1, s2) => + unifySummaries env (k, normalizeRecordSummary env s1, normalizeRecordSummary env s2) + handle CUnify' err => (ErrorMsg.errorAt (#2 k) "Error in Top final record unification"; + cunifyError env err)) + (!delayedUnifs) + val () = delayedUnifs := [] + val () = case gs of [] => () | _ => app (fn Disjoint (loc, env, denv, c1, c2) => @@ -3631,7 +3651,8 @@ fun elabFile basis topStr topSgn env file = (prefaces "Unresolved constraint in top.ur" [("loc", PD.string (ErrorMsg.spanToString loc)), ("c1", p_con env c1), - ("c2", p_con env c2)]; + ("c2", p_con env c2), + ("topStr", p_str env topStr)]; raise Fail "Unresolved constraint in top.ur")) | TypeClass (env, c, r, loc) => let @@ -3642,8 +3663,6 @@ fun elabFile basis topStr topSgn env file = | NONE => expError env (Unresolvable (loc, c)) end) gs - val () = subSgn env' topSgn' topSgn - val (env', top_n) = E.pushStrNamed env' "Top" topSgn val () = top_r := top_n diff --git a/src/monoize.sml b/src/monoize.sml index 8030b7ba..e8244c9e 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -127,10 +127,14 @@ fun monoType env = readType (mt env dtmap t, loc) | L.CFfi ("Basis", "url") => (L'.TFfi ("Basis", "string"), loc) - | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) => + | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CFfi ("Basis", "css_class"), _), _) => + (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CFfi ("Basis", "css_subset"), _), _), _), _) => + (L'.TRecord [], loc) | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) => (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc) @@ -2003,7 +2007,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EApp ( (L.ECApp ( - (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _), + (L.ECApp ( + (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _), + _), _), _), _), se) => let @@ -2012,19 +2018,32 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EFfiApp ("Basis", "htmlifyString", [se]), loc), fm) end + | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "css_subset"), _), _), _), _) => + ((L'.ERecord [], loc), fm) + | L.EApp ( (L.EApp ( - (L.ECApp ( - (L.ECApp ( + (L.EApp ( + (L.EApp ( (L.ECApp ( (L.ECApp ( - (L.EFfi ("Basis", "join"), - _), _), _), + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "join"), + _), _), _), + _), _), + _), _), + _), _), + _), _), + _), _), _), _), - _), _), - _), _), - xml1), _), - xml2) => + xml1), _), + xml2), _), + _), _), + _) => let val (xml1, fm) = monoExp (env, st, fm) xml1 val (xml2, fm) = monoExp (env, st, fm) xml2 @@ -2035,18 +2054,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EApp ( (L.EApp ( (L.EApp ( - (L.ECApp ( - (L.ECApp ( + (L.EApp ( + (L.EApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( - (L.EFfi ("Basis", "tag"), - _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), - attrs), _), - tag), _), + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "tag"), + _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), + _), _), _), _), _), _), + attrs), _), + tag), _), + _), _), + _), _), xml) => let fun getTag' (e, _) = diff --git a/src/urweb.grm b/src/urweb.grm index 0d750679..675bcc72 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -1208,11 +1208,12 @@ rexp : ([]) xml : xmlOne xml (let val pos = s (xmlOneleft, xmlright) + val e = (EVar (["Basis"], "join", Infer), pos) + val e = (EApp (e, xmlOne), pos) + val e = (EApp (e, xml), pos) + val e = (EApp (e, (EVar (["Basis"], "css_subset", Infer), pos)), pos) in - (EApp ((EApp ( - (EVar (["Basis"], "join", Infer), pos), - xmlOne), pos), - xml), pos) + (EApp (e, (EVar (["Basis"], "css_subset", Infer), pos)), pos) end) | xmlOne (xmlOne) @@ -1227,6 +1228,7 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer) let val e = (EVar (["Basis"], "cdata", DontInfer), pos) val e = (ECApp (e, (CWild (KWild, pos), pos)), pos) + val e = (ECApp (e, (CRecord [], pos)), pos) in (ECApp (e, (CRecord [], pos)), pos) end @@ -1267,13 +1269,13 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer) tag : tagHead attrs (let val pos = s (tagHeadleft, attrsright) + val e = (EVar (["Basis"], "tag", Infer), pos) + val e = (EApp (e, (ERecord attrs, pos)), pos) + val e = (EApp (e, (EApp (#2 tagHead, (ERecord [], pos)), pos)), pos) + val e = (EApp (e, (EVar (["Basis"], "css_subset", Infer), pos)), pos) + val e = (EApp (e, (EVar (["Basis"], "css_subset", Infer), pos)), pos) in - (#1 tagHead, - (EApp ((EApp ((EVar (["Basis"], "tag", Infer), pos), - (ERecord attrs, pos)), pos), - (EApp (#2 tagHead, - (ERecord [], pos)), pos)), - pos)) + (#1 tagHead, e) end) tagHead: BEGIN_TAG (let -- cgit v1.2.3