changeset 153:cfe6f9db74aa

radio and radioOption
author Adam Chlipala <adamc@hcoop.net>
date Thu, 24 Jul 2008 11:10:23 -0400
parents 67ab26888839
children e2b185379592
files lib/basis.lig src/elaborate.sml src/monoize.sml tests/radio.lac
diffstat 4 files changed, 86 insertions(+), 30 deletions(-) [+]
line wrap: on
line diff
--- a/lib/basis.lig	Thu Jul 24 10:41:53 2008 -0400
+++ b/lib/basis.lig	Thu Jul 24 11:10:23 2008 -0400
@@ -61,12 +61,16 @@
 val lform : ctx ::: {Unit} -> [Body] ~ ctx -> bind ::: {Type}
         -> xml lform [] bind
         -> xml ([Body] ++ ctx) [] []
-con lformTag = fn ty :: Type => fn attrs :: {Type} =>
+con lformTag = fn ty :: Type => fn inner :: {Unit} => fn attrs :: {Type} =>
         ctx ::: {Unit} -> [LForm] ~ ctx
         -> nm :: Name -> unit
-        -> tag attrs ([LForm] ++ ctx) [] [] [nm = ty]
-val textbox : lformTag string []
-val ltextarea : lformTag string []
+        -> tag attrs ([LForm] ++ ctx) inner [] [nm = ty]
+val textbox : lformTag string [] []
+val ltextarea : lformTag string [] []
+
+con radio = [Body, Radio]
+val radio : lformTag string radio []
+val radioOption : unit -> tag [Value = string] radio [] [] []
 
 val submit : ctx ::: {Unit} -> [LForm] ~ ctx
         -> use ::: {Type} -> unit
--- a/src/elaborate.sml	Thu Jul 24 10:41:53 2008 -0400
+++ b/src/elaborate.sml	Thu Jul 24 11:10:23 2008 -0400
@@ -445,7 +445,7 @@
        | CIncompatible of L'.con * L'.con
        | CExplicitness of L'.con * L'.con
        | CKindof of L'.kind * L'.con
-       | CRecordFailure
+       | CRecordFailure of PD.pp_desc * PD.pp_desc
 
 exception CUnify' of cunify_error
 
@@ -472,8 +472,10 @@
         eprefaces "Unexpected kind for kindof calculation"
                   [("Kind", p_kind k),
                    ("Con", p_con env c)]
-      | CRecordFailure =>
-        eprefaces "Can't unify record constructors" []
+      | CRecordFailure (s1, s2) =>
+        eprefaces "Can't unify record constructors"
+        [("Summary 1", s1),
+         ("Summary 2", s2)]
 
 exception SynUnif = E.SynUnif
 
@@ -677,12 +679,12 @@
                 if clear then
                     List.app (fn (_, r) => r := SOME empty) unifs2
                 else
-                    raise CUnify' CRecordFailure
+                    raise CUnify' (CRecordFailure (p_summary env s1, p_summary env s2))
               | (_, []) =>
                 if clear then
                     List.app (fn (_, r) => r := SOME empty) unifs1
                 else
-                    raise CUnify' CRecordFailure
+                    raise CUnify' (CRecordFailure (p_summary env s1, p_summary env s2))
               | ((c1, _) :: rest1, (_, r2) :: rest2) =>
                 (r2 := SOME c1;
                  pairOffUnifs (rest1, rest2))
--- a/src/monoize.sml	Thu Jul 24 10:41:53 2008 -0400
+++ b/src/monoize.sml	Thu Jul 24 11:10:23 2008 -0400
@@ -130,7 +130,28 @@
        | NotFound
        | Error
 
-fun monoExp env (all as (e, loc)) =
+structure St :> sig
+    type t
+
+    val empty : t
+
+    val radioGroup : t -> string option
+    val setRadioGroup : t * string -> t
+end = struct
+
+type t = {
+     radioGroup : string option
+}
+
+val empty = {radioGroup = NONE}
+
+fun radioGroup (t : t) = #radioGroup t
+
+fun setRadioGroup (t : t, x) = {radioGroup = SOME x}
+
+end
+
+fun monoExp (env, st) (all as (e, loc)) =
     let
         fun poly () =
             (E.errorAt loc "Unsupported expression";
@@ -142,13 +163,13 @@
           | L.ERel n => (L'.ERel n, loc)
           | L.ENamed n => (L'.ENamed n, loc)
           | L.EFfi mx => (L'.EFfi mx, loc)
-          | L.EFfiApp (m, x, es) => (L'.EFfiApp (m, x, map (monoExp env) es), loc)
+          | L.EFfiApp (m, x, es) => (L'.EFfiApp (m, x, map (monoExp (env, st)) es), loc)
 
           | L.EApp (
             (L.ECApp (
              (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _),
              _), _),
-            se) => (L'.EFfiApp ("Basis", "htmlifyString", [monoExp env se]), loc)
+            se) => (L'.EFfiApp ("Basis", "htmlifyString", [monoExp (env, st) se]), loc)
           | L.EApp (
             (L.EApp (
              (L.ECApp (
@@ -161,7 +182,7 @@
                _), _),
               _), _),
              xml1), _),
-            xml2) => (L'.EStrcat (monoExp env xml1, monoExp env xml2), loc)
+            xml2) => (L'.EStrcat (monoExp (env, st) xml1, monoExp (env, st) xml2), loc)
 
           | L.EApp (
             (L.EApp (
@@ -202,7 +223,7 @@
 
                 val (tag, targs) = getTag tag
 
-                val attrs = monoExp env attrs
+                val attrs = monoExp (env, st) attrs
 
                 fun tagStart tag =
                     case #1 attrs of
@@ -243,7 +264,7 @@
                                      (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\"/>")),
                                       loc)), loc)
                       | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
-                              raise Fail "No named passed to input tag")
+                              raise Fail "No name passed to input tag")
 
                 fun normal (tag, extra) =
                     let
@@ -254,7 +275,7 @@
 
                         fun normal () =
                             (L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc),
-                                         (L'.EStrcat (monoExp env xml,
+                                         (L'.EStrcat (monoExp (env, st) xml,
                                                       (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])),
                                                        loc)), loc)),
                              loc)
@@ -282,18 +303,31 @@
                                       (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\"/>")),
                                        loc)), loc)
                        | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
-                               raise Fail "No named passed to textarea tag"))
+                               raise Fail "No name passed to textarea tag"))
                   | "ltextarea" =>
                     (case targs of
                          [_, (L.CName name, _)] =>
                          (L'.EStrcat ((L'.EStrcat (tagStart "textarea",
                                                    (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc),
-                                      (L'.EStrcat (monoExp env xml,
+                                      (L'.EStrcat (monoExp (env, st) xml,
                                                    (L'.EPrim (Prim.String "</textarea>"),
                                                     loc)), loc)),
                           loc)
                        | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
-                               raise Fail "No named passed to ltextarea tag"))
+                               raise Fail "No name passed to ltextarea tag"))
+
+                  | "radio" =>
+                    (case targs of
+                         [_, (L.CName name, _)] =>
+                         monoExp (env, St.setRadioGroup (st, name)) xml
+                       | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs);
+                               raise Fail "No name passed to radio tag"))
+                  | "radioOption" =>
+                    (case St.radioGroup st of
+                         NONE => raise Fail "No name for radioGroup"
+                       | SOME name =>
+                         normal ("input",
+                                 SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc)))
 
                   | _ => normal (tag, NONE)
             end
@@ -358,12 +392,12 @@
                   | Found et => et
 
                 val actionT = monoType env actionT
-                val action = monoExp env action
+                val action = monoExp (env, st) action
             in
                 (L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form action=\""), loc),
                                           (L'.EStrcat (urlifyExp env (action, actionT),
                                                        (L'.EPrim (Prim.String "\">"), loc)), loc)), loc),
-                             (L'.EStrcat (monoExp env xml,
+                             (L'.EStrcat (monoExp (env, st) xml,
                                           (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc)
             end
 
@@ -375,22 +409,24 @@
                        _), _),
                       _), _),
                      _), _),
-                    xml) => monoExp env xml
+                    xml) => monoExp (env, st) xml
                      
 
-          | L.EApp (e1, e2) => (L'.EApp (monoExp env e1, monoExp env e2), loc)
+          | L.EApp (e1, e2) => (L'.EApp (monoExp (env, st) e1, monoExp (env, st) 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)
+            (L'.EAbs (x, monoType env dom, monoType env ran, monoExp (Env.pushERel env x dom, st) e), loc)
           | L.ECApp _ => poly ()
           | L.ECAbs _ => poly ()
 
-          | L.ERecord xes => (L'.ERecord (map (fn (x, e, t) => (monoName env x, monoExp env e, monoType env t)) xes), loc)
-          | L.EField (e, x, _) => (L'.EField (monoExp env e, monoName env x), loc)
+          | L.ERecord xes => (L'.ERecord (map (fn (x, e, t) => (monoName env x,
+                                                                monoExp (env, st) e,
+                                                                monoType env t)) xes), loc)
+          | L.EField (e, x, _) => (L'.EField (monoExp (env, st) e, monoName env x), loc)
           | L.ECut _ => poly ()
           | L.EFold _ => poly ()
-          | L.EWrite e => (L'.EWrite (monoExp env e), loc)
+          | L.EWrite e => (L'.EWrite (monoExp (env, st) e), loc)
 
-          | L.EClosure (n, es) => (L'.EClosure (n, map (monoExp env) es), loc)
+          | L.EClosure (n, es) => (L'.EClosure (n, map (monoExp (env, st)) es), loc)
     end
 
 fun monoDecl env (all as (d, loc)) =
@@ -403,13 +439,14 @@
         case d of
             L.DCon _ => NONE
           | L.DVal (x, n, t, e, s) => SOME (Env.pushENamed env x n t (SOME e) s,
-                                            (L'.DVal (x, n, monoType env t, monoExp env e, s), loc))
+                                            (L'.DVal (x, n, monoType env t, monoExp (env, St.empty) e, s), loc))
           | L.DValRec vis =>
             let
                 val env = foldl (fn ((x, n, t, e, s), env) => Env.pushENamed env x n t NONE s) env vis
             in
                 SOME (env,
-                      (L'.DValRec (map (fn (x, n, t, e, s) => (x, n, monoType env t, monoExp env e, s)) vis), loc))
+                      (L'.DValRec (map (fn (x, n, t, e, s) => (x, n, monoType env t,
+                                                               monoExp (env, St.empty) e, s)) vis), loc))
             end
           | L.DExport (ek, n) =>
             let
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/radio.lac	Thu Jul 24 11:10:23 2008 -0400
@@ -0,0 +1,13 @@
+val handler = fn x => <html><body>
+        You entered: {cdata x.A}
+</body></html>
+
+val main = fn () => <html><body>
+        <lform>
+                <radio{#A}>
+                        <li> <radioOption value="A"/>A</li>
+                        <li> <radioOption value="B"/>B</li>
+                </radio>
+                <submit action={handler}/>
+        </lform>
+</body></html>