Mercurial > urweb

annotate demo/crud.ur @ 1122:85d194409b17

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Reduce concatenations of the empty record; unpoly non-recursive functions
author Adam Chlipala <adamc@hcoop.net>
date Sun, 10 Jan 2010 13:44:22 -0500
parents 8d3aa6c7cee0
children ad15700272f6
rev   line source
adamc@1002 1 con colMeta = fn (db :: Type, widget :: Type) =>
adamc@1002 2 {Nam : string,
adamc@1002 3 Show : db -> xbody,
adamc@1002 4 Widget : nm :: Name -> xml form [] [nm = widget],
adamc@1002 5 WidgetPopulated : nm :: Name -> db -> xml form [] [nm = widget],
adamc@1002 6 Parse : widget -> db,
adamc@1002 7 Inject : sql_injectable db}
adamc@622 8 con colsMeta = fn cols :: {(Type * Type)} => $(map colMeta cols)
adamc@421 9
adamc@823 10 fun default [t] (sh : show t) (rd : read t) (inj : sql_injectable t)
adamc@421 11 name : colMeta (t, string) =
adamc@421 12 {Nam = name,
adamc@421 13 Show = txt,
adamc@823 14 Widget = fn [nm :: Name] => <xml><textbox{nm}/></xml>,
adamc@823 15 WidgetPopulated = fn [nm :: Name] n =>
adamc@421 16 <xml><textbox{nm} value={show n}/></xml>,
adamc@421 17 Parse = readError,
adamc@421 18 Inject = _}
adamc@421 19
adamc@421 20 val int = default
adamc@421 21 val float = default
adamc@421 22 val string = default
adamc@421 23
adamc@421 24 fun bool name = {Nam = name,
adamc@421 25 Show = txt,
adamc@823 26 Widget = fn [nm :: Name] => <xml><checkbox{nm}/></xml>,
adamc@823 27 WidgetPopulated = fn [nm :: Name] b =>
adamc@421 28 <xml><checkbox{nm} checked={b}/></xml>,
adamc@421 29 Parse = fn x => x,
adamc@421 30 Inject = _}
adamc@421 31
adamc@421 32 functor Make(M : sig
adamc@421 33 con cols :: {(Type * Type)}
adamc@421 34 constraint [Id] ~ cols
adamc@632 35 val fl : folder cols
adamc@632 36
adamc@706 37 table tab : ([Id = int] ++ map fst cols)
adamc@421 38
adamc@421 39 val title : string
adamc@421 40
adamc@421 41 val cols : colsMeta cols
adamc@421 42 end) = struct
adamc@421 43
adamc@421 44 val tab = M.tab
adamc@421 45
adamc@421 46 sequence seq
adamc@421 47
adamc@421 48 fun list () =
adamc@421 49 rows <- queryX (SELECT * FROM tab AS T)
adamc@637 50 (fn (fs : {T : $([Id = int] ++ map fst M.cols)}) => <xml>
adamc@421 51 <tr>
adamc@421 52 <td>{[fs.T.Id]}</td>
adamc@1093 53 {@foldRX2 [fst] [colMeta] [tr]
adamc@1093 54 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@1093 55 [[nm] ~ rest] v col => <xml>
adamc@1093 56 <td>{col.Show v}</td>
adamc@1093 57 </xml>)
adamc@1093 58 M.fl (fs.T -- #Id) M.cols}
adamc@421 59 <td>
adamc@421 60 <a link={upd fs.T.Id}>[Update]</a>
adamc@421 61 <a link={confirm fs.T.Id}>[Delete]</a>
adamc@421 62 </td>
adamc@421 63 </tr>
adamc@421 64 </xml>);
adamc@421 65 return <xml>
adamc@421 66 <table border={1}>
adamc@421 67 <tr>
adamc@421 68 <th>ID</th>
adamc@1093 69 {@foldRX [colMeta] [tr]
adamc@1093 70 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@1093 71 [[nm] ~ rest] col => <xml>
adamc@1093 72 <th>{cdata col.Nam}</th>
adamc@1093 73 </xml>)
adamc@1093 74 M.fl M.cols}
adamc@421 75 </tr>
adamc@421 76 {rows}
adamc@421 77 </table>
adamc@421 78
adamc@421 79 <br/><hr/><br/>
adamc@421 80
adamc@421 81 <form>
adamc@1093 82 {@foldR [colMeta] [fn cols :: {(Type * Type)} => xml form [] (map snd cols)]
adamc@1093 83 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@1093 84 [[nm] ~ rest] (col : colMeta t) (acc : xml form [] (map snd rest)) => <xml>
adamc@1093 85 <li> {cdata col.Nam}: {col.Widget [nm]}</li>
adamc@1093 86 {useMore acc}
adamc@1093 87 </xml>)
adamc@1093 88 <xml/>
adamc@1093 89 M.fl M.cols}
adamc@421 90
adamc@421 91 <submit action={create}/>
adamc@421 92 </form>
adamc@421 93 </xml>
adamc@421 94
adamc@637 95 and create (inputs : $(map snd M.cols)) =
adamc@421 96 id <- nextval seq;
adamc@434 97 dml (insert tab
adamc@1093 98 (@foldR2 [snd] [colMeta]
adamc@1093 99 [fn cols => $(map (fn t :: (Type * Type) =>
adamc@1093 100 sql_exp [] [] [] t.1) cols)]
adamc@1093 101 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@1093 102 [[nm] ~ rest] =>
adamc@1093 103 fn input col acc => acc ++ {nm = @sql_inject col.Inject (col.Parse input)})
adamc@1093 104 {} M.fl inputs M.cols
adamc@471 105 ++ {Id = (SQL {[id]})}));
adamc@421 106 ls <- list ();
adamc@421 107 return <xml><body>
adamc@421 108 <p>Inserted with ID {[id]}.</p>
adamc@421 109
adamc@421 110 {ls}
adamc@421 111 </body></xml>
adamc@421 112
adamc@499 113 and upd (id : int) =
adamc@499 114 let
adamc@637 115 fun save (inputs : $(map snd M.cols)) =
adamc@1093 116 dml (update [map fst M.cols]
adamc@1093 117 (@foldR2 [snd] [colMeta]
adamc@1093 118 [fn cols => $(map (fn t :: (Type * Type) =>
adamc@1093 119 sql_exp [T = [Id = int]
adamc@1093 120 ++ map fst M.cols]
adamc@1093 121 [] [] t.1) cols)]
adamc@1093 122 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@1093 123 [[nm] ~ rest] =>
adamc@1093 124 fn input col acc => acc ++ {nm =
adamc@1093 125 @sql_inject col.Inject (col.Parse input)})
adamc@1093 126 {} M.fl inputs M.cols)
adamc@499 127 tab (WHERE T.Id = {[id]}));
adamc@499 128 ls <- list ();
adamc@499 129 return <xml><body>
adamc@499 130 <p>Saved!</p>
adamc@421 131
adamc@499 132 {ls}
adamc@499 133 </body></xml>
adamc@499 134 in
adamc@637 135 fso <- oneOrNoRows (SELECT tab.{{map fst M.cols}} FROM tab WHERE tab.Id = {[id]});
adamc@637 136 case fso : (Basis.option {Tab : $(map fst M.cols)}) of
adamc@499 137 None => return <xml><body>Not found!</body></xml>
adamc@499 138 | Some fs => return <xml><body><form>
adamc@1093 139 {@foldR2 [fst] [colMeta] [fn cols :: {(Type * Type)} => xml form [] (map snd cols)]
adamc@1093 140 (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@1093 141 [[nm] ~ rest] (v : t.1) (col : colMeta t)
adamc@1093 142 (acc : xml form [] (map snd rest)) =>
adamc@1093 143 <xml>
adamc@1093 144 <li> {cdata col.Nam}: {col.WidgetPopulated [nm] v}</li>
adamc@1093 145 {useMore acc}
adamc@1093 146 </xml>)
adamc@1093 147 <xml/>
adamc@1093 148 M.fl fs.Tab M.cols}
adamc@421 149
adamc@499 150 <submit action={save}/>
adamc@499 151 </form></body></xml>
adamc@499 152 end
adamc@421 153
adamc@499 154 and confirm (id : int) =
adamc@499 155 let
adamc@499 156 fun delete () =
adamc@499 157 dml (DELETE FROM tab WHERE Id = {[id]});
adamc@499 158 ls <- list ();
adamc@499 159 return <xml><body>
adamc@499 160 <p>The deed is done.</p>
adamc@499 161
adamc@499 162 {ls}
adamc@499 163 </body></xml>
adamc@499 164 in
adamc@499 165 return <xml><body>
adamc@499 166 <p>Are you sure you want to delete ID #{[id]}?</p>
adamc@499 167
adamc@732 168 <form><submit action={delete} value="I was born sure!"/></form>
adamc@499 169 </body></xml>
adamc@499 170 end
adamc@421 171
adamc@421 172 and main () =
adamc@421 173 ls <- list ();
adamc@421 174 return <xml><head>
adamc@421 175 <title>{cdata M.title}</title>
adamc@421 176 </head><body>
adamc@421 177
adamc@421 178 <h1>{cdata M.title}</h1>
adamc@421 179
adamc@421 180 {ls}
adamc@421 181 </body></xml>
adamc@421 182
adamc@421 183 end