summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-04-12 11:08:00 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-04-12 11:08:00 -0400
commit6857918cbca4b1dda5bf378bcacb5dea4f5b5724 (patch)
treed4d5c202be4912da6d99166ecc5d1de3413f4c93 /src
parent64f0edf6a5db26ed8f872e18a43416cce7fcbab8 (diff)
hello compiles with CSS
Diffstat (limited to 'src')
-rw-r--r--src/corify.sml9
-rw-r--r--src/elab_print.sig1
-rw-r--r--src/elaborate.sml65
-rw-r--r--src/monoize.sml59
-rw-r--r--src/urweb.grm22
5 files changed, 103 insertions, 53 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-03 19:45:26 +0000