Mercurial > urweb

comparison demo/crud.ur @ 823:669ac5e9a69e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Demo compiles with pattern-matching-fu
author Adam Chlipala <adamc@hcoop.net>
date Thu, 28 May 2009 10:35:25 -0400
parents 5819fb63c93a
children 74e9e7642f08
comparison
equal deleted inserted replaced
822:d4e811beb8eb 823:669ac5e9a69e
6 Parse : t_formT.2 -> t_formT.1, 6 Parse : t_formT.2 -> t_formT.1,
7 Inject : sql_injectable t_formT.1 7 Inject : sql_injectable t_formT.1
8 } 8 }
9 con colsMeta = fn cols :: {(Type * Type)} => $(map colMeta cols) 9 con colsMeta = fn cols :: {(Type * Type)} => $(map colMeta cols)
10 10
11 fun default (t ::: Type) (sh : show t) (rd : read t) (inj : sql_injectable t) 11 fun default [t] (sh : show t) (rd : read t) (inj : sql_injectable t)
12 name : colMeta (t, string) = 12 name : colMeta (t, string) =
13 {Nam = name, 13 {Nam = name,
14 Show = txt, 14 Show = txt,
15 Widget = fn nm :: Name => <xml><textbox{nm}/></xml>, 15 Widget = fn [nm :: Name] => <xml><textbox{nm}/></xml>,
16 WidgetPopulated = fn (nm :: Name) n => 16 WidgetPopulated = fn [nm :: Name] n =>
17 <xml><textbox{nm} value={show n}/></xml>, 17 <xml><textbox{nm} value={show n}/></xml>,
18 Parse = readError, 18 Parse = readError,
19 Inject = _} 19 Inject = _}
20 20
21 val int = default 21 val int = default
22 val float = default 22 val float = default
23 val string = default 23 val string = default
24 24
25 fun bool name = {Nam = name, 25 fun bool name = {Nam = name,
26 Show = txt, 26 Show = txt,
27 Widget = fn nm :: Name => <xml><checkbox{nm}/></xml>, 27 Widget = fn [nm :: Name] => <xml><checkbox{nm}/></xml>,
28 WidgetPopulated = fn (nm :: Name) b => 28 WidgetPopulated = fn [nm :: Name] b =>
29 <xml><checkbox{nm} checked={b}/></xml>, 29 <xml><checkbox{nm} checked={b}/></xml>,
30 Parse = fn x => x, 30 Parse = fn x => x,
31 Inject = _} 31 Inject = _}
32 32
33 functor Make(M : sig 33 functor Make(M : sig
51 rows <- queryX (SELECT * FROM tab AS T) 51 rows <- queryX (SELECT * FROM tab AS T)
52 (fn (fs : {T : $([Id = int] ++ map fst M.cols)}) => <xml> 52 (fn (fs : {T : $([Id = int] ++ map fst M.cols)}) => <xml>
53 <tr> 53 <tr>
54 <td>{[fs.T.Id]}</td> 54 <td>{[fs.T.Id]}</td>
55 {foldRX2 [fst] [colMeta] [tr] 55 {foldRX2 [fst] [colMeta] [tr]
56 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) 56 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
57 [[nm] ~ rest] v col => <xml> 57 [[nm] ~ rest] v col => <xml>
58 <td>{col.Show v}</td> 58 <td>{col.Show v}</td>
59 </xml>) 59 </xml>)
60 [M.cols] M.fl (fs.T -- #Id) M.cols} 60 [M.cols] M.fl (fs.T -- #Id) M.cols}
61 <td> 61 <td>
67 return <xml> 67 return <xml>
68 <table border={1}> 68 <table border={1}>
69 <tr> 69 <tr>
70 <th>ID</th> 70 <th>ID</th>
71 {foldRX [colMeta] [tr] 71 {foldRX [colMeta] [tr]
72 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) 72 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
73 [[nm] ~ rest] col => <xml> 73 [[nm] ~ rest] col => <xml>
74 <th>{cdata col.Nam}</th> 74 <th>{cdata col.Nam}</th>
75 </xml>) 75 </xml>)
76 [M.cols] M.fl M.cols} 76 [M.cols] M.fl M.cols}
77 </tr> 77 </tr>
80 80
81 <br/><hr/><br/> 81 <br/><hr/><br/>
82 82
83 <form> 83 <form>
84 {foldR [colMeta] [fn cols :: {(Type * Type)} => xml form [] (map snd cols)] 84 {foldR [colMeta] [fn cols :: {(Type * Type)} => xml form [] (map snd cols)]
85 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) 85 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
86 [[nm] ~ rest] (col : colMeta t) (acc : xml form [] (map snd rest)) => <xml> 86 [[nm] ~ rest] (col : colMeta t) (acc : xml form [] (map snd rest)) => <xml>
87 <li> {cdata col.Nam}: {col.Widget [nm]}</li> 87 <li> {cdata col.Nam}: {col.Widget [nm]}</li>
88 {useMore acc} 88 {useMore acc}
89 </xml>) 89 </xml>)
90 <xml/> 90 <xml/>
98 id <- nextval seq; 98 id <- nextval seq;
99 dml (insert tab 99 dml (insert tab
100 (foldR2 [snd] [colMeta] 100 (foldR2 [snd] [colMeta]
101 [fn cols => $(map (fn t :: (Type * Type) => 101 [fn cols => $(map (fn t :: (Type * Type) =>
102 sql_exp [] [] [] t.1) cols)] 102 sql_exp [] [] [] t.1) cols)]
103 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) 103 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
104 [[nm] ~ rest] => 104 [[nm] ~ rest] =>
105 fn input col acc => acc ++ {nm = @sql_inject col.Inject (col.Parse input)}) 105 fn input col acc => acc ++ {nm = @sql_inject col.Inject (col.Parse input)})
106 {} [M.cols] M.fl inputs M.cols 106 {} [M.cols] M.fl inputs M.cols
107 ++ {Id = (SQL {[id]})})); 107 ++ {Id = (SQL {[id]})}));
108 ls <- list (); 108 ls <- list ();
119 (foldR2 [snd] [colMeta] 119 (foldR2 [snd] [colMeta]
120 [fn cols => $(map (fn t :: (Type * Type) => 120 [fn cols => $(map (fn t :: (Type * Type) =>
121 sql_exp [T = [Id = int] 121 sql_exp [T = [Id = int]
122 ++ map fst M.cols] 122 ++ map fst M.cols]
123 [] [] t.1) cols)] 123 [] [] t.1) cols)]
124 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) 124 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
125 [[nm] ~ rest] => 125 [[nm] ~ rest] =>
126 fn input col acc => acc ++ {nm = 126 fn input col acc => acc ++ {nm =
127 @sql_inject col.Inject (col.Parse input)}) 127 @sql_inject col.Inject (col.Parse input)})
128 {} [M.cols] M.fl inputs M.cols) 128 {} [M.cols] M.fl inputs M.cols)
129 tab (WHERE T.Id = {[id]})); 129 tab (WHERE T.Id = {[id]}));
137 fso <- oneOrNoRows (SELECT tab.{{map fst M.cols}} FROM tab WHERE tab.Id = {[id]}); 137 fso <- oneOrNoRows (SELECT tab.{{map fst M.cols}} FROM tab WHERE tab.Id = {[id]});
138 case fso : (Basis.option {Tab : $(map fst M.cols)}) of 138 case fso : (Basis.option {Tab : $(map fst M.cols)}) of
139 None => return <xml><body>Not found!</body></xml> 139 None => return <xml><body>Not found!</body></xml>
140 | Some fs => return <xml><body><form> 140 | Some fs => return <xml><body><form>
141 {foldR2 [fst] [colMeta] [fn cols :: {(Type * Type)} => xml form [] (map snd cols)] 141 {foldR2 [fst] [colMeta] [fn cols :: {(Type * Type)} => xml form [] (map snd cols)]
142 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) 142 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
143 [[nm] ~ rest] (v : t.1) (col : colMeta t) 143 [[nm] ~ rest] (v : t.1) (col : colMeta t)
144 (acc : xml form [] (map snd rest)) => 144 (acc : xml form [] (map snd rest)) =>
145 <xml> 145 <xml>
146 <li> {cdata col.Nam}: {col.WidgetPopulated [nm] v}</li> 146 <li> {cdata col.Nam}: {col.WidgetPopulated [nm] v}</li>
147 {useMore acc} 147 {useMore acc}