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) =>
--- a/tests/html_fn.lac	Sat Jul 19 18:56:57 2008 -0400
+++ b/tests/html_fn.lac	Sun Jul 20 10:11:16 2008 -0400
@@ -1,4 +1,4 @@
-val main = fn () => <html>
+val main : unit -> page = fn () => <html>
         <head>
                 <title>Hello World!</title>
         </head>