Crud demo

7 files changed, 254 insertions, 0 deletions

diff --git a/demo/crud.ur b/demo/crud.ur
new file mode 100644
index 00000000..472de6d4
--- /dev/null
+++ b/demo/crud.ur
@@ -0,0 +1,178 @@
+con colMeta = fn t_formT :: (Type * Type) => {
+                 Nam : string,
+                 Show : t_formT.1 -> xbody,
+                 Widget : nm :: Name -> xml form [] [nm = t_formT.2],
+                 WidgetPopulated : nm :: Name -> t_formT.1 -> xml form [] [nm = t_formT.2],
+                 Parse : t_formT.2 -> t_formT.1,
+                 Inject : sql_injectable t_formT.1
+                 }
+con colsMeta = fn cols :: {(Type * Type)} => $(Top.mapT2T colMeta cols)
+
+fun default (t ::: Type) (sh : show t) (rd : read t) (inj : sql_injectable t)
+            name : colMeta (t, string) =
+    {Nam = name,
+     Show = txt,
+     Widget = fn nm :: Name => <xml><textbox{nm}/></xml>,
+     WidgetPopulated = fn (nm :: Name) n =>
+                          <xml><textbox{nm} value={show n}/></xml>,
+     Parse = readError,
+     Inject = _}
+
+val int = default
+val float = default
+val string = default
+
+fun bool name = {Nam = name,
+                 Show = txt,
+                 Widget = fn nm :: Name => <xml><checkbox{nm}/></xml>,
+                 WidgetPopulated = fn (nm :: Name) b =>
+                                      <xml><checkbox{nm} checked={b}/></xml>,
+                 Parse = fn x => x,
+                 Inject = _}
+
+functor Make(M : sig
+                 con cols :: {(Type * Type)}
+                 constraint [Id] ~ cols
+                 val tab : sql_table ([Id = int] ++ mapT2T fstTT cols)
+
+                 val title : string
+
+                 val cols : colsMeta cols
+             end) = struct
+
+    open constraints M
+    val tab = M.tab
+
+    sequence seq
+
+    fun list () =
+        rows <- queryX (SELECT * FROM tab AS T)
+                       (fn (fs : {T : $([Id = int] ++ mapT2T fstTT M.cols)}) => <xml>
+                         <tr>
+                           <td>{[fs.T.Id]}</td>
+                           {foldT2RX2 [fstTT] [colMeta] [tr]
+                                      (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
+                                                       [[nm] ~ rest] v col => <xml>
+                                                         <td>{col.Show v}</td>
+                                                       </xml>)
+                                      [M.cols] (fs.T -- #Id) M.cols}
+                           <td>
+                             <a link={upd fs.T.Id}>[Update]</a>
+                             <a link={confirm fs.T.Id}>[Delete]</a>
+                           </td>
+                         </tr>
+                       </xml>);
+        return <xml>
+          <table border={1}>
+            <tr>
+              <th>ID</th>
+              {foldT2RX [colMeta] [tr]
+                        (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
+                                         [[nm] ~ rest] col => <xml>
+                                           <th>{cdata col.Nam}</th>
+                                         </xml>)
+                        [M.cols] M.cols}
+            </tr>
+            {rows}
+          </table>
+
+          <br/><hr/><br/>
+
+          <form>
+            {foldT2R [colMeta] [fn cols :: {(Type * Type)} => xml form [] (mapT2T sndTT cols)]
+                     (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
+                                      [[nm] ~ rest] (col : colMeta t) (acc : xml form [] (mapT2T sndTT rest)) => <xml>
+                                        <li> {cdata col.Nam}: {col.Widget [nm]}</li>
+                                        {useMore acc}
+                                      </xml>)
+                     <xml/>
+                     [M.cols] M.cols}
+            
+            <submit action={create}/>
+          </form>
+        </xml>
+
+    and create (inputs : $(mapT2T sndTT M.cols)) =
+        id <- nextval seq;
+        () <- dml (insert tab
+                          (foldT2R2 [sndTT] [colMeta]
+                                    [fn cols => $(mapT2T (fn t :: (Type * Type) =>
+                                                             sql_exp [] [] [] t.1) cols)]
+                                    (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
+                                                     [[nm] ~ rest] =>
+                                     fn input col acc => acc with nm = @sql_inject col.Inject (col.Parse input))
+                                    {} [M.cols] inputs M.cols
+                           with #Id = (SQL {id})));
+        ls <- list ();
+        return <xml><body>
+          <p>Inserted with ID {[id]}.</p>
+
+          {ls}
+        </body></xml>
+
+    and save (id : int) (inputs : $(mapT2T sndTT M.cols)) =
+        () <- dml (update [mapT2T fstTT M.cols]
+                          (foldT2R2 [sndTT] [colMeta]
+                                    [fn cols => $(mapT2T (fn t :: (Type * Type) =>
+                                                             sql_exp [T = [Id = int]
+                                                                              ++ mapT2T fstTT M.cols]
+                                                                     [] [] t.1) cols)]
+                                    (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
+                                                     [[nm] ~ rest] =>
+                                     fn input col acc => acc with nm =
+                                                                  @sql_inject col.Inject (col.Parse input))
+                                    {} [M.cols] inputs M.cols)
+                          tab (WHERE T.Id = {id}));
+        ls <- list ();
+        return <xml><body>
+          <p>Saved!</p>
+
+          {ls}
+        </body></xml>
+
+    and upd (id : int) =
+        fso <- oneOrNoRows (SELECT tab.{{mapT2T fstTT M.cols}} FROM tab WHERE tab.Id = {id});
+        case fso : (Basis.option {Tab : $(mapT2T fstTT M.cols)}) of
+            None => return <xml><body>Not found!</body></xml>
+          | Some fs => return <xml><body><form>
+            {foldT2R2 [fstTT] [colMeta] [fn cols :: {(Type * Type)} => xml form [] (mapT2T sndTT cols)]
+                      (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
+                                       [[nm] ~ rest] (v : t.1) (col : colMeta t)
+                                       (acc : xml form [] (mapT2T sndTT rest)) =>
+                          <xml>
+                            <li> {cdata col.Nam}: {col.WidgetPopulated [nm] v}</li>
+                            {useMore acc}
+                          </xml>)
+                      <xml/>
+                      [M.cols] fs.Tab M.cols}
+
+            <submit action={save id}/>
+          </form></body></xml>
+
+    and delete (id : int) =
+        () <- dml (DELETE FROM tab WHERE Id = {id});
+        ls <- list ();
+        return <xml><body>
+          <p>The deed is done.</p>
+
+          {ls}
+        </body></xml>
+
+    and confirm (id : int) = return <xml><body>
+      <p>Are you sure you want to delete ID #{[id]}?</p>
+
+      <p><a link={delete id}>I was born sure!</a></p>
+    </body></xml>
+
+    and main () =
+        ls <- list ();
+        return <xml><head>
+          <title>{cdata M.title}</title>
+        </head><body>
+
+          <h1>{cdata M.title}</h1>
+
+          {ls}
+        </body></xml>
+
+end
diff --git a/demo/crud.urs b/demo/crud.urs
new file mode 100644
index 00000000..33090421
--- /dev/null
+++ b/demo/crud.urs
@@ -0,0 +1,26 @@
+con colMeta = fn t_formT :: (Type * Type) =>
+                 {Nam : string,
+                  Show : t_formT.1 -> xbody,
+                  Widget : nm :: Name -> xml form [] [nm = t_formT.2],
+                  WidgetPopulated : nm :: Name -> t_formT.1
+                                    -> xml form [] [nm = t_formT.2],
+                  Parse : t_formT.2 -> t_formT.1,
+                  Inject : sql_injectable t_formT.1}
+con colsMeta = fn cols :: {(Type * Type)} => $(mapT2T colMeta cols)
+
+val int : string -> colMeta (int, string)
+val float : string -> colMeta (float, string)
+val string : string -> colMeta (string, string)
+val bool : string -> colMeta (bool, bool)
+
+functor Make(M : sig
+                 con cols :: {(Type * Type)}
+                 constraint [Id] ~ cols
+                 val tab : sql_table ([Id = int] ++ mapT2T fstTT cols)
+
+                 val title : string
+
+                 val cols : colsMeta cols
+             end) : sig
+    val main : unit -> transaction page
+end
diff --git a/demo/crud1.ur b/demo/crud1.ur
new file mode 100644
index 00000000..3849e822
--- /dev/null
+++ b/demo/crud1.ur
@@ -0,0 +1,12 @@
+table t1 : {Id : int, A : int, B : string, C : float, D : bool}
+
+open Crud.Make(struct
+                   val tab = t1
+                             
+                   val title = "Crud1"
+                               
+                   val cols = {A = Crud.int "A",
+                               B = Crud.string "B",
+                               C = Crud.float "C",
+                               D = Crud.bool "D"}
+               end)
diff --git a/demo/crud1.urp b/demo/crud1.urp
new file mode 100644
index 00000000..bfc2d14e
--- /dev/null
+++ b/demo/crud1.urp
@@ -0,0 +1,5 @@
+database dbname=test
+sql crud1.sql
+
+crud
+crud1
diff --git a/demo/prose b/demo/prose
index e447aee3..6b7ddf29 100644
--- a/demo/prose
+++ b/demo/prose
@@ -121,3 +121,34 @@ metaform1.urp
 metaform2.urp
 
 <p>This example showcases code reuse by applying the same functor as in the last example.  The <tt>Metaform2</tt> module mixes pages from the functor with some new pages of its own.</p>
+
+crud1.urp
+
+<p>This example pulls together much of what we have seen so far.  It involves a generic "admin interface" builder.  That is, we have the <tt>Crud.Make</tt> functor, which takes in a description of a table and outputs a sub-application for viewing and editing that table.</p>
+
+<p>The signature of <tt>Crud.Make</tt> is based around a type function <tt>colMeta</tt>, which describes which supporting values we need for each column.  This function is declared with the keyword <tt>con</tt>, which stands for "constructor," the general class of "compile-time things" that includes types.  An argument to <tt>colMeta</tt> has kind <tt>(Type * Type)</tt>, which means that it must be a type-level tuple.  The first type is how the column is represented in SQL, and the second is how we represent it in HTML forms.  In order, the components of the resulting record give:
+
+<ol>
+<li> A display name</li>
+<li> A way of pretty-printing values of the column</li>
+<li> A way of generating an HTML form widget to input this column</li>
+<li> A way of generating an HTML form widget with an initial value specified</li>
+<li> A way of parsing values of the column from strings</li>
+<li> A type class witness, showing that the SQL representation can really be included in SQL</li>
+</ol></p>
+
+<p>The function <tt>colsMeta</tt> lifts <tt>colMeta</tt> over type-level records of type pairs.  The <tt>Crud</tt> module also defines reasonable default <tt>colMeta</tt> values for some primitive types.</p>
+
+<p>The functor signature tells us (in order) that an input must contain:
+
+<ol>
+<li> A type pair record <tt>cols</tt></li>
+<li> A proof that <tt>cols</tt> does not contain a field named <tt>Id</tt></li>
+<li> A SQL table <tt>tab</tt> with an <tt>Id</tt> field of type <tt>int</tt> and other fields whose names and types are read off of <tt>cols</tt></li>
+<li> A display title for the admin interface</li>
+<li> A record of meta-data for the columns</li>
+</ol></p>
+
+<p>Looking at <tt>crud1.ur</tt>, we see that a use of the functor is almost trivial.  Only the value components of the argument structure must be provided.  The column row type is inferred, and the disjointness constraint is proved automatically.</p>
+
+<p>We won't go into detail on the implementation of <tt>Crud.Make</tt>.  The types of the functions used there can be found in the signatures of the built-in <tt>Basis</tt> module and the <tt>Top</tt> module from the standard library.  The signature of the first and the signature and implementation of the second can be found in the <tt>lib</tt> directory of the Ur/Web distribution.</p>
diff --git a/demo/ref.urp b/demo/ref.urp
index c00e5406..a6bb1de3 100644
--- a/demo/ref.urp
+++ b/demo/ref.urp
@@ -1,4 +1,5 @@
 database dbname=test
+sql ref.sql
 
 refFun
 ref
diff --git a/demo/sql.urp b/demo/sql.urp
index 1b8bb5a4..7894da95 100644
--- a/demo/sql.urp
+++ b/demo/sql.urp
@@ -1,3 +1,4 @@
 database dbname=test
+sql sql.sql
 
 sql