Initial form support

3 files changed, 82 insertions, 54 deletions

diff --git a/src/elaborate.sml b/src/elaborate.sml
index e0f712e2..a36a0224 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -444,7 +444,7 @@ datatype cunify_error =
        | COccursCheckFailed of L'.con * L'.con
        | CIncompatible of L'.con * L'.con
        | CExplicitness of L'.con * L'.con
-       | CKindof of L'.con
+       | CKindof of L'.kind * L'.con
        | CRecordFailure
 
 exception CUnify' of cunify_error
@@ -468,9 +468,10 @@ fun cunifyError env err =
         eprefaces "Differing constructor function explicitness"
                   [("Con 1", p_con env c1),
                    ("Con 2", p_con env c2)]
-      | CKindof c =>
+      | CKindof (k, c) =>
         eprefaces "Kind unification variable blocks kindof calculation"
-                  [("Con", p_con env c)]
+                  [("Kind", p_kind k),
+                   ("Con", p_con env c)]
       | CRecordFailure =>
         eprefaces "Can't unify record constructors" []
 
@@ -526,10 +527,10 @@ fun kindof env (c, loc) =
         end
 
       | L'.CApp (c, _) =>
-        (case #1 (hnormKind (kindof env c)) of
-             L'.KArrow (_, k) => k
-           | L'.KError => kerror
-           | _ => raise CUnify' (CKindof c))
+        (case hnormKind (kindof env c) of
+             (L'.KArrow (_, k), _) => k
+           | (L'.KError, _) => kerror
+           | k => raise CUnify' (CKindof (k, c)))
       | L'.CAbs (x, k, c) => (L'.KArrow (k, kindof (E.pushCRel env x k) c), loc)
       | L'.CDisjoint (_, _, c) => kindof env c
 
@@ -551,7 +552,8 @@ fun unifyRecordCons (env, denv) (c1, c2) =
         fun rkindof c =
             case kindof env c of
                 (L'.KRecord k, _) => k
-              | _ => raise CUnify' (CKindof c)
+              | (L'.KError, _) => kerror
+              | k => raise CUnify' (CKindof (k, c))
 
         val k1 = rkindof c1
         val k2 = rkindof c2
@@ -643,7 +645,8 @@ and unifySummaries (env, denv) (k, s1 : record_summary, s2 : record_summary) =
               | (_, _, (_, r) :: rest) =>
                 let
                     val r' = ref NONE
-                    val cr' = (L'.CUnif (dummy, k, "recd", r'), dummy)
+                    val kr = (L'.KRecord k, dummy)
+                    val cr' = (L'.CUnif (dummy, kr, "recd", r'), dummy)
 
                     val prefix = case (fs, others) of
                                      ([], other :: others) =>
diff --git a/src/lacweb.grm b/src/lacweb.grm
index 05b7bc39..0d2ab714 100644
--- a/src/lacweb.grm
+++ b/src/lacweb.grm
@@ -90,6 +90,8 @@ fun uppercaseFirst "" = ""
  | rexp of (con * exp) list
  | xml of exp
  | xmlOne of exp
+ | tag of string * exp
+ | tagHead of string * exp
 
  | attrs of (con * exp) list
  | attr of con * exp
@@ -306,47 +308,61 @@ rexp   :                                ([])
        | ident EQ eexp                  ([(ident, eexp)])
        | ident EQ eexp COMMA rexp       ((ident, eexp) :: rexp)
 
-xml    : xmlOne xml                  (let
-                                          val pos = s (xmlOneleft, xmlright)
-                                      in
-                                          (EApp ((EApp (
-                                                  (EVar (["Basis"], "join"), pos),
+xml    : xmlOne xml                     (let
+                                             val pos = s (xmlOneleft, xmlright)
+                                         in
+                                             (EApp ((EApp (
+                                                     (EVar (["Basis"], "join"), pos),
                                                   xmlOne), pos),
-                                                 xml), pos)
-                                      end)
-       | xmlOne                      (xmlOne)
-
-xmlOne : NOTAGS                      (EApp ((EVar (["Basis"], "cdata"), s (NOTAGSleft, NOTAGSright)),
-                                            (EPrim (Prim.String NOTAGS), s (NOTAGSleft, NOTAGSright))),
-                                      s (NOTAGSleft, NOTAGSright))
-       | BEGIN_TAG attrs DIVIDE GT   (let
-                                          val pos = s (BEGIN_TAGleft, GTright)
-                                      in
-                                          (EApp ((EApp ((EApp ((EVar (["Basis"], "tag"), pos),
-                                                               (ERecord attrs, pos)), pos),
-                                                        ((EApp ((EVar ([], BEGIN_TAG), pos),
-                                                                (ERecord [], pos)), pos))),
-                                                  pos),
-                                                 (EApp ((EVar (["Basis"], "cdata"), pos),
-                                                        (EPrim (Prim.String ""), pos)),
-                                                  pos)), pos)
-                                      end)
-
-       | BEGIN_TAG attrs GT xml END_TAG(let
-                                            val pos = s (BEGIN_TAGleft, GTright)
-                                        in
-                                            if BEGIN_TAG = END_TAG then
-                                                (EApp ((EApp ((EApp ((EVar (["Basis"], "tag"), pos),
-                                                                     (ERecord attrs, pos)), pos),
-                                                              (EApp ((EVar ([], BEGIN_TAG), pos),
-                                                                     (ERecord [], pos)), pos)),
-                                                        pos),
-                                                       xml), pos)
-                                            else
-                                                (ErrorMsg.errorAt pos "Begin and end tags don't match.";
-                                                 (EFold, pos))
-                                        end)
-       | LBRACE eexp RBRACE          (eexp)
+                                                    xml), pos)
+                                         end)
+       | xmlOne                         (xmlOne)
+
+xmlOne : NOTAGS                         (EApp ((EVar (["Basis"], "cdata"), s (NOTAGSleft, NOTAGSright)),
+                                               (EPrim (Prim.String NOTAGS), s (NOTAGSleft, NOTAGSright))),
+                                         s (NOTAGSleft, NOTAGSright))
+       | tag DIVIDE GT                  (let
+                                             val pos = s (tagleft, GTright)
+                                         in
+                                             (EApp (#2 tag,
+                                                    (EApp ((EVar (["Basis"], "cdata"), pos),
+                                                           (EPrim (Prim.String ""), pos)),
+                                                     pos)), pos)
+                                         end)
+         
+       | tag GT xml END_TAG             (let
+                                             val pos = s (tagleft, GTright)
+                                         in
+                                             if #1 tag = END_TAG then
+                                                 if END_TAG = "lform" then
+                                                     (EApp ((EVar (["Basis"], "lform"), pos),
+                                                            xml), pos)
+                                                 else
+                                                     (EApp (#2 tag, xml), pos)
+                                             else
+                                                 (ErrorMsg.errorAt pos "Begin and end tags don't match.";
+                                                  (EFold, pos))
+                                         end)
+       | LBRACE eexp RBRACE             (eexp)
+
+tag    : tagHead attrs                  (let
+                                             val pos = s (tagHeadleft, attrsright)
+                                         in
+                                             (#1 tagHead,
+                                              (EApp ((EApp ((EVar (["Basis"], "tag"), pos),
+                                                            (ERecord attrs, pos)), pos),
+                                                     (EApp (#2 tagHead,
+                                                            (ERecord [], pos)), pos)),
+                                               pos))
+                                         end)
+
+tagHead: BEGIN_TAG                      (let
+                                             val pos = s (BEGIN_TAGleft, BEGIN_TAGright)
+                                         in
+                                             (BEGIN_TAG,
+                                              (EVar ([], BEGIN_TAG), pos))
+                                         end)
+       | tagHead LBRACE cexp RBRACE     (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
                                           
 attrs  :                                ([])
        | attr attrs                     (attr :: attrs)
diff --git a/src/monoize.sml b/src/monoize.sml
index 6b2974ee..ad177a64 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -140,9 +140,7 @@ fun monoExp env (all as (e, loc)) =
 
           | L.EApp (
             (L.ECApp (
-             (L.ECApp (
-              (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
-              _), _),
+             (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
              _), _),
             se) => (L'.EFfiApp ("Basis", "htmlifyString", [monoExp env se]), loc)
           | L.EApp (
@@ -234,8 +232,11 @@ fun monoExp env (all as (e, loc)) =
 
             in
                 case xml of
-                    (L.EApp ((L.ECApp ((L.EFfi ("Basis", "cdata"), _),
-                                       _), _), (L.EPrim (Prim.String s), _)), _) =>
+                    (L.EApp ((L.ECApp (
+                              (L.ECApp ((L.EFfi ("Basis", "cdata"), _),
+                                        _), _),
+                              _), _),
+                             (L.EPrim (Prim.String s), _)), _) =>
                     if CharVector.all Char.isSpace s then
                         (L'.EStrcat (tagStart, (L'.EPrim (Prim.String "/>"), loc)), loc)
                     else
@@ -243,6 +244,14 @@ fun monoExp env (all as (e, loc)) =
                   | _ => normal ()
             end
 
+          | L.EApp ((L.ECApp (
+                     (L.ECApp ((L.EFfi ("Basis", "lform"), _), _), _),
+                     _), _),
+                    xml) =>
+            (L'.EStrcat ((L'.EPrim (Prim.String "<form>"), loc),
+                         (L'.EStrcat (monoExp env xml,
+                                      (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc)
+
           | L.EApp (e1, e2) => (L'.EApp (monoExp env e1, monoExp env e2), loc)
           | L.EAbs (x, dom, ran, e) =>
             (L'.EAbs (x, monoType env dom, monoType env ran, monoExp (Env.pushERel env x dom) e), loc)