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