Summary row with aggregates

8 files changed, 153 insertions, 94 deletions

diff --git a/demo/more/dbgrid.ur b/demo/more/dbgrid.ur
index deefd4f1..04eb6dc5 100644
--- a/demo/more/dbgrid.ur
+++ b/demo/more/dbgrid.ur
@@ -251,6 +251,7 @@ functor Make(M : sig
 
                  con aggregates :: {Type}
                  val aggregates : $(map (aggregateMeta (key ++ row)) aggregates)
+                 val aggFolder : folder aggregates
              end) = struct
     open Grid.Make(struct
                        fun keyOf r = r --- M.row
@@ -297,5 +298,7 @@ functor Make(M : sig
                        val folder = M.colsFolder
 
                        val aggregates = M.aggregates
+
+                       val aggFolder = M.aggFolder
                    end)
 end
diff --git a/demo/more/dbgrid.urs b/demo/more/dbgrid.urs
index 908f4b2a..e715542b 100644
--- a/demo/more/dbgrid.urs
+++ b/demo/more/dbgrid.urs
@@ -103,6 +103,7 @@ functor Make(M : sig
 
                  con aggregates :: {Type}
                  val aggregates : $(map (aggregateMeta (key ++ row)) aggregates)
+                 val aggFolder : folder aggregates
              end) : sig
     type grid
 
diff --git a/demo/more/dlist.ur b/demo/more/dlist.ur
index f8aca1e2..850836b0 100644
--- a/demo/more/dlist.ur
+++ b/demo/more/dlist.ur
@@ -86,3 +86,22 @@ fun elements [t] (dl : dlist t) =
     case dl' of
         Empty => return []
       | Nonempty {Head = hd, ...} => elements' hd
+
+fun foldl [t] [acc] (f : t -> acc -> signal acc) =
+    let
+        fun foldl'' (i : acc) (dl : dlist'' t) : signal acc =
+            case dl of
+                Nil => return i
+              | Cons (v, dl') =>
+                dl' <- signal dl';
+                i' <- f v i;
+                foldl'' i' dl'
+
+        fun foldl' (i : acc) (dl : dlist t) : signal acc =
+            dl <- signal dl;
+            case dl of
+                Empty => return i
+              | Nonempty {Head = dl, ...} => foldl'' i dl
+    in
+        foldl'
+    end
diff --git a/demo/more/dlist.urs b/demo/more/dlist.urs
index 872dabcd..fcfe15ee 100644
--- a/demo/more/dlist.urs
+++ b/demo/more/dlist.urs
@@ -6,6 +6,7 @@ val clear : t ::: Type -> dlist t -> transaction unit
 val append : t ::: Type -> dlist t -> t -> transaction position
 val delete : position -> transaction unit
 val elements : t ::: Type -> dlist t -> signal (list t)
+val foldl : t ::: Type -> acc ::: Type -> (t -> acc -> signal acc) -> acc -> dlist t -> signal acc
 
 val render : ctx ::: {Unit} -> [ctx ~ body] => t ::: Type
              -> (t -> position -> xml (ctx ++ body) [] [])
diff --git a/demo/more/grid.ur b/demo/more/grid.ur
index cb836970..7e593791 100644
--- a/demo/more/grid.ur
+++ b/demo/more/grid.ur
@@ -32,11 +32,13 @@ functor Make(M : sig
 
                  con aggregates :: {Type}
                  val aggregates : $(map (aggregateMeta row) aggregates)
+                 val aggFolder : folder aggregates
              end) = struct
     style tabl
     style tr
     style th
     style td
+    style agg
 
     fun make (row : M.row) [t] (m : colMeta' M.row t) : transaction t = m.Project row
 
@@ -77,101 +79,118 @@ functor Make(M : sig
         <tr class={tr}>
           <th/> <th/>
           {foldRX2 [fst] [colMeta M.row] [_]
-                  (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest]
-                                   data (meta : colMeta M.row p) =>
-                      <xml><th class={th}>{[(meta.Handlers data).Header]}</th></xml>)
-                  [_] M.folder grid.Cols M.cols}
-          </tr>
-
-          {Dlist.render (fn {Row = rowS, Cols = colsS, Updating = ud} 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 [fst] [colMeta M.row] [snd] [fn _ => option string]
-                                                           (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(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 [fst] [colMeta M.row] [snd] [fn _ => M.row]
-                                                             (fn [nm :: Name] [t :: (Type * Type)]
-                                                                              [rest :: {(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
-                                <xml><tr class={tr}>
-                                  <td>
-                                    <dyn signal={b <- signal ud;
+                   (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest]
+                                    data (meta : colMeta M.row p) =>
+                       <xml><th class={th}>{[(meta.Handlers data).Header]}</th></xml>)
+                   [_] M.folder grid.Cols M.cols}
+        </tr>
+
+        {Dlist.render (fn {Row = rowS, Cols = colsS, Updating = ud} 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 [fst] [colMeta M.row] [snd] [fn _ => option string]
+                                                         (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(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 [fst] [colMeta M.row] [snd] [fn _ => M.row]
+                                                           (fn [nm :: Name] [t :: (Type * Type)]
+                                                                            [rest :: {(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
+                              <xml><tr class={tr}>
+                                <td>
+                                  <dyn signal={b <- signal ud;
+                                               return (if b then
+                                                           <xml><button value="Save" onclick={save}/></xml>
+                                                       else
+                                                           <xml><button value="Update" onclick={update}/></xml>)}/>
+                                </td>
+
+                                <td><dyn signal={b <- signal ud;
                                                  return (if b then
-                                                             <xml><button value="Save" onclick={save}/></xml>
+                                                             <xml><button value="Cancel" onclick={cancel}/></xml>
                                                          else
-                                                             <xml><button value="Update" onclick={update}/></xml>)}/>
-                                  </td>
-                                  <td><dyn signal={b <- signal ud;
-                                                   return (if b then
-                                                               <xml><button value="Cancel" onclick={cancel}/></xml>
-                                                           else
-                                                               <xml><button value="Delete" onclick={delete}/></xml>)}/>
-                                  </td>
-
-                                  <dyn signal={cols <- signal colsS;
-                                               return (foldRX3 [fst] [colMeta M.row] [snd] [_]
-                                                               (fn [nm :: Name] [t :: (Type * Type)]
-                                                                                [rest :: {(Type * Type)}]
-                                                                                [[nm] ~ rest] data meta v =>
-                                                                   <xml><td class={td}>
-                                                                     <dyn signal={b <- signal ud;
-                                                                                  return (if b then
-                                                                                              (meta.Handlers data).Edit v
-                                                                                          else
-                                                                                              (meta.Handlers data).Display
-                                                                                                                  v)}/>
-                                                                     <dyn signal={b <- signal ud;
-                                                                                  if b then
-                                                                                      valid <-
-                                                                                      (meta.Handlers data).Validate v;
-                                                                                      return (if valid then
-                                                                                                  <xml/>
-                                                                                              else
-                                                                                                  <xml>!</xml>)
-                                                                                  else
-                                                                                      return <xml/>}/>
-                                                                   </td></xml>)
-                                                               [_] M.folder grid.Cols M.cols cols)}/>
-                                  </tr></xml>
-                            end) grid.Rows}
+                                                             <xml><button value="Delete" onclick={delete}/></xml>)}/>
+                                </td>
+
+                                <dyn signal={cols <- signal colsS;
+                                             return (foldRX3 [fst] [colMeta M.row] [snd] [_]
+                                                             (fn [nm :: Name] [t :: (Type * Type)]
+                                                                              [rest :: {(Type * Type)}]
+                                                                              [[nm] ~ rest] data meta v =>
+                                                                 <xml><td class={td}>
+                                                                   <dyn signal={b <- signal ud;
+                                                                                return (if b then
+                                                                                            (meta.Handlers data).Edit v
+                                                                                        else
+                                                                                            (meta.Handlers data).Display
+                                                                                                                v)}/>
+                                                                   <dyn signal={b <- signal ud;
+                                                                                if b then
+                                                                                    valid <-
+                                                                                    (meta.Handlers data).Validate v;
+                                                                                    return (if valid then
+                                                                                                <xml/>
+                                                                                            else
+                                                                                                <xml>!</xml>)
+                                                                                else
+                                                                                    return <xml/>}/>
+                                                                 </td></xml>)
+                                                             [_] M.folder grid.Cols M.cols cols)}/>
+                                </tr></xml>
+                          end) grid.Rows}
+
+            <dyn signal={rows <- Dlist.foldl (fn row => 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 <xml><tr>
+                           <td/><td/>
+                           {foldRX2 [aggregateMeta M.row] [id] [_]
+                                    (fn [nm :: Name] [t :: Type] [rest :: {Type}] [[nm] ~ rest] meta acc =>
+                                        <xml><td class={agg}>{meta.Display acc}</td></xml>)
+                                    [_] M.aggFolder M.aggregates rows}
+                         </tr></xml>}/>
           </table>
           
           <button value="New row" onclick={row <- rpc M.new;
diff --git a/demo/more/grid.urs b/demo/more/grid.urs
index 083f458f..a3fd76cc 100644
--- a/demo/more/grid.urs
+++ b/demo/more/grid.urs
@@ -32,6 +32,7 @@ functor Make(M : sig
 
                  con aggregates :: {Type}
                  val aggregates : $(map (aggregateMeta row) aggregates)
+                 val aggFolder : folder aggregates
              end) : sig
     type grid
 
diff --git a/demo/more/grid1.ur b/demo/more/grid1.ur
index 829cf052..edd5858d 100644
--- a/demo/more/grid1.ur
+++ b/demo/more/grid1.ur
@@ -45,7 +45,18 @@ open Make(struct
                           DA = computed "2A" (fn r => 2 * r.A),
                           Link = computedHtml "Link" (fn r => <xml><a link={page (r.A, r.B)}>Go</a></xml>)}
 
-              val aggregates = {}
+              val aggregates = {Dummy1 = {Initial = (),
+                                          Step = fn _ _ => (),
+                                          Display = fn _ => <xml/>},
+                                Sum = {Initial = 0,
+                                       Step = fn r n => r.A + n,
+                                       Display = txt},
+                                Dummy2 = {Initial = (),
+                                          Step = fn _ _ => (),
+                                          Display = fn _ => <xml>-</xml>},
+                                And = {Initial = True,
+                                       Step = fn r b => r.C && b,
+                                       Display = txt}}
           end)
 
 fun main () =
diff --git a/demo/more/out/grid.css b/demo/more/out/grid.css
index 22cfaa06..7903b673 100644
--- a/demo/more/out/grid.css
+++ b/demo/more/out/grid.css
@@ -13,3 +13,7 @@
 .Grid1_td {
         border-style: solid
 }
+
+.Grid1_agg {
+        border-style: solid
+}
\ No newline at end of file