adamc@915: con rawMeta = fn t :: Type =>
adamc@915:                  {New : transaction t,
adamc@915:                   Inj : sql_injectable t}
adamc@915: 
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@915: 
adamc@944: con colMeta = fn (row :: {Type}) (global_input_filter :: (Type * Type * Type)) =>
adamc@944:                  {Initialize : transaction global_input_filter.1,
adamc@944:                   Handlers : global_input_filter.1 -> colMeta' row global_input_filter.2 global_input_filter.3}
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: structure Direct = struct
adamc@944:     con metaBase = fn actual_input_filter :: (Type * Type * Type) =>
adamc@944:                   {Display : actual_input_filter.2 -> xbody,
adamc@944:                    Edit : actual_input_filter.2 -> xbody,
adamc@944:                    Initialize : actual_input_filter.1 -> transaction actual_input_filter.2,
adamc@944:                    Parse : actual_input_filter.2 -> signal (option actual_input_filter.1),
adamc@944:                    CreateFilter : transaction actual_input_filter.3,
adamc@944:                    DisplayFilter : actual_input_filter.3 -> xbody,
adamc@961:                    Filter : actual_input_filter.3 -> actual_input_filter.1 -> signal bool,
adamc@961:                    Sort : actual_input_filter.1 -> actual_input_filter.1 -> bool}
adamc@930: 
adamc@944:     datatype metaBoth actual input filter =
adamc@944:              NonNull of metaBase (actual, input, filter) * metaBase (option actual, input, filter)
adamc@944:            | Nullable of metaBase (actual, input, filter)
adamc@930: 
adam@1304:     con meta = fn global_actual_input_filter =>
adamc@944:                   {Initialize : transaction global_actual_input_filter.1,
adamc@944:                    Handlers : global_actual_input_filter.1
adamc@944:                               -> metaBoth global_actual_input_filter.2 global_actual_input_filter.3
adamc@944:                                           global_actual_input_filter.4}
adamc@915: 
adamc@944:     con editableState (ts :: (Type * Type * Type * Type)) = (ts.1, ts.3, ts.4)
adamc@915:     fun editable [ts] [rest] [nm :: Name] [[nm] ~ rest] name (m : meta ts) : colMeta ([nm = ts.2] ++ rest)
adamc@915:                                                                                      (editableState ts) =
adamc@930:        let
adam@1304:            fun doMr (mr : metaBase (ts.2, ts.3, ts.4)) : colMeta' ([nm = ts.2] ++ rest) ts.3 ts.4 =
adam@1304:                {Header = name,
adam@1304:                 Project = fn r => mr.Initialize r.nm,
adam@1304:                 Update = fn r s =>
adam@1304:                             vo <- current (mr.Parse s);
adam@1304:                             return (case vo of
adam@1304:                                         None => r
adam@1304:                                       | Some v => r -- nm ++ {nm = v}),
adam@1304:                 Display = mr.Display,
adam@1304:                 Edit = mr.Edit,
adam@1304:                 Validate = fn s => vo <- mr.Parse s; return (Option.isSome vo),
adam@1304:                 CreateFilter = mr.CreateFilter,
adam@1304:                 DisplayFilter = mr.DisplayFilter,
adam@1304:                 Filter = fn i r => mr.Filter i r.nm,
adam@1304:                 Sort = Some (fn r1 r2 => mr.Sort r1.nm r2.nm)} 
adamc@930:        in
adamc@930:            {Initialize = m.Initialize,
adamc@930:             Handlers = fn data => case m.Handlers data of
adam@1304:                                       NonNull (mr, _) => doMr mr
adam@1304:                                     | Nullable mr => doMr mr}
adamc@930:        end
adamc@915:         
adamc@944:     con readOnlyState (ts :: (Type * Type * Type * Type)) = (ts.1, ts.3, ts.4)
adamc@915:     fun readOnly [ts] [rest] [nm :: Name] [[nm] ~ rest] name (m : meta ts) : colMeta ([nm = ts.2] ++ rest)
adamc@915:                                                                                      (readOnlyState ts) =
adamc@930:        let
adamc@930:            fun doMr mr = {Header = name,
adamc@930:                           Project = fn r => mr.Initialize r.nm,
adamc@930:                           Update = fn r _ => return r,
adamc@930:                           Display = mr.Display,
adamc@930:                           Edit = mr.Display,
adamc@944:                           Validate = fn _ => return True,
adamc@944:                           CreateFilter = mr.CreateFilter,
adamc@944:                           DisplayFilter = mr.DisplayFilter,
adamc@961:                           Filter = fn i r => mr.Filter i r.nm,
adamc@961:                           Sort = Some (fn r1 r2 => mr.Sort r1.nm r2.nm)}
adamc@930:        in
adamc@930:            {Initialize = m.Initialize,
adamc@930:             Handlers = fn data => case m.Handlers data of
adamc@930:                                       NonNull (mr, _) => doMr mr
adamc@930:                                     | Nullable mr => doMr mr}
adamc@930:        end
adamc@915: 
adamc@944:     con metaBasic = fn actual_input_filter :: (Type * Type * Type) =>
adamc@944:                        {Display : actual_input_filter.2 -> xbody,
adamc@944:                         Edit : source actual_input_filter.2 -> xbody,
adamc@944:                         Initialize : actual_input_filter.1 -> actual_input_filter.2,
adamc@944:                         InitializeNull : actual_input_filter.2,
adamc@944:                         IsNull : actual_input_filter.2 -> bool,
adamc@944:                         Parse : actual_input_filter.2 -> option actual_input_filter.1,
adamc@944:                         CreateFilter : actual_input_filter.3,
adamc@944:                         DisplayFilter : source actual_input_filter.3 -> xbody,
adamc@944:                         Filter : actual_input_filter.3 -> actual_input_filter.1 -> bool,
adamc@961:                         FilterIsNull : actual_input_filter.3 -> bool,
adamc@961:                         Sort : actual_input_filter.1 -> actual_input_filter.1 -> bool}
adamc@915: 
adamc@915:     con basicState = source
adamc@944:     con basicFilter = source
adamc@944:     fun basic [ts ::: (Type * Type * Type)] (m : metaBasic ts) : meta (unit, ts.1, basicState ts.2, basicFilter ts.3) =
adamc@915:         {Initialize = return (),
adamc@930:          Handlers = fn () => NonNull (
adamc@930:                              {Display = fn s => <xml><dyn signal={v <- signal s; return (m.Display v)}/></xml>,
adamc@915:                               Edit = m.Edit,
adamc@915:                               Initialize = fn v => source (m.Initialize v),
adamc@944:                               Parse = fn s => v <- signal s; return (m.Parse v),
adamc@944:                               CreateFilter = source m.CreateFilter,
adamc@944:                               DisplayFilter = m.DisplayFilter,
adamc@946:                               Filter = fn f v => f <- signal f;
adamc@946:                                           return (if m.FilterIsNull f then
adamc@946:                                                       True
adamc@946:                                                   else
adamc@961:                                                       m.Filter f v),
adamc@961:                               Sort = m.Sort},
adamc@930:                              {Display = fn s => <xml><dyn signal={v <- signal s; return (m.Display v)}/></xml>,
adamc@930:                               Edit = m.Edit,
adamc@930:                               Initialize = fn v => source (case v of
adamc@930:                                                        None => m.InitializeNull
adamc@930:                                                      | Some v => m.Initialize v),
adamc@930:                               Parse = fn s => v <- signal s;
adamc@930:                                          return (if m.IsNull v then
adamc@930:                                                      Some None
adamc@930:                                                  else
adamc@930:                                                      case m.Parse v of
adamc@930:                                                          None => None
adamc@944:                                                        | Some v' => Some (Some v')),
adamc@944:                               CreateFilter = source m.CreateFilter,
adamc@944:                               DisplayFilter = m.DisplayFilter,
adamc@944:                               Filter = fn f v => f <- signal f;
adamc@944:                                           return (if m.FilterIsNull f then
adamc@946:                                                       True
adamc@944:                                                   else
adamc@944:                                                       case v of
adamc@944:                                                           None => False
adamc@961:                                                         | Some v => m.Filter f v),
adamc@961:                               Sort = fn x y =>
adamc@961:                                         case (x, y) of
adamc@961:                                             (None, _) => True
adamc@961:                                           | (Some x', Some y') => m.Sort x' y'
adamc@961:                                           | _ => False})}
adamc@930: 
adamc@944:     fun nullable [global] [actual] [input] [filter] (m : meta (global, actual, input, filter)) =
adamc@930:         {Initialize = m.Initialize,
adamc@930:          Handlers = fn d => case m.Handlers d of
adamc@930:                                 Nullable _ => error <xml>Don't stack calls to Direct.nullable!</xml>
adamc@930:                               | NonNull (_, ho) => Nullable ho}
adamc@915: 
adamc@915:     type intGlobal = unit
adamc@915:     type intInput = basicState string
adamc@944:     type intFilter = basicFilter string
adamc@944:     val int : meta (intGlobal, int, intInput, intFilter) =
adamc@915:         basic {Display = fn s => <xml>{[s]}</xml>,
adamc@946:                Edit = fn s => <xml><ctextbox size={5} source={s}/></xml>,
adamc@915:                Initialize = fn n => show n,
adamc@930:                InitializeNull = "",
adamc@930:                IsNull = eq "",
adamc@944:                Parse = fn v => read v,
adamc@944:                CreateFilter = "",
adamc@946:                DisplayFilter = fn s => <xml><ctextbox size={5} source={s}/></xml> : xbody,
adamc@944:                Filter = fn s n =>
adamc@944:                            case read s of
adamc@944:                                None => True
adamc@944:                              | Some n' => n' = n,
adamc@961:                FilterIsNull = eq "",
adamc@961:                Sort = le}
adamc@915: 
adamc@915:     type stringGlobal = unit
adamc@915:     type stringInput = basicState string
adamc@944:     type stringFilter = basicFilter string
adamc@944:     val string : meta (stringGlobal, string, stringInput, stringFilter) =
adamc@915:         basic {Display = fn s => <xml>{[s]}</xml>,
adamc@915:                Edit = fn s => <xml><ctextbox source={s}/></xml>,
adamc@915:                Initialize = fn s => s,
adamc@930:                InitializeNull = "",
adamc@930:                IsNull = eq "",
adamc@944:                Parse = fn s => Some s,
adamc@944:                CreateFilter = "",
adamc@944:                DisplayFilter = fn s => <xml><ctextbox source={s}/></xml> : xbody,
adamc@944:                Filter = fn s n =>
adamc@944:                            case read s of
adamc@944:                                None => True
adamc@944:                              | Some n' => n' = n,
adamc@961:                FilterIsNull = eq "",
adamc@961:                Sort = le}
adamc@915: 
adamc@915:     type boolGlobal = unit
adamc@915:     type boolInput = basicState bool
adamc@944:     type boolFilter = basicFilter string
adamc@944:     val bool : meta (boolGlobal, bool, boolInput, boolFilter) =
adamc@915:         basic {Display = fn b => <xml>{[b]}</xml>,
adamc@915:                Edit = fn s => <xml><ccheckbox source={s}/></xml>,
adamc@915:                Initialize = fn b => b,
adamc@930:                InitializeNull = False,
adamc@930:                IsNull = fn _ => False,
adamc@944:                Parse = fn b => Some b,
adamc@944:                CreateFilter = "",
adamc@944:                DisplayFilter = fn s => <xml><cselect source={s}>
adamc@944:                  <coption/>
adamc@944:                  <coption value="0">False</coption>
adamc@944:                  <coption value="1">True</coption>
adamc@944:                </cselect></xml> : xbody,
adamc@944:                Filter = fn s b =>
adamc@944:                            case s of
adamc@944:                                "0" => b = False
adamc@944:                              | "1" => b = True
adamc@944:                              | _ => True,
adamc@961:                FilterIsNull = eq "",
adamc@961:                Sort = le}
adamc@915: 
adamc@915:     functor Foreign (M : sig
adamc@915:                          con row :: {Type}
adamc@915:                          con t :: Type
adamc@915:                          val show_t : show t
adamc@915:                          val read_t : read t
adamc@915:                          val eq_t : eq t
adamc@961:                          val ord_t : ord t
adamc@915:                          val inj_t : sql_injectable t
adamc@915:                          con nm :: Name
adamc@915:                          constraint [nm] ~ row
adamc@915:                          table tab : ([nm = t] ++ row)
adamc@915:                          val render : $([nm = t] ++ row) -> string
adamc@915:                      end) = struct
adamc@915:         open M
adamc@915: 
adamc@944:         type global = list (t * string)
adamc@944:         type input = source string * option (t * $row)
adamc@944:         type filter = source string
adamc@915: 
adamc@915:         val getChoices = List.mapQuery (SELECT * FROM tab AS T)
adamc@915:                                        (fn r => (r.T.nm, render r.T))
adamc@915: 
adamc@915:         fun getChoice k =
adamc@915:             r <- oneRow (SELECT T.{{row}} FROM tab AS T WHERE T.{nm} = {[k]});
adamc@915:             return r.T
adamc@915: 
adamc@944:         val meta : meta (global, M.t, input, filter) =
adamc@915:             {Initialize = getChoices,
adamc@915:              Handlers = fn choices =>
adamc@930:                            NonNull (
adamc@930:                            {Display = fn (_, kr) => case kr of
adamc@930:                                                           None => error <xml>Unexpected Foreign null</xml>
adamc@930:                                                         | Some (k, r) => <xml>{[render ({nm = k} ++ r)]}</xml>,
adamc@930:                             Edit = fn (s, kr) => 
adamc@915:                                       <xml><cselect source={s}>
adamc@915:                                         {List.mapX (fn (k', rend) =>
adamc@930:                                                        <xml><coption value={show k'} selected={case kr of
adamc@930:                                                                                                    None => False
adamc@930:                                                                                                  | Some (k, _) =>
adamc@930:                                                                                                    k' = k}>{[rend]}</coption>
adamc@915:                                                        </xml>)
adamc@915:                                                    choices}
adamc@915:                                       </cselect></xml>,
adamc@915:                             Initialize = fn k => s <- source (show k);
adamc@915:                                             r <- rpc (getChoice k);
adamc@930:                                             return (s, Some (k, r)),
adamc@944:                             Parse = fn (s, _) => k <- signal s; return (read k : option t),
adamc@944:                             CreateFilter = source "",
adamc@944:                             DisplayFilter = fn s => 
adamc@944:                                                <xml><cselect source={s}>
adamc@944:                                                  <coption/>
adamc@944:                                                  {List.mapX (fn (k, rend) =>
adamc@944:                                                                 <xml><coption value={show k}>{[rend]}</coption></xml>)
adamc@944:                                                             choices}
adamc@944:                                                </cselect></xml> : xbody,
adamc@944:                             Filter = fn s k => s <- signal s;
adamc@944:                                         return (case read s : option t of
adamc@944:                                                     None => True
adamc@961:                                                   | Some k' => k' = k),
adamc@961:                             Sort = le},
adamc@930:                            {Display = fn (_, kr) => case kr of
adamc@930:                                                           None => <xml>NULL</xml>
adamc@930:                                                         | Some (k, r) => <xml>{[render ({nm = k} ++ r)]}</xml>,
adamc@930:                             Edit = fn (s, kr) => 
adamc@930:                                       <xml><cselect source={s}>
adamc@930:                                         <coption value="" selected={case kr of
adamc@930:                                                                         None => True
adamc@930:                                                                       | _ => False}>NULL</coption>
adamc@930:                                         {List.mapX (fn (k', rend) =>
adamc@930:                                                        <xml><coption value={show k'} selected={case kr of
adamc@930:                                                                                                    None => False
adamc@930:                                                                                                  | Some (k, _) =>
adamc@930:                                                                                                    k' = k}>{[rend]}</coption>
adamc@930:                                                        </xml>)
adamc@930:                                                    choices}
adamc@930:                                       </cselect></xml>,
adamc@930:                             Initialize = fn k => case k of
adamc@930:                                                      None =>
adamc@930:                                                      s <- source "";
adamc@930:                                                      return (s, None)
adamc@930:                                                    | Some k =>
adamc@930:                                                      s <- source (show k);
adamc@930:                                                      r <- rpc (getChoice k);
adamc@930:                                                      return (s, Some (k, r)),
adamc@930:                             Parse = fn (s, _) => ks <- signal s;
adamc@930:                                        return (case ks of
adamc@930:                                                    "" => Some None
adamc@930:                                                  | _ => case read ks : option t of
adamc@930:                                                             None => None
adamc@944:                                                           | Some k => Some (Some k)),
adamc@944:                             CreateFilter = source "",
adamc@944:                             DisplayFilter = fn s => 
adamc@944:                                                <xml><cselect source={s}>
adamc@944:                                                  <coption/>
adamc@944:                                                  <coption value="0">NULL</coption>
adamc@944:                                                  {List.mapX (fn (k, rend) =>
adamc@944:                                                                 <xml><coption value={"1" ^ show k}>{[rend]}</coption>
adamc@944:                                                                 </xml>)
adamc@944:                                                             choices}
adamc@944:                                                </cselect></xml> : xbody,
adamc@944:                             Filter = fn s ko => s <- signal s;
adamc@944:                                         return (case s of
adamc@944:                                                     "" => True
adamc@944:                                                   | "0" => ko = None
adamc@944:                                                   | _ =>
adamc@944:                                                     case read (String.substring s {Start = 1,
adamc@944:                                                                                    Len = String.length s - 1})
adamc@944:                                                          : option t of
adamc@944:                                                         None => True
adamc@961:                                                       | Some k => ko = Some k),
adamc@961:                             Sort = le})}
adamc@915:     end
adamc@915: end
adamc@915: 
adamc@944: con computedState = (unit, xbody, unit)
adamc@915: fun computed [row] [t] (_ : show t) name (f : $row -> t) : colMeta row computedState =
adamc@915:     {Initialize = return (),
adamc@915:      Handlers = fn () => {Header = name,
adamc@915:                           Project = fn r => return <xml>{[f r]}</xml>,
adamc@915:                           Update = fn r _ => return r,
adamc@915:                           Display = fn x => x,
adamc@915:                           Edit = fn _ => <xml>...</xml>,
adamc@944:                           Validate = fn _ => return True,
adamc@944:                           CreateFilter = return (),
adamc@944:                           DisplayFilter = fn _ => <xml/>,
adamc@961:                           Filter = fn _ _ => return True,
adamc@961:                           Sort = None}}
adamc@915: fun computedHtml [row] name (f : $row -> xbody) : colMeta row computedState =
adamc@915:     {Initialize = return (),
adamc@915:      Handlers = fn () => {Header = name,
adamc@915:                           Project = fn r => return (f r),
adamc@915:                           Update = fn r _ => return r,
adamc@915:                           Display = fn x => x,
adamc@915:                           Edit = fn _ => <xml>...</xml>,
adamc@944:                           Validate = fn _ => return True,
adamc@944:                           CreateFilter = return (),
adamc@944:                           DisplayFilter = fn _ => <xml/>,
adamc@961:                           Filter = fn _ _ => return True,
adamc@961:                           Sort = None}}
adamc@915: 
adamc@915: functor Make(M : sig
adamc@915:                  con key :: {Type}
adamc@915:                  con row :: {Type}
adamc@915:                  constraint key ~ row
adamc@915:                  table tab : (key ++ row)
adamc@915: 
adamc@915:                  val raw : $(map rawMeta (key ++ row))
adamc@915: 
adamc@944:                  con cols :: {(Type * Type * Type)}
adamc@915:                  val cols : $(map (colMeta (key ++ row)) cols)
adamc@915: 
adamc@915:                  val keyFolder : folder key
adamc@915:                  val rowFolder : folder row
adamc@915:                  val colsFolder : folder cols
adamc@935: 
adamc@935:                  con aggregates :: {Type}
adamc@935:                  val aggregates : $(map (aggregateMeta (key ++ row)) aggregates)
adamc@937:                  val aggFolder : folder aggregates
adamc@964: 
adamc@964:                  val pageLength : option int
adamc@915:              end) = struct
adamc@915:     open Grid.Make(struct
adamc@936:                        fun keyOf r = r --- M.row
adamc@936: 
adamc@915:                        val list = query (SELECT * FROM {{M.tab}} AS T) (fn r rs => return (r.T :: rs)) []
adamc@915: 
adamc@915:                        val wholeRow = @Folder.concat ! M.keyFolder M.rowFolder
adamc@915: 
adamc@915:                        fun ensql [env] (r : $(M.key ++ M.row)) =
adamc@1093:                            @map2 [rawMeta] [id] [sql_exp env [] []]
adamc@1093:                             (fn [t] meta v => @sql_inject meta.Inj v)
adamc@1093:                             wholeRow M.raw r
adamc@915: 
adamc@915:                        val new =
adamc@1093:                            row <- @Monad.mapR _ [rawMeta] [id]
adamc@1093:                                    (fn [nm :: Name] [t :: Type] meta => meta.New)
adamc@1093:                                    wholeRow M.raw;
adamc@915:                            dml (insert M.tab (ensql row));
adamc@915:                            return row
adamc@915: 
adamc@936:                        fun selector (r : $M.key) : sql_exp [T = M.key ++ M.row] [] [] bool =
adamc@1093:                          @foldR2 [rawMeta] [id]
adamc@1093:                           [fn key => rest :: {Type} -> [rest ~ key] => sql_exp [T = key ++ rest] [] [] bool]
adamc@1093:                           (fn [nm :: Name] [t :: Type] [key :: {Type}] [[nm] ~ key]
adamc@1093:                                            (meta : rawMeta t) (v : t)
adamc@1093:                                            (exp : rest :: {Type} -> [rest ~ key] => sql_exp [T = key ++ rest] [] [] bool)
adamc@1093:                                            [rest :: {Type}] [rest ~ [nm = t] ++ key] =>
adam@1488:                               (WHERE T.{nm} = {@sql_inject meta.Inj v} AND {exp [[nm = t] ++ rest]}))
adamc@1093:                           (fn [rest :: {Type}] [rest ~ []] => (WHERE TRUE))
adamc@1093:                           M.keyFolder (M.raw --- map rawMeta M.row) r
adamc@1093:                           [_] !
adamc@915: 
adamc@936:                        fun save key row =
adamc@1093:                            dml (update [M.key ++ M.row]
adamc@936:                                        (ensql row)
adamc@915:                                        M.tab
adamc@936:                                        (selector key))
adamc@915: 
adamc@936:                        fun delete key =
adamc@936:                            dml (Basis.delete M.tab (selector key))
adamc@915: 
adamc@915:                        val cols = M.cols
adamc@915: 
adamc@915:                        val folder = M.colsFolder
adamc@935: 
adamc@935:                        val aggregates = M.aggregates
adamc@937: 
adamc@937:                        val aggFolder = M.aggFolder
adamc@964: 
adamc@964:                        val pageLength = M.pageLength
adamc@915:                    end)
adamc@915: end