Add tuple pattern-matching at the constructor level

4 files changed, 81 insertions, 3 deletions

diff --git a/demo/more/conference.ur b/demo/more/conference.ur
new file mode 100644
index 00000000..a028bc41
--- /dev/null
+++ b/demo/more/conference.ur
@@ -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 --git a/demo/more/conference.urp b/demo/more/conference.urp
new file mode 100644
index 00000000..399721d4
--- /dev/null
+++ b/demo/more/conference.urp
@@ -0,0 +1,2 @@
+
+conference
diff --git a/demo/more/conference.urs b/demo/more/conference.urs
new file mode 100644
index 00000000..696b8b32
--- /dev/null
+++ b/demo/more/conference.urs
@@ -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 --git a/src/urweb.grm b/src/urweb.grm
index edd93d96..38d7d60d 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -242,6 +242,8 @@ fun patType loc (p : pat) =
  | 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 @@ cargp  : SYMBOL                         (fn (c, k) =>
                                                 ((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)