diff options
| author |  Adam Chlipala <adamc@hcoop.net> | 2008-07-20 10:40:25 -0400 |
|---|---|---|
| committer | Adam Chlipala <adamc@hcoop.net> | 2008-07-20 10:40:25 -0400 |
| commit | 0fe71710d474e4c93392ec9d2069ef36464fbfa0 (patch) | |
| tree | 4a158085273dfa721a1dcf645c70d5083aa52ebc /src | |
| parent | d76bf83a5e8eb9a0b4e194f83cfadd8d55c00dfd (diff) | |
A simpler context encoding
Diffstat (limited to 'src')
| -rw-r--r-- | src/elaborate.sml | 4 | ||||
| -rw-r--r-- | src/lacweb.grm | 11 | ||||
| -rw-r--r-- | src/monoize.sml | 19 | ||||
| -rw-r--r-- | src/tag.sml | 18 |
4 files changed, 33 insertions, 19 deletions
diff --git a/src/elaborate.sml b/src/elaborate.sml index 6dc76a59..e0f712e2 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -963,7 +963,7 @@ fun elabExp (env, denv) (eAll as (e, loc)) = ((L'.EModProj (n, ms, s), loc), t, []) end) - | L.EApp (arg as ((L.EApp ((L.ECApp ((L.EVar (["Basis"], "join"), _), (L.CWild _, _)), _), xml1), _), xml2)) => + (*| L.EApp (arg as ((L.EApp ((L.ECApp ((L.EVar (["Basis"], "join"), _), (L.CWild _, _)), _), xml1), _), xml2)) => let val (xml1', t1, gs1) = elabExp (env, denv) xml1 val (xml2', t2, gs2) = elabExp (env, denv) xml2 @@ -1067,7 +1067,7 @@ fun elabExp (env, denv) (eAll as (e, loc)) = :: (loc, env, denv, use1, use2) :: (loc, env, denv, bind1, bind2) :: gs1 @ gs2 @ gs3 @ gs4 @ gs5 @ gs6 @ gs7 @ gs8) - end + end*) | L.EApp (e1, e2) => let diff --git a/src/lacweb.grm b/src/lacweb.grm index 62e3c9e8..05b7bc39 100644 --- a/src/lacweb.grm +++ b/src/lacweb.grm @@ -310,10 +310,9 @@ xml : xmlOne xml (let val pos = s (xmlOneleft, xmlright) in (EApp ((EApp ( - (ECApp ((EVar (["Basis"], "join"), pos), - (CWild (KRecord (KUnit, pos), pos), pos)), pos), + (EVar (["Basis"], "join"), pos), xmlOne), pos), - xml), pos) + xml), pos) end) | xmlOne (xmlOne) @@ -325,7 +324,8 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata"), s (NOTAG in (EApp ((EApp ((EApp ((EVar (["Basis"], "tag"), pos), (ERecord attrs, pos)), pos), - (EVar ([], BEGIN_TAG), pos)), + ((EApp ((EVar ([], BEGIN_TAG), pos), + (ERecord [], pos)), pos))), pos), (EApp ((EVar (["Basis"], "cdata"), pos), (EPrim (Prim.String ""), pos)), @@ -338,7 +338,8 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata"), s (NOTAG if BEGIN_TAG = END_TAG then (EApp ((EApp ((EApp ((EVar (["Basis"], "tag"), pos), (ERecord attrs, pos)), pos), - (EVar ([], BEGIN_TAG), pos)), + (EApp ((EVar ([], BEGIN_TAG), pos), + (ERecord [], pos)), pos)), pos), xml), pos) else diff --git a/src/monoize.sml b/src/monoize.sml index d35d9092..6b2974ee 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -151,14 +151,8 @@ fun monoExp env (all as (e, loc)) = (L.ECApp ( (L.ECApp ( (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.EFfi ("Basis", "join"), + (L.EFfi ("Basis", "join"), _), _), _), - _), _), - _), _), - _), _), _), _), _), _), _), _), @@ -182,9 +176,18 @@ fun monoExp env (all as (e, loc)) = tag), _), xml) => let - fun getTag (e, _) = + fun getTag' (e, _) = case e of L.EFfi ("Basis", tag) => tag + | L.ECApp (e, _) => getTag' e + | _ => (E.errorAt loc "Non-constant XML tag"; + Print.eprefaces' [("Expression", CorePrint.p_exp env tag)]; + "") + + fun getTag (e, _) = + case e of + L.EFfiApp ("Basis", tag, [(L.ERecord [], _)]) => tag + | L.EApp (e, (L.ERecord [], _)) => getTag' e | _ => (E.errorAt loc "Non-constant XML tag"; Print.eprefaces' [("Expression", CorePrint.p_exp env tag)]; "") diff --git a/src/tag.sml b/src/tag.sml index 1a7e93ca..53966bf9 100644 --- a/src/tag.sml +++ b/src/tag.sml @@ -50,8 +50,13 @@ fun exp env (e, s) = (ECApp ( (ECApp ( (ECApp ( - (EFfi ("Basis", "tag"), - loc), given), _), absent), _), outer), _), inner), _), + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (EFfi ("Basis", "tag"), + loc), given), _), absent), _), outer), _), inner), _), + useOuter), _), useInner), _), bindOuter), _), bindInner), _), attrs), _), tag), _), xml) => @@ -113,8 +118,13 @@ fun exp env (e, s) = (ECApp ( (ECApp ( (ECApp ( - (EFfi ("Basis", "tag"), - loc), given), loc), absent), loc), outer), loc), inner), loc), + (ECApp ( + (ECApp ( + (ECApp ( + (ECApp ( + (EFfi ("Basis", "tag"), + loc), given), loc), absent), loc), outer), loc), inner), loc), + useOuter), loc), useInner), loc), bindOuter), loc), bindInner), loc), (ERecord xets, loc)), loc), tag), loc), xml), s) |