summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/basis.lig40
-rw-r--r--src/elaborate.sml4
-rw-r--r--src/lacweb.grm11
-rw-r--r--src/monoize.sml19
-rw-r--r--src/tag.sml18
-rw-r--r--tests/plink2.lac4
6 files changed, 59 insertions, 37 deletions
diff --git a/lib/basis.lig b/lib/basis.lig
index 86b01992..bdac9ba0 100644
--- a/lib/basis.lig
+++ b/lib/basis.lig
@@ -18,29 +18,37 @@ val tag : attrsGiven ::: {Type} -> attrsAbsent ::: {Type} -> attrsGiven ~ attrsA
-> 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 --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)
diff --git a/tests/plink2.lac b/tests/plink2.lac
index 22cd9094..e446515e 100644
--- a/tests/plink2.lac
+++ b/tests/plink2.lac
@@ -1,8 +1,8 @@
-val pA = fn size1 => fn size2 => <html><body>
+val pA : int -> int -> page = fn size1 => fn size2 => <html><body>
<font size={size1}>Hello</font> <font size={size2}>World!</font>
</body></html>
-val main = fn () => <html><body>
+val main : unit -> page = fn () => <html><body>
<li> <a link={pA 5 10}>Size 5</a></li>
<li> <a link={pA 10 5}>Size 10</a></li>
</body></html>
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-30 22:12:28 +0000