adamc@944: con colMeta' = fn (row :: Type) (input :: Type) (filter :: Type) =>
adamc@915:                   {Header : string,
adamc@944:                    Project : row -> transaction input,
adamc@944:                    Update : row -> input -> transaction row,
adamc@944:                    Display : input -> xbody,
adamc@944:                    Edit : input -> xbody,
adamc@944:                    Validate : input -> signal bool,
adamc@944:                    CreateFilter : transaction filter,
adamc@944:                    DisplayFilter : filter -> xbody,
adamc@961:                    Filter : filter -> row -> signal bool,
adamc@961:                    Sort : option (row -> row -> bool)}
adamc@1002: 
adamc@1002: con colMeta = fn (row :: Type) (global :: Type, input :: Type, filter :: Type) =>
adamc@1002:                  {Initialize : transaction global,
adamc@1002:                   Handlers : global -> colMeta' row input filter}                  
adamc@915: 
adamc@935: con aggregateMeta = fn (row :: Type) (acc :: Type) =>
adamc@935:                        {Initial : acc,
adamc@935:                         Step : row -> acc -> acc,
adamc@935:                         Display : acc -> xbody}
adamc@935: 
adamc@915: functor Make(M : sig
adamc@915:                  type row
adamc@936:                  type key
adamc@936:                  val keyOf : row -> key
adamc@936: 
adamc@915:                  val list : transaction (list row)
adamc@915:                  val new : transaction row
adamc@936:                  val save : key -> row -> transaction unit
adamc@936:                  val delete : key -> transaction unit
adamc@915: 
adamc@944:                  con cols :: {(Type * Type * Type)}
adamc@915:                  val cols : $(map (colMeta row) cols)
adamc@915: 
adamc@915:                  val folder : folder cols
adamc@935: 
adamc@935:                  con aggregates :: {Type}
adamc@935:                  val aggregates : $(map (aggregateMeta row) aggregates)
adamc@937:                  val aggFolder : folder aggregates
adamc@964: 
adamc@964:                  val pageLength : option int
adamc@915:              end) = struct
adamc@915:     style tabl
adamc@915:     style tr
adamc@915:     style th
adamc@915:     style td
adamc@937:     style agg
adamc@915: 
adamc@944:     fun make (row : M.row) [input] [filter] (m : colMeta' M.row input filter) : transaction input = m.Project row
adamc@915: 
adamc@944:     fun makeAll cols row = @@Monad.exec [transaction] _ [map snd3 M.cols]
adam@1304:                              (@map2 [fst3] [colMeta M.row] [fn p => transaction (snd3 p)]
adam@1304:                                (fn [p] data meta => make row (meta.Handlers data))
adam@1304:                                M.folder cols M.cols)
adam@1304:                              (@@Folder.mp [_] [_] M.folder)
adam@1304: 
adam@1304:     type listT = {Row : source M.row,
adam@1304:                   Cols : source ($(map snd3 M.cols)),
adam@1304:                   Updating : source bool,
adam@1304:                   Selected : source bool}
adamc@915: 
adamc@944:     type grid = {Cols : $(map fst3 M.cols),
adam@1304:                  Rows : Dlist.dlist listT,
adamc@944:                  Selection : source bool,
adamc@960:                  Filters : $(map thd3 M.cols),
adamc@964:                  Sort : source (option (M.row -> M.row -> bool)),
adamc@964:                  Position : source int}
adamc@940: 
adamc@954:     fun newRow cols row =
adamc@915:         rowS <- source row;
adamc@915:         cols <- makeAll cols row;
adamc@915:         colsS <- source cols;
adamc@915:         ud <- source False;
adamc@940:         sd <- source False;
adamc@954:         return {Row = rowS,
adamc@954:                 Cols = colsS,
adamc@954:                 Updating = ud,
adamc@954:                 Selected = sd}
adamc@954: 
adamc@954:     fun addRow cols rows row =
adamc@954:         r <- newRow cols row;
adamc@954:         Monad.ignore (Dlist.append rows r)
adamc@915: 
adamc@944:     val grid =
adamc@1093:         cols <- @Monad.mapR _ [colMeta M.row] [fst3]
adamc@1093:                  (fn [nm :: Name] [p :: (Type * Type * Type)] meta => meta.Initialize)
adamc@1093:                  M.folder M.cols;
adamc@915: 
adamc@1093:         filters <- @Monad.mapR2 _ [colMeta M.row] [fst3] [thd3]
adamc@1093:                     (fn [nm :: Name] [p :: (Type * Type * Type)] meta state =>
adamc@1093:                         (meta.Handlers state).CreateFilter)
adamc@1093:                     M.folder M.cols cols;
adamc@944: 
adamc@951:         rows <- Dlist.create;
adamc@940:         sel <- source False;
adamc@960:         sort <- source None;
adamc@964:         pos <- source 0;
adamc@951: 
adamc@951:         return {Cols = cols,
adamc@951:                 Rows = rows,
adamc@951:                 Selection = sel,
adamc@960:                 Filters = filters,
adamc@964:                 Sort = sort,
adamc@964:                 Position = pos}
adamc@915: 
adamc@940:     fun sync {Cols = cols, Rows = rows, ...} =
adamc@915:         Dlist.clear rows;
adamc@915:         init <- rpc M.list;
adamc@954:         rs <- List.mapM (newRow cols) init;
adamc@954:         Dlist.replace rows rs
adamc@915: 
adamc@965:     fun myFilter grid all =
adamc@965:         row <- signal all.Row;
adamc@1093:         @foldR3 [colMeta M.row] [fst3] [thd3] [fn _ => M.row -> signal bool]
adamc@1093:          (fn [nm :: Name] [p :: (Type * Type * Type)]
adamc@1093:                           [rest :: {(Type * Type * Type)}] [[nm] ~ rest]
adamc@1093:                           meta state filter combinedFilter row =>
adamc@1093:              previous <- combinedFilter row;
adamc@1093:              this <- (meta.Handlers state).Filter filter row;
adamc@1093:              return (previous && this))
adamc@1093:          (fn _ => return True)
adamc@1093:          M.folder M.cols grid.Cols grid.Filters row
adamc@965: 
adamc@961:     fun render (grid : grid) = <xml>
adamc@915:       <table class={tabl}>
adamc@915:         <tr class={tr}>
adamc@961:           <th/> <th/> <th><button value="No sort" onclick={set grid.Sort None}/></th>
adam@1342:           {@mapX2 [fst3] [colMeta M.row] [[Body, Tr]]
adamc@1093:             (fn [nm :: Name] [p :: (Type * Type * Type)] [rest :: {(Type * Type * Type)}] [[nm] ~ rest]
adamc@1093:                              data (meta : colMeta M.row p) =>
adamc@1093:                 <xml><th class={th}>
adamc@1093:                   {case (meta.Handlers data).Sort of
adamc@1093:                        None => txt (meta.Handlers data).Header
adamc@1093:                      | sort => <xml><button value={(meta.Handlers data).Header}
adamc@1093:                                                       onclick={set grid.Sort sort}/></xml>}
adamc@1093:                 </th></xml>)
adamc@1093:             M.folder grid.Cols M.cols}
adamc@937:         </tr>
adamc@915: 
adamc@940:         {Dlist.render (fn {Row = rowS, Cols = colsS, Updating = ud, Selected = sd} pos =>
adamc@937:                           let
adamc@937:                               val delete =
adamc@937:                                   Dlist.delete pos;
adamc@937:                                   row <- get rowS;
adamc@937:                                   rpc (M.delete (M.keyOf row))
adamc@915: 
adamc@937:                               val update = set ud True
adamc@915: 
adamc@937:                               val cancel =
adamc@937:                                   set ud False;
adamc@937:                                   row <- get rowS;
adamc@937:                                   cols <- makeAll grid.Cols row;
adamc@937:                                   set colsS cols
adamc@937:                                   
adamc@937:                               val save =
adamc@937:                                   cols <- get colsS;
adamc@1093:                                   errors <- @Monad.foldR3 _ [fst3] [colMeta M.row] [snd3] [fn _ => option string]
adamc@1093:                                              (fn [nm :: Name] [p :: (Type * Type * Type)] [rest :: {(Type * Type * Type)}]
adamc@1093:                                                               [[nm] ~ rest] data meta v errors =>
adamc@1093:                                                  b <- current ((meta.Handlers data).Validate v);
adamc@1093:                                                  return (if b then
adamc@1093:                                                              errors
adamc@1093:                                                          else
adamc@1093:                                                              case errors of
adamc@1093:                                                                  None => Some ((meta.Handlers data).Header)
adamc@1093:                                                                | Some s => Some ((meta.Handlers data).Header
adamc@1093:                                                                                  ^ ", " ^ s)))
adamc@1093:                                              None M.folder grid.Cols M.cols cols;
adamc@915: 
adamc@937:                                   case errors of
adamc@937:                                       Some s => alert ("Can't save because the following columns have invalid values:\n"
adamc@937:                                                        ^ s)
adamc@937:                                     | None =>
adamc@937:                                       set ud False;
adamc@937:                                       row <- get rowS;
adamc@1093:                                       row' <- @Monad.foldR3 _ [fst3] [colMeta M.row] [snd3] [fn _ => M.row]
adamc@1093:                                                (fn [nm :: Name] [t :: (Type * Type * Type)]
adamc@1093:                                                                 [rest :: {(Type * Type * Type)}]
adamc@1093:                                                                 [[nm] ~ rest] data meta v row' =>
adamc@1093:                                                    (meta.Handlers data).Update row' v)
adamc@1093:                                                row M.folder grid.Cols M.cols cols;
adamc@937:                                       rpc (M.save (M.keyOf row) row');
adamc@937:                                       set rowS row';
adamc@937: 
adamc@937:                                       cols <- makeAll grid.Cols row';
adamc@937:                                       set colsS cols
adamc@937:                           in
adamc@937:                               <xml><tr class={tr}>
adamc@937:                                 <td>
adamc@940:                                   <dyn signal={b <- signal grid.Selection;
adamc@941:                                                return (if b then
adamc@940:                                                            <xml><ccheckbox source={sd}/></xml>
adamc@940:                                                        else
adamc@941:                                                            <xml/>)}/>
adamc@940:                                 </td>
adamc@940: 
adamc@940:                                 <td>
adamc@937:                                   <dyn signal={b <- signal ud;
adamc@937:                                                return (if b then
adamc@937:                                                            <xml><button value="Save" onclick={save}/></xml>
adamc@937:                                                        else
adamc@937:                                                            <xml><button value="Update" onclick={update}/></xml>)}/>
adamc@937:                                 </td>
adamc@937: 
adamc@937:                                 <td><dyn signal={b <- signal ud;
adamc@937:                                                  return (if b then
adamc@937:                                                              <xml><button value="Cancel" onclick={cancel}/></xml>
adamc@937:                                                          else
adamc@937:                                                              <xml><button value="Delete" onclick={delete}/></xml>)}/>
adamc@937:                                 </td>
adamc@937: 
adamc@937:                                 <dyn signal={cols <- signal colsS;
adamc@1172:                                              return (@mapX3 [fst3] [colMeta M.row] [snd3] [_]
adamc@1093:                                                       (fn [nm :: Name] [t :: (Type * Type * Type)]
adamc@1093:                                                                        [rest :: {(Type * Type * Type)}]
adamc@1093:                                                                        [[nm] ~ rest] data meta v =>
adamc@1093:                                                           <xml><td class={td}>
adamc@1093:                                                             <dyn signal={b <- signal ud;
adamc@1093:                                                                          return (if b then
adamc@1093:                                                                                      (meta.Handlers data).Edit v
adamc@1093:                                                                                  else
adamc@1093:                                                                                      (meta.Handlers data).Display
adamc@1093:                                                                                                          v)}/>
adamc@1093:                                                             <dyn signal={b <- signal ud;
adamc@1093:                                                                          if b then
adamc@1093:                                                                              valid <-
adamc@1093:                                                                              (meta.Handlers data).Validate v;
adamc@1093:                                                                              return (if valid then
adamc@1093:                                                                                          <xml/>
adamc@1093:                                                                                      else
adamc@1093:                                                                                          <xml>!</xml>)
adamc@1093:                                                                          else
adamc@1093:                                                                              return <xml/>}/>
adamc@1093:                                                           </td></xml>)
adamc@1093:                                                       M.folder grid.Cols M.cols cols)}/>
adamc@937:                                 </tr></xml>
adamc@951:                           end)
adamc@965:                       {StartPosition = case M.pageLength of
adamc@965:                                            None => return None
adamc@965:                                          | Some len =>
adamc@965:                                            avail <- Dlist.numPassing (myFilter grid) grid.Rows;
adamc@965:                                            pos <- signal grid.Position;
adamc@965:                                            return (Some (if pos >= avail then
adamc@965:                                                              0
adamc@965:                                                          else
adamc@965:                                                              pos)),
adamc@964:                        MaxLength = return M.pageLength,
adamc@965:                        Filter = myFilter grid,
adamc@960:                        Sort = f <- signal grid.Sort;
adamc@960:                               return (Option.mp (fn f r1 r2 => r1 <- signal r1.Row;
adamc@960:                                                     r2 <- signal r2.Row;
adamc@960:                                                     return (f r1 r2)) f)}
adamc@951:                       grid.Rows}
adamc@915: 
adam@1304:             <dyn signal={rows <- Dlist.foldl (fn row : listT =>
adam@1304:                                                  @Monad.mapR2 _ [aggregateMeta M.row] [id] [id]
adam@1304:                                                   (fn [nm :: Name] [t :: Type] meta acc =>
adam@1304:                                                       Monad.mp (fn v => meta.Step v acc)
adam@1304:                                                                (signal row.Row))
adam@1304:                                                   M.aggFolder M.aggregates)
adamc@1093:                                  (@mp [aggregateMeta M.row] [id]
adamc@937:                                   (fn [t] meta => meta.Initial)
adamc@1093:                                   M.aggFolder M.aggregates) grid.Rows;
adamc@937:                          return <xml><tr>
adamc@941:                            <th colspan={3}>Aggregates</th>
adamc@1172:                            {@mapX2 [aggregateMeta M.row] [id] [_]
adamc@1093:                              (fn [nm :: Name] [t :: Type] [rest :: {Type}] [[nm] ~ rest] meta acc =>
adamc@1093:                                  <xml><td class={agg}>{meta.Display acc}</td></xml>)
adamc@1093:                              M.aggFolder M.aggregates rows}
adamc@937:                          </tr></xml>}/>
adamc@944: 
adamc@944:               <tr><th colspan={3}>Filters</th>
adamc@1172:                 {@mapX3 [colMeta M.row] [fst3] [thd3] [_]
adamc@1093:                   (fn [nm :: Name] [p :: (Type * Type * Type)] [rest :: {(Type * Type * Type)}] [[nm] ~ rest]
adamc@1093:                                    meta state filter => <xml><td>{(meta.Handlers state).DisplayFilter filter}</td></xml>)
adamc@1093:                   M.folder M.cols grid.Cols grid.Filters}
adamc@944:               </tr>
adamc@915:           </table>
adamc@964: 
adamc@964:           {case M.pageLength of
adamc@964:                None => <xml/>
adamc@964:              | Some plen => <xml>
adamc@965:                <dyn signal={avail <- Dlist.numPassing (myFilter grid) grid.Rows;
adamc@964:                             return (if avail <= plen then
adamc@964:                                         <xml/>
adamc@964:                                     else
adamc@964:                                         let
adamc@964:                                             val numPages = avail / plen
adamc@964:                                             val numPages = if numPages * plen < avail then
adamc@964:                                                                numPages + 1
adamc@964:                                                            else
adamc@964:                                                                numPages
adamc@964: 
adamc@964:                                             fun pages n =
adamc@964:                                                 if n * plen >= avail then
adamc@964:                                                     <xml/>
adamc@964:                                                 else
adamc@964:                                                     <xml>
adamc@964:                                                       <dyn signal={pos <- signal grid.Position;
adamc@964:                                                                    return (if n * plen = pos then
adamc@964:                                                                                <xml><b>{[n + 1]}</b></xml>
adamc@964:                                                                            else
adamc@964:                                                                                <xml>
adamc@964:                                                                                  <button value={show (n + 1)}
adamc@964:                                                                                          onclick={set grid.Position
adamc@964:                                                                                                       (n * plen)
adamc@964:                                                                                                  }/></xml>)}/>
adamc@964:                                                       {if (n + 1) * plen >= avail then <xml/> else <xml>|</xml>}
adamc@964:                                                       {pages (n + 1)}
adamc@964:                                                     </xml>
adamc@964:                                         in
adamc@964:                                             <xml><p><b>Pages:</b> {pages 0}</p></xml>
adamc@964:                                         end)}/>
adamc@964:                </xml>}
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@940: 
adamc@940:     fun showSelection grid = grid.Selection
adamc@940: 
adamc@940:     fun selection grid = Dlist.foldl (fn {Row = rowS, Selected = sd, ...} ls =>
adamc@940:                                          sd <- signal sd;
adamc@940:                                          if sd then
adamc@940:                                              row <- signal rowS;
adamc@940:                                              return (row :: ls)
adamc@940:                                          else
adamc@940:                                              return ls) [] grid.Rows
adamc@915: end