# HG changeset patch
# User Adam Chlipala <adamc@hcoop.net>
# Date 1256048340 14400
# Node ID 1d456a06ea4e3d50522defdd7d227124c568f8ca
# Parent  5d7e05b4a5c0ec2ed85c2f89eae7ea666993f175
Add tuple pattern-matching at the constructor level

diff -r 5d7e05b4a5c0 -r 1d456a06ea4e demo/more/conference.ur
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/demo/more/conference.ur	Tue Oct 20 10:19:00 2009 -0400
@@ -0,0 +1,33 @@
+con reviewMeta = fn (db :: Type, widget :: Type) =>
+                    {Show : db -> xbody,
+                     Widget : nm :: Name -> xml form [] [nm = widget],
+                     WidgetPopulated : nm :: Name -> db -> xml form [] [nm = widget],
+                     Parse : widget -> db,
+                     Inject : sql_injectable db}
+
+fun default [t] (sh : show t) (rd : read t) (inj : sql_injectable t) : reviewMeta (t, string) =
+    {Show = txt,
+     Widget = fn [nm :: Name] => <xml><textbox{nm}/></xml>,
+     WidgetPopulated = fn [nm :: Name] n =>
+                          <xml><textbox{nm} value={show n}/></xml>,
+     Parse = readError,
+     Inject = _}
+
+val int = default
+val float = default
+val string = default
+val bool = {Show = txt,
+            Widget = fn [nm :: Name] => <xml><checkbox{nm}/></xml>,
+            WidgetPopulated = fn [nm :: Name] b =>
+                                 <xml><checkbox{nm} checked={b}/></xml>,
+            Parse = fn x => x,
+            Inject = _}
+
+functor Make(M : sig
+                 con review :: {(Type * Type)}
+                 val review : $(map reviewMeta review)
+             end) = struct
+
+    fun main () = return <xml/>
+
+end
diff -r 5d7e05b4a5c0 -r 1d456a06ea4e demo/more/conference.urp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/demo/more/conference.urp	Tue Oct 20 10:19:00 2009 -0400
@@ -0,0 +1,2 @@
+
+conference
diff -r 5d7e05b4a5c0 -r 1d456a06ea4e demo/more/conference.urs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/demo/more/conference.urs	Tue Oct 20 10:19:00 2009 -0400
@@ -0,0 +1,20 @@
+con reviewMeta = fn (db :: Type, widget :: Type) =>
+                    {Show : db -> xbody,
+                     Widget : nm :: Name -> xml form [] [nm = widget],
+                     WidgetPopulated : nm :: Name -> db -> xml form [] [nm = widget],
+                     Parse : widget -> db,
+                     Inject : sql_injectable db}
+
+val int : reviewMeta (int, string)
+val float : reviewMeta (float, string)
+val string : reviewMeta (string, string)
+val bool : reviewMeta (bool, bool)
+
+functor Make(M : sig
+                 con review :: {(Type * Type)}
+                 val review : $(map reviewMeta review)
+             end) : sig
+
+    val main : unit -> transaction page
+
+end
diff -r 5d7e05b4a5c0 -r 1d456a06ea4e src/urweb.grm
--- a/src/urweb.grm	Thu Oct 15 14:27:38 2009 -0400
+++ b/src/urweb.grm	Tue Oct 20 10:19:00 2009 -0400
@@ -242,6 +242,8 @@
  | csts of exp
  | cstopt of exp
 
+ | ckl of (string * kind option) list
+
  | pmode of prop_kind * exp
  | pkind of prop_kind
  | prule of exp
@@ -847,14 +849,35 @@
                                                 ((CAbs ("_", NONE, c), loc),
                                                  (KArrow ((KWild, loc), k), loc))
                                             end)
-       | LPAREN SYMBOL DCOLON kind RPAREN (fn (c, k) =>
+       | LPAREN SYMBOL kopt ckl RPAREN (fn (c, k) =>
                                               let
                                                   val loc = s (LPARENleft, RPARENright)
+                                                  val ckl = (SYMBOL, kopt) :: ckl
+                                                  val ckl = map (fn (x, ko) => (x, case ko of
+                                                                                       NONE => (KWild, loc)
+                                                                                     | SOME k => k)) ckl
                                               in
-                                                  ((CAbs (SYMBOL, SOME kind, c), loc),
-                                                   (KArrow (kind, k), loc))
+                                                  case ckl of
+                                                      [(x, k')] => ((CAbs (SYMBOL, SOME k', c), loc),
+                                                                    (KArrow (k', k), loc))
+                                                    | _ =>
+                                                      let
+                                                          val k' = (KTuple (map #2 ckl), loc)
+
+                                                          val c = foldr (fn ((x, k), c) =>
+                                                                            (CAbs (x, SOME k, c), loc)) c ckl
+                                                          val v = (CVar ([], "$x"), loc)
+                                                          val c = ListUtil.foldli (fn (i, _, c) =>
+                                                                                      (CApp (c, (CProj (v, i + 1), loc)),
+                                                                                       loc)) c ckl
+                                                      in
+                                                          ((CAbs ("$x", SOME k', c), loc),
+                                                           (KArrow (k', k), loc))
+                                                      end
                                               end)
 
+ckl    :                                ([])
+       | COMMA SYMBOL kopt ckl          ((SYMBOL, kopt) :: ckl)
 
 path   : SYMBOL                         ([], SYMBOL)
        | CSYMBOL DOT path               (let val (ms, x) = path in (CSYMBOL :: ms, x) end)