adamc@915: con colMeta' = fn (row :: Type) (t :: Type) =>
adamc@915:                   {Header : string,
adamc@915:                    Project : row -> transaction t,
adamc@915:                    Update : row -> t -> transaction row,
adamc@915:                    Display : t -> xbody,
adamc@915:                    Edit : t -> xbody,
adamc@915:                    Validate : t -> signal bool}
adamc@915: 
adamc@915: con colMeta = fn (row :: Type) (global_t :: (Type * Type)) =>
adamc@915:                  {Initialize : transaction global_t.1,
adamc@915:                   Handlers : global_t.1 -> colMeta' row global_t.2}                  
adamc@915: 
adamc@915: functor Make(M : sig
adamc@915:                  type row
adamc@915:                  val list : transaction (list row)
adamc@915:                  val new : transaction row
adamc@915:                  val save : {Old : row, New : row} -> transaction unit
adamc@915:                  val delete : row -> transaction unit
adamc@915: 
adamc@915:                  con cols :: {(Type * Type)}
adamc@915:                  val cols : $(map (colMeta row) cols)
adamc@915: 
adamc@915:                  val folder : folder cols
adamc@915:              end) = struct
adamc@915:     style tabl
adamc@915:     style tr
adamc@915:     style th
adamc@915:     style td
adamc@915: 
adamc@915:     fun make (row : M.row) [t] (m : colMeta' M.row t) : transaction t = m.Project row
adamc@915: 
adamc@915:     fun makeAll cols row = @@Monad.exec [transaction] _ [map snd M.cols]
adamc@915:                                (map2 [fst] [colMeta M.row] [fn p :: (Type * Type) => transaction p.2]
adamc@915:                                      (fn [p] data meta => make row [_] (meta.Handlers data))
adamc@915:                                      [_] M.folder cols M.cols)
adamc@915:                                (@@Folder.mp [_] [_] M.folder)
adamc@915: 
adamc@915:     fun addRow cols rows row =
adamc@915:         rowS <- source row;
adamc@915:         cols <- makeAll cols row;
adamc@915:         colsS <- source cols;
adamc@915:         ud <- source False;
adamc@915:         Monad.ignore (Dlist.append rows {Row = rowS,
adamc@915:                                          Cols = colsS,
adamc@915:                                          Updating = ud})
adamc@915: 
adamc@915:     type grid = {Cols : $(map fst M.cols),
adamc@915:                  Rows : Dlist.dlist {Row : source M.row, Cols : source ($(map snd M.cols)), Updating : source bool}}
adamc@915:  
adamc@915:     val createMetas = Monad.mapR [colMeta M.row] [fst]
adamc@915:                            (fn [nm :: Name] [p :: (Type * Type)] meta => meta.Initialize)
adamc@915:                            [_] M.folder M.cols
adamc@915: 
adamc@915:     val grid =
adamc@915:         cols <- createMetas;
adamc@915:         rows <- Dlist.create;
adamc@915:         return {Cols = cols, Rows = rows}
adamc@915: 
adamc@915:     fun sync {Cols = cols, Rows = rows} =
adamc@915:         Dlist.clear rows;
adamc@915:         init <- rpc M.list;
adamc@915:         List.app (addRow cols rows) init
adamc@915: 
adamc@915:     fun render grid = <xml>
adamc@915:       <table class={tabl}>
adamc@915:         <tr class={tr}>
adamc@915:           <th/> <th/>
adamc@915:           {foldRX2 [fst] [colMeta M.row] [_]
adamc@915:                   (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest]
adamc@915:                                    data (meta : colMeta M.row p) =>
adamc@915:                       <xml><th class={th}>{[(meta.Handlers data).Header]}</th></xml>)
adamc@915:                   [_] M.folder grid.Cols M.cols}
adamc@915:           </tr>
adamc@915: 
adamc@915:           {Dlist.render (fn {Row = rowS, Cols = colsS, Updating = ud} pos =>
adamc@915:                             let
adamc@915:                                 val delete =
adamc@915:                                     Dlist.delete pos;
adamc@915:                                     row <- get rowS;
adamc@915:                                     rpc (M.delete row)
adamc@915: 
adamc@915:                                 val update = set ud True
adamc@915: 
adamc@915:                                 val cancel =
adamc@915:                                     set ud False;
adamc@915:                                     row <- get rowS;
adamc@915:                                     cols <- makeAll grid.Cols row;
adamc@915:                                     set colsS cols
adamc@915:                                     
adamc@915:                                 val save =
adamc@915:                                     cols <- get colsS;
adamc@915:                                     errors <- Monad.foldR3 [fst] [colMeta M.row] [snd] [fn _ => option string]
adamc@915:                                                            (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}]
adamc@915:                                                                             [[nm] ~ rest] data meta v errors =>
adamc@915:                                                                b <- current ((meta.Handlers data).Validate v);
adamc@915:                                                                return (if b then
adamc@915:                                                                            errors
adamc@915:                                                                        else
adamc@915:                                                                            case errors of
adamc@915:                                                                                None => Some ((meta.Handlers data).Header)
adamc@915:                                                                              | Some s => Some ((meta.Handlers data).Header
adamc@915:                                                                                                ^ ", " ^ s)))
adamc@915:                                                            None [_] M.folder grid.Cols M.cols cols;
adamc@915: 
adamc@915:                                     case errors of
adamc@915:                                         Some s => alert ("Can't save because the following columns have invalid values:\n"
adamc@915:                                                          ^ s)
adamc@915:                                       | None =>
adamc@915:                                         set ud False;
adamc@915:                                         row <- get rowS;
adamc@915:                                         row' <- Monad.foldR3 [fst] [colMeta M.row] [snd] [fn _ => M.row]
adamc@915:                                                              (fn [nm :: Name] [t :: (Type * Type)]
adamc@915:                                                                               [rest :: {(Type * Type)}]
adamc@915:                                                                               [[nm] ~ rest] data meta v row' =>
adamc@915:                                                                  (meta.Handlers data).Update row' v)
adamc@915:                                                              row [_] M.folder grid.Cols M.cols cols;
adamc@915:                                         rpc (M.save {Old = row, New = row'});
adamc@915:                                         set rowS row';
adamc@915: 
adamc@915:                                         cols <- makeAll grid.Cols row';
adamc@915:                                         set colsS cols
adamc@915:                             in
adamc@915:                                 <xml><tr class={tr}>
adamc@915:                                   <td>
adamc@915:                                     <dyn signal={b <- signal ud;
adamc@915:                                                  return (if b then
adamc@915:                                                              <xml><button value="Save" onclick={save}/></xml>
adamc@915:                                                          else
adamc@915:                                                              <xml><button value="Update" onclick={update}/></xml>)}/>
adamc@915:                                   </td>
adamc@915:                                   <td><dyn signal={b <- signal ud;
adamc@915:                                                    return (if b then
adamc@915:                                                                <xml><button value="Cancel" onclick={cancel}/></xml>
adamc@915:                                                            else
adamc@915:                                                                <xml><button value="Delete" onclick={delete}/></xml>)}/>
adamc@915:                                   </td>
adamc@915: 
adamc@915:                                   <dyn signal={cols <- signal colsS;
adamc@915:                                                return (foldRX3 [fst] [colMeta M.row] [snd] [_]
adamc@915:                                                                (fn [nm :: Name] [t :: (Type * Type)]
adamc@915:                                                                                 [rest :: {(Type * Type)}]
adamc@915:                                                                                 [[nm] ~ rest] data meta v =>
adamc@915:                                                                    <xml><td class={td}>
adamc@915:                                                                      <dyn signal={b <- signal ud;
adamc@915:                                                                                   return (if b then
adamc@915:                                                                                               (meta.Handlers data).Edit v
adamc@915:                                                                                           else
adamc@915:                                                                                               (meta.Handlers data).Display
adamc@915:                                                                                                                   v)}/>
adamc@915:                                                                      <dyn signal={b <- signal ud;
adamc@915:                                                                                   if b then
adamc@915:                                                                                       valid <-
adamc@915:                                                                                       (meta.Handlers data).Validate v;
adamc@915:                                                                                       return (if valid then
adamc@915:                                                                                                   <xml/>
adamc@915:                                                                                               else
adamc@915:                                                                                                   <xml>!</xml>)
adamc@915:                                                                                   else
adamc@915:                                                                                       return <xml/>}/>
adamc@915:                                                                    </td></xml>)
adamc@915:                                                                [_] M.folder grid.Cols M.cols cols)}/>
adamc@915:                                   </tr></xml>
adamc@915:                             end) grid.Rows}
adamc@915:           </table>
adamc@915:           
adamc@915:           <button value="New row" onclick={row <- rpc M.new;
adamc@915:                                            addRow grid.Cols grid.Rows row}/>
adamc@915:           <button value="Refresh" onclick={sync grid}/>
adamc@915:     </xml>
adamc@915: end