demo/more/grid.ur


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170

con colMeta' = fn (row :: Type) (t :: Type) =>
                  {Header : string,
                   Project : row -> transaction t,
                   Update : row -> t -> transaction row,
                   Display : t -> xbody,
                   Edit : t -> xbody,
                   Validate : t -> signal bool}

con colMeta = fn (row :: Type) (global_t :: (Type * Type)) =>
                 {Initialize : transaction global_t.1,
                  Handlers : global_t.1 -> colMeta' row global_t.2}                  

functor Make(M : sig
                 type row
                 val list : transaction (list row)
                 val new : transaction row
                 val save : {Old : row, New : row} -> transaction unit
                 val delete : row -> transaction unit

                 con cols :: {(Type * Type)}
                 val cols : $(map (colMeta row) cols)

                 val folder : folder cols
             end) = struct
    style tabl
    style tr
    style th
    style td

    fun make (row : M.row) [t] (m : colMeta' M.row t) : transaction t = m.Project row

    fun makeAll cols row = @@Monad.exec [transaction] _ [map snd M.cols]
                               (map2 [fst] [colMeta M.row] [fn p :: (Type * Type) => transaction p.2]
                                     (fn [p] data meta => make row [_] (meta.Handlers data))
                                     [_] M.folder cols M.cols)
                               (@@Folder.mp [_] [_] M.folder)

    fun addRow cols rows row =
        rowS <- source row;
        cols <- makeAll cols row;
        colsS <- source cols;
        ud <- source False;
        Monad.ignore (Dlist.append rows {Row = rowS,
                                         Cols = colsS,
                                         Updating = ud})

    type grid = {Cols : $(map fst M.cols),
                 Rows : Dlist.dlist {Row : source M.row, Cols : source ($(map snd M.cols)), Updating : source bool}}
 
    val createMetas = Monad.mapR [colMeta M.row] [fst]
                           (fn [nm :: Name] [p :: (Type * Type)] meta => meta.Initialize)
                           [_] M.folder M.cols

    val grid =
        cols <- createMetas;
        rows <- Dlist.create;
        return {Cols = cols, Rows = rows}

    fun sync {Cols = cols, Rows = rows} =
        Dlist.clear rows;
        init <- rpc M.list;
        List.app (addRow cols rows) init

    fun render grid = <xml>
      <table class={tabl}>
        <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 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 {Old = row, New = 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="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}
          </table>
          
          <button value="New row" onclick={row <- rpc M.new;
                                           addRow grid.Cols grid.Rows row}/>
          <button value="Refresh" onclick={sync grid}/>
    </xml>
end