Mercurial > urweb
changeset 823:669ac5e9a69e
Demo compiles with pattern-matching-fu
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 28 May 2009 10:35:25 -0400 |
| parents | d4e811beb8eb |
| children | be0988e46336 |
| files | demo/batchFun.ur demo/crud.ur demo/crud2.ur demo/crud3.ur demo/list.ur demo/metaform.ur demo/sum.ur demo/tcSum.ur demo/view.ur src/monoize.sml src/reduce.sml src/urweb.grm |
| diffstat | 12 files changed, 38 insertions(+), 31 deletions(-) [+] |
line wrap: on
line diff
--- a/demo/batchFun.ur Thu May 28 10:16:50 2009 -0400 +++ b/demo/batchFun.ur Thu May 28 10:35:25 2009 -0400 @@ -8,7 +8,7 @@ ReadState : t_state.2 -> transaction t_state.1} con colsMeta = fn cols :: {(Type * Type)} => $(map colMeta cols) -fun default (t ::: Type) (sh : show t) (rd : read t) (inj : sql_injectable t) +fun default [t] (sh : show t) (rd : read t) (inj : sql_injectable t) name : colMeta (t, source string) = {Nam = name, Show = txt, @@ -49,7 +49,7 @@ (foldR2 [fst] [colMeta] [fn cols => $(map (fn t :: (Type * Type) => sql_exp [] [] [] t.1) cols)] - (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) + (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] input col acc => acc ++ {nm = @sql_inject col.Inject input}) {} [M.cols] M.fl (r -- #Id) M.cols @@ -74,7 +74,7 @@ <tr> <td>{[r.Id]}</td> {foldRX2 [colMeta] [fst] [_] - (fn (nm :: Name) (p :: (Type * Type)) (rest :: {(Type * Type)}) + (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] m v => <xml><td>{m.Show v}</td></xml>) [M.cols] M.fl M.cols (r -- #Id)} @@ -90,7 +90,7 @@ <tr> <th>Id</th> {foldRX [colMeta] [_] - (fn (nm :: Name) (p :: (Type * Type)) (rest :: {(Type * Type)}) + (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] m => <xml><th>{[m.Nam]}</th></xml>) [M.cols] M.fl M.cols} @@ -105,7 +105,7 @@ id <- source ""; inps <- foldR [colMeta] [fn r => transaction ($(map snd r))] - (fn (nm :: Name) (p :: (Type * Type)) (rest :: {(Type * Type)}) [[nm] ~ rest] m acc => + (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] m acc => s <- m.NewState; r <- acc; return ({nm = s} ++ r)) @@ -116,7 +116,7 @@ fun add () = id <- get id; vs <- foldR2 [colMeta] [snd] [fn r => transaction ($(map fst r))] - (fn (nm :: Name) (p :: (Type * Type)) (rest :: {(Type * Type)}) + (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] m s acc => v <- m.ReadState s; r <- acc; @@ -146,7 +146,7 @@ <table> <tr> <th>Id:</th> <td><ctextbox source={id}/></td> </tr> {foldRX2 [colMeta] [snd] [_] - (fn (nm :: Name) (p :: (Type * Type)) (rest :: {(Type * Type)}) + (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] m s => <xml><tr> <th>{[m.Nam]}:</th> <td>{m.Widget s}</td> </tr></xml>) [M.cols] M.fl M.cols inps}
--- a/demo/crud.ur Thu May 28 10:16:50 2009 -0400 +++ b/demo/crud.ur Thu May 28 10:35:25 2009 -0400 @@ -8,12 +8,12 @@ } con colsMeta = fn cols :: {(Type * Type)} => $(map colMeta cols) -fun default (t ::: Type) (sh : show t) (rd : read t) (inj : sql_injectable t) +fun default [t] (sh : show t) (rd : read t) (inj : sql_injectable t) name : colMeta (t, string) = {Nam = name, Show = txt, - Widget = fn nm :: Name => <xml><textbox{nm}/></xml>, - WidgetPopulated = fn (nm :: Name) n => + Widget = fn [nm :: Name] => <xml><textbox{nm}/></xml>, + WidgetPopulated = fn [nm :: Name] n => <xml><textbox{nm} value={show n}/></xml>, Parse = readError, Inject = _} @@ -24,8 +24,8 @@ fun bool name = {Nam = name, Show = txt, - Widget = fn nm :: Name => <xml><checkbox{nm}/></xml>, - WidgetPopulated = fn (nm :: Name) b => + Widget = fn [nm :: Name] => <xml><checkbox{nm}/></xml>, + WidgetPopulated = fn [nm :: Name] b => <xml><checkbox{nm} checked={b}/></xml>, Parse = fn x => x, Inject = _} @@ -53,7 +53,7 @@ <tr> <td>{[fs.T.Id]}</td> {foldRX2 [fst] [colMeta] [tr] - (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) + (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] v col => <xml> <td>{col.Show v}</td> </xml>) @@ -69,7 +69,7 @@ <tr> <th>ID</th> {foldRX [colMeta] [tr] - (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) + (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] col => <xml> <th>{cdata col.Nam}</th> </xml>) @@ -82,7 +82,7 @@ <form> {foldR [colMeta] [fn cols :: {(Type * Type)} => xml form [] (map snd cols)] - (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) + (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] (col : colMeta t) (acc : xml form [] (map snd rest)) => <xml> <li> {cdata col.Nam}: {col.Widget [nm]}</li> {useMore acc} @@ -100,7 +100,7 @@ (foldR2 [snd] [colMeta] [fn cols => $(map (fn t :: (Type * Type) => sql_exp [] [] [] t.1) cols)] - (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) + (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] => fn input col acc => acc ++ {nm = @sql_inject col.Inject (col.Parse input)}) {} [M.cols] M.fl inputs M.cols @@ -121,7 +121,7 @@ sql_exp [T = [Id = int] ++ map fst M.cols] [] [] t.1) cols)] - (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) + (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] => fn input col acc => acc ++ {nm = @sql_inject col.Inject (col.Parse input)}) @@ -139,7 +139,7 @@ None => return <xml><body>Not found!</body></xml> | Some fs => return <xml><body><form> {foldR2 [fst] [colMeta] [fn cols :: {(Type * Type)} => xml form [] (map snd cols)] - (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) + (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] (v : t.1) (col : colMeta t) (acc : xml form [] (map snd rest)) => <xml>
--- a/demo/crud2.ur Thu May 28 10:16:50 2009 -0400 +++ b/demo/crud2.ur Thu May 28 10:35:25 2009 -0400 @@ -12,13 +12,13 @@ <xml>Ready!</xml> else <xml>Not ready</xml>), - Widget = (fn (nm :: Name) => <xml> + Widget = (fn [nm :: Name] => <xml> <select{nm}> <option>Ready</option> <option>Not ready</option> </select> </xml>), - WidgetPopulated = (fn (nm :: Name) b => <xml> + WidgetPopulated = (fn [nm :: Name] b => <xml> <select{nm}> <option selected={b}>Ready</option> <option selected={not b}>Not ready</option>
--- a/demo/crud3.ur Thu May 28 10:16:50 2009 -0400 +++ b/demo/crud3.ur Thu May 28 10:35:25 2009 -0400 @@ -8,13 +8,13 @@ val cols = {Text = {Nam = "Text", Show = txt, - Widget = (fn (nm :: Name) => <xml> + Widget = (fn [nm :: Name] => <xml> <subform{nm}> <textbox{#A}/> <textbox{#B}/> </subform> </xml>), - WidgetPopulated = (fn (nm :: Name) s => <xml> + WidgetPopulated = (fn [nm :: Name] s => <xml> <subform{nm}> <textbox{#A} value={s}/> <textbox{#B}/>
--- a/demo/list.ur Thu May 28 10:16:50 2009 -0400 +++ b/demo/list.ur Thu May 28 10:35:25 2009 -0400 @@ -1,6 +1,6 @@ datatype list t = Nil | Cons of t * list t -fun length (t ::: Type) (ls : list t) = +fun length [t] (ls : list t) = let fun length' (ls : list t) (acc : int) = case ls of @@ -10,7 +10,7 @@ length' ls 0 end -fun rev (t ::: Type) (ls : list t) = +fun rev [t] (ls : list t) = let fun rev' (ls : list t) (acc : list t) = case ls of
--- a/demo/metaform.ur Thu May 28 10:16:50 2009 -0400 +++ b/demo/metaform.ur Thu May 28 10:35:25 2009 -0400 @@ -6,7 +6,7 @@ fun handler values = return <xml><body> {foldURX2 [string] [string] [body] - (fn (nm :: Name) (rest :: {Unit}) [[nm] ~ rest] name value => <xml> + (fn [nm :: Name] [rest :: {Unit}] [[nm] ~ rest] name value => <xml> <li> {[name]} = {[value]}</li> </xml>) [M.fs] M.fl M.names values} @@ -15,7 +15,7 @@ fun main () = return <xml><body> <form> {foldUR [string] [fn cols :: {Unit} => xml form [] (mapU string cols)] - (fn (nm :: Name) (rest :: {Unit}) [[nm] ~ rest] name + (fn [nm :: Name] [rest :: {Unit}] [[nm] ~ rest] name (acc : xml form [] (mapU string rest)) => <xml> <li> {[name]}: <textbox{nm}/></li> {useMore acc}
--- a/demo/sum.ur Thu May 28 10:16:50 2009 -0400 +++ b/demo/sum.ur Thu May 28 10:35:25 2009 -0400 @@ -1,6 +1,6 @@ -fun sum (fs ::: {Unit}) (fl : folder fs) (x : $(mapU int fs)) = +fun sum [fs ::: {Unit}] (fl : folder fs) (x : $(mapU int fs)) = foldUR [int] [fn _ => int] - (fn (nm :: Name) (rest :: {Unit}) [[nm] ~ rest] n acc => n + acc) + (fn [nm :: Name] [rest :: {Unit}] [[nm] ~ rest] n acc => n + acc) 0 [fs] fl x fun main () = return <xml><body>
--- a/demo/tcSum.ur Thu May 28 10:16:50 2009 -0400 +++ b/demo/tcSum.ur Thu May 28 10:35:25 2009 -0400 @@ -1,6 +1,6 @@ -fun sum (t ::: Type) (_ : num t) (fs ::: {Unit}) (fl : folder fs) (x : $(mapU t fs)) = +fun sum [t] (_ : num t) [fs ::: {Unit}] (fl : folder fs) (x : $(mapU t fs)) = foldUR [t] [fn _ => t] - (fn (nm :: Name) (rest :: {Unit}) [[nm] ~ rest] n acc => n + acc) + (fn [nm :: Name] [rest :: {Unit}] [[nm] ~ rest] n acc => n + acc) zero [fs] fl x fun main () = return <xml><body>
--- a/demo/view.ur Thu May 28 10:16:50 2009 -0400 +++ b/demo/view.ur Thu May 28 10:35:25 2009 -0400 @@ -1,7 +1,7 @@ table t : { A : int } view v = SELECT t.A AS A FROM t WHERE t.A > 7 -fun list (u ::: Type) (_ : fieldsOf u [A = int]) (title : string) (x : u) = +fun list [u] (_ : fieldsOf u [A = int]) (title : string) (x : u) = xml <- queryX (SELECT * FROM x) (fn r : {X : {A : int}} => <xml><li>{[r.X.A]}</li></xml>); return <xml>
--- a/src/monoize.sml Thu May 28 10:16:50 2009 -0400 +++ b/src/monoize.sml Thu May 28 10:35:25 2009 -0400 @@ -148,6 +148,8 @@ (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_table"), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CFfi ("Basis", "sql_view"), _), _) => + (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "sql_sequence") => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query"), _), _), _), _) =>
--- a/src/reduce.sml Thu May 28 10:16:50 2009 -0400 +++ b/src/reduce.sml Thu May 28 10:35:25 2009 -0400 @@ -390,6 +390,9 @@ | _ => default () end + | ECase (_, [((PRecord [], _), e)], _) => exp env e + | ECase (_, [((PWild, _), e)], _) => exp env e + | ECase (e, pes, {disc, result}) => let fun patBinds (p, _) =
--- a/src/urweb.grm Thu May 28 10:16:50 2009 -0400 +++ b/src/urweb.grm Thu May 28 10:35:25 2009 -0400 @@ -985,6 +985,7 @@ val e' = case #1 patS of PVar x => (EAbs (x, NONE, e), loc) + | PAnnot ((PVar x, _), t) => (EAbs (x, SOME t, e), loc) | _ => (EAbs ("$x", SOME pt, (ECase ((EVar ([], "$x", DontInfer), loc), @@ -1001,6 +1002,7 @@ val e' = case #1 pterm of PVar x => (EAbs (x, NONE, e), loc) + | PAnnot ((PVar x, _), t) => (EAbs (x, SOME t, e), loc) | _ => (EAbs ("$x", SOME pt, (ECase ((EVar ([], "$x", DontInfer), loc),