summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/types.h1
-rw-r--r--lib/basis.lig49
-rw-r--r--src/c/driver.c2
-rw-r--r--src/corify.sml8
-rw-r--r--src/elaborate.sml54
-rw-r--r--src/monoize.sml29
-rw-r--r--tests/html_fn.lac2
7 files changed, 101 insertions, 44 deletions
diff --git a/include/types.h b/include/types.h
index 083f478a..81cec229 100644
--- a/include/types.h
+++ b/include/types.h
@@ -11,3 +11,4 @@ typedef lw_unit lw_Basis_unit;
typedef struct lw_context *lw_context;
typedef lw_Basis_string lw_Basis_xhtml;
+typedef lw_Basis_string lw_Basis_page;
diff --git a/lib/basis.lig b/lib/basis.lig
index 189b0350..86b01992 100644
--- a/lib/basis.lig
+++ b/lib/basis.lig
@@ -5,35 +5,42 @@ type string
type unit = {}
-con tag :: {Type} -> {Unit} -> {Unit} -> Type
+con tag :: {Type} -> {Unit} -> {Unit} -> {Type} -> {Type} -> Type
-con xml :: {Unit} -> Type
-val cdata : ctx ::: {Unit} -> string -> xml ctx
+con xml :: {Unit} -> {Type} -> {Type} -> Type
+val cdata : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> string -> xml ctx use bind
val tag : attrsGiven ::: {Type} -> attrsAbsent ::: {Type} -> attrsGiven ~ attrsAbsent
- -> outer ::: {Unit} -> inner ::: {Unit}
+ -> ctxOuter ::: {Unit} -> ctxInner ::: {Unit}
+ -> useOuter ::: {Type} -> useInner ::: {Type} -> useOuter ~ useInner
+ -> bindOuter ::: {Type} -> bindInner ::: {Type} -> bindOuter ~ bindInner
-> $attrsGiven
- -> tag (attrsGiven ++ attrsAbsent) outer inner
- -> xml inner
- -> xml outer
-val join : shared :: {Unit}
- -> ctx1 ::: {Unit} -> ctx1 ~ shared
- -> ctx2 ::: {Unit} -> ctx2 ~ shared
- -> xml (shared ++ ctx1) -> xml (shared ++ ctx2) -> xml shared
+ -> 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
+ -> 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)
con xhtml = xml [Html]
+con page = xhtml [] []
-val head : tag [] [Html] [Head]
-val title : tag [] [Head] []
+val head : tag [] [Html] [Head] [] []
+val title : tag [] [Head] [] [] []
-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 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 h1 : tag [] [Body] [Body]
-val li : tag [] [Body] [Body]
+val h1 : tag [] [Body] [Body] [] []
+val li : tag [] [Body] [Body] [] []
-val a : tag [Link = xhtml] [Body] [Body]
+val a : tag [Link = page] [Body] [Body] [] []
diff --git a/src/c/driver.c b/src/c/driver.c
index f79c166d..ac0b0c86 100644
--- a/src/c/driver.c
+++ b/src/c/driver.c
@@ -207,7 +207,7 @@ int main(int argc, char *argv[]) {
pthread_mutex_lock(&queue_mutex);
enqueue(new_fd);
- pthread_mutex_unlock(&queue_mutex);
pthread_cond_broadcast(&queue_cond);
+ pthread_mutex_unlock(&queue_mutex);
}
}
diff --git a/src/corify.sml b/src/corify.sml
index 13db0685..719b4215 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -480,9 +480,11 @@ fun corifyDecl ((d, loc : EM.span), st) =
L.SgiVal (s, _, t as (L.TFun (dom, ran), _)) =>
(case (#1 dom, #1 ran) of
(L.TRecord _,
- L.CApp ((L.CModProj (_, [], "xml"), _),
- (L.CRecord (_, [((L.CName "Html", _),
- _)]), _))) =>
+ L.CApp
+ ((L.CApp
+ ((L.CApp ((L.CModProj (_, [], "xml"), _),
+ (L.CRecord (_, [((L.CName "Html", _),
+ _)]), _)), _), _), _), _)) =>
let
val ran = (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc)
val e = (L.EModProj (m, ms, s), loc)
diff --git a/src/elaborate.sml b/src/elaborate.sml
index eca00e54..6dc76a59 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -970,6 +970,7 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
val kunit = (L'.KUnit, loc)
val k = (L'.KRecord kunit, loc)
+ val kt = (L'.KRecord (L'.KType, loc), loc)
val basis =
case E.lookupStr env "Basis" of
@@ -979,12 +980,19 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
fun xml () =
let
val ns = cunif (loc, k)
+ val use = cunif (loc, kt)
+ val bind = cunif (loc, kt)
+
+ val t = (L'.CModProj (basis, [], "xml"), loc)
+ val t = (L'.CApp (t, ns), loc)
+ val t = (L'.CApp (t, use), loc)
+ val t = (L'.CApp (t, bind), loc)
in
- (ns, (L'.CApp ((L'.CModProj (basis, [], "xml"), loc), ns), loc))
+ (ns, use, bind, t)
end
- val (ns1, c1) = xml ()
- val (ns2, c2) = xml ()
+ val (ns1, use1, bind1, c1) = xml ()
+ val (ns2, use2, bind2, c2) = xml ()
val gs3 = checkCon (env, denv) xml1' t1 c1
val gs4 = checkCon (env, denv) xml2' t2 c2
@@ -1017,10 +1025,17 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
val e = (L'.ECApp (e, shared), loc)
val e = (L'.ECApp (e, ctx1), loc)
val e = (L'.ECApp (e, ctx2), loc)
+ val e = (L'.ECApp (e, use1), loc)
+ val e = (L'.ECApp (e, use2), loc)
+ val e = (L'.ECApp (e, bind1), loc)
+ val e = (L'.ECApp (e, bind2), loc)
val e = (L'.EApp (e, xml1'), loc)
val e = (L'.EApp (e, xml2'), loc)
- val t = (L'.CApp ((L'.CModProj (basis, [], "xml"), loc), shared), loc)
+ val t = (L'.CModProj (basis, [], "xml"), loc)
+ val t = (L'.CApp (t, shared), loc)
+ val t = (L'.CApp (t, (L'.CConcat (use1, use2), loc)), loc)
+ val t = (L'.CApp (t, (L'.CConcat (bind1, bind2), loc)), loc)
fun doUnify (ns, ns') =
let
@@ -1049,6 +1064,8 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
in
(e, t, (loc, env, denv, shared, ctx1)
:: (loc, env, denv, shared, ctx2)
+ :: (loc, env, denv, use1, use2)
+ :: (loc, env, denv, bind1, bind2)
:: gs1 @ gs2 @ gs3 @ gs4 @ gs5 @ gs6 @ gs7 @ gs8)
end
@@ -1975,14 +1992,27 @@ fun elabDecl ((d, loc), (env, denv, gs)) =
((L'.TFun (dom, ran), _), []) =>
(case (hnormCon (env, denv) dom, hnormCon (env, denv) ran) of
(((L'.TRecord domR, _), []),
- ((L'.CApp (tf, ranR), _), [])) =>
- (case (hnormCon (env, denv) tf, hnormCon (env, denv) ranR) of
- ((tf, []), (ranR, [])) =>
- (case (hnormCon (env, denv) domR, hnormCon (env, denv) ranR) of
- ((domR, []), (ranR, [])) =>
- (L'.SgiVal (x, n, (L'.TFun ((L'.TRecord domR, loc),
- (L'.CApp (tf, ranR), loc)),
- loc)), loc)
+ ((L'.CApp (tf, arg3), _), [])) =>
+ (case (hnormCon (env, denv) tf, hnormCon (env, denv) arg3) of
+ (((L'.CApp (tf, arg2), _), []),
+ (((L'.CRecord (_, []), _), []))) =>
+ (case (hnormCon (env, denv) tf) of
+ ((L'.CApp (tf, arg1), _), []) =>
+ (case (hnormCon (env, denv) tf,
+ hnormCon (env, denv) domR,
+ hnormCon (env, denv) arg2) of
+ ((tf, []), (domR, []),
+ ((L'.CRecord (_, []), _), [])) =>
+ let
+ val t = (L'.CApp (tf, arg1), loc)
+ val t = (L'.CApp (t, arg2), loc)
+ val t = (L'.CApp (t, arg3), loc)
+ in
+ (L'.SgiVal (x, n, (L'.TFun ((L'.TRecord domR, loc),
+ t),
+ loc)), loc)
+ end
+ | _ => all)
| _ => all)
| _ => all)
| _ => all)
diff --git a/src/monoize.sml b/src/monoize.sml
index 4c28fb48..d35d9092 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -138,15 +138,28 @@ fun monoExp env (all as (e, loc)) =
| L.EFfi mx => (L'.EFfi mx, loc)
| L.EFfiApp (m, x, es) => (L'.EFfiApp (m, x, map (monoExp env) es), loc)
- | L.EApp ((L.ECApp ((L.EFfi ("Basis", "cdata"), _),
- _), _), se) => (L'.EFfiApp ("Basis", "htmlifyString", [monoExp env se]), loc)
+ | L.EApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
+ _), _),
+ _), _),
+ se) => (L'.EFfiApp ("Basis", "htmlifyString", [monoExp env se]), loc)
| L.EApp (
(L.EApp (
(L.ECApp (
(L.ECApp (
(L.ECApp (
- (L.EFfi ("Basis", "join"),
- _), _), _),
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.EFfi ("Basis", "join"),
+ _), _), _),
+ _), _),
+ _), _),
+ _), _),
+ _), _),
_), _),
_), _),
xml1), _),
@@ -159,8 +172,12 @@ fun monoExp env (all as (e, loc)) =
(L.ECApp (
(L.ECApp (
(L.ECApp (
- (L.EFfi ("Basis", "tag"),
- _), _), _), _), _), _), _), _), _),
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.ECApp (
+ (L.EFfi ("Basis", "tag"),
+ _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _),
attrs), _),
tag), _),
xml) =>
diff --git a/tests/html_fn.lac b/tests/html_fn.lac
index 9b81b73d..fab70cc3 100644
--- a/tests/html_fn.lac
+++ b/tests/html_fn.lac
@@ -1,4 +1,4 @@
-val main = fn () => <html>
+val main : unit -> page = fn () => <html>
<head>
<title>Hello World!</title>
</head>
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-04 14:12:34 +0000