summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-10-20 10:19:00 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-10-20 10:19:00 -0400
commitaece9fdadf1bdfbf069cc5ac5ab397eef1e3f2ad (patch)
tree800ab89ca52c3ef6e7df0f9420292131459f0e47
parente177d0dd0db2639bd056e81296f2f0f5c930ad5f (diff)
Add tuple pattern-matching at the constructor level
-rw-r--r--demo/more/conference.ur33
-rw-r--r--demo/more/conference.urp2
-rw-r--r--demo/more/conference.urs20
-rw-r--r--src/urweb.grm29
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)