# HG changeset patch # User Adam Chlipala # Date 1216564825 14400 # Node ID f214c535d25338f0021cd0ca49d63ab0bbfad75a # Parent adfa2c7a75dacee36363ef0019af8907dc11f236 A simpler context encoding diff -r adfa2c7a75da -r f214c535d253 lib/basis.lig --- a/lib/basis.lig Sun Jul 20 10:11:16 2008 -0400 +++ b/lib/basis.lig Sun Jul 20 10:40:25 2008 -0400 @@ -18,29 +18,37 @@ -> tag (attrsGiven ++ attrsAbsent) ctxOuter ctxInner useOuter bindOuter -> xml ctxInner useInner bindInner -> xml ctxOuter (useOuter ++ useInner) (bindOuter ++ bindInner) -val join : sharedCtx :: {Unit} - -> ctx1 ::: {Unit} -> ctx1 ~ sharedCtx - -> ctx2 ::: {Unit} -> ctx2 ~ sharedCtx +val join : ctx ::: {Unit} -> use1 ::: {Type} -> bind1 ::: {Type} -> bind2 ::: {Type} -> use1 ~ bind1 -> bind1 ~ bind2 - -> xml (sharedCtx ++ ctx1) use1 bind1 - -> xml (sharedCtx ++ ctx2) (use1 ++ bind1) bind2 - -> xml sharedCtx use1 (bind1 ++ bind2) + -> xml ctx use1 bind1 + -> xml ctx (use1 ++ bind1) bind2 + -> xml ctx use1 (bind1 ++ bind2) con xhtml = xml [Html] con page = xhtml [] [] -val head : tag [] [Html] [Head] [] [] -val title : tag [] [Head] [] [] [] +con html = [Html] +con head = [Head] +con body = [Body] +con form = [Body, Form] -val body : tag [] [Html] [Body] [] [] -val p : tag [] [Body] [Body] [] [] -val b : tag [] [Body] [Body] [] [] -val i : tag [] [Body] [Body] [] [] -val font : tag [Size = int, Face = string] [Body] [Body] [] [] +val head : unit -> tag [] html head [] [] +val title : unit -> tag [] head [] [] [] -val h1 : tag [] [Body] [Body] [] [] -val li : tag [] [Body] [Body] [] [] +val body : unit -> tag [] html body [] [] +con bodyTag = fn attrs :: {Type} => ctx ::: {Unit} -> [Body] ~ ctx -> unit + -> tag attrs ([Body] ++ ctx) ([Body] ++ ctx) [] [] -val a : tag [Link = page] [Body] [Body] [] [] +val p : bodyTag [] +val b : bodyTag [] +val i : bodyTag [] +val font : bodyTag [Size = int, Face = string] + +val h1 : bodyTag [] +val li : bodyTag [] + +val a : bodyTag [Link = page] + +val form : unit -> tag [] [Body] [Form] [] [] diff -r adfa2c7a75da -r f214c535d253 src/elaborate.sml --- a/src/elaborate.sml Sun Jul 20 10:11:16 2008 -0400 +++ b/src/elaborate.sml Sun Jul 20 10:40:25 2008 -0400 @@ -963,7 +963,7 @@ ((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 @@ :: (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 -r adfa2c7a75da -r f214c535d253 src/lacweb.grm --- a/src/lacweb.grm Sun Jul 20 10:11:16 2008 -0400 +++ b/src/lacweb.grm Sun Jul 20 10:40:25 2008 -0400 @@ -310,10 +310,9 @@ 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 @@ 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 @@ 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 -r adfa2c7a75da -r f214c535d253 src/monoize.sml --- a/src/monoize.sml Sun Jul 20 10:11:16 2008 -0400 +++ b/src/monoize.sml Sun Jul 20 10:40:25 2008 -0400 @@ -151,14 +151,8 @@ (L.ECApp ( (L.ECApp ( (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.EFfi ("Basis", "join"), + (L.EFfi ("Basis", "join"), _), _), _), - _), _), - _), _), - _), _), _), _), _), _), _), _), @@ -182,9 +176,18 @@ tag), _), xml) => let + 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.EFfi ("Basis", tag) => tag + 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 -r adfa2c7a75da -r f214c535d253 src/tag.sml --- a/src/tag.sml Sun Jul 20 10:11:16 2008 -0400 +++ b/src/tag.sml Sun Jul 20 10:40:25 2008 -0400 @@ -50,8 +50,13 @@ (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 @@ (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) diff -r adfa2c7a75da -r f214c535d253 tests/plink2.lac --- a/tests/plink2.lac Sun Jul 20 10:11:16 2008 -0400 +++ b/tests/plink2.lac Sun Jul 20 10:40:25 2008 -0400 @@ -1,8 +1,8 @@ -val pA = fn size1 => fn size2 => +val pA : int -> int -> page = fn size1 => fn size2 => Hello World! -val main = fn () => +val main : unit -> page = fn () =>
  • Size 5
  • Size 10