Mercurial > urweb
changeset 139:adfa2c7a75da
Form binding parameters threaded through
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 20 Jul 2008 10:11:16 -0400 |
| parents | d6d78055f001 |
| children | f214c535d253 |
| files | include/types.h lib/basis.lig src/c/driver.c src/corify.sml src/elaborate.sml src/monoize.sml tests/html_fn.lac |
| diffstat | 7 files changed, 101 insertions(+), 44 deletions(-) [+] |
line wrap: on
line diff
--- a/include/types.h Sat Jul 19 18:56:57 2008 -0400 +++ b/include/types.h Sun Jul 20 10:11:16 2008 -0400 @@ -11,3 +11,4 @@ typedef struct lw_context *lw_context; typedef lw_Basis_string lw_Basis_xhtml; +typedef lw_Basis_string lw_Basis_page;
--- a/lib/basis.lig Sat Jul 19 18:56:57 2008 -0400 +++ b/lib/basis.lig Sun Jul 20 10:11:16 2008 -0400 @@ -5,35 +5,42 @@ 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] [] []
--- a/src/c/driver.c Sat Jul 19 18:56:57 2008 -0400 +++ b/src/c/driver.c Sun Jul 20 10:11:16 2008 -0400 @@ -207,7 +207,7 @@ pthread_mutex_lock(&queue_mutex); enqueue(new_fd); + pthread_cond_broadcast(&queue_cond); pthread_mutex_unlock(&queue_mutex); - pthread_cond_broadcast(&queue_cond); } }
--- a/src/corify.sml Sat Jul 19 18:56:57 2008 -0400 +++ b/src/corify.sml Sun Jul 20 10:11:16 2008 -0400 @@ -480,9 +480,11 @@ 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)
--- a/src/elaborate.sml Sat Jul 19 18:56:57 2008 -0400 +++ b/src/elaborate.sml Sun Jul 20 10:11:16 2008 -0400 @@ -970,6 +970,7 @@ 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 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 @@ 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 @@ 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 @@ ((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)
--- a/src/monoize.sml Sat Jul 19 18:56:57 2008 -0400 +++ b/src/monoize.sml Sun Jul 20 10:11:16 2008 -0400 @@ -138,15 +138,28 @@ | 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 @@ (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) =>