diff src/monoize.sml @ 153:cfe6f9db74aa

radio and radioOption
author Adam Chlipala <adamc@hcoop.net>
date Thu, 24 Jul 2008 11:10:23 -0400
parents 67ab26888839
children e2b185379592
line wrap: on
line diff
--- 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