adamc@993: functor Make(M : sig
adamc@993:                  con key :: {Type}
adamc@993:                  con data :: {Type}
adamc@993:                  constraint key ~ data
adamc@995:                  constraint [When, Version] ~ (key ++ data)
adamc@993: 
adamc@993:                  val key : $(map sql_injectable key)
adamc@993:                  val data : $(map (fn t => {Inj : sql_injectable_prim t,
adamc@993:                                             Eq : eq t}) data)
adamc@993: 
adamc@993:                  val keyFolder : folder key
adamc@993:                  val dataFolder : folder data
adamc@993:              end) = struct
adamc@995:     type version = int
adamc@995:     con all = [When = time, Version = version] ++ M.key ++ map option M.data
adamc@995:     sequence s
adamc@993:     table t : all
adamc@993: 
adamc@993:     val keys = List.mapQuery (SELECT DISTINCT t.{{M.key}} FROM t) (fn r => r.T)
adamc@995:     fun keysAt vr = List.mapQuery (SELECT DISTINCT t.{{M.key}} FROM t
adamc@995:                                    WHERE t.Version <= {[vr]}) (fn r => r.T)
adamc@993: 
adamc@993:     con dmeta = fn t => {Inj : sql_injectable_prim t,
adamc@993:                          Eq : eq t}
adamc@993: 
adamc@993:     fun keyRecd (r : $(M.key ++ M.data)) =
adam@1778:         @map2 [sql_injectable] [ident] [sql_exp [] [] []]
adamc@1093:          (fn [t] => @sql_inject)
adamc@1093:          M.keyFolder M.key (r --- M.data)
adamc@993: 
adamc@995:     fun insert r =
adamc@995:         vr <- nextval s;
adamc@995:         dml (Basis.insert t
adamc@995:                           ({Version = (SQL {[vr]}), When = (SQL CURRENT_TIMESTAMP)}
adamc@995:                                ++ keyRecd r
adam@1649:                                ++ @map2 [dmeta] [ident]
adam@1778:                                [fn t => sql_exp [] [] [] (option t)]
adamc@995:                                (fn [t] x v => @sql_inject (@sql_option_prim x.Inj)
adamc@995:                                                (Some v))
adamc@1093:                                M.dataFolder M.data (r --- M.key)))
adamc@993: 
adam@1778:     fun keyExp (r : $M.key) : sql_exp [T = all] [] [] bool =
adam@1649:         @foldR2 [sql_injectable] [ident] [fn before => after :: {Type} -> [before ~ after]
adam@1778:                                           => sql_exp [T = before ++ after] [] [] bool]
adamc@1093:          (fn [nm :: Name] [t :: Type] [before :: {Type}] [[nm] ~ before]
adamc@1093:                           (inj : sql_injectable t) (v : t)
adamc@1093:                           (e : after :: {Type} -> [before ~ after]
adam@1778:                            => sql_exp [T = before ++ after] [] [] bool)
adamc@1093:                           [after :: {Type}] [[nm = t] ++ before ~ after] =>
adam@1488:              (SQL t.{nm} = {[v]} AND {e [[nm = t] ++ after]}))
adamc@1093:          (fn [after :: {Type}] [[] ~ after] => (SQL TRUE))
adamc@1093:          M.keyFolder M.key r
adamc@1093:          [_] !
adamc@993: 
adamc@995:     datatype bound =
adamc@995:              NoBound
adamc@995:            | Lt of int
adamc@995:            | Le of int
adamc@995: 
adamc@995:     fun seek vro k =
adamc@993:         let
adamc@995:             fun current' vro r =
adamc@993:                 let
adamc@1093:                     val complete = @foldR [option] [fn ts => option $ts]
adamc@1093:                                     (fn [nm :: Name] [v :: Type] [r :: {Type}] [[nm] ~ r]
adamc@1093:                                                      v r =>
adamc@1093:                                         case (v, r) of
adamc@1093:                                             (Some v, Some r) => Some ({nm = v} ++ r)
adamc@1093:                                           | _ => None)
adamc@1093:                                     (Some {}) M.dataFolder r
adamc@993:                 in
adamc@993:                     case complete of
adamc@993:                         Some r => return (Some r)
adamc@993:                       | None =>
adamc@993:                         let
adamc@995:                             val filter = case vro of
adamc@995:                                              NoBound => (WHERE TRUE)
adamc@995:                                            | Lt vr => (WHERE t.Version < {[vr]})
adamc@995:                                            | Le vr => (WHERE t.Version <= {[vr]})
adamc@993:                         in
adamc@995:                             ro <- oneOrNoRows (SELECT t.Version, t.{{map option M.data}}
adamc@993:                                                FROM t
adamc@993:                                                WHERE {filter}
adamc@993:                                                  AND {keyExp k}
adamc@993:                                                ORDER BY t.When DESC
adamc@993:                                                LIMIT 1);
adamc@993:                             case ro of
adamc@993:                                 None => return None
adamc@993:                               | Some r' =>
adamc@993:                                 let
adamc@1093:                                     val r = @map2 [option] [option] [option]
adamc@1093:                                              (fn [t ::: Type] old new =>
adamc@1093:                                                  case old of
adamc@1093:                                                      None => new
adamc@1093:                                                    | Some _ => old)
adamc@1093:                                              M.dataFolder r (r'.T -- #Version)
adamc@993:                                 in
adamc@995:                                     current' (Lt r'.T.Version) r
adamc@993:                                 end
adamc@993:                         end
adamc@993:                 end
adamc@993:         in
adamc@1093:             current' vro (@map0 [option] (fn [t :: Type] => None : option t) M.dataFolder)
adamc@993:         end
adamc@993: 
adamc@995:     val current = seek NoBound
adamc@995:     fun archive vr = seek (Le vr)
adamc@995: 
adamc@993:     fun update r =
adamc@993:         cur <- current (r --- M.data);
adamc@993:         case cur of
adamc@993:             None => error <xml>Tried to update nonexistent key</xml>
adamc@993:           | Some cur =>
adamc@995:             vr <- nextval s;
adamc@993:             let
adam@1778:                 val r' = @map3 [dmeta] [ident] [ident] [fn t => sql_exp [] [] [] (option t)]
adamc@1093:                           (fn [t] (meta : dmeta t) old new =>
adamc@1093:                               @sql_inject (@sql_option_prim meta.Inj)
adamc@1093:                                (if @@eq [_] meta.Eq old new then
adamc@1093:                                     None
adamc@1093:                                 else
adamc@1093:                                     Some new))
adamc@1093:                           M.dataFolder M.data cur (r --- M.key)
adamc@995:                 val r' = {Version = (SQL {[vr]}), When = (SQL CURRENT_TIMESTAMP)}
adamc@993:                              ++ keyRecd r
adamc@993:                              ++ r'
adamc@993:             in
adamc@993:                 dml (Basis.insert t r')
adamc@993:             end
adamc@995: 
adamc@995:     val updateTimes = List.mapQuery (SELECT t.Version, t.When
adamc@995:                                      FROM t
adamc@995:                                      ORDER BY t.When) (fn r => (r.T.Version, r.T.When))
adamc@993: end