adamc@915: con rawMeta = fn t :: Type =>
adamc@915:                  {New : transaction t,
adamc@915:                   Inj : sql_injectable t}
adamc@915: 
adamc@915: con colMeta' = fn (row :: {Type}) (t :: Type) =>
adamc@915:                   {Header : string,
adamc@915:                    Project : $row -> transaction t,
adamc@915:                    Update : $row -> t -> transaction ($row),
adamc@915:                    Display : t -> xbody,
adamc@915:                    Edit : t -> xbody,
adamc@915:                    Validate : t -> signal bool}
adamc@915: 
adamc@915: con colMeta = fn (row :: {Type}) (global_t :: (Type * Type)) =>
adamc@915:                  {Initialize : transaction global_t.1,
adamc@915:                   Handlers : global_t.1 -> colMeta' row global_t.2}
adamc@915: 
adamc@915: structure Direct = struct
adamc@915:     con meta = fn global_actual_input :: (Type * Type * Type) =>
adamc@915:                   {Initialize : transaction global_actual_input.1,
adamc@915:                    Handlers : global_actual_input.1
adamc@915:                               -> {Display : global_actual_input.3 -> xbody,
adamc@915:                                   Edit : global_actual_input.3 -> xbody,
adamc@915:                                   Initialize : global_actual_input.2 -> transaction global_actual_input.3,
adamc@915:                                   Parse : global_actual_input.3 -> signal (option global_actual_input.2)}}
adamc@915: 
adamc@915:     con editableState (ts :: (Type * Type * Type)) = (ts.1, ts.3)
adamc@915:     fun editable [ts] [rest] [nm :: Name] [[nm] ~ rest] name (m : meta ts) : colMeta ([nm = ts.2] ++ rest)
adamc@915:                                                                                      (editableState ts) =
adamc@915:        {Initialize = m.Initialize,
adamc@915:         Handlers = fn data => {Header = name,
adamc@915:                                Project = fn r => (m.Handlers data).Initialize r.nm,
adamc@915:                                Update = fn r s =>
adamc@915:                                            vo <- current ((m.Handlers data).Parse s);
adamc@915:                                            return (case vo of
adamc@915:                                                        None => r
adamc@915:                                                      | Some v => r -- nm ++ {nm = v}),
adamc@915:                                Display = (m.Handlers data).Display,
adamc@915:                                Edit = (m.Handlers data).Edit,
adamc@915:                                Validate = fn s => vo <- (m.Handlers data).Parse s; return (Option.isSome vo)}}
adamc@915:         
adamc@915:     con readOnlyState (ts :: (Type * Type * Type)) = (ts.1, ts.3)
adamc@915:     fun readOnly [ts] [rest] [nm :: Name] [[nm] ~ rest] name (m : meta ts) : colMeta ([nm = ts.2] ++ rest)
adamc@915:                                                                                      (readOnlyState ts) =
adamc@915:        {Initialize = m.Initialize,
adamc@915:         Handlers = fn data => {Header = name,
adamc@915:                                Project = fn r => (m.Handlers data).Initialize r.nm,
adamc@915:                                Update = fn r _ => return r,
adamc@915:                                Display = (m.Handlers data).Display,
adamc@915:                                Edit = (m.Handlers data).Display,
adamc@915:                                Validate = fn _ => return True}}
adamc@915: 
adamc@915:     con metaBasic = fn actual_input :: (Type * Type) =>
adamc@915:                   {Display : actual_input.2 -> xbody,
adamc@915:                    Edit : source actual_input.2 -> xbody,
adamc@915:                    Initialize : actual_input.1 -> actual_input.2,
adamc@915:                    Parse : actual_input.2 -> option actual_input.1}
adamc@915: 
adamc@915:     con basicState = source
adamc@915:     fun basic [ts ::: (Type * Type)] (m : metaBasic ts) : meta (unit, ts.1, basicState ts.2) =
adamc@915:         {Initialize = return (),
adamc@915:          Handlers = fn () => {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@915:                               Parse = fn s => v <- signal s; return (m.Parse v)}}
adamc@915: 
adamc@915:     type intGlobal = unit
adamc@915:     type intInput = basicState string
adamc@915:     val int : meta (intGlobal, int, intInput) =
adamc@915:         basic {Display = fn s => <xml>{[s]}</xml>,
adamc@915:                Edit = fn s => <xml><ctextbox source={s}/></xml>,
adamc@915:                Initialize = fn n => show n,
adamc@915:                Parse = fn v => read v}
adamc@915: 
adamc@915:     type stringGlobal = unit
adamc@915:     type stringInput = basicState string
adamc@915:     val string : meta (stringGlobal, string, stringInput) =
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@915:                Parse = fn s => Some s}
adamc@915: 
adamc@915:     type boolGlobal = unit
adamc@915:     type boolInput = basicState bool
adamc@915:     val bool : meta (boolGlobal, bool, boolInput) =
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@915:                Parse = fn b => Some b}
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@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@915:         con global = list (t * string)
adamc@915:         con input = source string * t * $row
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@915:         val meta =
adamc@915:             {Initialize = getChoices,
adamc@915:              Handlers = fn choices =>
adamc@915:                            {Display = fn (_, k, r) => <xml>{[render ({nm = k} ++ r)]}</xml>,
adamc@915:                             Edit = fn (s, k, _) => 
adamc@915:                                       <xml><cselect source={s}>
adamc@915:                                         {List.mapX (fn (k', rend) =>
adamc@915:                                                        <xml><coption value={show k'} selected={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@915:                                             return (s, k, r),
adamc@915:                             Parse = fn (s, _, _) => k <- signal s; return (read k)}}
adamc@915:     end
adamc@915: end
adamc@915: 
adamc@915: con computedState = (unit, xbody)
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@915:                           Validate = fn _ => return True}}
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@915:                           Validate = fn _ => return True}}
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@915:                  con cols :: {(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@915:              end) = struct
adamc@915:     open Grid.Make(struct
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@915:                            map2 [rawMeta] [id] [sql_exp env [] []]
adamc@915:                            (fn [t] meta v => @sql_inject meta.Inj v)
adamc@915:                            [_] wholeRow M.raw r
adamc@915: 
adamc@915:                        val new =
adamc@915:                            row <- Monad.mapR [rawMeta] [id]
adamc@915:                                               (fn [nm :: Name] [t :: Type] meta => meta.New)
adamc@915:                                               [_] wholeRow M.raw;
adamc@915:                            dml (insert M.tab (ensql row));
adamc@915:                            return row
adamc@915: 
adamc@915:                        fun selector (r : $(M.key ++ M.row)) : sql_exp [T = M.key ++ M.row] [] [] bool =
adamc@915:                          foldR2 [rawMeta] [id]
adamc@915:                                 [fn key => rest :: {Type} -> [rest ~ key] => sql_exp [T = key ++ rest] [] [] bool]
adamc@915:                                 (fn [nm :: Name] [t :: Type] [key :: {Type}] [[nm] ~ key]
adamc@915:                                     (meta : rawMeta t) (v : t)
adamc@915:                                     (exp : rest :: {Type} -> [rest ~ key] => sql_exp [T = key ++ rest] [] [] bool)
adamc@915:                                     [rest :: {Type}] [rest ~ [nm = t] ++ key] =>
adamc@915:                                     (WHERE T.{nm} = {@sql_inject meta.Inj v} AND {exp [[nm = t] ++ rest] !}))
adamc@915:                                 (fn [rest :: {Type}] [rest ~ []] => (WHERE TRUE))
adamc@915:                                 [_] M.keyFolder (M.raw --- map rawMeta M.row) (r --- M.row)
adamc@915:                                 [_] !
adamc@915: 
adamc@915:                        fun save {Old = row, New = row'} =
adamc@915:                            dml (update [M.key ++ M.row] !
adamc@915:                                        (ensql row')
adamc@915:                                        M.tab
adamc@915:                                        (selector row))
adamc@915: 
adamc@915:                        fun delete row =
adamc@915:                            dml (Basis.delete M.tab (selector row))
adamc@915: 
adamc@915:                        val cols = M.cols
adamc@915: 
adamc@915:                        val folder = M.colsFolder
adamc@915:                    end)
adamc@915: end