Mercurial > urweb
comparison tests/crud.ur @ 369:226c977faa9c
Crud indented properly, except for <xml>...</xml> outside parens and sig/struct
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Thu, 16 Oct 2008 14:40:28 -0400 |
parents | b6be16792584 |
children | 4f75cc2e1373 |
comparison
equal
deleted
inserted
replaced
368:b6be16792584 | 369:226c977faa9c |
---|---|
1 con colMeta = fn t_formT :: (Type * Type) => { | 1 con colMeta = fn t_formT :: (Type * Type) => { |
2 Nam : string, | 2 Nam : string, |
3 Show : t_formT.1 -> xbody, | 3 Show : t_formT.1 -> xbody, |
4 Widget : nm :: Name -> xml form [] [nm = t_formT.2], | 4 Widget : nm :: Name -> xml form [] [nm = t_formT.2], |
5 WidgetPopulated : nm :: Name -> t_formT.1 -> xml form [] [nm = t_formT.2], | 5 WidgetPopulated : nm :: Name -> t_formT.1 -> xml form [] [nm = t_formT.2], |
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)} => $(Top.mapT2T colMeta cols) | 9 con colsMeta = fn cols :: {(Type * Type)} => $(Top.mapT2T colMeta cols) |
10 | 10 |
11 fun default (t ::: Type) (sh : show t) (rd : read t) (inj : sql_injectable t) | 11 fun default (t ::: Type) (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 _,e | 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 _ _ _ |
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 |
34 con cols :: {(Type * Type)} | 34 con cols :: {(Type * Type)} |
35 constraint [Id] ~ cols | 35 constraint [Id] ~ cols |
36 val tab : sql_table ([Id = int] ++ mapT2T fstTT cols) | 36 val tab : sql_table ([Id = int] ++ mapT2T fstTT cols) |
37 | 37 |
38 val title : string | 38 val title : string |
39 | 39 |
40 val cols : colsMeta cols | 40 val cols : colsMeta cols |
41 end) = struct | 41 end) = struct |
42 | 42 |
43 open constraints M | 43 open constraints M |
44 val tab = M.tab | 44 val tab = M.tab |
45 | 45 |
46 sequence seq | 46 sequence seq |
62 | 62 |
63 fun save (id : int) (inputs : $(mapT2T sndTT M.cols)) = | 63 fun save (id : int) (inputs : $(mapT2T sndTT M.cols)) = |
64 () <- dml (update [mapT2T fstTT M.cols] | 64 () <- dml (update [mapT2T fstTT M.cols] |
65 (foldT2R2 [sndTT] [colMeta] | 65 (foldT2R2 [sndTT] [colMeta] |
66 [fn cols => $(mapT2T (fn t :: (Type * Type) => | 66 [fn cols => $(mapT2T (fn t :: (Type * Type) => |
67 sql_exp [T = [Id = int] ++ mapT2T fstTT M.cols] [] [] t.1) cols)] | 67 sql_exp [T = [Id = int] |
68 ++ mapT2T fstTT M.cols] | |
69 [] [] t.1) cols)] | |
68 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) | 70 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) |
69 [[nm] ~ rest] => | 71 [[nm] ~ rest] => |
70 fn input col acc => acc with nm = sql_inject col.Inject (col.Parse input)) | 72 fn input col acc => acc with nm = |
73 sql_inject col.Inject (col.Parse input)) | |
71 {} [M.cols] inputs M.cols) | 74 {} [M.cols] inputs M.cols) |
72 tab (WHERE T.Id = {id})); | 75 tab (WHERE T.Id = {id})); |
73 return <xml><body> | 76 return <xml><body> |
74 Saved! | 77 Saved! |
75 </body></xml> | 78 </body></xml> |
77 fun update (id : int) = | 80 fun update (id : int) = |
78 fso <- oneOrNoRows (SELECT tab.{{mapT2T fstTT M.cols}} FROM tab WHERE tab.Id = {id}); | 81 fso <- oneOrNoRows (SELECT tab.{{mapT2T fstTT M.cols}} FROM tab WHERE tab.Id = {id}); |
79 case fso : (Basis.option {Tab : $(mapT2T fstTT M.cols)}) of | 82 case fso : (Basis.option {Tab : $(mapT2T fstTT M.cols)}) of |
80 None => return <xml><body>Not found!</body></xml> | 83 None => return <xml><body>Not found!</body></xml> |
81 | Some fs => return <xml><body><form> | 84 | Some fs => return <xml><body><form> |
82 {foldT2R2 [fstTT] [colMeta] [fn cols :: {(Type * Type)} => xml form [] (mapT2T sndTT cols)] | 85 {foldT2R2 [fstTT] [colMeta] [fn cols :: {(Type * Type)} => xml form [] (mapT2T sndTT cols)] |
83 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) | 86 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) |
84 [[nm] ~ rest] (v : t.1) (col : colMeta t) | 87 [[nm] ~ rest] (v : t.1) (col : colMeta t) |
85 (acc : xml form [] (mapT2T sndTT rest)) => | 88 (acc : xml form [] (mapT2T sndTT rest)) => |
86 <xml> | 89 <xml> |
87 <li> {cdata col.Nam}: {col.WidgetPopulated [nm] v}</li> | 90 <li> {cdata col.Nam}: {col.WidgetPopulated [nm] v}</li> |
88 {useMore acc} | 91 {useMore acc} |
89 </xml>) | 92 </xml>) |
90 <xml/> | 93 <xml/> |
91 [M.cols] fs.Tab M.cols} | 94 [M.cols] fs.Tab M.cols} |
92 | 95 |
93 <submit action={save id}/> | 96 <submit action={save id}/> |
94 </form></body></xml> | 97 </form></body></xml> |
95 | 98 |
96 fun delete (id : int) = | 99 fun delete (id : int) = |
97 () <- dml (DELETE FROM tab WHERE Id = {id}); | 100 () <- dml (DELETE FROM tab WHERE Id = {id}); |
98 return <xml><body> | 101 return <xml><body> |
99 The deed is done. | 102 The deed is done. |
100 </body></xml> | 103 </body></xml> |
101 | 104 |
102 fun confirm (id : int) = return <xml><body> | 105 fun confirm (id : int) = return <xml><body> |
103 <p>Are you sure you want to delete ID #{txt _ id}?</p> | 106 <p>Are you sure you want to delete ID #{txt _ id}?</p> |
104 | 107 |
105 <p><a link={delete id}>I was born sure!</a></p> | 108 <p><a link={delete id}>I was born sure!</a></p> |
106 </body></xml> | 109 </body></xml> |
107 | 110 |
108 fun main () = | 111 fun main () = |
109 rows <- queryX (SELECT * FROM tab AS T) | 112 rows <- queryX (SELECT * FROM tab AS T) |
110 (fn (fs : {T : $([Id = int] ++ mapT2T fstTT M.cols)}) => <xml> | 113 (fn (fs : {T : $([Id = int] ++ mapT2T fstTT M.cols)}) => <xml> |
111 <tr> | 114 <tr> |
112 <td>{txt _ fs.T.Id}</td> | 115 <td>{txt _ fs.T.Id}</td> |
113 {foldT2RX2 [fstTT] [colMeta] [tr] | 116 {foldT2RX2 [fstTT] [colMeta] [tr] |
114 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) | 117 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) |
115 [[nm] ~ rest] v col => <xml> | 118 [[nm] ~ rest] v col => <xml> |
116 <td>{col.Show v}</td> | 119 <td>{col.Show v}</td> |
117 </xml>) | 120 </xml>) |
118 [M.cols] (fs.T -- #Id) M.cols} | 121 [M.cols] (fs.T -- #Id) M.cols} |
119 <td><a link={update fs.T.Id}>[Update]</a> <a link={confirm fs.T.Id}>[Delete]</a></td> | 122 <td> |
120 </tr> | 123 <a link={update fs.T.Id}>[Update]</a> |
121 </xml>); | 124 <a link={confirm fs.T.Id}>[Delete]</a> |
125 </td> | |
126 </tr> | |
127 </xml>); | |
122 return <xml><head> | 128 return <xml><head> |
123 <title>{cdata M.title}</title> | 129 <title>{cdata M.title}</title> |
124 | |
125 </head><body> | 130 </head><body> |
126 | 131 |
127 <h1>{cdata M.title}</h1> | 132 <h1>{cdata M.title}</h1> |
128 | 133 |
129 <table border={1}> | 134 <table border={1}> |
130 <tr> | 135 <tr> |
131 <th>ID</th> | 136 <th>ID</th> |
132 {foldT2RX [colMeta] [tr] | 137 {foldT2RX [colMeta] [tr] |
133 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) | 138 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) |
134 [[nm] ~ rest] col => <xml> | 139 [[nm] ~ rest] col => <xml> |
135 <th>{cdata col.Nam}</th> | 140 <th>{cdata col.Nam}</th> |
136 </xml>) | 141 </xml>) |
137 [M.cols] M.cols} | 142 [M.cols] M.cols} |
138 </tr> | 143 </tr> |
139 {rows} | 144 {rows} |
140 </table> | 145 </table> |
141 | 146 |
142 <br/> | 147 <br/> |
143 | 148 |
144 <form> | 149 <form> |
145 {foldT2R [colMeta] [fn cols :: {(Type * Type)} => xml form [] (mapT2T sndTT cols)] | 150 {foldT2R [colMeta] [fn cols :: {(Type * Type)} => xml form [] (mapT2T sndTT cols)] |
146 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) | 151 (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) |
147 [[nm] ~ rest] (col : colMeta t) (acc : xml form [] (mapT2T sndTT rest)) => <xml> | 152 [[nm] ~ rest] (col : colMeta t) (acc : xml form [] (mapT2T sndTT rest)) => <xml> |
148 <li> {cdata col.Nam}: {col.Widget [nm]}</li> | 153 <li> {cdata col.Nam}: {col.Widget [nm]}</li> |
149 {useMore acc} | 154 {useMore acc} |
150 </xml>) | 155 </xml>) |
151 <xml/> | 156 <xml/> |
152 [M.cols] M.cols} | 157 [M.cols] M.cols} |
153 | 158 |
154 <submit action={create}/> | 159 <submit action={create}/> |
155 </form> | 160 </form> |
156 </body></xml> | 161 </body></xml> |
157 | 162 |
158 end | 163 end |