Mercurial > urweb

annotate demo/crud.ur @ 2142:3288e3c9948b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix XML indentation in Emacs mode The return value of MATCH-STRING is a string. At least on Emacs 25, the comparisons between string and character with EQUAL could never succeed, and so the cases for matching braces were never triggered. GET-TEXT-PROPERTY may return a list rather than an atom (for example, on long lines with whitespace-mode turned on), and this broke the heuristic of looking for the tag face in previous text.
author Julian Squires <julian@cipht.net>
date Mon, 04 May 2015 14:35:07 -0400
parents 818d4097e2ed
children
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}
adam@1302 8 con colsMeta = fn cols => $(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@1172 53 {@mapX2 [fst] [colMeta] [tr]
adam@1302 54 (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] v col => <xml>
adam@1302 55 <td>{col.Show v}</td>
adam@1302 56 </xml>)
adamc@1093 57 M.fl (fs.T -- #Id) M.cols}
adamc@421 58 <td>
adamc@421 59 <a link={upd fs.T.Id}>[Update]</a>
adamc@421 60 <a link={confirm fs.T.Id}>[Delete]</a>
adamc@421 61 </td>
adamc@421 62 </tr>
adamc@421 63 </xml>);
adamc@421 64 return <xml>
adamc@421 65 <table border={1}>
adamc@421 66 <tr>
adamc@421 67 <th>ID</th>
adamc@1172 68 {@mapX [colMeta] [tr]
adam@1302 69 (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] col => <xml>
adam@1302 70 <th>{cdata col.Nam}</th>
adam@1302 71 </xml>)
adamc@1093 72 M.fl M.cols}
adamc@421 73 </tr>
adamc@421 74 {rows}
adamc@421 75 </table>
adamc@421 76
adamc@421 77 <br/><hr/><br/>
adamc@421 78
adamc@421 79 <form>
adam@1302 80 {@foldR [colMeta] [fn cols => xml form [] (map snd cols)]
adam@1303 81 (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] (col : colMeta t) acc => <xml>
adam@1302 82 <li> {cdata col.Nam}: {col.Widget [nm]}</li>
adam@1302 83 {useMore acc}
adam@1302 84 </xml>)
adamc@1093 85 <xml/>
adamc@1093 86 M.fl M.cols}
adamc@421 87
adamc@421 88 <submit action={create}/>
adamc@421 89 </form>
adamc@421 90 </xml>
adamc@421 91
adamc@637 92 and create (inputs : $(map snd M.cols)) =
adamc@421 93 id <- nextval seq;
adamc@434 94 dml (insert tab
adamc@1093 95 (@foldR2 [snd] [colMeta]
adam@1778 96 [fn cols => $(map (fn t => sql_exp [] [] [] t.1) cols)]
adam@1302 97 (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] =>
adamc@1093 98 fn input col acc => acc ++ {nm = @sql_inject col.Inject (col.Parse input)})
adamc@1093 99 {} M.fl inputs M.cols
adamc@471 100 ++ {Id = (SQL {[id]})}));
adamc@421 101 ls <- list ();
adamc@421 102 return <xml><body>
adamc@421 103 <p>Inserted with ID {[id]}.</p>
adamc@421 104
adamc@421 105 {ls}
adamc@421 106 </body></xml>
adamc@421 107
adamc@499 108 and upd (id : int) =
adamc@499 109 let
adamc@637 110 fun save (inputs : $(map snd M.cols)) =
adamc@1093 111 dml (update [map fst M.cols]
adamc@1093 112 (@foldR2 [snd] [colMeta]
adam@1778 113 [fn cols => $(map (fn t => sql_exp [T = [Id = int] ++ map fst M.cols] [] [] t.1) cols)]
adam@1302 114 (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] =>
adamc@1093 115 fn input col acc => acc ++ {nm =
adamc@1093 116 @sql_inject col.Inject (col.Parse input)})
adamc@1093 117 {} M.fl inputs M.cols)
adamc@499 118 tab (WHERE T.Id = {[id]}));
adamc@499 119 ls <- list ();
adamc@499 120 return <xml><body>
adamc@499 121 <p>Saved!</p>
adamc@421 122
adamc@499 123 {ls}
adamc@499 124 </body></xml>
adamc@499 125 in
adamc@637 126 fso <- oneOrNoRows (SELECT tab.{{map fst M.cols}} FROM tab WHERE tab.Id = {[id]});
adamc@637 127 case fso : (Basis.option {Tab : $(map fst M.cols)}) of
adamc@499 128 None => return <xml><body>Not found!</body></xml>
adamc@499 129 | Some fs => return <xml><body><form>
adam@1302 130 {@foldR2 [fst] [colMeta] [fn cols => xml form [] (map snd cols)]
adam@1303 131 (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] v (col : colMeta t)
adamc@1093 132 (acc : xml form [] (map snd rest)) =>
adamc@1093 133 <xml>
adamc@1093 134 <li> {cdata col.Nam}: {col.WidgetPopulated [nm] v}</li>
adamc@1093 135 {useMore acc}
adamc@1093 136 </xml>)
adamc@1093 137 <xml/>
adamc@1093 138 M.fl fs.Tab M.cols}
adamc@421 139
adamc@499 140 <submit action={save}/>
adamc@499 141 </form></body></xml>
adamc@499 142 end
adamc@421 143
adamc@499 144 and confirm (id : int) =
adamc@499 145 let
adamc@499 146 fun delete () =
adamc@499 147 dml (DELETE FROM tab WHERE Id = {[id]});
adamc@499 148 ls <- list ();
adamc@499 149 return <xml><body>
adamc@499 150 <p>The deed is done.</p>
adamc@499 151
adamc@499 152 {ls}
adamc@499 153 </body></xml>
adamc@499 154 in
adamc@499 155 return <xml><body>
adamc@499 156 <p>Are you sure you want to delete ID #{[id]}?</p>
adamc@499 157
adamc@732 158 <form><submit action={delete} value="I was born sure!"/></form>
adamc@499 159 </body></xml>
adamc@1265 160 end
adamc@421 161
adamc@421 162 and main () =
adamc@421 163 ls <- list ();
adamc@421 164 return <xml><head>
adamc@421 165 <title>{cdata M.title}</title>
adamc@421 166 </head><body>
adamc@421 167
adamc@421 168 <h1>{cdata M.title}</h1>
adamc@421 169
adamc@421 170 {ls}
adamc@421 171 </body></xml>
adamc@421 172
adamc@421 173 end