changeset 140:f214c535d253

A simpler context encoding
author Adam Chlipala <adamc@hcoop.net>
date Sun, 20 Jul 2008 10:40:25 -0400
parents adfa2c7a75da
children 63c699450281
files lib/basis.lig src/elaborate.sml src/lacweb.grm src/monoize.sml src/tag.sml tests/plink2.lac
diffstat 6 files changed, 59 insertions(+), 37 deletions(-) [+]
line wrap: on
line diff
--- 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] [] []
--- 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
--- 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
--- 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)];
                               "")
--- 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)
--- 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 => <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>