adamc@1002: con colMeta = fn (db :: Type, widget :: Type) =>
adamc@1002:                  {Nam : string,
adamc@1002:                   Show : db -> xbody,
adamc@1002:                   Widget : nm :: Name -> xml form [] [nm = widget],
adamc@1002:                   WidgetPopulated : nm :: Name -> db -> xml form [] [nm = widget],
adamc@1002:                   Parse : widget -> db,
adamc@1002:                   Inject : sql_injectable db}
adam@1302: con colsMeta = fn cols => $(map colMeta cols)
adamc@421: 
adamc@823: fun default [t] (sh : show t) (rd : read t) (inj : sql_injectable t)
adamc@421:             name : colMeta (t, string) =
adamc@421:     {Nam = name,
adamc@421:      Show = txt,
adamc@823:      Widget = fn [nm :: Name] => <xml><textbox{nm}/></xml>,
adamc@823:      WidgetPopulated = fn [nm :: Name] n =>
adamc@421:                           <xml><textbox{nm} value={show n}/></xml>,
adamc@421:      Parse = readError,
adamc@421:      Inject = _}
adamc@421: 
adamc@421: val int = default
adamc@421: val float = default
adamc@421: val string = default
adamc@421: 
adamc@421: fun bool name = {Nam = name,
adamc@421:                  Show = txt,
adamc@823:                  Widget = fn [nm :: Name] => <xml><checkbox{nm}/></xml>,
adamc@823:                  WidgetPopulated = fn [nm :: Name] b =>
adamc@421:                                       <xml><checkbox{nm} checked={b}/></xml>,
adamc@421:                  Parse = fn x => x,
adamc@421:                  Inject = _}
adamc@421: 
adamc@421: functor Make(M : sig
adamc@421:                  con cols :: {(Type * Type)}
adamc@421:                  constraint [Id] ~ cols
adamc@632:                  val fl : folder cols
adamc@632: 
adamc@706:                  table tab : ([Id = int] ++ map fst cols)
adamc@421: 
adamc@421:                  val title : string
adamc@421: 
adamc@421:                  val cols : colsMeta cols
adamc@421:              end) = struct
adamc@421: 
adamc@421:     val tab = M.tab
adamc@421: 
adamc@421:     sequence seq
adamc@421: 
adamc@421:     fun list () =
adamc@421:         rows <- queryX (SELECT * FROM tab AS T)
adamc@637:                        (fn (fs : {T : $([Id = int] ++ map fst M.cols)}) => <xml>
adamc@421:                          <tr>
adamc@421:                            <td>{[fs.T.Id]}</td>
adamc@1172:                            {@mapX2 [fst] [colMeta] [tr]
adam@1302:                              (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] v col => <xml>
adam@1302:                                <td>{col.Show v}</td>
adam@1302:                              </xml>)
adamc@1093:                              M.fl (fs.T -- #Id) M.cols}
adamc@421:                            <td>
adamc@421:                              <a link={upd fs.T.Id}>[Update]</a>
adamc@421:                              <a link={confirm fs.T.Id}>[Delete]</a>
adamc@421:                            </td>
adamc@421:                          </tr>
adamc@421:                        </xml>);
adamc@421:         return <xml>
adamc@421:           <table border={1}>
adamc@421:             <tr>
adamc@421:               <th>ID</th>
adamc@1172:               {@mapX [colMeta] [tr]
adam@1302:                 (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] col => <xml>
adam@1302:                   <th>{cdata col.Nam}</th>
adam@1302:                 </xml>)
adamc@1093:                 M.fl M.cols}
adamc@421:             </tr>
adamc@421:             {rows}
adamc@421:           </table>
adamc@421: 
adamc@421:           <br/><hr/><br/>
adamc@421: 
adamc@421:           <form>
adam@1302:             {@foldR [colMeta] [fn cols => xml form [] (map snd cols)]
adam@1303:               (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] (col : colMeta t) acc => <xml>
adam@1302:                 <li> {cdata col.Nam}: {col.Widget [nm]}</li>
adam@1302:                 {useMore acc}
adam@1302:               </xml>)
adamc@1093:               <xml/>
adamc@1093:               M.fl M.cols}
adamc@421:             
adamc@421:             <submit action={create}/>
adamc@421:           </form>
adamc@421:         </xml>
adamc@421: 
adamc@637:     and create (inputs : $(map snd M.cols)) =
adamc@421:         id <- nextval seq;
adamc@434:         dml (insert tab
adamc@1093:                     (@foldR2 [snd] [colMeta]
adam@1302:                       [fn cols => $(map (fn t => sql_exp [] [] [] t.1) cols)]
adam@1302:                       (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] =>
adamc@1093:                        fn input col acc => acc ++ {nm = @sql_inject col.Inject (col.Parse input)})
adamc@1093:                       {} M.fl inputs M.cols
adamc@471:                      ++ {Id = (SQL {[id]})}));
adamc@421:         ls <- list ();
adamc@421:         return <xml><body>
adamc@421:           <p>Inserted with ID {[id]}.</p>
adamc@421: 
adamc@421:           {ls}
adamc@421:         </body></xml>
adamc@421: 
adamc@499:     and upd (id : int) =
adamc@499:         let
adamc@637:             fun save (inputs : $(map snd M.cols)) =
adamc@1093:                 dml (update [map fst M.cols]
adamc@1093:                             (@foldR2 [snd] [colMeta]
adam@1302:                               [fn cols => $(map (fn t => sql_exp [T = [Id = int] ++ map fst M.cols] [] [] t.1) cols)]
adam@1302:                               (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] =>
adamc@1093:                                fn input col acc => acc ++ {nm =
adamc@1093:                                                            @sql_inject col.Inject (col.Parse input)})
adamc@1093:                               {} M.fl inputs M.cols)
adamc@499:                             tab (WHERE T.Id = {[id]}));
adamc@499:                 ls <- list ();
adamc@499:                 return <xml><body>
adamc@499:                   <p>Saved!</p>
adamc@421: 
adamc@499:                   {ls}
adamc@499:                 </body></xml>
adamc@499:         in
adamc@637:             fso <- oneOrNoRows (SELECT tab.{{map fst M.cols}} FROM tab WHERE tab.Id = {[id]});
adamc@637:             case fso : (Basis.option {Tab : $(map fst M.cols)}) of
adamc@499:                 None => return <xml><body>Not found!</body></xml>
adamc@499:               | Some fs => return <xml><body><form>
adam@1302:                 {@foldR2 [fst] [colMeta] [fn cols => xml form [] (map snd cols)]
adam@1303:                   (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] v (col : colMeta t)
adamc@1093:                                    (acc : xml form [] (map snd rest)) =>
adamc@1093:                       <xml>
adamc@1093:                         <li> {cdata col.Nam}: {col.WidgetPopulated [nm] v}</li>
adamc@1093:                         {useMore acc}
adamc@1093:                       </xml>)
adamc@1093:                   <xml/>
adamc@1093:                   M.fl fs.Tab M.cols}
adamc@421: 
adamc@499:                 <submit action={save}/>
adamc@499:               </form></body></xml>
adamc@499:         end
adamc@421: 
adamc@499:     and confirm (id : int) =
adamc@499:         let
adamc@499:             fun delete () =
adamc@499:                 dml (DELETE FROM tab WHERE Id = {[id]});
adamc@499:                 ls <- list ();
adamc@499:                 return <xml><body>
adamc@499:                   <p>The deed is done.</p>
adamc@499:                   
adamc@499:                   {ls}
adamc@499:                 </body></xml>
adamc@499:         in
adamc@499:             return <xml><body>
adamc@499:               <p>Are you sure you want to delete ID #{[id]}?</p>
adamc@499:               
adamc@732:               <form><submit action={delete} value="I was born sure!"/></form>
adamc@499:             </body></xml>
adamc@1265:         end
adamc@421: 
adamc@421:     and main () =
adamc@421:         ls <- list ();
adamc@421:         return <xml><head>
adamc@421:           <title>{cdata M.title}</title>
adamc@421:         </head><body>
adamc@421: 
adamc@421:           <h1>{cdata M.title}</h1>
adamc@421: 
adamc@421:           {ls}
adamc@421:         </body></xml>
adamc@421: 
adamc@421: end