Mercurial > urweb
changeset 1001:1d456a06ea4e
Add tuple pattern-matching at the constructor level
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 20 Oct 2009 10:19:00 -0400 |
| parents | 5d7e05b4a5c0 |
| children | bb3fc575cfe7 |
| files | demo/more/conference.ur demo/more/conference.urp demo/more/conference.urs src/urweb.grm |
| diffstat | 4 files changed, 81 insertions(+), 3 deletions(-) [+] |
line wrap: on
line diff
--- /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
--- /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
--- /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
--- 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)