From a2008ff2da76acfd69886499c6f8386041a1a4e0 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Thu, 30 Oct 2008 15:33:28 -0400
Subject: CURRENT_TIMESTAMP

---
 src/urweb.lex | 2 ++
 1 file changed, 2 insertions(+)

(limited to 'src/urweb.lex')

diff --git a/src/urweb.lex b/src/urweb.lex
index fd8a8077..fc8db17f 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -356,6 +356,8 @@ notags = [^<{\n]+;
 <INITIAL> "SET"       => (Tokens.SET (pos yypos, pos yypos + size yytext));
 <INITIAL> "DELETE"    => (Tokens.DELETE (pos yypos, pos yypos + size yytext));
 
+<INITIAL> "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext));
+
 <INITIAL> {id}        => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext));
 <INITIAL> {cid}       => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext));
 
-- 
cgit v1.2.3


From 389aae9254a3bdee3e79bb75b7355de270f2e8dd Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Fri, 31 Oct 2008 09:30:22 -0400
Subject: Replace 'with' with '++'

---
 lib/top.ur           | 50 +++++++++++++++++++++++++++++++++++++
 lib/top.urs          | 35 ++++++++++++++++++++++++++
 src/core.sml         |  2 +-
 src/core_print.sml   | 23 +++++++----------
 src/core_util.sml    | 16 ++++++------
 src/corify.sml       |  4 +--
 src/elab.sml         |  2 +-
 src/elab_print.sml   | 25 +++++++------------
 src/elab_util.sml    | 16 ++++++------
 src/elaborate.sml    | 70 ++++++++++++++++++++++++++--------------------------
 src/expl.sml         |  2 +-
 src/expl_print.sml   | 23 +++++++----------
 src/expl_util.sml    | 16 ++++++------
 src/explify.sml      |  4 +--
 src/monoize.sml      |  2 +-
 src/reduce.sml       |  8 +++---
 src/source.sml       |  2 +-
 src/source_print.sml | 12 ++++-----
 src/termination.sml  |  2 +-
 src/urweb.grm        |  5 ++--
 src/urweb.lex        |  1 -
 21 files changed, 189 insertions(+), 131 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/lib/top.ur b/lib/top.ur
index d36af3f3..347b2a35 100644
--- a/lib/top.ur
+++ b/lib/top.ur
@@ -4,6 +4,9 @@ con idT (t :: Type) = t
 con record (t :: {Type}) = $t
 con fstTT (t :: (Type * Type)) = t.1
 con sndTT (t :: (Type * Type)) = t.2
+con fstTTT (t :: (Type * Type * Type)) = t.1
+con sndTTT (t :: (Type * Type * Type)) = t.2
+con thdTTT (t :: (Type * Type * Type)) = t.3
 
 con mapTT (f :: Type -> Type) = fold (fn nm t acc [[nm] ~ acc] =>
                                          [nm = f t] ++ acc) []
@@ -14,6 +17,9 @@ con mapUT = fn f :: Type => fold (fn nm t acc [[nm] ~ acc] =>
 con mapT2T (f :: (Type * Type) -> Type) = fold (fn nm t acc [[nm] ~ acc] =>
                                                    [nm = f t] ++ acc) []
 
+con mapT3T (f :: (Type * Type * Type) -> Type) = fold (fn nm t acc [[nm] ~ acc] =>
+                                                          [nm = f t] ++ acc) []
+
 con ex = fn tf :: (Type -> Type) =>
             res ::: Type -> (choice :: Type -> tf choice -> res) -> res
 
@@ -80,6 +86,17 @@ fun foldT2R (tf :: (Type * Type) -> Type) (tr :: {(Type * Type)} -> Type)
                  f [nm] [t] [rest] r.nm (acc (r -- nm)))
              (fn _ => i)
 
+fun foldT3R (tf :: (Type * Type * Type) -> Type) (tr :: {(Type * Type * Type)} -> Type)
+            (f : nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)}
+                 -> fn [[nm] ~ rest] =>
+                       tf t -> tr rest -> tr ([nm = t] ++ rest))
+            (i : tr []) =
+    fold [fn r :: {(Type * Type * Type)} => $(mapT3T tf r) -> tr r]
+             (fn (nm :: Name) (t :: (Type * Type * Type)) (rest :: {(Type * Type * Type)})
+                              (acc : _ -> tr rest) [[nm] ~ rest] r =>
+                 f [nm] [t] [rest] r.nm (acc (r -- nm)))
+             (fn _ => i)
+
 fun foldTR2 (tf1 :: Type -> Type) (tf2 :: Type -> Type) (tr :: {Type} -> Type)
             (f : nm :: Name -> t :: Type -> rest :: {Type}
                  -> fn [[nm] ~ rest] =>
@@ -103,6 +120,18 @@ fun foldT2R2 (tf1 :: (Type * Type) -> Type) (tf2 :: (Type * Type) -> Type)
                  f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
              (fn _ _ => i)
 
+fun foldT3R2 (tf1 :: (Type * Type * Type) -> Type) (tf2 :: (Type * Type * Type) -> Type)
+             (tr :: {(Type * Type * Type)} -> Type)
+             (f : nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)}
+                  -> fn [[nm] ~ rest] =>
+                        tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest))
+             (i : tr []) =
+    fold [fn r :: {(Type * Type * Type)} => $(mapT3T tf1 r) -> $(mapT3T tf2 r) -> tr r]
+             (fn (nm :: Name) (t :: (Type * Type * Type)) (rest :: {(Type * Type * Type)})
+                              (acc : _ -> _ -> tr rest) [[nm] ~ rest] r1 r2 =>
+                 f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
+             (fn _ _ => i)
+
 fun foldTRX (tf :: Type -> Type) (ctx :: {Unit})
             (f : nm :: Name -> t :: Type -> rest :: {Type}
                  -> fn [[nm] ~ rest] =>
@@ -122,6 +151,16 @@ fun foldT2RX (tf :: (Type * Type) -> Type) (ctx :: {Unit})
                 <xml>{f [nm] [t] [rest] r}{acc}</xml>)
             <xml/>
 
+fun foldT3RX (tf :: (Type * Type * Type) -> Type) (ctx :: {Unit})
+             (f : nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)}
+                  -> fn [[nm] ~ rest] =>
+                        tf t -> xml ctx [] []) =
+    foldT3R [tf] [fn _ => xml ctx [] []]
+            (fn (nm :: Name) (t :: (Type * Type * Type)) (rest :: {(Type * Type * Type)})
+                             [[nm] ~ rest] r acc =>
+                <xml>{f [nm] [t] [rest] r}{acc}</xml>)
+            <xml/>
+
 fun foldTRX2 (tf1 :: Type -> Type) (tf2 :: Type -> Type) (ctx :: {Unit})
              (f : nm :: Name -> t :: Type -> rest :: {Type}
                   -> fn [[nm] ~ rest] =>
@@ -143,6 +182,17 @@ fun foldT2RX2 (tf1 :: (Type * Type) -> Type) (tf2 :: (Type * Type) -> Type)
                  <xml>{f [nm] [t] [rest] r1 r2}{acc}</xml>)
              <xml/>
 
+fun foldT3RX2 (tf1 :: (Type * Type * Type) -> Type) (tf2 :: (Type * Type * Type) -> Type)
+              (ctx :: {Unit})
+              (f : nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)}
+                   -> fn [[nm] ~ rest] =>
+                         tf1 t -> tf2 t -> xml ctx [] []) =
+    foldT3R2 [tf1] [tf2] [fn _ => xml ctx [] []]
+             (fn (nm :: Name) (t :: (Type * Type * Type)) (rest :: {(Type * Type * Type)})
+                              [[nm] ~ rest] r1 r2 acc =>
+                 <xml>{f [nm] [t] [rest] r1 r2}{acc}</xml>)
+             <xml/>
+
 fun queryX (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit})
            (q : sql_query tables exps) [tables ~ exps]
            (f : $(exps ++ fold (fn nm (fields :: {Type}) acc [[nm] ~ acc] =>
diff --git a/lib/top.urs b/lib/top.urs
index 6e9dda4e..d52ec9d7 100644
--- a/lib/top.urs
+++ b/lib/top.urs
@@ -4,6 +4,9 @@ con idT = fn t :: Type => t
 con record = fn t :: {Type} => $t
 con fstTT = fn t :: (Type * Type) => t.1
 con sndTT = fn t :: (Type * Type) => t.2
+con fstTTT = fn t :: (Type * Type * Type) => t.1
+con sndTTT = fn t :: (Type * Type * Type) => t.2
+con thdTTT = fn t :: (Type * Type * Type) => t.3
 
 con mapTT = fn f :: Type -> Type => fold (fn nm t acc [[nm] ~ acc] =>
                                              [nm = f t] ++ acc) []
@@ -14,6 +17,9 @@ con mapUT = fn f :: Type => fold (fn nm t acc [[nm] ~ acc] =>
 con mapT2T = fn f :: (Type * Type) -> Type => fold (fn nm t acc [[nm] ~ acc] =>
                                                        [nm = f t] ++ acc) []
 
+con mapT3T = fn f :: (Type * Type * Type) -> Type => fold (fn nm t acc [[nm] ~ acc] =>
+                                                              [nm = f t] ++ acc) []
+
 con ex = fn tf :: (Type -> Type) =>
             res ::: Type -> (choice :: Type -> tf choice -> res) -> res
 
@@ -55,6 +61,12 @@ val foldT2R : tf :: ((Type * Type) -> Type) -> tr :: ({(Type * Type)} -> Type)
                         tf t -> tr rest -> tr ([nm = t] ++ rest))
               -> tr [] -> r :: {(Type * Type)} -> $(mapT2T tf r) -> tr r
 
+val foldT3R : tf :: ((Type * Type * Type) -> Type) -> tr :: ({(Type * Type * Type)} -> Type)
+              -> (nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)}
+                  -> fn [[nm] ~ rest] =>
+                        tf t -> tr rest -> tr ([nm = t] ++ rest))
+              -> tr [] -> r :: {(Type * Type * Type)} -> $(mapT3T tf r) -> tr r
+
 val foldTR2 : tf1 :: (Type -> Type) -> tf2 :: (Type -> Type)
               -> tr :: ({Type} -> Type)
               -> (nm :: Name -> t :: Type -> rest :: {Type}
@@ -71,6 +83,14 @@ val foldT2R2 : tf1 :: ((Type * Type) -> Type) -> tf2 :: ((Type * Type) -> Type)
                -> tr [] -> r :: {(Type * Type)}
                -> $(mapT2T tf1 r) -> $(mapT2T tf2 r) -> tr r
 
+val foldT3R2 : tf1 :: ((Type * Type * Type) -> Type) -> tf2 :: ((Type * Type * Type) -> Type)
+               -> tr :: ({(Type * Type * Type)} -> Type)
+               -> (nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)}
+                   -> fn [[nm] ~ rest] =>
+                         tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest))
+               -> tr [] -> r :: {(Type * Type * Type)}
+               -> $(mapT3T tf1 r) -> $(mapT3T tf2 r) -> tr r
+
 val foldTRX : tf :: (Type -> Type) -> ctx :: {Unit}
               -> (nm :: Name -> t :: Type -> rest :: {Type}
                   -> fn [[nm] ~ rest] =>
@@ -83,6 +103,12 @@ val foldT2RX : tf :: ((Type * Type) -> Type) -> ctx :: {Unit}
                          tf t -> xml ctx [] [])
                -> r :: {(Type * Type)} -> $(mapT2T tf r) -> xml ctx [] []
 
+val foldT3RX : tf :: ((Type * Type * Type) -> Type) -> ctx :: {Unit}
+               -> (nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)}
+                   -> fn [[nm] ~ rest] =>
+                         tf t -> xml ctx [] [])
+               -> r :: {(Type * Type * Type)} -> $(mapT3T tf r) -> xml ctx [] []
+
 val foldTRX2 : tf1 :: (Type -> Type) -> tf2 :: (Type -> Type) -> ctx :: {Unit}
                -> (nm :: Name -> t :: Type -> rest :: {Type}
                    -> fn [[nm] ~ rest] =>
@@ -98,6 +124,15 @@ val foldT2RX2 : tf1 :: ((Type * Type) -> Type) -> tf2 :: ((Type * Type) -> Type)
                 -> r :: {(Type * Type)}
                 -> $(mapT2T tf1 r) -> $(mapT2T tf2 r) -> xml ctx [] []
 
+
+val foldT3RX2 : tf1 :: ((Type * Type * Type) -> Type) -> tf2 :: ((Type * Type * Type) -> Type)
+                -> ctx :: {Unit}
+                -> (nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)}
+                    -> fn [[nm] ~ rest] =>
+                          tf1 t -> tf2 t -> xml ctx [] [])
+                -> r :: {(Type * Type * Type)}
+                -> $(mapT3T tf1 r) -> $(mapT3T tf2 r) -> xml ctx [] []
+
 val queryX : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit}
              -> sql_query tables exps
              -> fn [tables ~ exps] =>
diff --git a/src/core.sml b/src/core.sml
index 11055aa4..baec6e41 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -93,7 +93,7 @@ datatype exp' =
 
        | ERecord of (con * exp * con) list
        | EField of exp * con * { field : con, rest : con }
-       | EWith of exp * con * exp * { field : con, rest : con }
+       | EConcat of exp * con * exp * con
        | ECut of exp * con * { field : con, rest : con }
        | EFold of kind
 
diff --git a/src/core_print.sml b/src/core_print.sml
index 0d470d39..1214a54f 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -283,31 +283,26 @@ fun p_exp' par env (e, _) =
             box [p_exp' true env e,
                  string ".",
                  p_con' true env c]
-      | EWith (e1, c, e2, {field, rest}) =>
+      | EConcat (e1, c1, e2, c2) =>
         parenIf par (if !debug then
-                         box [p_exp env e1,
+                         box [p_exp' true env e1,
                               space,
-                              string "with",
+                              string ":",
                               space,
-                              p_con' true env c,
+                              p_con env c1,
+                              space,
+                              string "++",
                               space,
-                              string "=",
                               p_exp' true env e2,
                               space,
-                              string "[",
-                              p_con env field,
+                              string ":",
                               space,
-                              string " in ",
-                              space,
-                              p_con env rest,
-                              string "]"]
+                              p_con env c2]
                      else
-                         box [p_exp env e1,
+                         box [p_exp' true env e1,
                               space,
                               string "with",
                               space,
-                              p_con' true env c,
-                              space,
                               p_exp' true env e2])
       | ECut (e, c, {field, rest}) =>
         parenIf par (if !debug then
diff --git a/src/core_util.sml b/src/core_util.sml
index df8465ae..f0697183 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -424,19 +424,17 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
                                              S.map2 (mfc ctx rest,
                                                   fn rest' =>
                                                      (EField (e', c', {field = field', rest = rest'}), loc)))))
-              | EWith (e1, c, e2, {field, rest}) =>
+              | EConcat (e1, c1, e2, c2) =>
                 S.bind2 (mfe ctx e1,
                       fn e1' =>
-                         S.bind2 (mfc ctx c,
-                              fn c' =>
+                         S.bind2 (mfc ctx c1,
+                              fn c1' =>
                                  S.bind2 (mfe ctx e2,
                                        fn e2' =>
-                                          S.bind2 (mfc ctx field,
-                                                fn field' =>
-                                                   S.map2 (mfc ctx rest,
-                                                        fn rest' =>
-                                                           (EWith (e1', c', e2', {field = field', rest = rest'}),
-                                                            loc))))))
+                                          S.map2 (mfc ctx c2,
+                                               fn c2' =>
+                                                  (EConcat (e1', c1', e2', c2'),
+                                                   loc)))))
               | ECut (e, c, {field, rest}) =>
                 S.bind2 (mfe ctx e,
                       fn e' =>
diff --git a/src/corify.sml b/src/corify.sml
index 89d1e63f..ff9506fd 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -566,8 +566,8 @@ fun corifyExp st (e, loc) =
                                               (corifyCon st c, corifyExp st e, corifyCon st t)) xes), loc)
       | L.EField (e1, c, {field, rest}) => (L'.EField (corifyExp st e1, corifyCon st c,
                                                        {field = corifyCon st field, rest = corifyCon st rest}), loc)
-      | L.EWith (e1, c, e2, {field, rest}) => (L'.EWith (corifyExp st e1, corifyCon st c, corifyExp st e2,
-                                                         {field = corifyCon st field, rest = corifyCon st rest}), loc)
+      | L.EConcat (e1, c1, e2, c2) => (L'.EConcat (corifyExp st e1, corifyCon st c1, corifyExp st e2,
+                                                   corifyCon st c2), loc)
       | L.ECut (e1, c, {field, rest}) => (L'.ECut (corifyExp st e1, corifyCon st c,
                                                    {field = corifyCon st field, rest = corifyCon st rest}), loc)
       | L.EFold k => (L'.EFold (corifyKind k), loc)
diff --git a/src/elab.sml b/src/elab.sml
index 9bb609bf..4202d367 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -108,7 +108,7 @@ datatype exp' =
 
        | ERecord of (con * exp * con) list
        | EField of exp * con * { field : con, rest : con }
-       | EWith of exp * con * exp * { field : con, rest : con }
+       | EConcat of exp * con * exp * con
        | ECut of exp * con * { field : con, rest : con }
        | EFold of kind
 
diff --git a/src/elab_print.sml b/src/elab_print.sml
index c1bc5938..8c0b41f7 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -317,33 +317,26 @@ fun p_exp' par env (e, _) =
             box [p_exp' true env e,
                  string ".",
                  p_con' true env c]
-      | EWith (e1, c, e2, {field, rest}) =>
+      | EConcat (e1, c1, e2, c2) =>
         parenIf par (if !debug then
-                         box [p_exp env e1,
+                         box [p_exp' true env e1,
                               space,
-                              string "with",
+                              string ":",
                               space,
-                              p_con' true env c,
+                              p_con env c1,
                               space,
-                              string "=",
-                              p_exp' true env e2,
+                              string "++",
                               space,
-                              string "[",
-                              p_con env field,
+                              p_exp' true env e2,
                               space,
-                              string " in ",
+                              string ":",
                               space,
-                              p_con env rest,
-                              string "]"]
+                              p_con env c2]
                      else
-                         box [p_exp env e1,
+                         box [p_exp' true env e1,
                               space,
                               string "with",
                               space,
-                              p_con' true env c,
-                              space,
-                              string "=",
-                              space,
                               p_exp' true env e2])
       | ECut (e, c, {field, rest}) =>
         parenIf par (if !debug then
diff --git a/src/elab_util.sml b/src/elab_util.sml
index 69ed3248..247e2b3a 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -309,19 +309,17 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
                                              S.map2 (mfc ctx rest,
                                                   fn rest' =>
                                                      (EField (e', c', {field = field', rest = rest'}), loc)))))
-              | EWith (e1, c, e2, {field, rest}) =>
+              | EConcat (e1, c1, e2, c2) =>
                 S.bind2 (mfe ctx e1,
                       fn e1' =>
-                         S.bind2 (mfc ctx c,
-                              fn c' =>
+                         S.bind2 (mfc ctx c1,
+                              fn c1' =>
                                  S.bind2 (mfe ctx e2,
                                        fn e2' =>
-                                          S.bind2 (mfc ctx field,
-                                                fn field' =>
-                                                   S.map2 (mfc ctx rest,
-                                                        fn rest' =>
-                                                           (EWith (e1', c', e2', {field = field', rest = rest'}),
-                                                            loc))))))
+                                          S.map2 (mfc ctx c2,
+                                               fn c2' =>
+                                                  (EConcat (e1', c1', e2', c2'),
+                                                   loc)))))
               | ECut (e, c, {field, rest}) =>
                 S.bind2 (mfe ctx e,
                       fn e' =>
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 6e23c760..4927e37d 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1,29 +1,29 @@
 (* Copyright (c) 2008, Adam Chlipala
-  * All rights reserved.
-  *
-  * Redistribution and use in source and binary forms, with or without
-  * modification, are permitted provided that the following conditions are met:
-  *
-  * - Redistributions of source code must retain the above copyright notice,
-  *   this list of conditions and the following disclaimer.
-  * - Redistributions in binary form must reproduce the above copyright notice,
-  *   this list of conditions and the following disclaimer in the documentation
-  *   and/or other materials provided with the distribution.
-  * - The names of contributors may not be used to endorse or promote products
-  *   derived from this software without specific prior written permission.
-  *
-  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
-  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
-  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
-  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
-  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
-  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
-  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
-  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-  * POSSIBILITY OF SUCH DAMAGE.
-  *)
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
 
  structure Elaborate :> ELABORATE = struct
 
@@ -1603,21 +1603,21 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
                 ((L'.EField (e', c', {field = ft, rest = rest}), loc), ft, gs1 @ enD gs2 @ enD gs3 @ enD gs4)
             end
 
-          | L.EWith (e1, c, e2) =>
+          | L.EConcat (e1, e2) =>
             let
                 val (e1', e1t, gs1) = elabExp (env, denv) e1
-                val (c', ck, gs2) = elabCon (env, denv) c
-                val (e2', e2t, gs3) = elabExp (env, denv) e2
+                val (e2', e2t, gs2) = elabExp (env, denv) e2
 
-                val rest = cunif (loc, ktype_record)
-                val first = (L'.CRecord (ktype, [(c', e2t)]), loc)
+                val r1 = cunif (loc, ktype_record)
+                val r2 = cunif (loc, ktype_record)
 
-                val gs4 = checkCon (env, denv) e1' e1t (L'.TRecord rest, loc)
-                val gs5 = D.prove env denv (first, rest, loc)
+                val gs3 = checkCon (env, denv) e1' e1t (L'.TRecord r1, loc)
+                val gs4 = checkCon (env, denv) e2' e2t (L'.TRecord r2, loc)
+                val gs5 = D.prove env denv (r1, r2, loc)
             in
-                ((L'.EWith (e1', c', e2', {field = e2t, rest = rest}), loc),
-                 (L'.TRecord ((L'.CConcat (first, rest), loc)), loc),
-                 gs1 @ enD gs2 @ gs3 @ enD gs4 @ enD gs5)
+                ((L'.EConcat (e1', r1, e2', r2), loc),
+                 (L'.TRecord ((L'.CConcat (r1, r2), loc)), loc),
+                 gs1 @ gs2 @ enD gs3 @ enD gs4 @ enD gs5)
             end
           | L.ECut (e, c) =>
             let
diff --git a/src/expl.sml b/src/expl.sml
index 9e35d674..2e96db54 100644
--- a/src/expl.sml
+++ b/src/expl.sml
@@ -90,7 +90,7 @@ datatype exp' =
 
        | ERecord of (con * exp * con) list
        | EField of exp * con * { field : con, rest : con }
-       | EWith of exp * con * exp * { field : con, rest : con }
+       | EConcat of exp * con * exp * con
        | ECut of exp * con * { field : con, rest : con }
        | EFold of kind
 
diff --git a/src/expl_print.sml b/src/expl_print.sml
index 39df4e3f..d19edeae 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -289,31 +289,26 @@ fun p_exp' par env (e, loc) =
             box [p_exp' true env e,
                  string ".",
                  p_con' true env c]
-      | EWith (e1, c, e2, {field, rest}) =>
+      | EConcat (e1, c1, e2, c2) =>
         parenIf par (if !debug then
-                         box [p_exp env e1,
+                         box [p_exp' true env e1,
                               space,
-                              string "with",
+                              string ":",
                               space,
-                              p_con' true env c,
+                              p_con env c1,
+                              space,
+                              string "++",
                               space,
-                              string "=",
                               p_exp' true env e2,
                               space,
-                              string "[",
-                              p_con env field,
+                              string ":",
                               space,
-                              string " in ",
-                              space,
-                              p_con env rest,
-                              string "]"]
+                              p_con env c2]
                      else
-                         box [p_exp env e1,
+                         box [p_exp' true env e1,
                               space,
                               string "with",
                               space,
-                              p_con' true env c,
-                              space,
                               p_exp' true env e2])
       | ECut (e, c, {field, rest}) =>
         parenIf par (if !debug then
diff --git a/src/expl_util.sml b/src/expl_util.sml
index 8dec2687..bda602d3 100644
--- a/src/expl_util.sml
+++ b/src/expl_util.sml
@@ -282,19 +282,17 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
                                              S.map2 (mfc ctx rest,
                                                   fn rest' =>
                                                      (EField (e', c', {field = field', rest = rest'}), loc)))))
-              | EWith (e1, c, e2, {field, rest}) =>
+              | EConcat (e1, c1, e2, c2) =>
                 S.bind2 (mfe ctx e1,
                       fn e1' =>
-                         S.bind2 (mfc ctx c,
-                              fn c' =>
+                         S.bind2 (mfc ctx c1,
+                              fn c1' =>
                                  S.bind2 (mfe ctx e2,
                                        fn e2' =>
-                                          S.bind2 (mfc ctx field,
-                                                fn field' =>
-                                                   S.map2 (mfc ctx rest,
-                                                        fn rest' =>
-                                                           (EWith (e1', c', e2', {field = field', rest = rest'}),
-                                                            loc))))))
+                                          S.map2 (mfc ctx c2,
+                                               fn c2' =>
+                                                  (EConcat (e1', c1', e2', c2'),
+                                                   loc)))))
               | ECut (e, c, {field, rest}) =>
                 S.bind2 (mfe ctx e,
                       fn e' =>
diff --git a/src/explify.sml b/src/explify.sml
index 72531d7a..1bca49c3 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -101,8 +101,8 @@ fun explifyExp (e, loc) =
       | L.ERecord xes => (L'.ERecord (map (fn (c, e, t) => (explifyCon c, explifyExp e, explifyCon t)) xes), loc)
       | L.EField (e1, c, {field, rest}) => (L'.EField (explifyExp e1, explifyCon c,
                                                        {field = explifyCon field, rest = explifyCon rest}), loc)
-      | L.EWith (e1, c, e2, {field, rest}) => (L'.EWith (explifyExp e1, explifyCon c, explifyExp e2,
-                                                        {field = explifyCon field, rest = explifyCon rest}), loc)
+      | L.EConcat (e1, c1, e2, c2) => (L'.EConcat (explifyExp e1, explifyCon c1, explifyExp e2, explifyCon c2),
+                                       loc)
       | L.ECut (e1, c, {field, rest}) => (L'.ECut (explifyExp e1, explifyCon c,
                                                      {field = explifyCon field, rest = explifyCon rest}), loc)
       | L.EFold k => (L'.EFold (explifyKind k), loc)
diff --git a/src/monoize.sml b/src/monoize.sml
index df775554..17e28034 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1920,7 +1920,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             in
                 ((L'.EField (e, monoName env x), loc), fm)
             end
-          | L.EWith _ => poly ()
+          | L.EConcat _ => poly ()
           | L.ECut _ => poly ()
           | L.EFold _ => poly ()
 
diff --git a/src/reduce.sml b/src/reduce.sml
index 8dc4527f..1404b598 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -107,18 +107,18 @@ fun exp env e =
                                       | _ => false) xes of
                          SOME (_, e, _) => #1 e
                        | NONE => e)
-                  | EWith (r as (_, loc), x, e, {rest = (CRecord (k, xts), _), field}) =>
+                  | EConcat (r1 as (_, loc), (CRecord (k, xts1), _), r2, (CRecord (_, xts2), _)) =>
                     let
-                        fun fields (remaining, passed) =
+                        fun fields (r, remaining, passed) =
                             case remaining of
                                 [] => []
                               | (x, t) :: rest =>
                                 (x,
                                  (EField (r, x, {field = t,
                                                  rest = (CRecord (k, List.revAppend (passed, rest)), loc)}), loc),
-                                 t) :: fields (rest, (x, t) :: passed)
+                                 t) :: fields (r, rest, (x, t) :: passed)
                     in
-                        #1 (reduceExp env (ERecord ((x, e, field) :: fields (xts, [])), loc))
+                        #1 (reduceExp env (ERecord (fields (r1, xts1, []) @ fields (r2, xts2, [])), loc))
                     end
                   | ECut (r as (_, loc), _, {rest = (CRecord (k, xts), _), ...}) =>
                     let
diff --git a/src/source.sml b/src/source.sml
index 23d2089f..386b1a83 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -123,7 +123,7 @@ datatype exp' =
 
        | ERecord of (con * exp) list
        | EField of exp * con
-       | EWith of exp * con * exp
+       | EConcat of exp * exp
        | ECut of exp * con
        | EFold
 
diff --git a/src/source_print.sml b/src/source_print.sml
index f9fc8a53..a25be2d4 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -258,13 +258,11 @@ fun p_exp' par (e, _) =
       | EField (e, c) => box [p_exp' true e,
                               string ".",
                               p_con' true c]
-      | EWith (e1, c, e2) => parenIf par (box [p_exp e1,
-                                               space,
-                                               string "with",
-                                               space,
-                                               p_con' true c,
-                                               space,
-                                               p_exp' true e2])
+      | EConcat (e1, e2) => parenIf par (box [p_exp' true e1,
+                                              space,
+                                              string "++",
+                                              space,
+                                              p_exp' true e2])
       | ECut (e, c) => parenIf par (box [p_exp' true e,
                                          space,
                                          string "--",
diff --git a/src/termination.sml b/src/termination.sml
index 1bae7592..b0716eca 100644
--- a/src/termination.sml
+++ b/src/termination.sml
@@ -265,7 +265,7 @@ fun declOk' env (d, loc) =
                         in
                             (Rabble, calls)
                         end
-                      | EWith (e1, _, e2, _) =>
+                      | EConcat (e1, _, e2, _) =>
                         let
                             val (_, calls) = exp parent (penv, calls) e1
                             val (_, calls) = exp parent (penv, calls) e2
diff --git a/src/urweb.grm b/src/urweb.grm
index 3f56cb94..143b6935 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -198,7 +198,7 @@ fun tagIn bt =
  | TYPE | NAME
  | ARROW | LARROW | DARROW | STAR | SEMI
  | FN | PLUSPLUS | MINUSMINUS | DOLLAR | TWIDDLE
- | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | WITH | SQL
+ | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL
  | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE
  | CASE | IF | THEN | ELSE
 
@@ -344,7 +344,6 @@ fun tagIn bt =
 %right CAND
 %nonassoc EQ NE LT LE GT GE
 %right ARROW
-%left WITH
 %right PLUSPLUS MINUSMINUS
 %left PLUS MINUS
 %left STAR DIVIDE MOD
@@ -699,7 +698,7 @@ eexp   : eapps                          (eapps)
        | eexp GT eexp                   (native_op ("gt", eexp1, eexp2, s (eexp1left, eexp2right)))
        | eexp GE eexp                   (native_op ("ge", eexp1, eexp2, s (eexp1left, eexp2right)))
 
-       | eexp WITH cterm EQ eexp        (EWith (eexp1, cterm, eexp2), s (eexp1left, eexp2right))
+       | eexp PLUSPLUS eexp             (EConcat (eexp1, eexp2), s (eexp1left, eexp2right))
 
 bind   : SYMBOL LARROW eapps            (SYMBOL, NONE, eapps)
        | UNIT LARROW eapps              (let
diff --git a/src/urweb.lex b/src/urweb.lex
index fc8db17f..cc0f5b7c 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -311,7 +311,6 @@ notags = [^<{\n]+;
 <INITIAL> "table"     => (Tokens.TABLE (pos yypos, pos yypos + size yytext));
 <INITIAL> "sequence"  => (Tokens.SEQUENCE (pos yypos, pos yypos + size yytext));
 <INITIAL> "class"     => (Tokens.CLASS (pos yypos, pos yypos + size yytext));
-<INITIAL> "with"      => (Tokens.WITH (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "Type"      => (Tokens.TYPE (pos yypos, pos yypos + size yytext));
 <INITIAL> "Name"      => (Tokens.NAME (pos yypos, pos yypos + size yytext));
-- 
cgit v1.2.3


From 89f97891a33b5c0a8971d3508059a139a8815091 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sat, 1 Nov 2008 10:47:10 -0400
Subject: Parsing 'let'

---
 src/elisp/urweb-defs.el | 23 +++++++++++----------
 src/elisp/urweb-mode.el |  2 +-
 src/source.sml          |  7 +++++++
 src/source_print.sml    | 55 +++++++++++++++++++++++++++++++++++--------------
 src/urweb.grm           | 12 +++++++++++
 src/urweb.lex           |  2 ++
 tests/let.ur            |  6 ++++++
 tests/let.urp           |  3 +++
 8 files changed, 82 insertions(+), 28 deletions(-)
 create mode 100644 tests/let.ur
 create mode 100644 tests/let.urp

(limited to 'src/urweb.lex')

diff --git a/src/elisp/urweb-defs.el b/src/elisp/urweb-defs.el
index 8b4ebe2e..fe4da2e4 100644
--- a/src/elisp/urweb-defs.el
+++ b/src/elisp/urweb-defs.el
@@ -91,7 +91,7 @@ notion of \"the end of an outline\".")
 
 
 (defconst urweb-begin-syms
-  '("struct" "sig")
+  '("let" "struct" "sig")
   "Symbols matching the `end' symbol.")
 
 (defconst urweb-begin-syms-re
@@ -103,12 +103,12 @@ notion of \"the end of an outline\".")
 ;;   "Symbols matching (loosely) the `end' symbol.")
 
 (defconst urweb-sexp-head-symbols-re
-  (urweb-syms-re "struct" "sig" "with"
-	       "if" "then" "else" "case" "of" "fn" "fun" "val" "and"
-	       "datatype" "type" "open" "include"
-	       urweb-module-head-syms
-	       "con" "fold" "where" "extern" "constraint" "constraints"
-               "table" "sequence" "class")
+  (urweb-syms-re "let" "struct" "sig" "in" "with"
+                 "if" "then" "else" "case" "of" "fn" "fun" "val" "and"
+                 "datatype" "type" "open" "include"
+                 urweb-module-head-syms
+                 "con" "fold" "where" "extern" "constraint" "constraints"
+                 "table" "sequence" "class")
   "Symbols starting an sexp.")
 
 ;; (defconst urweb-not-arg-start-re
@@ -133,11 +133,11 @@ notion of \"the end of an outline\".")
      ("if" "else" 0)
      (,urweb-=-starter-syms nil)
      (("case" "datatype" "if" "then" "else"
-       "open" "sig" "struct" "type" "val"
+       "let" "open" "sig" "struct" "type" "val"
        "con" "constraint" "table" "sequence" "class")))))
 
 (defconst urweb-starters-indent-after
-  (urweb-syms-re "struct" "sig")
+  (urweb-syms-re "let" "in" "struct" "sig")
   "Indent after these.")
 
 (defconst urweb-delegate
@@ -164,11 +164,12 @@ for all symbols and in all lines starting with the given symbol."
 
 (defconst urweb-open-paren
   (urweb-preproc-alist
-   `((,(list* urweb-begin-syms) ,urweb-begin-syms-re "\\<end\\>")))
+   `((,(list* "in" urweb-begin-syms) ,urweb-begin-syms-re "\\<end\\>")))
   "Symbols that should behave somewhat like opening parens.")
 
 (defconst urweb-close-paren
-  `(("end" ,urweb-begin-syms-re)
+  `(("in" "\\<let\\>")
+    ("end" ,urweb-begin-syms-re)
     ("then" "\\<if\\>")
     ("else" "\\<if\\>" (urweb-bolp))
     ("of" "\\<case\\>")
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index 8c016e3d..1a578cf9 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -135,7 +135,7 @@ See doc for the variable `urweb-mode-info'."
   (urweb-syms-re "and" "case" "class" "con" "constraint" "constraints"
 	       "datatype" "else" "end" "extern" "fn" "fold"
 	       "fun" "functor" "if" "include"
-	       "of" "open"
+	       "of" "open" "let" "in"
 	       "rec" "sequence" "sig" "signature"
 	       "struct" "structure" "table" "then" "type" "val" "where"
 	       "with"
diff --git a/src/source.sml b/src/source.sml
index 386b1a83..7e204390 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -131,7 +131,14 @@ datatype exp' =
 
        | ECase of exp * (pat * exp) list
 
+       | ELet of edecl list * exp
+
+and edecl' =
+    EDVal of string * con option * exp
+  | EDValRec of (string * con option * exp) list
+
 withtype exp = exp' located
+and edecl = edecl' located
 
 datatype decl' =
          DCon of string * kind option * con
diff --git a/src/source_print.sml b/src/source_print.sml
index a25be2d4..9e6608df 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -285,8 +285,47 @@ fun p_exp' par (e, _) =
 
       | EWild => string "_"
 
+      | ELet (ds, e) => box [string "let",
+                             newline,
+                             box [p_list_sep newline p_edecl ds],
+                             newline,
+                             string "in",
+                             newline,
+                             box [p_exp e],
+                             newline,
+                             string "end"]
+
 and p_exp e = p_exp' false e
 
+and p_edecl (d, _) =
+  case d of
+      EDVal vi => box [string "val",
+                       space,
+                       p_vali vi]
+    | EDValRec vis => box [string "val",
+                           space,
+                           string "rec",
+                           space,
+                           p_list_sep (box [newline, string "and", space]) p_vali vis]
+
+and p_vali (x, co, e) =
+    case co of
+        NONE => box [string x,
+                     space,
+                     string "=",
+                     space,
+                     p_exp e]
+      | SOME t => box [string x,
+                       space,
+                       string ":",
+                       space,
+                       p_con t,
+                       space,
+                       string "=",
+                       space,
+                       p_exp e]
+
+
 fun p_datatype (x, xs, cons) =
     box [string "datatype",
          space,
@@ -424,22 +463,6 @@ and p_sgn (sgn, _) =
       | SgnProj (m, ms, x) => p_list_sep (string ".") string (m :: ms @ [x])
                                    
 
-fun p_vali (x, co, e) =
-    case co of
-        NONE => box [string x,
-                     space,
-                     string "=",
-                     space,
-                     p_exp e]
-      | SOME t => box [string x,
-                       space,
-                       string ":",
-                       space,
-                       p_con t,
-                       space,
-                       string "=",
-                       space,
-                       p_exp e]
 
 fun p_decl ((d, _) : decl) =
     case d of
diff --git a/src/urweb.grm b/src/urweb.grm
index 143b6935..1555dc37 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -198,6 +198,7 @@ fun tagIn bt =
  | TYPE | NAME
  | ARROW | LARROW | DARROW | STAR | SEMI
  | FN | PLUSPLUS | MINUSMINUS | DOLLAR | TWIDDLE
+ | LET | IN
  | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL
  | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE
  | CASE | IF | THEN | ELSE
@@ -272,6 +273,8 @@ fun tagIn bt =
  | tag of string * exp
  | tagHead of string * exp
  | bind of string * con option * exp
+ | edecl of edecl
+ | edecls of edecl list
 
  | earg of exp * con -> exp * con
  | eargp of exp * con -> exp * con
@@ -919,6 +922,15 @@ eterm  : LPAREN eexp RPAREN             (#1 eexp, s (LPARENleft, RPARENright))
 
        | UNDER                          (EWild, s (UNDERleft, UNDERright))
 
+       | LET edecls IN eexp END         (ELet (edecls, eexp), s (LETleft, ENDright))
+
+edecls :                                ([])
+       | edecl edecls                   (edecl :: edecls)
+
+edecl  : VAL vali                       ((EDVal vali, s (VALleft, valiright)))
+       | VAL REC valis                  ((EDValRec valis, s (VALleft, valisright)))
+       | FUN valis                      ((EDValRec valis, s (FUNleft, valisright)))
+
 enterDml :                              (inDml := true)
 leaveDml :                              (inDml := false)
 
diff --git a/src/urweb.lex b/src/urweb.lex
index cc0f5b7c..d5393e7d 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -299,6 +299,8 @@ notags = [^<{\n]+;
 <INITIAL> "signature" => (Tokens.SIGNATURE (pos yypos, pos yypos + size yytext));
 <INITIAL> "struct"    => (Tokens.STRUCT (pos yypos, pos yypos + size yytext));
 <INITIAL> "sig"       => (if yypos = 2 then initialSig () else (); Tokens.SIG (pos yypos, pos yypos + size yytext));
+<INITIAL> "let"       => (Tokens.LET (pos yypos, pos yypos + size yytext));
+<INITIAL> "in"        => (Tokens.IN (pos yypos, pos yypos + size yytext));
 <INITIAL> "end"       => (Tokens.END (pos yypos, pos yypos + size yytext));
 <INITIAL> "functor"   => (Tokens.FUNCTOR (pos yypos, pos yypos + size yytext));
 <INITIAL> "where"     => (Tokens.WHERE (pos yypos, pos yypos + size yytext));
diff --git a/tests/let.ur b/tests/let.ur
new file mode 100644
index 00000000..45d52ded
--- /dev/null
+++ b/tests/let.ur
@@ -0,0 +1,6 @@
+fun main () : transaction page =
+    let
+        val x = 1
+    in
+        return <xml>{[x]}</xml>
+    end
diff --git a/tests/let.urp b/tests/let.urp
new file mode 100644
index 00000000..4bb17d32
--- /dev/null
+++ b/tests/let.urp
@@ -0,0 +1,3 @@
+debug
+
+let
-- 
cgit v1.2.3


From 12bb99a0ba702af12e89bfe544f2a572e5d4818d Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Thu, 6 Nov 2008 10:29:55 -0500
Subject: Cookies through elaborate

---
 lib/basis.urs           |  4 +++
 src/elab.sml            |  2 ++
 src/elab_env.sml        | 15 +++++++++++
 src/elab_print.sml      | 14 +++++++++++
 src/elab_util.sml       | 27 +++++++++++++++-----
 src/elaborate.sml       | 66 ++++++++++++++++++++++++++++++++++++++++++++++++-
 src/elisp/urweb-defs.el |  6 ++---
 src/elisp/urweb-mode.el |  4 +--
 src/source.sml          |  2 ++
 src/source_print.sml    | 15 +++++++++++
 src/unnest.sml          |  1 +
 src/urweb.grm           |  3 +++
 src/urweb.lex           |  1 +
 tests/cookie.ur         |  9 +++++++
 tests/cookie.urp        |  3 +++
 15 files changed, 160 insertions(+), 12 deletions(-)
 create mode 100644 tests/cookie.ur
 create mode 100644 tests/cookie.urp

(limited to 'src/urweb.lex')

diff --git a/lib/basis.urs b/lib/basis.urs
index 806a9623..84fb4e4c 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -84,6 +84,10 @@ val bind : t1 ::: Type -> t2 ::: Type
 
 val requestHeader : string -> transaction (option string)
 
+con http_cookie :: Type -> Type
+val getCookie : t ::: Type -> http_cookie t -> transaction (option t)
+val setCookie : t ::: Type -> http_cookie t -> t -> transaction unit
+
 
 (** SQL *)
 
diff --git a/src/elab.sml b/src/elab.sml
index b5350c2a..afb8f7aa 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -139,6 +139,7 @@ datatype sgn_item' =
        | SgiSequence of int * string * int
        | SgiClassAbs of string * int
        | SgiClass of string * int * con
+       | SgiCookie of int * string * int * con
 
 and sgn' =
     SgnConst of sgn_item list
@@ -166,6 +167,7 @@ datatype decl' =
        | DSequence of int * string * int
        | DClass of string * int * con
        | DDatabase of string
+       | DCookie of int * string * int * con
 
      and str' =
          StrConst of decl list
diff --git a/src/elab_env.sml b/src/elab_env.sml
index 6b762abd..a782771a 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -592,6 +592,7 @@ fun sgiSeek (sgi, (sgns, strs, cons)) =
       | SgiSequence _ => (sgns, strs, cons)
       | SgiClassAbs (x, n) => (sgns, strs, IM.insert (cons, n, x))
       | SgiClass (x, n, _) => (sgns, strs, IM.insert (cons, n, x))
+      | SgiCookie _ => (sgns, strs, cons)
 
 fun sgnSeek f sgis =
     let
@@ -945,6 +946,13 @@ fun sgiBinds env (sgi, loc) =
 
       | SgiClassAbs (x, n) => pushCNamedAs env x n (KArrow ((KType, loc), (KType, loc)), loc) NONE
       | SgiClass (x, n, c) => pushCNamedAs env x n (KArrow ((KType, loc), (KType, loc)), loc) (SOME c)
+
+      | SgiCookie (tn, x, n, c) =>
+        let
+            val t = (CApp ((CModProj (tn, [], "http_cookie"), loc), c), loc)
+        in
+            pushENamedAs env x n t
+        end
         
 
 fun sgnSubCon x =
@@ -1095,6 +1103,7 @@ fun sgnSeekConstraints (str, sgis) =
                   | SgiSequence _ => seek (sgis, sgns, strs, cons, acc)
                   | SgiClassAbs (x, n) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc)
                   | SgiClass (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc)
+                  | SgiCookie _ => seek (sgis, sgns, strs, cons, acc)
     in
         seek (sgis, IM.empty, IM.empty, IM.empty, [])
     end
@@ -1189,6 +1198,12 @@ fun declBinds env (d, loc) =
             pushClass env n
         end
       | DDatabase _ => env
+      | DCookie (tn, x, n, c) =>
+        let
+            val t = (CApp ((CModProj (tn, [], "cookie"), loc), c), loc)
+        in
+            pushENamedAs env x n t
+        end
 
 fun patBinds env (p, loc) =
     case p of
diff --git a/src/elab_print.sml b/src/elab_print.sml
index b236954e..a686abe5 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -536,6 +536,13 @@ fun p_sgn_item env (sgi, _) =
                                    string "=",
                                    space,
                                    p_con env c]
+      | SgiCookie (_, x, n, c) => box [string "cookie",
+                                       space,
+                                       p_named x n,
+                                       space,
+                                       string ":",
+                                       space,
+                                       p_con env c]
 
 and p_sgn env (sgn, _) =
     case sgn of
@@ -707,6 +714,13 @@ fun p_decl env (dAll as (d, _) : decl) =
       | DDatabase s => box [string "database",
                             space,
                             string s]
+      | DCookie (_, x, n, c) => box [string "cookie",
+                                     space,
+                                     p_named x n,
+                                     space,
+                                     string ":",
+                                     space,
+                                     p_con env c]
 
 and p_str env (str, _) =
     case str of
diff --git a/src/elab_util.sml b/src/elab_util.sml
index 57a94486..fe75ee0d 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -548,6 +548,10 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} =
                 S.map2 (con ctx c,
                         fn c' =>
                            (SgiClass (x, n, c'), loc))
+              | SgiCookie (tn, x, n, c) =>
+                S.map2 (con ctx c,
+                        fn c' =>
+                           (SgiCookie (tn, x, n, c'), loc))
 
         and sg ctx s acc =
             S.bindP (sg' ctx s acc, sgn ctx)
@@ -576,7 +580,8 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} =
                                                  | SgiClassAbs (x, n) =>
                                                    bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc)))
                                                  | SgiClass (x, n, _) =>
-                                                   bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))),
+                                                   bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc)))
+                                                 | SgiCookie _ => ctx,
                                                sgi ctx si)) ctx sgis,
                      fn sgis' =>
                         (SgnConst sgis', loc))
@@ -720,7 +725,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
                                                    bind (ctx, NamedE (x, (CModProj (n, [], "sql_sequence"), loc)))
                                                  | DClass (x, n, _) =>
                                                    bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc)))
-                                                 | DDatabase _ => ctx,
+                                                 | DDatabase _ => ctx
+                                                 | DCookie (tn, x, n, c) =>
+                                                   bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "cookie"), loc),
+                                                                                c), loc))),
                                                mfd ctx d)) ctx ds,
                      fn ds' => (StrConst ds', loc))
               | StrVar _ => S.return2 strAll
@@ -821,6 +829,11 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
 
               | DDatabase _ => S.return2 dAll
 
+              | DCookie (tn, x, n, c) =>
+                S.map2 (mfc ctx c,
+                        fn c' =>
+                           (DCookie (tn, x, n, c'), loc))
+
         and mfvi ctx (x, n, c, e) =
             S.bind2 (mfc ctx c,
                   fn c' =>
@@ -955,9 +968,10 @@ and maxNameDecl (d, _) =
       | DConstraint _ => 0
       | DClass (_, n, _) => n
       | DExport _ => 0
-      | DTable (n, _, _, _) => n
-      | DSequence (n, _, _) => n
+      | DTable (n1, _, n2, _) => Int.max (n1, n2)
+      | DSequence (n1, _, n2) => Int.max (n1, n2)
       | DDatabase _ => 0
+      | DCookie (n1, _, n2, _) => Int.max (n1, n2)
 
 and maxNameStr (str, _) =
     case str of
@@ -991,10 +1005,11 @@ and maxNameSgi (sgi, _) =
       | SgiStr (_, n, sgn) => Int.max (n, maxNameSgn sgn)
       | SgiSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn)
       | SgiConstraint _ => 0
-      | SgiTable (n, _, _, _) => n
-      | SgiSequence (n, _, _) => n
+      | SgiTable (n1, _, n2, _) => Int.max (n1, n2)
+      | SgiSequence (n1, _, n2) => Int.max (n1, n2)
       | SgiClassAbs (_, n) => n
       | SgiClass (_, n, _) => n
+      | SgiCookie (n1, _, n2, _) => Int.max (n1, n2)
               
 end
 
diff --git a/src/elaborate.sml b/src/elaborate.sml
index b0f2d331..3a966eaf 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1760,6 +1760,7 @@ val hnormSgn = E.hnormSgn
 
 fun tableOf () = (L'.CModProj (!basis_r, [], "sql_table"), ErrorMsg.dummySpan)
 fun sequenceOf () = (L'.CModProj (!basis_r, [], "sql_sequence"), ErrorMsg.dummySpan)
+fun cookieOf () = (L'.CModProj (!basis_r, [], "http_cookie"), ErrorMsg.dummySpan)
 
 fun elabSgn_item ((sgi, loc), (env, denv, gs)) =
     case sgi of
@@ -1967,6 +1968,15 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) =
             ([(L'.SgiClass (x, n, c'), loc)], (env, denv, []))
         end
 
+      | L.SgiCookie (x, c) =>
+        let
+            val (c', k, gs) = elabCon (env, denv) c
+            val (env, n) = E.pushENamed env x (L'.CApp (cookieOf (), c'), loc)
+        in
+            checkKind env c' k (L'.KType, loc);
+            ([(L'.SgiCookie (!basis_r, x, n, c'), loc)], (env, denv, gs))
+        end
+
 and elabSgn (env, denv) (sgn, loc) =
     case sgn of
         L.SgnConst sgis =>
@@ -2051,7 +2061,13 @@ and elabSgn (env, denv) (sgn, loc) =
                                        sgnError env (DuplicateCon (loc, x))
                                    else
                                        ();
-                                   (SS.add (cons, x), vals, sgns, strs)))
+                                   (SS.add (cons, x), vals, sgns, strs))
+                                | L'.SgiCookie (_, x, _, _) =>
+                                  (if SS.member (vals, x) then
+                                       sgnError env (DuplicateVal (loc, x))
+                                   else
+                                       ();
+                                   (cons, SS.add (vals, x), sgns, strs)))
                     (SS.empty, SS.empty, SS.empty, SS.empty) sgis'
         in
             ((L'.SgnConst sgis', loc), gs)
@@ -2203,6 +2219,9 @@ fun dopen (env, denv) {str, strs, sgn} =
                                               in
                                                   (L'.DCon (x, n, k, c), loc)
                                               end
+                                            | L'.SgiCookie (_, x, n, c) =>
+                                              (L'.DVal (x, n, (L'.CApp (cookieOf (), c), loc),
+                                                        (L'.EModProj (str, strs, x), loc)), loc)
                                   in
                                       (d, (E.declBinds env' d, denv'))
                                   end)
@@ -2259,6 +2278,7 @@ fun sgiOfDecl (d, loc) =
       | L'.DSequence (tn, x, n) => [(L'.SgiSequence (tn, x, n), loc)]
       | L'.DClass (x, n, c) => [(L'.SgiClass (x, n, c), loc)]
       | L'.DDatabase _ => []
+      | L'.DCookie (tn, x, n, c) => [(L'.SgiCookie (tn, x, n, c), loc)]
 
 fun sgiBindsD (env, denv) (sgi, _) =
     case sgi of
@@ -2508,6 +2528,16 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
                                                  SOME (env, denv))
                                      else
                                          NONE
+                                   | L'.SgiCookie (_, x', n1, c1) =>
+                                     if x = x' then
+                                         (case unifyCons (env, denv) (L'.CApp (cookieOf (), c1), loc) c2 of
+                                              [] => SOME (env, denv)
+                                            | _ => NONE)
+                                         handle CUnify (c1, c2, err) =>
+                                                (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err));
+                                                 SOME (env, denv))
+                                     else
+                                         NONE
                                    | _ => NONE)
 
                       | L'.SgiStr (x, n2, sgn2) =>
@@ -2651,6 +2681,21 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
                                          L'.SgiClass (x', n1, c1) => found (x', n1, c1)
                                        | _ => NONE
                                  end)
+
+                      | L'.SgiCookie (_, x, n2, c2) =>
+                        seek (fn sgi1All as (sgi1, _) =>
+                                 case sgi1 of
+                                     L'.SgiCookie (_, x', n1, c1) =>
+                                     if x = x' then
+                                         (case unifyCons (env, denv) c1 c2 of
+                                              [] => SOME (env, denv)
+                                            | _ => NONE)
+                                         handle CUnify (c1, c2, err) =>
+                                                (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err));
+                                                 SOME (env, denv))
+                                     else
+                                         NONE
+                                   | _ => NONE)
                 end
         in
             ignore (foldl folder (env, denv) sgis2)
@@ -3194,6 +3239,15 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) =
 
               | L.DDatabase s => ([(L'.DDatabase s, loc)], (env, denv, gs))
 
+              | L.DCookie (x, c) =>
+                let
+                    val (c', k, gs') = elabCon (env, denv) c
+                    val (env, n) = E.pushENamed env x (L'.CApp (cookieOf (), c'), loc)
+                in
+                    checkKind env c' k (L'.KType, loc);
+                    ([(L'.DCookie (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs))
+                end
+
         (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*)
     in
         (*prefaces "elabDecl" [("e", SourcePrint.p_decl dAll),
@@ -3336,6 +3390,16 @@ and elabStr (env, denv) (str, loc) =
                                           (SS.add (cons, x), x)
                               in
                                   ((L'.SgiClass (x, n, c), loc) :: sgis, cons, vals, sgns, strs)
+                              end
+                            | L'.SgiCookie (tn, x, n, c) =>
+                              let
+                                  val (vals, x) =
+                                      if SS.member (vals, x) then
+                                          (vals, "?" ^ x)
+                                      else
+                                          (SS.add (vals, x), x)
+                              in
+                                  ((L'.SgiCookie (tn, x, n, c), loc) :: sgis, cons, vals, sgns, strs)
                               end)
 
                 ([], SS.empty, SS.empty, SS.empty, SS.empty) sgis
diff --git a/src/elisp/urweb-defs.el b/src/elisp/urweb-defs.el
index fe4da2e4..5551b7a2 100644
--- a/src/elisp/urweb-defs.el
+++ b/src/elisp/urweb-defs.el
@@ -108,7 +108,7 @@ notion of \"the end of an outline\".")
                  "datatype" "type" "open" "include"
                  urweb-module-head-syms
                  "con" "fold" "where" "extern" "constraint" "constraints"
-                 "table" "sequence" "class")
+                 "table" "sequence" "class" "cookie")
   "Symbols starting an sexp.")
 
 ;; (defconst urweb-not-arg-start-re
@@ -134,7 +134,7 @@ notion of \"the end of an outline\".")
      (,urweb-=-starter-syms nil)
      (("case" "datatype" "if" "then" "else"
        "let" "open" "sig" "struct" "type" "val"
-       "con" "constraint" "table" "sequence" "class")))))
+       "con" "constraint" "table" "sequence" "class" "cookie")))))
 
 (defconst urweb-starters-indent-after
   (urweb-syms-re "let" "in" "struct" "sig")
@@ -188,7 +188,7 @@ for all symbols and in all lines starting with the given symbol."
   (append urweb-module-head-syms
 	  '("datatype" "fun"
 	    "open" "type" "val" "and"
-	    "con" "constraint" "table" "sequence" "class"))
+	    "con" "constraint" "table" "sequence" "class" "cookie"))
   "The starters of new expressions.")
 
 (defconst urweb-exptrail-syms
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index 1a578cf9..223006fc 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -136,7 +136,7 @@ See doc for the variable `urweb-mode-info'."
 	       "datatype" "else" "end" "extern" "fn" "fold"
 	       "fun" "functor" "if" "include"
 	       "of" "open" "let" "in"
-	       "rec" "sequence" "sig" "signature"
+	       "rec" "sequence" "sig" "signature" "cookie"
 	       "struct" "structure" "table" "then" "type" "val" "where"
 	       "with"
 
@@ -223,7 +223,7 @@ See doc for the variable `urweb-mode-info'."
     ("\\<\\(\\(data\\)?type\\|con\\|class\\)\\s-+\\(\\sw+\\)"
      (1 font-lock-keyword-face)
      (3 (amAttribute font-lock-type-def-face)))
-    ("\\<\\(val\\|table\\|sequence\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
+    ("\\<\\(val\\|table\\|sequence\\|cookie\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
      (1 font-lock-keyword-face)
      (3 (amAttribute font-lock-variable-name-face)))
     ("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)"
diff --git a/src/source.sml b/src/source.sml
index 7e204390..a0591afb 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -85,6 +85,7 @@ datatype sgn_item' =
        | SgiSequence of string
        | SgiClassAbs of string
        | SgiClass of string * con
+       | SgiCookie of string * con
 
 and sgn' =
     SgnConst of sgn_item list
@@ -157,6 +158,7 @@ datatype decl' =
        | DSequence of string
        | DClass of string * con
        | DDatabase of string
+       | DCookie of string * con
 
      and str' =
          StrConst of decl list
diff --git a/src/source_print.sml b/src/source_print.sml
index 9e6608df..d33fb38d 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -428,6 +428,13 @@ fun p_sgn_item (sgi, _) =
                                 string "=",
                                 space,
                                 p_con c]
+      | SgiCookie (x, c) => box [string "cookie",
+                                 space,
+                                 string x,
+                                 space,
+                                 string ":",
+                                 space,
+                                 p_con c]
 
 and p_sgn (sgn, _) =
     case sgn of
@@ -579,6 +586,14 @@ fun p_decl ((d, _) : decl) =
                             space,
                             string s]
 
+      | DCookie (x, c) => box [string "cookie",
+                               space,
+                               string x,
+                               space,
+                               string ":",
+                               space,
+                               p_con c]
+
 and p_str (str, _) =
     case str of
         StrConst ds => box [string "struct",
diff --git a/src/unnest.sml b/src/unnest.sml
index b56daf8a..6a37d484 100644
--- a/src/unnest.sml
+++ b/src/unnest.sml
@@ -348,6 +348,7 @@ fun unnest file =
                   | DSequence _ => default ()
                   | DClass _ => default ()
                   | DDatabase _ => default ()
+                  | DCookie _ => default ()
             end
 
         and doStr (all as (str, loc), st) =
diff --git a/src/urweb.grm b/src/urweb.grm
index 1555dc37..879afb9c 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -201,6 +201,7 @@ fun tagIn bt =
  | LET | IN
  | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL
  | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE
+ | COOKIE
  | CASE | IF | THEN | ELSE
 
  | XML_BEGIN of string | XML_END | XML_BEGIN_END of string
@@ -426,6 +427,7 @@ decl   : CON SYMBOL cargl2 kopt EQ cexp (let
                                          in
                                              [(DClass (SYMBOL1, c), s (CLASSleft, cexpright))]
                                          end)
+       | COOKIE SYMBOL COLON cexp       ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))])
 
 kopt   :                                (NONE)
        | DCOLON kind                    (SOME kind)
@@ -506,6 +508,7 @@ sgi    : CON SYMBOL DCOLON kind         (SgiConAbs (SYMBOL, kind), s (CONleft, k
                                          in
                                              (SgiClass (SYMBOL1, c), s (CLASSleft, cexpright))
                                          end)
+       | COOKIE SYMBOL COLON cexp       (SgiCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))
 
 sgis   :                                ([])
        | sgi sgis                       (sgi :: sgis)
diff --git a/src/urweb.lex b/src/urweb.lex
index d5393e7d..f5ea558a 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -313,6 +313,7 @@ notags = [^<{\n]+;
 <INITIAL> "table"     => (Tokens.TABLE (pos yypos, pos yypos + size yytext));
 <INITIAL> "sequence"  => (Tokens.SEQUENCE (pos yypos, pos yypos + size yytext));
 <INITIAL> "class"     => (Tokens.CLASS (pos yypos, pos yypos + size yytext));
+<INITIAL> "cookie"    => (Tokens.COOKIE (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "Type"      => (Tokens.TYPE (pos yypos, pos yypos + size yytext));
 <INITIAL> "Name"      => (Tokens.NAME (pos yypos, pos yypos + size yytext));
diff --git a/tests/cookie.ur b/tests/cookie.ur
new file mode 100644
index 00000000..b2bca580
--- /dev/null
+++ b/tests/cookie.ur
@@ -0,0 +1,9 @@
+cookie c : string
+
+fun main () : transaction page =
+    setCookie c "Hi";
+    so <- getCookie c;
+    case so of
+        None => return <xml>No cookie</xml>
+      | Some s => return <xml>Cookie: {[s]}</xml>
+
diff --git a/tests/cookie.urp b/tests/cookie.urp
new file mode 100644
index 00000000..61a1a1e0
--- /dev/null
+++ b/tests/cookie.urp
@@ -0,0 +1,3 @@
+debug
+
+cookie
-- 
cgit v1.2.3


From 0a10b5b7d2bbdcbfec723176b2a31d6b4c6d34d1 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Thu, 6 Nov 2008 15:37:38 -0500
Subject: Inserted a NULL value

---
 CHANGELOG            |   9 +++++
 include/urweb.h      |   6 +++
 lib/basis.urs        |   5 +++
 src/c/urweb.c        |  35 ++++++++++++++++++
 src/cjr_print.sml    | 101 +++++++++++++++++++++++++++++++++++++++++----------
 src/elab_env.sml     |  31 ++++++++++++++--
 src/elaborate.sml    |  47 ++++++++++++++++--------
 src/mono_opt.sml     |   5 +++
 src/monoize.sml      |  24 ++++++++++--
 src/urweb.grm        |   5 ++-
 src/urweb.lex        |   1 +
 tests/sql_option.ur  |  22 +++++++++++
 tests/sql_option.urp |   5 +++
 13 files changed, 252 insertions(+), 44 deletions(-)
 create mode 100644 tests/sql_option.ur
 create mode 100644 tests/sql_option.urp

(limited to 'src/urweb.lex')

diff --git a/CHANGELOG b/CHANGELOG
index aca01ea7..0f8d0f09 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,3 +1,12 @@
+========
+NEXT
+========
+
+- Nested function definitions
+- Primitive "time" type
+- Nullable SQL columns (via "option")
+- Cookies
+
 ========
 20081028
 ========
diff --git a/include/urweb.h b/include/urweb.h
index 7db66ed4..7e16fd40 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -80,6 +80,12 @@ uw_Basis_string uw_Basis_sqlifyString(uw_context, uw_Basis_string);
 uw_Basis_string uw_Basis_sqlifyBool(uw_context, uw_Basis_bool);
 uw_Basis_string uw_Basis_sqlifyTime(uw_context, uw_Basis_time);
 
+uw_Basis_string uw_Basis_sqlifyIntN(uw_context, uw_Basis_int*);
+uw_Basis_string uw_Basis_sqlifyFloatN(uw_context, uw_Basis_float*);
+uw_Basis_string uw_Basis_sqlifyStringN(uw_context, uw_Basis_string);
+uw_Basis_string uw_Basis_sqlifyBoolN(uw_context, uw_Basis_bool*);
+uw_Basis_string uw_Basis_sqlifyTimeN(uw_context, uw_Basis_time*);
+
 char *uw_Basis_ensqlBool(uw_Basis_bool);
 
 uw_Basis_string uw_Basis_intToString(uw_context, uw_Basis_int);
diff --git a/lib/basis.urs b/lib/basis.urs
index 84fb4e4c..f68bedee 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -188,6 +188,11 @@ val sql_int : sql_injectable int
 val sql_float : sql_injectable float
 val sql_string : sql_injectable string
 val sql_time : sql_injectable time
+val sql_option_bool : sql_injectable (option bool)
+val sql_option_int : sql_injectable (option int)
+val sql_option_float : sql_injectable (option float)
+val sql_option_string : sql_injectable (option string)
+val sql_option_time : sql_injectable (option time)
 val sql_inject : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
                  -> t ::: Type
                  -> sql_injectable t -> t -> sql_exp tables agg exps t
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 638fbb16..1530c138 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -872,6 +872,13 @@ char *uw_Basis_sqlifyInt(uw_context ctx, uw_Basis_int n) {
   return r;
 }
 
+char *uw_Basis_sqlifyIntN(uw_context ctx, uw_Basis_int *n) {
+  if (n == NULL)
+    return "NULL";
+  else
+    return uw_Basis_sqlifyInt(ctx, *n);
+}
+
 char *uw_Basis_sqlifyFloat(uw_context ctx, uw_Basis_float n) {
   int len;
   char *r;
@@ -883,6 +890,13 @@ char *uw_Basis_sqlifyFloat(uw_context ctx, uw_Basis_float n) {
   return r;
 }
 
+char *uw_Basis_sqlifyFloatN(uw_context ctx, uw_Basis_float *n) {
+  if (n == NULL)
+    return "NULL";
+  else
+    return uw_Basis_sqlifyFloat(ctx, *n);
+}
+
 
 uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) {
   char *r, *s2;
@@ -920,6 +934,13 @@ uw_Basis_string uw_Basis_sqlifyString(uw_context ctx, uw_Basis_string s) {
   return r;
 }
 
+uw_Basis_string uw_Basis_sqlifyStringN(uw_context ctx, uw_Basis_string s) {
+  if (s == NULL)
+    return "NULL";
+  else
+    return uw_Basis_sqlifyString(ctx, s);
+}
+
 char *uw_Basis_sqlifyBool(uw_context ctx, uw_Basis_bool b) {
   if (b == uw_Basis_False)
     return "FALSE";
@@ -927,6 +948,13 @@ char *uw_Basis_sqlifyBool(uw_context ctx, uw_Basis_bool b) {
     return "TRUE";
 }
 
+char *uw_Basis_sqlifyBoolN(uw_context ctx, uw_Basis_bool *b) {
+  if (b == NULL)
+    return "NULL";
+  else
+    return uw_Basis_sqlifyBool(ctx, *b);
+}
+
 char *uw_Basis_sqlifyTime(uw_context ctx, uw_Basis_time t) {
   size_t len;
   char *r;
@@ -942,6 +970,13 @@ char *uw_Basis_sqlifyTime(uw_context ctx, uw_Basis_time t) {
     return "<Invalid time>";
 }
 
+char *uw_Basis_sqlifyTimeN(uw_context ctx, uw_Basis_time *t) {
+  if (t == NULL)
+    return "NULL";
+  else
+    return uw_Basis_sqlifyTime(ctx, *t);
+}
+
 char *uw_Basis_ensqlBool(uw_Basis_bool b) {
   static uw_Basis_int true = 1;
   static uw_Basis_int false = 0;
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 06154b91..d7e426c3 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -408,24 +408,61 @@ fun p_unsql wontLeakStrings env (tAll as (t, loc)) e =
             box [string "uw_Basis_strdup(ctx, ", e, string ")"]
       | TFfi ("Basis", "bool") => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"]
       | TFfi ("Basis", "time") => box [string "uw_Basis_stringToTime_error(ctx, ", e, string ")"]
+
       | _ => (ErrorMsg.errorAt loc "Don't know how to unmarshal type from SQL";
               Print.eprefaces' [("Type", p_typ env tAll)];
               string "ERROR")
 
+fun p_getcol wontLeakStrings env (tAll as (t, loc)) i =
+    case t of
+        TOption t =>
+        box [string "(PQgetisnull (res, i, ",
+             string (Int.toString i),
+             string ") ? NULL : ",
+             case t of
+                 (TFfi ("Basis", "string"), _) => p_getcol wontLeakStrings env t i
+               | _ => box [string "({",
+                           newline,
+                           p_typ env t,
+                           space,
+                           string "*tmp = uw_malloc(ctx, sizeof(",
+                           p_typ env t,
+                           string "));",
+                           newline,
+                           string "*tmp = ",
+                           p_getcol wontLeakStrings env t i,
+                           string ";",
+                           newline,
+                           string "tmp;",
+                           newline,
+                           string "})"],
+             string ")"]
+             
+      | _ =>
+        p_unsql wontLeakStrings env tAll
+                (box [string "PQgetvalue(res, i, ",
+                      string (Int.toString i),
+                      string ")"])
+
 datatype sql_type =
          Int
        | Float
        | String
        | Bool
        | Time
+       | Nullable of sql_type
+
+fun p_sql_type' t =
+    case t of
+        Int => "uw_Basis_int"
+      | Float => "uw_Basis_float"
+      | String => "uw_Basis_string"
+      | Bool => "uw_Basis_bool"
+      | Time => "uw_Basis_time"
+      | Nullable String => "uw_Basis_string"
+      | Nullable t => p_sql_type' t ^ "*"
 
-fun p_sql_type t =
-    string (case t of
-                Int => "uw_Basis_int"
-              | Float => "uw_Basis_float"
-              | String => "uw_Basis_string"
-              | Bool => "uw_Basis_bool"
-              | Time => "uw_Basis_time")
+fun p_sql_type t = string (p_sql_type' t)
 
 fun getPargs (e, _) =
     case e of
@@ -448,6 +485,12 @@ fun p_ensql t e =
       | String => e
       | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"]
       | Time => box [string "uw_Basis_sqlifyTime(ctx, ", e, string ")"]
+      | Nullable String => e
+      | Nullable t => box [string "(",
+                           e,
+                           string " == NULL ? NULL : ",
+                           p_ensql t (box [string "*", e]),
+                           string ")"]
 
 fun notLeaky env allowHeapAllocated =
     let
@@ -1169,10 +1212,7 @@ fun p_exp' par env (e, loc) =
                                                     space,
                                                     string "=",
                                                     space,
-                                                    p_unsql wontLeakStrings env t
-                                                            (box [string "PQgetvalue(res, i, ",
-                                                                  string (Int.toString i),
-                                                                  string ")"]),
+                                                    p_getcol wontLeakStrings env t i,
                                                     string ";",
                                                     newline]) outputs,
              
@@ -1660,7 +1700,10 @@ fun p_decl env (dAll as (d, _) : decl) =
                             string "}",
                             newline]
 
-      | DPreparedStatements [] => box []
+      | DPreparedStatements [] =>
+        box [string "static void uw_db_prepare(uw_context ctx) {",
+             newline,
+             string "}"]
       | DPreparedStatements ss =>
         box [string "static void uw_db_prepare(uw_context ctx) {",
              newline,
@@ -1708,7 +1751,7 @@ datatype 'a search =
        | NotFound
        | Error
 
-fun p_sqltype' env (tAll as (t, loc)) =
+fun p_sqltype'' env (tAll as (t, loc)) =
     case t of
         TFfi ("Basis", "int") => "int8"
       | TFfi ("Basis", "float") => "float8"
@@ -1719,8 +1762,25 @@ fun p_sqltype' env (tAll as (t, loc)) =
               Print.eprefaces' [("Type", p_typ env tAll)];
               "ERROR")
 
+fun p_sqltype' env (tAll as (t, loc)) =
+    case t of
+        (TOption t, _) => p_sqltype'' env t
+      | _ => p_sqltype'' env t ^ " NOT NULL"
+
 fun p_sqltype env t = string (p_sqltype' env t)
 
+fun p_sqltype_base' env t =
+    case t of
+        (TOption t, _) => p_sqltype'' env t
+      | _ => p_sqltype'' env t
+
+fun p_sqltype_base env t = string (p_sqltype_base' env t)
+
+fun is_not_null t =
+    case t of
+        (TOption _, _) => false
+      | _ => true
+
 fun p_file env (ds, ps) =
     let
         val (pds, env) = ListUtil.foldlMap (fn (d, env) =>
@@ -1997,8 +2057,13 @@ fun p_file env (ds, ps) =
                                                                                           Char.toLower (ident x),
                                                                                       "' AND atttypid = (SELECT oid FROM pg_type",
                                                                                       " WHERE typname = '",
-                                                                                      p_sqltype' env t,
-                                                                                      "'))"]) xts),
+                                                                                      p_sqltype_base' env t,
+                                                                                      "') AND attnotnull = ",
+                                                                                      if is_not_null t then
+                                                                                          "TRUE"
+                                                                                      else
+                                                                                          "FALSE",
+                                                                                      ")"]) xts),
                                                             ")"]
 
                                     val q'' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '",
@@ -2295,11 +2360,7 @@ fun p_sql env (ds, _) =
                                                             box [string "uw_",
                                                                  string (CharVector.map Char.toLower x),
                                                                  space,
-                                                                 p_sqltype env t,
-                                                                 space,
-                                                                 string "NOT",
-                                                                 space,
-                                                                 string "NULL"]) xts,
+                                                                 p_sqltype env (t, ErrorMsg.dummySpan)]) xts,
                                                  string ");",
                                                  newline,
                                                  newline]
diff --git a/src/elab_env.sml b/src/elab_env.sml
index b14cd06c..46f62727 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -150,12 +150,14 @@ datatype class_key =
          CkNamed of int
        | CkRel of int
        | CkProj of int * string list * string
+       | CkApp of class_key * class_key
 
 fun ck2s ck =
     case ck of
         CkNamed n => "Named(" ^ Int.toString n ^ ")"
       | CkRel n => "Rel(" ^ Int.toString n ^ ")"
       | CkProj (m, ms, x) => "Proj(" ^ Int.toString m ^ "," ^ String.concatWith "," ms ^ "," ^ x ^ ")"
+      | CkApp (ck1, ck2) => "App(" ^ ck2s ck1 ^ ", " ^ ck2s ck2 ^ ")"
 
 fun cp2s (cn, ck) = "(" ^ cn2s cn ^ "," ^ ck2s ck ^ ")"
 
@@ -176,6 +178,12 @@ fun compare x =
         join (Int.compare (m1, m2),
               fn () => join (joinL String.compare (ms1, ms2),
                              fn () => String.compare (x1, x2)))
+      | (CkProj _, _) => LESS
+      | (_, CkProj _) => GREATER
+
+      | (CkApp (f1, x1), CkApp (f2, x2)) =>
+        join (compare (f1, f2),
+              fn () => compare (x1, x2))
 end
 
 structure KM = BinaryMapFn(KK)
@@ -251,6 +259,7 @@ fun liftClassKey ck =
         CkNamed _ => ck
       | CkRel n => CkRel (n + 1)
       | CkProj _ => ck
+      | CkApp (ck1, ck2) => CkApp (liftClassKey ck1, liftClassKey ck2)
 
 fun pushCRel (env : env) x k =
     let
@@ -411,6 +420,10 @@ fun class_key_in (c, _) =
       | CNamed n => SOME (CkNamed n)
       | CModProj x => SOME (CkProj x)
       | CUnif (_, _, _, ref (SOME c)) => class_key_in c
+      | CApp (c1, c2) =>
+        (case (class_key_in c1, class_key_in c2) of
+             (SOME k1, SOME k2) => SOME (CkApp (k1, k2))
+           | _ => NONE)
       | _ => NONE
 
 fun class_pair_in (c, _) =
@@ -653,7 +666,7 @@ fun sgnS_con (str, (sgns, strs, cons)) c =
              end)
       | _ => c
 
-fun sgnS_con' (m1, ms', (sgns, strs, cons)) c =
+fun sgnS_con' (arg as (m1, ms', (sgns, strs, cons))) c =
     case c of
         CModProj (m1, ms, x) =>
         (case IM.find (strs, m1) of
@@ -663,6 +676,8 @@ fun sgnS_con' (m1, ms', (sgns, strs, cons)) c =
         (case IM.find (cons, n) of
              NONE => c
            | SOME nx => CModProj (m1, ms', nx))
+      | CApp (c1, c2) => CApp ((sgnS_con' arg (#1 c1), #2 c1),
+                               (sgnS_con' arg (#1 c2), #2 c2))
       | _ => c
 
 fun sgnS_sgn (str, (sgns, strs, cons)) sgn =
@@ -1033,13 +1048,21 @@ fun projectVal env {sgn, str, field} =
                 ListUtil.search (fn (x, _, to) =>
                                     if x = field then
                                         SOME (let
+                                                  val base = (CNamed n, #2 sgn)
+                                                  val nxs = length xs
+                                                  val base = ListUtil.foldli (fn (i, _, base) =>
+                                                                                 (CApp (base,
+                                                                                       (CRel (nxs - i - 1), #2 sgn)),
+                                                                                  #2 sgn))
+                                                                             base xs
+
                                                   val t =
                                                       case to of
-                                                          NONE => (CNamed n, #2 sgn)
-                                                        | SOME t => (TFun (t, (CNamed n, #2 sgn)), #2 sgn)
+                                                          NONE => base
+                                                        | SOME t => (TFun (t, base), #2 sgn)
                                                   val k = (KType, #2 sgn)
                                               in
-                                                  foldr (fn (x, t) => (TCFun (Explicit, x, k, t), #2 sgn))
+                                                  foldr (fn (x, t) => (TCFun (Implicit, x, k, t), #2 sgn))
                                                   t xs
                                               end)
                                     else
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 3b70c623..a6edc0ed 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1389,17 +1389,32 @@ fun unmodCon env (c, loc) =
         end
       | _ => (c, loc)
 
-fun normClassConstraint envs (c, loc) =
+fun normClassKey envs c =
+    let
+        val c = ElabOps.hnormCon envs c
+    in
+        case #1 c of
+            L'.CApp (c1, c2) =>
+            let
+                val c1 = normClassKey envs c1
+                val c2 = normClassKey envs c2
+            in
+                (L'.CApp (c1, c2), #2 c)
+            end
+          | _ => c
+    end
+
+fun normClassConstraint env (c, loc) =
     case c of
         L'.CApp (f, x) =>
         let
-            val f = unmodCon (#1 envs) f
-            val (x, gs) = hnormCon envs x
+            val f = unmodCon env f
+            val x = normClassKey env x
         in
-            ((L'.CApp (f, x), loc), gs)
+            (L'.CApp (f, x), loc)
         end
-      | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint envs c
-      | _ => ((c, loc), [])
+      | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint env c
+      | _ => (c, loc)
 
 
 val makeInstantiable =
@@ -1491,12 +1506,12 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
                                         checkKind env t' tk ktype;
                                         (t', gs)
                                     end
-                val (dom, gs2) = normClassConstraint (env, denv) t'
-                val (e', et, gs3) = elabExp (E.pushERel env x dom, denv) e
+                val dom = normClassConstraint env t'
+                val (e', et, gs2) = elabExp (E.pushERel env x dom, denv) e
             in
                 ((L'.EAbs (x, t', et, e'), loc),
                  (L'.TFun (t', et), loc),
-                 enD gs1 @ enD gs2 @ gs3)
+                 enD gs1 @ gs2)
             end
           | L.ECApp (e, c) =>
             let
@@ -1708,11 +1723,11 @@ and elabEdecl denv (dAll as (d, loc), (env, gs : constraint list)) =
 
                     val (e', et, gs2) = elabExp (env, denv) e
                     val gs3 = checkCon (env, denv) e' et c'
-                    val (c', gs4) = normClassConstraint (env, denv) c'
+                    val c' = normClassConstraint env c'
                     val env' = E.pushERel env x c'
                     val c' = makeInstantiable c'
                 in
-                    ((L'.EDVal (x, c', e'), loc), (env', enD gs1 @ gs2 @ enD gs3 @ enD gs4 @ gs))
+                    ((L'.EDVal (x, c', e'), loc), (env', enD gs1 @ gs2 @ enD gs3 @ gs))
                 end
               | L.EDValRec vis =>
                 let
@@ -1884,12 +1899,12 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) =
             val (c', ck, gs') = elabCon (env, denv) c
 
             val (env', n) = E.pushENamed env x c'
-            val (c', gs'') = normClassConstraint (env, denv) c'
+            val c' = normClassConstraint env c'
         in
             (unifyKinds ck ktype
              handle KUnify ue => strError env (NotType (ck, ue)));
 
-            ([(L'.SgiVal (x, n, c'), loc)], (env', denv, gs' @ gs'' @ gs))
+            ([(L'.SgiVal (x, n, c'), loc)], (env', denv, gs' @ gs))
         end
 
       | L.SgiStr (x, sgn) =>
@@ -2875,13 +2890,13 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) =
 
                     val (e', et, gs2) = elabExp (env, denv) e
                     val gs3 = checkCon (env, denv) e' et c'
-                    val (c', gs4) = normClassConstraint (env, denv) c'
+                    val c = normClassConstraint env c'
                     val (env', n) = E.pushENamed env x c'
                     val c' = makeInstantiable c'
                 in
                     (*prefaces "DVal" [("x", Print.PD.string x),
                                      ("c'", p_con env c')];*)
-                    ([(L'.DVal (x, n, c', e'), loc)], (env', denv, enD gs1 @ gs2 @ enD gs3 @ enD gs4 @ gs))
+                    ([(L'.DVal (x, n, c', e'), loc)], (env', denv, enD gs1 @ gs2 @ enD gs3 @ gs))
                 end
               | L.DValRec vis =>
                 let
@@ -3404,7 +3419,7 @@ fun elabFile basis topStr topSgn env file =
                                       ("Hnormed 2", p_con env (ElabOps.hnormCon env c2))]))
                   | TypeClass (env, c, r, loc) =>
                     let
-                        val c = ElabOps.hnormCon env c
+                        val c = normClassKey env c
                     in
                         case E.resolveClass env c of
                             SOME e => r := SOME e
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index b22f053b..93cb888b 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -268,6 +268,11 @@ fun exp e =
 
       | EFfiApp ("Basis", "sqlifyInt", [(EPrim (Prim.Int n), _)]) =>
         EPrim (Prim.String (sqlifyInt n))
+      | EFfiApp ("Basis", "sqlifyIntN", [(ENone _, _)]) =>
+        EPrim (Prim.String "NULL")
+      | EFfiApp ("Basis", "sqlifyIntN", [(ESome (_, (EPrim (Prim.Int n), _)), _)]) =>
+        EPrim (Prim.String (sqlifyInt n))
+
       | EFfiApp ("Basis", "sqlifyFloat", [(EPrim (Prim.Float n), _)]) =>
         EPrim (Prim.String (sqlifyFloat n))
       | EFfiApp ("Basis", "sqlifyBool", [b as (_, loc)]) =>
diff --git a/src/monoize.sml b/src/monoize.sml
index c4c296bd..83da382b 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -982,10 +982,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
           | L.EFfiApp ("Basis", "dml", [e]) =>
             let
                 val (e, fm) = monoExp (env, st, fm) e
-                val un = (L'.TRecord [], loc)
             in
-                ((L'.EAbs ("_", un, un,
-                           (L'.EDml (liftExpInExp 0 e), loc)), loc),
+                ((L'.EDml (liftExpInExp 0 e), loc),
                  fm)
             end
 
@@ -1274,6 +1272,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "string"), loc),
                        (L'.EFfiApp ("Basis", "sqlifyTime", [(L'.ERel 0, loc)]), loc)), loc),
              fm)
+          | L.EFfi ("Basis", "sql_option_int") =>
+            ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "int"), loc), loc), (L'.TFfi ("Basis", "string"), loc),
+                       (L'.EFfiApp ("Basis", "sqlifyIntN", [(L'.ERel 0, loc)]), loc)), loc),
+             fm)
+          | L.EFfi ("Basis", "sql_option_float") =>
+            ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "float"), loc), loc), (L'.TFfi ("Basis", "string"), loc),
+                       (L'.EFfiApp ("Basis", "sqlifyFloatN", [(L'.ERel 0, loc)]), loc)), loc),
+             fm)
+          | L.EFfi ("Basis", "sql_option_bool") =>
+            ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "bool"), loc), loc), (L'.TFfi ("Basis", "string"), loc),
+                       (L'.EFfiApp ("Basis", "sqlifyBoolN", [(L'.ERel 0, loc)]), loc)), loc),
+             fm)
+          | L.EFfi ("Basis", "sql_option_string") =>
+            ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "string"), loc), loc), (L'.TFfi ("Basis", "string"), loc),
+                       (L'.EFfiApp ("Basis", "sqlifyStringN", [(L'.ERel 0, loc)]), loc)), loc),
+             fm)
+          | L.EFfi ("Basis", "sql_option_time") =>
+            ((L'.EAbs ("x", (L'.TOption (L'.TFfi ("Basis", "time"), loc), loc), (L'.TFfi ("Basis", "string"), loc),
+                       (L'.EFfiApp ("Basis", "sqlifyTimeN", [(L'.ERel 0, loc)]), loc)), loc),
+             fm)
 
           | L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) =>
             ((L'.ERecord [], loc), fm)
diff --git a/src/urweb.grm b/src/urweb.grm
index b2f2d486..2482be1b 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -214,7 +214,7 @@ fun tagIn bt =
  | TRUE | FALSE | CAND | OR | NOT
  | COUNT | AVG | SUM | MIN | MAX
  | ASC | DESC
- | INSERT | INTO | VALUES | UPDATE | SET | DELETE
+ | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL
  | CURRENT_TIMESTAMP
  | NE | LT | LE | GT | GE
 
@@ -1251,6 +1251,9 @@ sqlexp : TRUE                           (sql_inject (EVar (["Basis"], "True", In
                                                      s (LBRACEleft, RBRACEright)))
        | LPAREN sqlexp RPAREN           (sqlexp)
 
+       | NULL                           (sql_inject ((EVar (["Basis"], "None", Infer), 
+                                                      s (NULLleft, NULLright))))
+
        | COUNT LPAREN STAR RPAREN       (let
                                              val loc = s (COUNTleft, RPARENright)
                                          in
diff --git a/src/urweb.lex b/src/urweb.lex
index f5ea558a..f4ae3a85 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -357,6 +357,7 @@ notags = [^<{\n]+;
 <INITIAL> "UPDATE"    => (Tokens.UPDATE (pos yypos, pos yypos + size yytext));
 <INITIAL> "SET"       => (Tokens.SET (pos yypos, pos yypos + size yytext));
 <INITIAL> "DELETE"    => (Tokens.DELETE (pos yypos, pos yypos + size yytext));
+<INITIAL> "NULL"      => (Tokens.NULL (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext));
 
diff --git a/tests/sql_option.ur b/tests/sql_option.ur
new file mode 100644
index 00000000..257f8c55
--- /dev/null
+++ b/tests/sql_option.ur
@@ -0,0 +1,22 @@
+table t : { O : option int }
+
+fun addNull () =
+    dml (INSERT INTO t (O) VALUES (NULL));
+    return <xml>Done</xml>
+
+(*fun add42 () =
+    dml (INSERT INTO t (O) VALUES (42));
+    return <xml>Done</xml>*)
+
+fun main () : transaction page =
+    xml <- queryX (SELECT * FROM t)
+                  (fn r => case r.T.O of
+                               None => <xml>Nada<br/></xml>
+                             | Some n => <xml>Num: {[n]}<br/></xml>);
+    return <xml><body>
+      {xml}
+
+      <a link={addNull ()}>Add a null</a><br/>
+    </body></xml>
+
+(*      <a link={add42 ()}>Add a 42</a><br/>*)
diff --git a/tests/sql_option.urp b/tests/sql_option.urp
new file mode 100644
index 00000000..543c32a8
--- /dev/null
+++ b/tests/sql_option.urp
@@ -0,0 +1,5 @@
+debug
+database dbname=option
+sql option.sql
+
+sql_option
-- 
cgit v1.2.3


From dd4d718ac9f0a9862ebef19beb568bbedcc85848 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Thu, 6 Nov 2008 18:49:38 -0500
Subject: Tree demo works

---
 demo/treeFun.ur     |   2 +-
 lib/basis.urs       |   5 +
 lib/top.ur          |  13 ++
 lib/top.urs         |  12 ++
 src/c/urweb.c       |   2 +-
 src/cjr_print.sml   |   9 +-
 src/mono_reduce.sml | 440 +++++++++++++++++++++++++++++-----------------------
 src/monoize.sml     |  19 +++
 src/urweb.grm       |  13 +-
 src/urweb.lex       |   1 +
 10 files changed, 316 insertions(+), 200 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/demo/treeFun.ur b/demo/treeFun.ur
index 60633695..236f354c 100644
--- a/demo/treeFun.ur
+++ b/demo/treeFun.ur
@@ -18,7 +18,7 @@ functor Make(M : sig
              (root : option M.key) =
         let
             fun recurse (root : option key) =
-                queryX' (SELECT * FROM tab WHERE tab.{parent} = {root})
+                queryX' (SELECT * FROM tab WHERE {[eqNullable' (SQL tab.{parent}) root]})
                         (fn r =>
                             children <- recurse (Some r.Tab.id);
                             return <xml>
diff --git a/lib/basis.urs b/lib/basis.urs
index daefe954..656c5b91 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -197,6 +197,11 @@ val sql_inject : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
                  -> t ::: Type
                  -> sql_injectable t -> t -> sql_exp tables agg exps t
 
+val sql_is_null : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+                  -> t ::: Type
+                  -> sql_exp tables agg exps (option t)
+                  -> sql_exp tables agg exps bool
+
 con sql_unary :: Type -> Type -> Type
 val sql_not : sql_unary bool bool
 val sql_unary : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
diff --git a/lib/top.ur b/lib/top.ur
index abc70e53..5d00282c 100644
--- a/lib/top.ur
+++ b/lib/top.ur
@@ -226,3 +226,16 @@ fun oneRow (tables ::: {{Type}}) (exps ::: {Type})
                 None => error <xml>Query returned no rows</xml>
               | Some r => r)
 
+fun eqNullable (tables ::: {{Type}}) (agg ::: {{Type}}) (exps ::: {Type})
+    (t ::: Type) (_ : sql_injectable (option t))
+    (e1 : sql_exp tables agg exps (option t))
+    (e2 : sql_exp tables agg exps (option t)) =
+    (SQL ({[e1]} IS NULL AND {[e2]} IS NULL) OR {[e1]} = {[e2]})
+
+fun eqNullable' (tables ::: {{Type}}) (agg ::: {{Type}}) (exps ::: {Type})
+    (t ::: Type) (inj : sql_injectable (option t))
+    (e1 : sql_exp tables agg exps (option t))
+    (e2 : option t) =
+    case e2 of
+        None => (SQL {[e1]} IS NULL)
+      | Some _ => sql_comparison sql_eq e1 (@sql_inject inj e2)
diff --git a/lib/top.urs b/lib/top.urs
index 6653db07..d6315b92 100644
--- a/lib/top.urs
+++ b/lib/top.urs
@@ -169,3 +169,15 @@ val oneRow : tables ::: {{Type}} -> exps ::: {Type}
                                             [[nm] ~ acc] =>
                                          [nm = $fields] ++ acc)
                                          [] tables)
+
+val eqNullable : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+                 -> t ::: Type -> sql_injectable (option t)
+                 -> sql_exp tables agg exps (option t)
+                 -> sql_exp tables agg exps (option t)
+                 -> sql_exp tables agg exps bool
+
+val eqNullable' : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+                  -> t ::: Type -> sql_injectable (option t)
+                  -> sql_exp tables agg exps (option t)
+                  -> option t
+                  -> sql_exp tables agg exps bool
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 1530c138..e50d6965 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -174,7 +174,7 @@ void uw_push_cleanup(uw_context ctx, void (*func)(void *), void *arg) {
       newLen = 1;
     else
       newLen = len * 2;
-    ctx->cleanup = realloc(ctx->cleanup, newLen);
+    ctx->cleanup = realloc(ctx->cleanup, newLen * sizeof(cleanup));
     ctx->cleanup_front = ctx->cleanup + len;
     ctx->cleanup_back = ctx->cleanup + newLen;
   }
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index b6c32e24..2485e317 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -70,13 +70,14 @@ fun isUnboxable (t : typ) =
 
 fun p_typ' par env (t, loc) =
     case t of
-        TFun (t1, t2) => parenIf par (box [p_typ' true env t2,
+        TFun (t1, t2) => parenIf par (box [string "(",
+                                           p_typ' true env t2,
                                            space,
                                            string "(*)",
                                            space,
                                            string "(",
                                            p_typ env t1,
-                                           string ")"])
+                                           string "))"])
       | TRecord i => box [string "struct",
                           space,
                           string "__uws_",
@@ -1151,6 +1152,10 @@ fun p_exp' par env (e, loc) =
                  p_exp env initial,
                  string ";",
                  newline,
+                 case prepared of
+                     NONE => box [string "printf(\"Executing: %s\\n\", query);",
+                                  newline]
+                   | _ => box [],
                  string "PGresult *res = ",
                  case prepared of
                      NONE => string "PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);"
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index bf68f175..dce6ef35 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -34,6 +34,8 @@ open Mono
 structure E = MonoEnv
 structure U = MonoUtil
 
+structure IM = IntBinaryMap
+
 
 fun impure (e, _) =
     case e of
@@ -212,6 +214,8 @@ fun p_event e =
           | Unsure => string "Unsure"
     end
 
+val p_events = Print.p_list p_event
+
 fun patBinds (p, _) =
     case p of
         PWild => 0
@@ -223,218 +227,266 @@ fun patBinds (p, _) =
       | PNone _ => 0
       | PSome (_, p) => patBinds p
 
-fun summarize d (e, _) =
-    case e of
-        EPrim _ => []
-      | ERel n => if n >= d then [UseRel (n - d)] else []
-      | ENamed _ => []
-      | ECon (_, _, NONE) => []
-      | ECon (_, _, SOME e) => summarize d e
-      | ENone _ => []
-      | ESome (_, e) => summarize d e
-      | EFfi _ => []
-      | EFfiApp ("Basis", "set_cookie", _) => [Unsure]
-      | EFfiApp (_, _, es) => List.concat (map (summarize d) es)
-      | EApp ((EFfi _, _), e) => summarize d e
-      | EApp _ => [Unsure]
-      | EAbs _ => []
-
-      | EUnop (_, e) => summarize d e
-      | EBinop (_, e1, e2) => summarize d e1 @ summarize d e2
-
-      | ERecord xets => List.concat (map (summarize d o #2) xets)
-      | EField (e, _) => summarize d e
-
-      | ECase (e, pes, _) =>
-        let
-            val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes
-        in
-            case lss of
-                [] => raise Fail "Empty pattern match"
-              | ls :: lss =>
-                if List.all (fn ls' => ls' = ls) lss then
-                    summarize d e @ ls
-                else
-                    [Unsure]
-        end
-      | EStrcat (e1, e2) => summarize d e1 @ summarize d e2
-
-      | EError (e, _) => summarize d e @ [Unsure]
-
-      | EWrite e => summarize d e @ [WritePage]
-        
-      | ESeq (e1, e2) => summarize d e1 @ summarize d e2
-      | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2
-
-      | EClosure (_, es) => List.concat (map (summarize d) es)
-
-      | EQuery {query, body, initial, ...} =>
-        List.concat [summarize d query,
-                     summarize (d + 2) body,
-                     summarize d initial,
-                     [ReadDb]]
-
-      | EDml e => summarize d e @ [WriteDb]
-      | ENextval e => summarize d e @ [WriteDb]
-      | EUnurlify (e, _) => summarize d e
-
-fun exp env e =
+fun reduce file =
     let
-        (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*)
-
-        val r =
+        fun countAbs (e, _) =
+            case e of
+                EAbs (_, _, _, e) => 1 + countAbs e
+              | _ => 0
+
+        val absCounts =
+            foldl (fn ((d, _), absCounts) =>
+                      case d of
+                          DVal (_, n, _, e, _) =>
+                          IM.insert (absCounts, n, countAbs e)
+                        | DValRec vis =>
+                          foldl (fn ((_, n, _, e, _), absCounts) =>
+                                    IM.insert (absCounts, n, countAbs e))
+                          absCounts vis
+                        | _ => absCounts)
+            IM.empty file
+
+        fun summarize d (e, _) =
             case e of
-                ERel n =>
-                (case E.lookupERel env n of
-                     (_, _, SOME e') => #1 e'
-                   | _ => e)
-              | ENamed n =>
-                (case E.lookupENamed env n of
-                     (_, _, SOME e', _) => ((*Print.prefaces "Switch" [("n", Print.PD.string (Int.toString n)),
-                                                                     ("e'", MonoPrint.p_exp env e')];*)
-                                            #1 e')
-                   | _ => e)
-
-              | EApp ((EAbs (x, t, _, e1), loc), e2) =>
-                ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1),
-                                               ("e2", MonoPrint.p_exp env e2),
-                                               ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*)
-                 if impure e2 then
-                     #1 (reduceExp env (ELet (x, t, e2, e1), loc))
-                 else
-                     #1 (reduceExp env (subExpInExp (0, e2) e1)))
-
-              | ECase (e', pes, {disc, result}) =>
+                EPrim _ => []
+              | ERel n => if n >= d then [UseRel (n - d)] else []
+              | ENamed _ => []
+              | ECon (_, _, NONE) => []
+              | ECon (_, _, SOME e) => summarize d e
+              | ENone _ => []
+              | ESome (_, e) => summarize d e
+              | EFfi _ => []
+              | EFfiApp ("Basis", "set_cookie", _) => [Unsure]
+              | EFfiApp (_, _, es) => List.concat (map (summarize d) es)
+              | EApp ((EFfi _, _), e) => summarize d e
+              | EApp _ =>
                 let
-                    fun push () =
-                        case result of
-                            (TFun (dom, result), loc) =>
-                            if List.all (fn (_, (EAbs _, _)) => true | _ => false) pes then
-                                EAbs ("_", dom, result,
-                                      (ECase (liftExpInExp 0 e',
-                                              map (fn (p, (EAbs (_, _, _, e), _)) =>
-                                                      (p, swapExpVarsPat (0, patBinds p) e)
-                                                    | _ => raise Fail "MonoReduce ECase") pes,
-                                              {disc = disc, result = result}), loc))
-                            else
-                                e
-                          | _ => e
-
-                    fun search pes =
-                        case pes of
-                            [] => push ()
-                          | (p, body) :: pes =>
-                            case match (env, p, e') of
-                                No => search pes
-                              | Maybe => push ()
-                              | Yes env => #1 (reduceExp env body)
+                    fun unravel (e, ls) =
+                        case e of
+                            ENamed n =>
+                            let
+                                val ls = rev ls
+                            in
+                                case IM.find (absCounts, n) of
+                                    NONE => [Unsure]
+                                  | SOME len =>
+                                    if length ls < len then
+                                        ls
+                                    else
+                                        [Unsure]
+                            end
+                          | ERel n => List.revAppend (ls, [UseRel (n - d), Unsure])
+                          | EApp (f, x) =>
+                            unravel (#1 f, summarize d x @ ls)
+                          | _ => [Unsure]
                 in
-                    search pes
+                    unravel (e, [])
                 end
 
-              | EField ((ERecord xes, _), x) =>
-                (case List.find (fn (x', _, _) => x' = x) xes of
-                     SOME (_, e, _) => #1 e
-                   | NONE => e)
+              | EAbs _ => []
+
+              | EUnop (_, e) => summarize d e
+              | EBinop (_, e1, e2) => summarize d e1 @ summarize d e2
 
-              | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) =>
+              | ERecord xets => List.concat (map (summarize d o #2) xets)
+              | EField (e, _) => summarize d e
+
+              | ECase (e, pes, _) =>
                 let
-                    val e' = (ELet (x2, t2, e1,
-                                    (ELet (x1, t1, b1,
-                                           liftExpInExp 1 b2), loc)), loc)
+                    val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes
                 in
-                    (*Print.prefaces "ELet commute" [("e", MonoPrint.p_exp env (e, loc)),
-                                                     ("e'", MonoPrint.p_exp env e')];*)
-                    #1 (reduceExp env e')
+                    case lss of
+                        [] => raise Fail "Empty pattern match"
+                      | ls :: lss =>
+                        if List.all (fn ls' => ls' = ls) lss then
+                            summarize d e @ ls
+                        else
+                            [Unsure]
                 end
-              | EApp ((ELet (x, t, e, b), loc), e') =>
-                #1 (reduceExp env (ELet (x, t, e,
-                                         (EApp (b, liftExpInExp 0 e'), loc)), loc))
-
-              | ELet (x, t, e', (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) =>
-                (*if impure e' then
-                    e
-                else*)
-                (* Seems unsound in general without the check... should revisit later *)
-                    EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc))
-
-              | ELet (x, t, e', b) =>
-                let
-                    fun doSub () =
-                        #1 (reduceExp env (subExpInExp (0, e') b))
-
-                    fun trySub () =
-                        case t of
-                            (TFfi ("Basis", "string"), _) => doSub ()
-                          | _ =>
-                            case e' of
-                                (ECase _, _) => e
-                              | _ => doSub ()
-                in
-                    if impure e' then
+              | EStrcat (e1, e2) => summarize d e1 @ summarize d e2
+
+              | EError (e, _) => summarize d e @ [Unsure]
+
+              | EWrite e => summarize d e @ [WritePage]
+                            
+              | ESeq (e1, e2) => summarize d e1 @ summarize d e2
+              | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2
+
+              | EClosure (_, es) => List.concat (map (summarize d) es)
+
+              | EQuery {query, body, initial, ...} =>
+                List.concat [summarize d query,
+                             summarize (d + 2) body,
+                             summarize d initial,
+                             [ReadDb]]
+
+              | EDml e => summarize d e @ [WriteDb]
+              | ENextval e => summarize d e @ [WriteDb]
+              | EUnurlify (e, _) => summarize d e
+
+
+        fun exp env e =
+            let
+                (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*)
+
+                val r =
+                    case e of
+                        ERel n =>
+                        (case E.lookupERel env n of
+                             (_, _, SOME e') => #1 e'
+                           | _ => e)
+                      | ENamed n =>
+                        (case E.lookupENamed env n of
+                             (_, _, SOME e', _) => ((*Print.prefaces "Switch" [("n", Print.PD.string (Int.toString n)),
+                                                                               ("e'", MonoPrint.p_exp env e')];*)
+                                                    #1 e')
+                           | _ => e)
+
+                      | EApp ((EAbs (x, t, _, e1), loc), e2) =>
+                        ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1),
+                                                         ("e2", MonoPrint.p_exp env e2),
+                                                         ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*)
+                         if impure e2 then
+                             #1 (reduceExp env (ELet (x, t, e2, e1), loc))
+                         else
+                             #1 (reduceExp env (subExpInExp (0, e2) e1)))
+
+                      | ECase (e', pes, {disc, result}) =>
                         let
-                            val effs_e' = summarize 0 e'
-                            val effs_b = summarize 0 b
-
-                            fun does eff = List.exists (fn eff' => eff' = eff) effs_e'
-                            val writesPage = does WritePage
-                            val readsDb = does ReadDb
-                            val writesDb = does WriteDb
-
-                            fun verifyUnused eff =
-                                case eff of
-                                    UseRel r => r <> 0
-                                  | Unsure => false
-                                  | _ => true
-
-                            fun verifyCompatible effs =
-                                case effs of
-                                    [] => false
-                                  | eff :: effs =>
-                                    case eff of
-                                        Unsure => false
-                                      | UseRel r =>
-                                        if r = 0 then
-                                            List.all verifyUnused effs
-                                        else
-                                            verifyCompatible effs
-                                      | WritePage => not writesPage andalso verifyCompatible effs
-                                      | ReadDb => not writesDb andalso verifyCompatible effs
-                                      | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs
+                            fun push () =
+                                case result of
+                                    (TFun (dom, result), loc) =>
+                                    if List.all (fn (_, (EAbs _, _)) => true | _ => false) pes then
+                                        EAbs ("_", dom, result,
+                                              (ECase (liftExpInExp 0 e',
+                                                      map (fn (p, (EAbs (_, _, _, e), _)) =>
+                                                              (p, swapExpVarsPat (0, patBinds p) e)
+                                                            | _ => raise Fail "MonoReduce ECase") pes,
+                                                      {disc = disc, result = result}), loc))
+                                    else
+                                        e
+                                  | _ => e
+
+                            fun search pes =
+                                case pes of
+                                    [] => push ()
+                                  | (p, body) :: pes =>
+                                    case match (env, p, e') of
+                                        No => search pes
+                                      | Maybe => push ()
+                                      | Yes env => #1 (reduceExp env body)
                         in
-                            (*Print.prefaces "verifyCompatible"
-                                             [("e'", MonoPrint.p_exp env e'),
-                                              ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
-                                              ("effs_e'", Print.p_list p_event effs_e'),
-                                              ("effs_b", Print.p_list p_event effs_b)];*)
-                            if verifyCompatible effs_b then
-                                trySub ()
-                            else
-                                e
+                            search pes
                         end
-                    else
-                        trySub ()
-                end
 
-              | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) =>
-                EPrim (Prim.String (s1 ^ s2))
+                      | EField ((ERecord xes, _), x) =>
+                        (case List.find (fn (x', _, _) => x' = x) xes of
+                             SOME (_, e, _) => #1 e
+                           | NONE => e)
 
-              | _ => e
-    in
-        (*Print.prefaces "exp'" [("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*)
-        r
-    end
+                      | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) =>
+                        let
+                            val e' = (ELet (x2, t2, e1,
+                                            (ELet (x1, t1, b1,
+                                                   liftExpInExp 1 b2), loc)), loc)
+                        in
+                            (*Print.prefaces "ELet commute" [("e", MonoPrint.p_exp env (e, loc)),
+                                                             ("e'", MonoPrint.p_exp env e')];*)
+                            #1 (reduceExp env e')
+                        end
+                      | EApp ((ELet (x, t, e, b), loc), e') =>
+                        #1 (reduceExp env (ELet (x, t, e,
+                                                 (EApp (b, liftExpInExp 0 e'), loc)), loc))
+
+                      | ELet (x, t, e', (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) =>
+                        (*if impure e' then
+                              e
+                          else*)
+                        (* Seems unsound in general without the check... should revisit later *)
+                        EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc))
+
+                      | ELet (x, t, e', b) =>
+                        let
+                            fun doSub () =
+                                #1 (reduceExp env (subExpInExp (0, e') b))
+
+                            fun trySub () =
+                                case t of
+                                    (TFfi ("Basis", "string"), _) => doSub ()
+                                  | _ =>
+                                    case e' of
+                                        (ECase _, _) => e
+                                      | _ => doSub ()
+                        in
+                            if impure e' then
+                                let
+                                    val effs_e' = summarize 0 e'
+                                    val effs_b = summarize 0 b
+
+                                    (*val () = Print.prefaces "Try"
+                                             [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),
+                                              ("e'", p_events effs_e'),
+                                              ("b", p_events effs_b)]*)
+
+                                    fun does eff = List.exists (fn eff' => eff' = eff) effs_e'
+                                    val writesPage = does WritePage
+                                    val readsDb = does ReadDb
+                                    val writesDb = does WriteDb
+
+                                    fun verifyUnused eff =
+                                        case eff of
+                                            UseRel r => r <> 0
+                                          | _ => true
+
+                                    fun verifyCompatible effs =
+                                        case effs of
+                                            [] => false
+                                          | eff :: effs =>
+                                            case eff of
+                                                Unsure => false
+                                              | UseRel r =>
+                                                if r = 0 then
+                                                    List.all verifyUnused effs
+                                                else
+                                                    verifyCompatible effs
+                                              | WritePage => not writesPage andalso verifyCompatible effs
+                                              | ReadDb => not writesDb andalso verifyCompatible effs
+                                              | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs
+                                in
+                                    (*Print.prefaces "verifyCompatible"
+                                                     [("e'", MonoPrint.p_exp env e'),
+                                                      ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
+                                                      ("effs_e'", Print.p_list p_event effs_e'),
+                                                      ("effs_b", Print.p_list p_event effs_b)];*)
+                                    if verifyCompatible effs_b then
+                                        trySub ()
+                                    else
+                                        e
+                                end
+                            else
+                                trySub ()
+                        end
+
+                      | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) =>
+                        EPrim (Prim.String (s1 ^ s2))
 
-and bind (env, b) =
-    case b of
-        U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs
-      | U.Decl.RelE (x, t) => E.pushERel env x t NONE
-      | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t (Option.map (reduceExp env) eo) s
+                      | _ => e
+            in
+                (*Print.prefaces "exp'" [("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*)
+                r
+            end
 
-and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env
+        and bind (env, b) =
+            case b of
+                U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs
+              | U.Decl.RelE (x, t) => E.pushERel env x t NONE
+              | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t (Option.map (reduceExp env) eo) s
 
-fun decl env d = d
+        and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env
 
-val reduce = U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty
+        fun decl env d = d
+    in
+        U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file
+    end
 
 end
diff --git a/src/monoize.sml b/src/monoize.sml
index 70f15867..9e1a4d22 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1584,6 +1584,25 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             end
           | L.EFfi ("Basis", "sql_current_timestamp") => ((L'.EPrim (Prim.String "CURRENT_TIMESTAMP"), loc), fm)
 
+          | (L.ECApp (
+             (L.ECApp (
+              (L.ECApp (
+               (L.ECApp (
+                (L.EFfi ("Basis", "sql_is_null"), _), _),
+                _), _),
+               _), _),
+              _), _)) =>
+            let
+                val s = (L'.TFfi ("Basis", "string"), loc)
+                fun sc s = (L'.EPrim (Prim.String s), loc)
+            in
+                ((L'.EAbs ("s", s, s,
+                           strcat loc [sc "(",
+                                       (L'.ERel 0, loc),
+                                       sc " IS NULL)"]), loc),
+                 fm)
+            end
+
           | L.EFfiApp ("Basis", "nextval", [e]) =>
             let
                 val (e, fm) = monoExp (env, st, fm) e
diff --git a/src/urweb.grm b/src/urweb.grm
index 2482be1b..4ac14450 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -214,7 +214,7 @@ fun tagIn bt =
  | TRUE | FALSE | CAND | OR | NOT
  | COUNT | AVG | SUM | MIN | MAX
  | ASC | DESC
- | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL
+ | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS
  | CURRENT_TIMESTAMP
  | NE | LT | LE | GT | GE
 
@@ -346,7 +346,7 @@ fun tagIn bt =
 %right COMMA
 %right OR
 %right CAND
-%nonassoc EQ NE LT LE GT GE
+%nonassoc EQ NE LT LE GT GE IS
 %right ARROW
 %right PLUSPLUS MINUSMINUS
 %left PLUS MINUS
@@ -1236,6 +1236,8 @@ sqlexp : TRUE                           (sql_inject (EVar (["Basis"], "True", In
                                                   end
                                           end)
 
+       | LBRACE LBRACK eexp RBRACK RBRACE       (eexp)
+
        | sqlexp EQ sqlexp               (sql_compare ("eq", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
        | sqlexp NE sqlexp               (sql_compare ("ne", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
        | sqlexp LT sqlexp               (sql_compare ("lt", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
@@ -1247,6 +1249,13 @@ sqlexp : TRUE                           (sql_inject (EVar (["Basis"], "True", In
        | sqlexp OR sqlexp               (sql_binary ("or", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
        | NOT sqlexp                     (sql_unary ("not", sqlexp, s (NOTleft, sqlexpright)))
 
+       | sqlexp IS NULL                 (let
+                                             val loc = s (sqlexpleft, NULLright)
+                                         in
+                                             (EApp ((EVar (["Basis"], "sql_is_null", Infer), loc),
+                                                    sqlexp), loc)
+                                         end)
+
        | LBRACE eexp RBRACE             (sql_inject (#1 eexp,
                                                      s (LBRACEleft, RBRACEright)))
        | LPAREN sqlexp RPAREN           (sqlexp)
diff --git a/src/urweb.lex b/src/urweb.lex
index f4ae3a85..642282ec 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -358,6 +358,7 @@ notags = [^<{\n]+;
 <INITIAL> "SET"       => (Tokens.SET (pos yypos, pos yypos + size yytext));
 <INITIAL> "DELETE"    => (Tokens.DELETE (pos yypos, pos yypos + size yytext));
 <INITIAL> "NULL"      => (Tokens.NULL (pos yypos, pos yypos + size yytext));
+<INITIAL> "IS"        => (Tokens.IS (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext));
 
-- 
cgit v1.2.3


From 887af944c67e3395679a750a205ef114234c61a0 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Tue, 11 Nov 2008 19:20:37 -0500
Subject: Add CutMulti

---
 include/urweb.h      |  1 +
 src/c/urweb.c        |  7 ++++++
 src/cjr_print.sml    |  2 +-
 src/core.sml         |  1 +
 src/core_print.sml   | 17 +++++++++++++
 src/core_util.sml    | 16 ++++++++++++-
 src/corify.sml       |  2 ++
 src/elab.sml         |  1 +
 src/elab_print.sml   | 18 ++++++++++++++
 src/elab_util.sml    |  9 +++++++
 src/elaborate.sml    | 67 +++++++++++++++++++++++++++++++++++++++++++++-------
 src/expl.sml         |  1 +
 src/expl_print.sml   | 17 +++++++++++++
 src/expl_util.sml    |  8 +++++++
 src/explify.sml      |  2 ++
 src/monoize.sml      |  1 +
 src/reduce.sml       | 13 ++++++++++
 src/source.sml       |  1 +
 src/source_print.sml |  5 ++++
 src/termination.sml  |  6 +++++
 src/urweb.grm        |  5 ++--
 src/urweb.lex        |  1 +
 tests/cut.ur         |  7 +++---
 tests/cut.urp        |  3 +++
 24 files changed, 195 insertions(+), 16 deletions(-)
 create mode 100644 tests/cut.urp

(limited to 'src/urweb.lex')

diff --git a/include/urweb.h b/include/urweb.h
index d148654f..ad08c811 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -75,6 +75,7 @@ uw_Basis_time uw_Basis_unurlifyTime(uw_context, char **);
 
 uw_Basis_string uw_Basis_strcat(uw_context, uw_Basis_string, uw_Basis_string);
 uw_Basis_string uw_Basis_strdup(uw_context, uw_Basis_string);
+uw_Basis_string uw_Basis_maybe_strdup(uw_context, uw_Basis_string);
 
 uw_Basis_string uw_Basis_sqlifyInt(uw_context, uw_Basis_int);
 uw_Basis_string uw_Basis_sqlifyFloat(uw_context, uw_Basis_float);
diff --git a/src/c/urweb.c b/src/c/urweb.c
index a347dd45..253cda87 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -869,6 +869,13 @@ uw_Basis_string uw_Basis_strdup(uw_context ctx, uw_Basis_string s1) {
   return s;
 }
 
+uw_Basis_string uw_Basis_maybe_strdup(uw_context ctx, uw_Basis_string s1) {
+  if (s1)
+    return uw_Basis_strdup(ctx, s1);
+  else
+    return NULL;
+}
+
 
 char *uw_Basis_sqlifyInt(uw_context ctx, uw_Basis_int n) {
   int len;
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 1c750b33..8c3c3d86 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1481,7 +1481,7 @@ fun p_exp' par env (e, loc) =
         in
             box [string "({",
                  newline,
-                 string "uw_Basis_string request = uw_Basis_strdup(ctx, ",
+                 string "uw_Basis_string request = uw_Basis_maybe_strdup(ctx, ",
                  p_exp env e,
                  string ");",
                  newline,
diff --git a/src/core.sml b/src/core.sml
index 1a181a68..4623bb49 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -95,6 +95,7 @@ datatype exp' =
        | EField of exp * con * { field : con, rest : con }
        | EConcat of exp * con * exp * con
        | ECut of exp * con * { field : con, rest : con }
+       | ECutMulti of exp * con * { rest : con }
        | EFold of kind
 
        | ECase of exp * (pat * exp) list * { disc : con, result : con }
diff --git a/src/core_print.sml b/src/core_print.sml
index f209b84f..53922936 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -325,6 +325,23 @@ fun p_exp' par env (e, _) =
                               string "--",
                               space,
                               p_con' true env c])
+      | ECutMulti (e, c, {rest}) =>
+        parenIf par (if !debug then
+                         box [p_exp' true env e,
+                              space,
+                              string "---",
+                              space,
+                              p_con' true env c,
+                              space,
+                              string "[",
+                              p_con env rest,
+                              string "]"]
+                     else
+                         box [p_exp' true env e,
+                              space,
+                              string "---",
+                              space,
+                              p_con' true env c])
       | EFold _ => string "fold"
 
       | ECase (e, pes, {disc, result}) =>
diff --git a/src/core_util.sml b/src/core_util.sml
index 38004f74..71efe16e 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -444,10 +444,16 @@ fun compare ((e1, _), (e2, _)) =
 
       | (ECut (e1, c1, _), ECut (e2, c2, _)) =>
         join (compare (e1, e2),
-              fn () => Con.compare (c1, c2))
+           fn () => Con.compare (c1, c2))
       | (ECut _, _) => LESS
       | (_, ECut _) => GREATER
 
+      | (ECutMulti (e1, c1, _), ECutMulti (e2, c2, _)) =>
+        join (compare (e1, e2),
+           fn () => Con.compare (c1, c2))
+      | (ECutMulti _, _) => LESS
+      | (_, ECutMulti _) => GREATER
+
       | (EFold _, EFold _) => EQUAL
       | (EFold _, _) => LESS
       | (_, EFold _) => GREATER
@@ -588,6 +594,14 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
                                              S.map2 (mfc ctx rest,
                                                   fn rest' =>
                                                      (ECut (e', c', {field = field', rest = rest'}), loc)))))
+              | ECutMulti (e, c, {rest}) =>
+                S.bind2 (mfe ctx e,
+                      fn e' =>
+                         S.bind2 (mfc ctx c,
+                              fn c' =>
+                                 S.map2 (mfc ctx rest,
+                                      fn rest' =>
+                                         (ECutMulti (e', c', {rest = rest'}), loc))))
               | EFold k =>
                 S.map2 (mfk k,
                          fn k' =>
diff --git a/src/corify.sml b/src/corify.sml
index fdb4e7b7..8bb1a925 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -590,6 +590,8 @@ fun corifyExp st (e, loc) =
                                                    corifyCon st c2), loc)
       | L.ECut (e1, c, {field, rest}) => (L'.ECut (corifyExp st e1, corifyCon st c,
                                                    {field = corifyCon st field, rest = corifyCon st rest}), loc)
+      | L.ECutMulti (e1, c, {rest}) => (L'.ECutMulti (corifyExp st e1, corifyCon st c,
+                                                      {rest = corifyCon st rest}), loc)
       | L.EFold k => (L'.EFold (corifyKind k), loc)
 
       | L.ECase (e, pes, {disc, result}) =>
diff --git a/src/elab.sml b/src/elab.sml
index d00d1f1a..d997b7ec 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -110,6 +110,7 @@ datatype exp' =
        | EField of exp * con * { field : con, rest : con }
        | EConcat of exp * con * exp * con
        | ECut of exp * con * { field : con, rest : con }
+       | ECutMulti of exp * con * { rest : con }
        | EFold of kind
 
        | ECase of exp * (pat * exp) list * { disc : con, result : con }
diff --git a/src/elab_print.sml b/src/elab_print.sml
index 2afedef1..62b1ea02 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -359,6 +359,24 @@ fun p_exp' par env (e, _) =
                               string "--",
                               space,
                               p_con' true env c])
+      | ECutMulti (e, c, {rest}) =>
+        parenIf par (if !debug then
+                         box [p_exp' true env e,
+                              space,
+                              string "---",
+                              space,
+                              p_con' true env c,
+                              space,
+                              string "[",
+                              p_con env rest,
+                              string "]"]
+                     else
+                         box [p_exp' true env e,
+                              space,
+                              string "---",
+                              space,
+                              p_con' true env c])
+
       | EFold _ => string "fold"
 
       | ECase (e, pes, _) => parenIf par (box [string "case",
diff --git a/src/elab_util.sml b/src/elab_util.sml
index 9c25ae86..6e2c76f6 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -338,6 +338,15 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
                                                   fn rest' =>
                                                      (ECut (e', c', {field = field', rest = rest'}), loc)))))
 
+              | ECutMulti (e, c, {rest}) =>
+                S.bind2 (mfe ctx e,
+                      fn e' =>
+                         S.bind2 (mfc ctx c,
+                              fn c' =>
+                                 S.map2 (mfc ctx rest,
+                                      fn rest' =>
+                                         (ECutMulti (e', c', {rest = rest'}), loc))))
+
               | EFold k =>
                 S.map2 (mfk k,
                          fn k' =>
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 70429c1b..e3d334eb 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1664,6 +1664,21 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
                 ((L'.ECut (e', c', {field = ft, rest = rest}), loc), (L'.TRecord rest, loc),
                  gs1 @ enD gs2 @ enD gs3 @ enD gs4)
             end
+          | L.ECutMulti (e, c) =>
+            let
+                val (e', et, gs1) = elabExp (env, denv) e
+                val (c', ck, gs2) = elabCon (env, denv) c
+
+                val rest = cunif (loc, ktype_record)
+                            
+                val gs3 =
+                    checkCon (env, denv) e' et
+                             (L'.TRecord (L'.CConcat (c', rest), loc), loc)
+                val gs4 = D.prove env denv (c', rest, loc)
+            in
+                ((L'.ECutMulti (e', c', {rest = rest}), loc), (L'.TRecord rest, loc),
+                 gs1 @ enD gs2 @ enD gs3 @ enD gs4)
+            end
 
           | L.EFold =>
             let
@@ -2694,6 +2709,33 @@ fun wildifyStr env (str, sgn) =
         (case #1 str of
              L.StrConst ds =>
              let
+                 fun decompileKind (k, loc) =
+                     case k of
+                         L'.KType => SOME (L.KType, loc)
+                       | L'.KArrow (k1, k2) =>
+                         (case (decompileKind k1, decompileKind k2) of
+                              (SOME k1, SOME k2) => SOME (L.KArrow (k1, k2), loc)
+                            | _ => NONE)
+                       | L'.KName => SOME (L.KName, loc)
+                       | L'.KRecord k =>
+                         (case decompileKind k of
+                              SOME k => SOME (L.KRecord k, loc)
+                            | _ => NONE)
+                       | L'.KUnit => SOME (L.KUnit, loc)
+                       | L'.KTuple ks =>
+                         let
+                             val ks' = List.mapPartial decompileKind ks
+                         in
+                             if length ks' = length ks then
+                                 SOME (L.KTuple ks', loc)
+                             else
+                                 NONE
+                         end
+
+                       | L'.KError => NONE
+                       | L'.KUnif (_, _, ref (SOME k)) => decompileKind k
+                       | L'.KUnif _ => NONE
+
                  fun decompileCon env (c, loc) =
                      case c of
                          L'.CRel i =>
@@ -2741,7 +2783,7 @@ fun wildifyStr env (str, sgn) =
                                let
                                    val (needed, constraints, neededV) =
                                        case sgi of
-                                           L'.SgiConAbs (x, _, _) => (SS.add (neededC, x), constraints, neededV)
+                                           L'.SgiConAbs (x, _, k) => (SM.insert (neededC, x, k), constraints, neededV)
                                          | L'.SgiConstraint cs => (neededC, (env', cs, loc) :: constraints, neededV)
 
                                          | L'.SgiVal (x, _, t) =>
@@ -2764,18 +2806,18 @@ fun wildifyStr env (str, sgn) =
                                in
                                    (needed, constraints, neededV, E.sgiBinds env' (sgi, loc))
                                end)
-                           (SS.empty, [], SS.empty, env) sgis
+                           (SM.empty, [], SS.empty, env) sgis
                                                               
                  val (neededC, neededV) = foldl (fn ((d, _), needed as (neededC, neededV)) =>
                                                     case d of
-                                                        L.DCon (x, _, _) => ((SS.delete (neededC, x), neededV)
+                                                        L.DCon (x, _, _) => ((#1 (SM.remove (neededC, x)), neededV)
                                                                              handle NotFound =>
                                                                                     needed)
-                                                      | L.DClass (x, _) => ((SS.delete (neededC, x), neededV)
+                                                      | L.DClass (x, _) => ((#1 (SM.remove (neededC, x)), neededV)
                                                                             handle NotFound => needed)
                                                       | L.DVal (x, _, _) => ((neededC, SS.delete (neededV, x))
                                                                              handle NotFound => needed)
-                                                      | L.DOpen _ => (SS.empty, SS.empty)
+                                                      | L.DOpen _ => (SM.empty, SS.empty)
                                                       | _ => needed)
                                                 (neededC, neededV) ds
 
@@ -2797,13 +2839,20 @@ fun wildifyStr env (str, sgn) =
                          end
 
                  val ds' =
-                     case SS.listItems neededC of
+                     case SM.listItemsi neededC of
                          [] => ds'
                        | xs =>
                          let
-                             val kwild = (L.KWild, #2 str)
-                             val cwild = (L.CWild kwild, #2 str)
-                             val ds'' = map (fn x => (L.DCon (x, NONE, cwild), #2 str)) xs
+                             val ds'' = map (fn (x, k) =>
+                                                let
+                                                    val k =
+                                                        case decompileKind k of
+                                                            NONE => (L.KWild, #2 str)
+                                                          | SOME k => k
+                                                    val cwild = (L.CWild k, #2 str)
+                                                in
+                                                    (L.DCon (x, NONE, cwild), #2 str)
+                                                end) xs
                          in
                              ds'' @ ds'
                          end
diff --git a/src/expl.sml b/src/expl.sml
index 57396684..cce0fc22 100644
--- a/src/expl.sml
+++ b/src/expl.sml
@@ -92,6 +92,7 @@ datatype exp' =
        | EField of exp * con * { field : con, rest : con }
        | EConcat of exp * con * exp * con
        | ECut of exp * con * { field : con, rest : con }
+       | ECutMulti of exp * con * { rest : con }
        | EFold of kind
 
        | ECase of exp * (pat * exp) list * { disc : con, result : con }
diff --git a/src/expl_print.sml b/src/expl_print.sml
index e3153ef2..2ce0c5e2 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -334,6 +334,23 @@ fun p_exp' par env (e, loc) =
                               string "--",
                               space,
                               p_con' true env c])
+      | ECutMulti (e, c, {rest}) =>
+        parenIf par (if !debug then
+                         box [p_exp' true env e,
+                              space,
+                              string "---",
+                              space,
+                              p_con' true env c,
+                              space,
+                              string "[",
+                              p_con env rest,
+                              string "]"]
+                     else
+                         box [p_exp' true env e,
+                              space,
+                              string "---",
+                              space,
+                              p_con' true env c])
       | EFold _ => string "fold"
 
       | EWrite e => box [string "write(",
diff --git a/src/expl_util.sml b/src/expl_util.sml
index 2bd9eabd..d2073a23 100644
--- a/src/expl_util.sml
+++ b/src/expl_util.sml
@@ -303,6 +303,14 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
                                              S.map2 (mfc ctx rest,
                                                   fn rest' =>
                                                      (ECut (e', c', {field = field', rest = rest'}), loc)))))
+              | ECutMulti (e, c, {rest}) =>
+                S.bind2 (mfe ctx e,
+                      fn e' =>
+                         S.bind2 (mfc ctx c,
+                              fn c' =>
+                                 S.map2 (mfc ctx rest,
+                                      fn rest' =>
+                                         (ECutMulti (e', c', {rest = rest'}), loc))))
               | EFold k =>
                 S.map2 (mfk k,
                          fn k' =>
diff --git a/src/explify.sml b/src/explify.sml
index 4115476b..e3c22f20 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -105,6 +105,8 @@ fun explifyExp (e, loc) =
                                        loc)
       | L.ECut (e1, c, {field, rest}) => (L'.ECut (explifyExp e1, explifyCon c,
                                                      {field = explifyCon field, rest = explifyCon rest}), loc)
+      | L.ECutMulti (e1, c, {rest}) => (L'.ECutMulti (explifyExp e1, explifyCon c,
+                                                      {rest = explifyCon rest}), loc)
       | L.EFold k => (L'.EFold (explifyKind k), loc)
 
       | L.ECase (e, pes, {disc, result}) =>
diff --git a/src/monoize.sml b/src/monoize.sml
index a4f38dc6..28ea5946 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2014,6 +2014,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             end
           | L.EConcat _ => poly ()
           | L.ECut _ => poly ()
+          | L.ECutMulti _ => poly ()
           | L.EFold _ => poly ()
 
           | L.ECase (e, pes, {disc, result}) =>
diff --git a/src/reduce.sml b/src/reduce.sml
index 1404b598..e480dea2 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -133,6 +133,19 @@ fun exp env e =
                     in
                         #1 (reduceExp env (ERecord (fields (xts, [])), loc))
                     end
+                  | ECutMulti (r as (_, loc), _, {rest = (CRecord (k, xts), _), ...}) =>
+                    let
+                        fun fields (remaining, passed) =
+                            case remaining of
+                                [] => []
+                              | (x, t) :: rest =>
+                                (x,
+                                 (EField (r, x, {field = t,
+                                                 rest = (CRecord (k, List.revAppend (passed, rest)), loc)}), loc),
+                                 t) :: fields (rest, (x, t) :: passed)
+                    in
+                        #1 (reduceExp env (ERecord (fields (xts, [])), loc))
+                    end
 
                   | _ => e
     in
diff --git a/src/source.sml b/src/source.sml
index 2a348338..7685bb2f 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -123,6 +123,7 @@ datatype exp' =
        | EField of exp * con
        | EConcat of exp * exp
        | ECut of exp * con
+       | ECutMulti of exp * con
        | EFold
 
        | EWild
diff --git a/src/source_print.sml b/src/source_print.sml
index 3c26812f..77f2d749 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -268,6 +268,11 @@ fun p_exp' par (e, _) =
                                          string "--",
                                          space,
                                          p_con' true c])
+      | ECutMulti (e, c) => parenIf par (box [p_exp' true e,
+                                              space,
+                                              string "---",
+                                              space,
+                                              p_con' true c])
       | EFold => string "fold"
 
       | ECase (e, pes) => parenIf par (box [string "case",
diff --git a/src/termination.sml b/src/termination.sml
index 2db5bb11..e89f329e 100644
--- a/src/termination.sml
+++ b/src/termination.sml
@@ -265,6 +265,12 @@ fun declOk' env (d, loc) =
                         in
                             (Rabble, calls)
                         end
+                      | ECutMulti (e, _, _) =>
+                        let
+                            val (_, calls) = exp parent (penv, calls) e
+                        in
+                            (Rabble, calls)
+                        end
                       | EConcat (e1, _, e2, _) =>
                         let
                             val (_, calls) = exp parent (penv, calls) e1
diff --git a/src/urweb.grm b/src/urweb.grm
index 5241ed20..8a3bee7f 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -197,7 +197,7 @@ fun tagIn bt =
  | DATATYPE | OF
  | TYPE | NAME
  | ARROW | LARROW | DARROW | STAR | SEMI
- | FN | PLUSPLUS | MINUSMINUS | DOLLAR | TWIDDLE
+ | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE
  | LET | IN
  | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL
  | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE
@@ -348,7 +348,7 @@ fun tagIn bt =
 %right CAND
 %nonassoc EQ NE LT LE GT GE IS
 %right ARROW
-%right PLUSPLUS MINUSMINUS
+%right PLUSPLUS MINUSMINUS MINUSMINUSMINUS
 %left PLUS MINUS
 %left STAR DIVIDE MOD
 %left NOT
@@ -692,6 +692,7 @@ eexp   : eapps                          (eapps)
                                          end)
        | eexp COLON cexp                (EAnnot (eexp, cexp), s (eexpleft, cexpright))
        | eexp MINUSMINUS cexp           (ECut (eexp, cexp), s (eexpleft, cexpright))
+       | eexp MINUSMINUSMINUS cexp      (ECutMulti (eexp, cexp), s (eexpleft, cexpright))
        | CASE eexp OF barOpt branch branchs (ECase (eexp, branch :: branchs), s (CASEleft, branchsright))
        | IF eexp THEN eexp ELSE eexp    (let
                                              val loc = s (IFleft, eexp3right)
diff --git a/src/urweb.lex b/src/urweb.lex
index 642282ec..aef68ad1 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -251,6 +251,7 @@ notags = [^<{\n]+;
 <INITIAL> "=>"        => (Tokens.DARROW (pos yypos, pos yypos + size yytext));
 <INITIAL> "++"        => (Tokens.PLUSPLUS (pos yypos, pos yypos + size yytext));
 <INITIAL> "--"        => (Tokens.MINUSMINUS (pos yypos, pos yypos + size yytext));
+<INITIAL> "---"       => (Tokens.MINUSMINUSMINUS (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "="         => (Tokens.EQ (pos yypos, pos yypos + size yytext));
 <INITIAL> "<>"        => (Tokens.NE (pos yypos, pos yypos + size yytext));
diff --git a/tests/cut.ur b/tests/cut.ur
index 6b7b4ef3..7d0ee77a 100644
--- a/tests/cut.ur
+++ b/tests/cut.ur
@@ -1,6 +1,7 @@
 val r = {A = 1, B = "Hi", C = 0.0}
 val rA = r -- #A
+val rB = r --- [A = _, C = _]
 
-val main : unit -> page = fn () => <html><body>
-        {cdata rA.B}
-</body></html>
+fun main () : transaction page = return <xml>
+        {cdata rA.B}, {cdata rB.B}
+</xml>
diff --git a/tests/cut.urp b/tests/cut.urp
new file mode 100644
index 00000000..5c9c3e81
--- /dev/null
+++ b/tests/cut.urp
@@ -0,0 +1,3 @@
+debug
+
+cut
-- 
cgit v1.2.3


From c40cb1851bc27f0a0a99648be21dacb821b65ed9 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sat, 21 Feb 2009 15:33:20 -0500
Subject: "Hello world" compiles, after replacing type-level fold with map

---
 lib/ur/basis.urs        |  31 ++----
 lib/ur/top.ur           |  30 ++----
 lib/ur/top.urs          |  52 ++++------
 src/core.sml            |   2 +-
 src/core_print.sml      |   2 +-
 src/core_util.sml       |  10 +-
 src/corify.sml          |   2 +-
 src/disjoint.sml        |  33 +------
 src/elab.sml            |   2 +-
 src/elab_ops.sml        | 253 ++++++++++++++++--------------------------------
 src/elab_print.sml      |   2 +-
 src/elab_util.sml       |   4 +-
 src/elaborate.sml       | 176 ++++++++++++++-------------------
 src/elisp/urweb-defs.el |   4 +-
 src/elisp/urweb-mode.el |   2 +-
 src/expl.sml            |   2 +-
 src/expl_print.sml      |   2 +-
 src/expl_util.sml       |   4 +-
 src/explify.sml         |   2 +-
 src/monoize.sml         |   2 +-
 src/reduce.sml          |  13 ++-
 src/source.sml          |   2 +-
 src/source_print.sml    |   2 +-
 src/urweb.grm           |   4 +-
 src/urweb.lex           |   1 +
 25 files changed, 223 insertions(+), 416 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index b4a40fde..cd2468ba 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -120,31 +120,20 @@ con sql_exp :: {{Type}} -> {{Type}} -> {Type} -> Type -> Type
 con sql_subset :: {{Type}} -> {{Type}} -> Type
 val sql_subset : keep_drop :: {({Type} * {Type})}
                               -> sql_subset
-                                     (fold (fn nm (fields :: ({Type} * {Type}))
-                                                  acc [[nm] ~ acc]
-                                                  [fields.1 ~ fields.2] =>
-                                               [nm = fields.1 ++ fields.2]
-                                                   ++ acc) [] keep_drop)
-                                     (fold (fn nm (fields :: ({Type} * {Type}))
-                                                  acc [[nm] ~ acc] =>
-                                               [nm = fields.1] ++ acc)
-                                               [] keep_drop)
+                                     (map (fn fields :: ({Type} * {Type}) => fields.1 ++ fields.2) keep_drop)
+                                     (map (fn fields :: ({Type} * {Type}) => fields.1) keep_drop)
 val sql_subset_all : tables :: {{Type}} -> sql_subset tables tables
 
 val sql_query1 : tables ::: {{Type}}
                  -> grouped ::: {{Type}}
                  -> selectedFields ::: {{Type}}
                  -> selectedExps ::: {Type}
-                 -> {From : $(fold (fn nm (fields :: {Type}) acc [[nm] ~ acc] =>
-                                       [nm = sql_table fields] ++ acc)
-                                       [] tables),
+                 -> {From : $(map (fn fields :: {Type} => sql_table fields) tables),
                      Where : sql_exp tables [] [] bool,
                      GroupBy : sql_subset tables grouped,
                      Having : sql_exp grouped tables [] bool,
                      SelectFields : sql_subset grouped selectedFields,
-                     SelectExps : $(fold (fn nm (t :: Type) acc [[nm] ~ acc] =>
-                                             [nm = sql_exp grouped tables [] t]
-                                                 ++ acc) [] selectedExps) }
+                     SelectExps : $(map (fn (t :: Type) => sql_exp grouped tables [] t) selectedExps) }
                  -> sql_query1 tables selectedFields selectedExps
 
 type sql_relop 
@@ -291,8 +280,7 @@ val query : tables ::: {{Type}} -> exps ::: {Type}
             -> fn [tables ~ exps] =>
                   state ::: Type
                   -> sql_query tables exps
-                  -> ($(exps ++ fold (fn nm (fields :: {Type}) acc [[nm] ~ acc] =>
-                                         [nm = $fields] ++ acc) [] tables)
+                  -> ($(exps ++ map (fn fields :: {Type} => $fields) tables)
                       -> state
                       -> transaction state)
                   -> state
@@ -306,17 +294,12 @@ val dml : dml -> transaction unit
 
 val insert : fields ::: {Type}
              -> sql_table fields
-             -> $(fold (fn nm (t :: Type) acc [[nm] ~ acc] =>
-                           [nm = sql_exp [] [] [] t] ++ acc)
-                           [] fields)
+             -> $(map (fn t :: Type => sql_exp [] [] [] t) fields)
              -> dml
 
 val update : unchanged ::: {Type} -> changed :: {Type} ->
              fn [changed ~ unchanged] =>
-                $(fold (fn nm (t :: Type) acc [[nm] ~ acc] =>
-                           [nm = sql_exp [T = changed ++ unchanged] [] [] t]
-                               ++ acc)
-                           [] changed)
+                $(map (fn t :: Type => sql_exp [T = changed ++ unchanged] [] [] t) changed)
                 -> sql_table (changed ++ unchanged)
                 -> sql_exp [T = changed ++ unchanged] [] [] bool
                 -> dml
diff --git a/lib/ur/top.ur b/lib/ur/top.ur
index 35e8519b..58e99f3c 100644
--- a/lib/ur/top.ur
+++ b/lib/ur/top.ur
@@ -8,17 +8,7 @@ con fstTTT (t :: (Type * Type * Type)) = t.1
 con sndTTT (t :: (Type * Type * Type)) = t.2
 con thdTTT (t :: (Type * Type * Type)) = t.3
 
-con mapTT (f :: Type -> Type) = fold (fn nm t acc [[nm] ~ acc] =>
-                                         [nm = f t] ++ acc) []
-
-con mapUT = fn f :: Type => fold (fn nm t acc [[nm] ~ acc] =>
-                                     [nm = f] ++ acc) []
-
-con mapT2T (f :: (Type * Type) -> Type) = fold (fn nm t acc [[nm] ~ acc] =>
-                                                   [nm = f t] ++ acc) []
-
-con mapT3T (f :: (Type * Type * Type) -> Type) = fold (fn nm t acc [[nm] ~ acc] =>
-                                                          [nm = f t] ++ acc) []
+con mapUT = fn f :: Type => map (fn _ :: Unit => f)
 
 con ex = fn tf :: (Type -> Type) =>
             res ::: Type -> (choice :: Type -> tf choice -> res) -> res
@@ -69,7 +59,7 @@ fun foldTR (tf :: Type -> Type) (tr :: {Type} -> Type)
                 -> fn [[nm] ~ rest] =>
                       tf t -> tr rest -> tr ([nm = t] ++ rest))
            (i : tr []) =
-    fold [fn r :: {Type} => $(mapTT tf r) -> tr r]
+    fold [fn r :: {Type} => $(map tf r) -> tr r]
              (fn (nm :: Name) (t :: Type) (rest :: {Type}) (acc : _ -> tr rest)
                               [[nm] ~ rest] r =>
                  f [nm] [t] [rest] r.nm (acc (r -- nm)))
@@ -80,7 +70,7 @@ fun foldT2R (tf :: (Type * Type) -> Type) (tr :: {(Type * Type)} -> Type)
                  -> fn [[nm] ~ rest] =>
                        tf t -> tr rest -> tr ([nm = t] ++ rest))
             (i : tr []) =
-    fold [fn r :: {(Type * Type)} => $(mapT2T tf r) -> tr r]
+    fold [fn r :: {(Type * Type)} => $(map tf r) -> tr r]
              (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
                               (acc : _ -> tr rest) [[nm] ~ rest] r =>
                  f [nm] [t] [rest] r.nm (acc (r -- nm)))
@@ -91,7 +81,7 @@ fun foldT3R (tf :: (Type * Type * Type) -> Type) (tr :: {(Type * Type * Type)} -
                  -> fn [[nm] ~ rest] =>
                        tf t -> tr rest -> tr ([nm = t] ++ rest))
             (i : tr []) =
-    fold [fn r :: {(Type * Type * Type)} => $(mapT3T tf r) -> tr r]
+    fold [fn r :: {(Type * Type * Type)} => $(map tf r) -> tr r]
              (fn (nm :: Name) (t :: (Type * Type * Type)) (rest :: {(Type * Type * Type)})
                               (acc : _ -> tr rest) [[nm] ~ rest] r =>
                  f [nm] [t] [rest] r.nm (acc (r -- nm)))
@@ -102,7 +92,7 @@ fun foldTR2 (tf1 :: Type -> Type) (tf2 :: Type -> Type) (tr :: {Type} -> Type)
                  -> fn [[nm] ~ rest] =>
                        tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest))
             (i : tr []) =
-    fold [fn r :: {Type} => $(mapTT tf1 r) -> $(mapTT tf2 r) -> tr r]
+    fold [fn r :: {Type} => $(map tf1 r) -> $(map tf2 r) -> tr r]
              (fn (nm :: Name) (t :: Type) (rest :: {Type})
                               (acc : _ -> _ -> tr rest) [[nm] ~ rest] r1 r2 =>
                  f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
@@ -114,7 +104,7 @@ fun foldT2R2 (tf1 :: (Type * Type) -> Type) (tf2 :: (Type * Type) -> Type)
                   -> fn [[nm] ~ rest] =>
                         tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest))
              (i : tr []) =
-    fold [fn r :: {(Type * Type)} => $(mapT2T tf1 r) -> $(mapT2T tf2 r) -> tr r]
+    fold [fn r :: {(Type * Type)} => $(map tf1 r) -> $(map tf2 r) -> tr r]
              (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
                               (acc : _ -> _ -> tr rest) [[nm] ~ rest] r1 r2 =>
                  f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
@@ -126,7 +116,7 @@ fun foldT3R2 (tf1 :: (Type * Type * Type) -> Type) (tf2 :: (Type * Type * Type)
                   -> fn [[nm] ~ rest] =>
                         tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest))
              (i : tr []) =
-    fold [fn r :: {(Type * Type * Type)} => $(mapT3T tf1 r) -> $(mapT3T tf2 r) -> tr r]
+    fold [fn r :: {(Type * Type * Type)} => $(map tf1 r) -> $(map tf2 r) -> tr r]
              (fn (nm :: Name) (t :: (Type * Type * Type)) (rest :: {(Type * Type * Type)})
                               (acc : _ -> _ -> tr rest) [[nm] ~ rest] r1 r2 =>
                  f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
@@ -195,8 +185,7 @@ fun foldT3RX2 (tf1 :: (Type * Type * Type) -> Type) (tf2 :: (Type * Type * Type)
 
 fun queryX (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit})
            (q : sql_query tables exps) [tables ~ exps]
-           (f : $(exps ++ fold (fn nm (fields :: {Type}) acc [[nm] ~ acc] =>
-                                   [nm = $fields] ++ acc) [] tables)
+           (f : $(exps ++ map (fn fields :: {Type} => $fields) tables)
                 -> xml ctx [] []) =
     query q
           (fn fs acc => return <xml>{acc}{f fs}</xml>)
@@ -204,8 +193,7 @@ fun queryX (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit})
 
 fun queryX' (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit})
             (q : sql_query tables exps) [tables ~ exps]
-            (f : $(exps ++ fold (fn nm (fields :: {Type}) acc [[nm] ~ acc] =>
-                                    [nm = $fields] ++ acc) [] tables)
+            (f : $(exps ++ map (fn fields :: {Type} => $fields) tables)
                  -> transaction (xml ctx [] [])) =
     query q
           (fn fs acc =>
diff --git a/lib/ur/top.urs b/lib/ur/top.urs
index d6315b92..49aad50c 100644
--- a/lib/ur/top.urs
+++ b/lib/ur/top.urs
@@ -8,17 +8,7 @@ con fstTTT = fn t :: (Type * Type * Type) => t.1
 con sndTTT = fn t :: (Type * Type * Type) => t.2
 con thdTTT = fn t :: (Type * Type * Type) => t.3
 
-con mapTT = fn f :: Type -> Type => fold (fn nm t acc [[nm] ~ acc] =>
-                                             [nm = f t] ++ acc) []
-
-con mapUT = fn f :: Type => fold (fn nm t acc [[nm] ~ acc] =>
-                                     [nm = f] ++ acc) []
-
-con mapT2T = fn f :: (Type * Type) -> Type => fold (fn nm t acc [[nm] ~ acc] =>
-                                                       [nm = f t] ++ acc) []
-
-con mapT3T = fn f :: (Type * Type * Type) -> Type => fold (fn nm t acc [[nm] ~ acc] =>
-                                                              [nm = f t] ++ acc) []
+con mapUT = fn f :: Type => map (fn _ :: Unit => f)
 
 con ex = fn tf :: (Type -> Type) =>
             res ::: Type -> (choice :: Type -> tf choice -> res) -> res
@@ -53,19 +43,19 @@ val foldTR : tf :: (Type -> Type) -> tr :: ({Type} -> Type)
              -> (nm :: Name -> t :: Type -> rest :: {Type}
                  -> fn [[nm] ~ rest] =>
                        tf t -> tr rest -> tr ([nm = t] ++ rest))
-             -> tr [] -> r :: {Type} -> $(mapTT tf r) -> tr r
+             -> tr [] -> r :: {Type} -> $(map tf r) -> tr r
 
 val foldT2R : tf :: ((Type * Type) -> Type) -> tr :: ({(Type * Type)} -> Type)
               -> (nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)}
                   -> fn [[nm] ~ rest] =>
                         tf t -> tr rest -> tr ([nm = t] ++ rest))
-              -> tr [] -> r :: {(Type * Type)} -> $(mapT2T tf r) -> tr r
+              -> tr [] -> r :: {(Type * Type)} -> $(map tf r) -> tr r
 
 val foldT3R : tf :: ((Type * Type * Type) -> Type) -> tr :: ({(Type * Type * Type)} -> Type)
               -> (nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)}
                   -> fn [[nm] ~ rest] =>
                         tf t -> tr rest -> tr ([nm = t] ++ rest))
-              -> tr [] -> r :: {(Type * Type * Type)} -> $(mapT3T tf r) -> tr r
+              -> tr [] -> r :: {(Type * Type * Type)} -> $(map tf r) -> tr r
 
 val foldTR2 : tf1 :: (Type -> Type) -> tf2 :: (Type -> Type)
               -> tr :: ({Type} -> Type)
@@ -73,7 +63,7 @@ val foldTR2 : tf1 :: (Type -> Type) -> tf2 :: (Type -> Type)
                   -> fn [[nm] ~ rest] =>
                         tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest))
               -> tr []
-              -> r :: {Type} -> $(mapTT tf1 r) -> $(mapTT tf2 r) -> tr r
+              -> r :: {Type} -> $(map tf1 r) -> $(map tf2 r) -> tr r
                                                                     
 val foldT2R2 : tf1 :: ((Type * Type) -> Type) -> tf2 :: ((Type * Type) -> Type)
                -> tr :: ({(Type * Type)} -> Type)
@@ -81,7 +71,7 @@ val foldT2R2 : tf1 :: ((Type * Type) -> Type) -> tf2 :: ((Type * Type) -> Type)
                    -> fn [[nm] ~ rest] =>
                          tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest))
                -> tr [] -> r :: {(Type * Type)}
-               -> $(mapT2T tf1 r) -> $(mapT2T tf2 r) -> tr r
+               -> $(map tf1 r) -> $(map tf2 r) -> tr r
 
 val foldT3R2 : tf1 :: ((Type * Type * Type) -> Type) -> tf2 :: ((Type * Type * Type) -> Type)
                -> tr :: ({(Type * Type * Type)} -> Type)
@@ -89,32 +79,32 @@ val foldT3R2 : tf1 :: ((Type * Type * Type) -> Type) -> tf2 :: ((Type * Type * T
                    -> fn [[nm] ~ rest] =>
                          tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest))
                -> tr [] -> r :: {(Type * Type * Type)}
-               -> $(mapT3T tf1 r) -> $(mapT3T tf2 r) -> tr r
+               -> $(map tf1 r) -> $(map tf2 r) -> tr r
 
 val foldTRX : tf :: (Type -> Type) -> ctx :: {Unit}
               -> (nm :: Name -> t :: Type -> rest :: {Type}
                   -> fn [[nm] ~ rest] =>
                         tf t -> xml ctx [] [])
-              -> r :: {Type} -> $(mapTT tf r) -> xml ctx [] []
+              -> r :: {Type} -> $(map tf r) -> xml ctx [] []
 
 val foldT2RX : tf :: ((Type * Type) -> Type) -> ctx :: {Unit}
                -> (nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)}
                    -> fn [[nm] ~ rest] =>
                          tf t -> xml ctx [] [])
-               -> r :: {(Type * Type)} -> $(mapT2T tf r) -> xml ctx [] []
+               -> r :: {(Type * Type)} -> $(map tf r) -> xml ctx [] []
 
 val foldT3RX : tf :: ((Type * Type * Type) -> Type) -> ctx :: {Unit}
                -> (nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)}
                    -> fn [[nm] ~ rest] =>
                          tf t -> xml ctx [] [])
-               -> r :: {(Type * Type * Type)} -> $(mapT3T tf r) -> xml ctx [] []
+               -> r :: {(Type * Type * Type)} -> $(map tf r) -> xml ctx [] []
 
 val foldTRX2 : tf1 :: (Type -> Type) -> tf2 :: (Type -> Type) -> ctx :: {Unit}
                -> (nm :: Name -> t :: Type -> rest :: {Type}
                    -> fn [[nm] ~ rest] =>
                          tf1 t -> tf2 t -> xml ctx [] [])
                -> r :: {Type}
-               -> $(mapTT tf1 r) -> $(mapTT tf2 r) -> xml ctx [] []
+               -> $(map tf1 r) -> $(map tf2 r) -> xml ctx [] []
 
 val foldT2RX2 : tf1 :: ((Type * Type) -> Type) -> tf2 :: ((Type * Type) -> Type)
                 -> ctx :: {Unit}
@@ -122,7 +112,7 @@ val foldT2RX2 : tf1 :: ((Type * Type) -> Type) -> tf2 :: ((Type * Type) -> Type)
                     -> fn [[nm] ~ rest] =>
                           tf1 t -> tf2 t -> xml ctx [] [])
                 -> r :: {(Type * Type)}
-                -> $(mapT2T tf1 r) -> $(mapT2T tf2 r) -> xml ctx [] []
+                -> $(map tf1 r) -> $(map tf2 r) -> xml ctx [] []
 
 
 val foldT3RX2 : tf1 :: ((Type * Type * Type) -> Type) -> tf2 :: ((Type * Type * Type) -> Type)
@@ -131,21 +121,19 @@ val foldT3RX2 : tf1 :: ((Type * Type * Type) -> Type) -> tf2 :: ((Type * Type *
                     -> fn [[nm] ~ rest] =>
                           tf1 t -> tf2 t -> xml ctx [] [])
                 -> r :: {(Type * Type * Type)}
-                -> $(mapT3T tf1 r) -> $(mapT3T tf2 r) -> xml ctx [] []
+                -> $(map tf1 r) -> $(map tf2 r) -> xml ctx [] []
 
 val queryX : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit}
              -> sql_query tables exps
              -> fn [tables ~ exps] =>
-                   ($(exps ++ fold (fn nm (fields :: {Type}) acc [[nm] ~ acc] =>
-                                       [nm = $fields] ++ acc) [] tables)
+                   ($(exps ++ map (fn fields :: {Type} => $fields) tables)
                     -> xml ctx [] [])
                    -> transaction (xml ctx [] [])
 
 val queryX' : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit}
               -> sql_query tables exps
               -> fn [tables ~ exps] =>
-                    ($(exps ++ fold (fn nm (fields :: {Type}) acc [[nm] ~ acc] =>
-                                        [nm = $fields] ++ acc) [] tables)
+                    ($(exps ++ map (fn fields :: {Type} => $fields) tables)
                      -> transaction (xml ctx [] []))
                     -> transaction (xml ctx [] [])
                        
@@ -155,20 +143,14 @@ val oneOrNoRows : tables ::: {{Type}} -> exps ::: {Type}
                         transaction
                             (option
                                  $(exps
-                                       ++ fold (fn nm (fields :: {Type}) acc
-                                                      [[nm] ~ acc] =>
-                                                   [nm = $fields] ++ acc)
-                                                   [] tables))
+                                       ++ map (fn fields :: {Type} => $fields) tables))
 
 val oneRow : tables ::: {{Type}} -> exps ::: {Type}
              -> sql_query tables exps
              -> fn [tables ~ exps] =>
                    transaction
                        $(exps
-                             ++ fold (fn nm (fields :: {Type}) acc
-                                            [[nm] ~ acc] =>
-                                         [nm = $fields] ++ acc)
-                                         [] tables)
+                             ++ map (fn fields :: {Type} => $fields) tables)
 
 val eqNullable : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
                  -> t ::: Type -> sql_injectable (option t)
diff --git a/src/core.sml b/src/core.sml
index c6e0cfef..d7a57493 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -54,7 +54,7 @@ datatype con' =
 
        | CRecord of kind * (con * con) list
        | CConcat of con * con
-       | CFold of kind * kind
+       | CMap of kind * kind
 
        | CUnit
 
diff --git a/src/core_print.sml b/src/core_print.sml
index 405ae14e..db8c3907 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -138,7 +138,7 @@ fun p_con' par env (c, _) =
                                               string "++",
                                               space,
                                               p_con env c2])
-      | CFold _ => string "fold"
+      | CMap _ => string "map"
       | CUnit => string "()"
 
       | CTuple cs => box [string "(",
diff --git a/src/core_util.sml b/src/core_util.sml
index a222dca4..e76da387 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -178,11 +178,11 @@ fun compare ((c1, _), (c2, _)) =
       | (CConcat _, _) => LESS
       | (_, CConcat _) => GREATER
 
-      | (CFold (d1, r1), CFold (d2, r2)) =>
+      | (CMap (d1, r1), CMap (d2, r2)) =>
         join (Kind.compare (d1, r2),
               fn () => Kind.compare (r1, r2))
-      | (CFold _, _) => LESS
-      | (_, CFold _) => GREATER
+      | (CMap _, _) => LESS
+      | (_, CMap _) => GREATER
 
       | (CUnit, CUnit) => EQUAL
       | (CUnit, _) => LESS
@@ -261,12 +261,12 @@ fun mapfoldB {kind = fk, con = fc, bind} =
                          S.map2 (mfc ctx c2,
                               fn c2' =>
                                  (CConcat (c1', c2'), loc)))
-              | CFold (k1, k2) =>
+              | CMap (k1, k2) =>
                 S.bind2 (mfk k1,
                          fn k1' =>
                             S.map2 (mfk k2,
                                     fn k2' =>
-                                       (CFold (k1', k2'), loc)))
+                                       (CMap (k1', k2'), loc)))
 
               | CUnit => S.return2 cAll
 
diff --git a/src/corify.sml b/src/corify.sml
index 2383ee03..c464e5a5 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -473,7 +473,7 @@ fun corifyCon st (c, loc) =
       | L.CRecord (k, xcs) =>
         (L'.CRecord (corifyKind k, map (fn (c1, c2) => (corifyCon st c1, corifyCon st c2)) xcs), loc)
       | L.CConcat (c1, c2) => (L'.CConcat (corifyCon st c1, corifyCon st c2), loc)
-      | L.CFold (k1, k2) => (L'.CFold (corifyKind k1, corifyKind k2), loc)
+      | L.CMap (k1, k2) => (L'.CMap (corifyKind k1, corifyKind k2), loc)
       | L.CUnit => (L'.CUnit, loc)
 
       | L.CTuple cs => (L'.CTuple (map (corifyCon st) cs), loc)
diff --git a/src/disjoint.sml b/src/disjoint.sml
index c6a8d50f..81023972 100644
--- a/src/disjoint.sml
+++ b/src/disjoint.sml
@@ -213,37 +213,8 @@ fun decomposeRow (env, denv) c =
                                                 ("c'", ElabPrint.p_con env (#1 (hnormCon (env, denv) c)))];*)
                 case #1 (#1 (hnormCon (env, denv) c)) of
                     CApp (
-                    (CApp (
-                     (CApp ((CFold (dom, ran), _), f), _),
-                     i), _),
-                    r) =>
-                    let
-                        val (env', nm) = E.pushCNamed env "nm" (KName, loc) NONE
-                        val (env', v) = E.pushCNamed env' "v" dom NONE
-                        val (env', st) = E.pushCNamed env' "st" ran NONE
-
-                        val (denv', gs') = assert env' denv ((CRecord (dom, [((CNamed nm, loc),
-                                                                              (CUnit, loc))]), loc),
-                                                             (CNamed st, loc))
-
-                        val c' = (CApp (f, (CNamed nm, loc)), loc)
-                        val c' = (CApp (c', (CNamed v, loc)), loc)
-                        val c' = (CApp (c', (CNamed st, loc)), loc)
-                        val (ps, gs'') = decomposeRow (env', denv') c'
-
-                        fun covered p =
-                            case p of
-                                Unknown _ => false
-                              | Piece p =>
-                                case p of
-                                    (NameN n, []) => n = nm
-                                  | (RowN n, []) => n = st
-                                  | _ => false
-
-                        val ps = List.filter (not o covered) ps
-                    in
-                        decomposeRow' (i, decomposeRow' (r, (ps @ acc, gs'' @ gs' @ gs)))
-                    end
+                    (CApp ((CMap _, _), _), _),
+                    r) => decomposeRow' (r, (acc, gs))
                   | _ => default ()
             end
     in
diff --git a/src/elab.sml b/src/elab.sml
index 8e44c43c..ec8a910a 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -66,7 +66,7 @@ datatype con' =
 
        | CRecord of kind * (con * con) list
        | CConcat of con * con
-       | CFold of kind * kind
+       | CMap of kind * kind
 
        | CUnit
 
diff --git a/src/elab_ops.sml b/src/elab_ops.sml
index 0648d704..c3e9274c 100644
--- a/src/elab_ops.sml
+++ b/src/elab_ops.sml
@@ -114,181 +114,98 @@ fun hnormCon env (cAll as (c, loc)) =
                                           ("sc", ElabPrint.p_con env sc)];*)
                  sc
              end
-           | c1' as CApp (c', i) =>
+           | c1' as CApp (c', f) =>
              let
                  fun default () = (CApp ((c1', loc), hnormCon env c2), loc)
              in
                  case #1 (hnormCon env c') of
-                     CApp (c', f) =>
-                     (case #1 (hnormCon env c') of
-                          CFold ks =>
-                          (case #1 (hnormCon env c2) of
-                               CRecord (_, []) => hnormCon env i
-                             | CRecord (k, (x, c) :: rest) =>
-                               hnormCon env
-                                        (CApp ((CApp ((CApp (f, x), loc), c), loc),
-                                               (CApp ((CApp ((CApp ((CFold ks, loc), f), loc), i), loc),
-                                                      (CRecord (k, rest), loc)), loc)), loc)
-                             | CConcat ((CRecord (k, (x, c) :: rest), _), rest') =>
-                               let
-                                   val rest'' = (CConcat ((CRecord (k, rest), loc), rest'), loc)
-
-                               (*val ccc = (CApp ((CApp ((CApp (f, x), loc), c), loc),
-                                                  (CApp ((CApp ((CApp ((CFold ks, loc), f), loc), i), loc),
-                                                         rest''), loc)), loc)*)
-                               in
-                                   (*eprefaces "Red to" [("ccc", p_con env ccc), ("ccc'", p_con env (hnormCon env ccc))];*)
-                                   hnormCon env
-                                            (CApp ((CApp ((CApp (f, x), loc), c), loc),
-                                                   (CApp ((CApp ((CApp ((CFold ks, loc), f), loc), i), loc),
-                                                          rest''), loc)), loc)
-                               end
-                             | _ =>
-                               let
-                                   fun cunif () =
-                                       let
-                                           val r = ref NONE
-                                       in
-                                           (r, (CUnif (loc, (KType, loc), "_", r), loc))
-                                       end
-
-                                   val (nmR, nm) = cunif ()
-                                   val (vR, v) = cunif ()
-                                   val (rR, r) = cunif ()
-
-                                   val c = f
-                                   val c = (CApp (c, nm), loc)
-                                   val c = (CApp (c, v), loc)
-                                   val c = (CApp (c, r), loc)
-                                   fun unconstraint c =
-                                       case hnormCon env c of
-                                           (CDisjoint (_, _, _, c), _) => unconstraint c
-                                         | c => c
-                                   val c = unconstraint c
-
-                                   fun tryDistributivity () =
-                                       let
-                                           fun distribute (c1, c2) =
-                                               let
-                                                   val c = (CFold ks, loc)
-                                                   val c = (CApp (c, f), loc)
-                                                   val c = (CApp (c, i), loc)
-
-                                                   val c1 = (CApp (c, c1), loc)
-                                                   val c2 = (CApp (c, c2), loc)
-                                                   val c = (CConcat (c1, c2), loc)
-                                               in
-                                                   hnormCon env c
-                                               end
-                                       in
-                                           case (hnormCon env i, hnormCon env c2, hnormCon env c) of
-                                               ((CRecord (_, []), _),
-                                                (CConcat (arg1, arg2), _),
-                                                (CConcat (c1, c2'), _)) =>
-                                               (case (hnormCon env c1, hnormCon env c2') of
-                                                    ((CRecord (_, [(nm', v')]), _),
-                                                     (CUnif (_, _, _, rR'), _)) =>
-                                                    (case hnormCon env nm' of
-                                                         (CUnif (_, _, _, nmR'), _) =>
-                                                         if nmR' = nmR andalso rR' = rR then
-                                                             distribute (arg1, arg2)
-                                                         else
-                                                             default ()
-                                                       | _ => default ())
-                                                  | _ => default ())
-                                             | _ => default ()
-                                       end
-
-                                   fun tryFusion () =
-                                       let
-                                           fun fuse (dom, new_v, r') =
-                                               let
-                                                   val ran = #2 ks
-
-                                                   val f = (CApp (f, (CRel 2, loc)), loc)
-                                                   val f = (CApp (f, new_v), loc)
-                                                   val f = (CApp (f, (CRel 0, loc)), loc)
-                                                   val f = (CAbs ("acc", ran, f), loc)
-                                                   val f = (CAbs ("v", dom, f), loc)
-                                                   val f = (CAbs ("nm", (KName, loc), f), loc)
-
-                                                   val c = (CFold (dom, ran), loc)
-                                                   val c = (CApp (c, f), loc)
-                                                   val c = (CApp (c, i), loc)
-                                                   val c = (CApp (c, r'), loc)
-                                               in
-                                                   hnormCon env c
-                                               end
-                                       in
-                                           case #1 (hnormCon env c2) of
-                                               CApp (f, r') =>
-                                               (case #1 (hnormCon env f) of
-                                                    CApp (f, inner_i) =>
-                                                    (case (#1 (hnormCon env f), #1 (hnormCon env inner_i)) of
-                                                         (CApp (f, inner_f), CRecord (_, [])) =>
-                                                         (case #1 (hnormCon env f) of
-                                                              CFold (dom, _) =>
-                                                              let
-                                                                  val c = inner_f
-                                                                  val c = (CApp (c, nm), loc)
-                                                                  val c = (CApp (c, v), loc)
-                                                                  val c = (CApp (c, r), loc)
-                                                                  val c = unconstraint c
-
-                                                                  (*val () = Print.prefaces "Onto something!"
-                                                                           [("c", ElabPrint.p_con env cAll),
-                                                                            ("c'", ElabPrint.p_con env c)]*)
-
-                                                              in
-                                                                  case #1 (hnormCon env c) of
-                                                                      CConcat (first, rest) =>
-                                                                      (case (#1 (hnormCon env first),
-                                                                             #1 (hnormCon env rest)) of
-                                                                           (CRecord (_, [(nm', v')]),
-                                                                            CUnif (_, _, _, rR')) =>
-                                                                           (case #1 (hnormCon env nm') of
-                                                                                CUnif (_, _, _, nmR') =>
-                                                                                if rR' = rR andalso nmR' = nmR then
-                                                                                    (nmR := SOME (CRel 2, loc);
-                                                                                     vR := SOME (CRel 1, loc);
-                                                                                     rR := SOME (CError, loc);
-                                                                                     fuse (dom, v', r'))
-                                                                                else
-                                                                                    tryDistributivity ()
-                                                                              | _ => tryDistributivity ())
-                                                                         | _ => tryDistributivity ())
-                                                                    | _ => tryDistributivity ()
-                                                              end
-                                                            | _ => tryDistributivity ())
-                                                       | _ => tryDistributivity ())
-                                                  | _ => tryDistributivity ())
-                                             | _ => tryDistributivity ()
-                                       end
-
-                               in
-                                   (*Print.prefaces "Consider" [("c", ElabPrint.p_con env c)];*)
-                                   case (hnormCon env i, unconstraint c) of
-                                       ((CRecord (_, []), _),
-                                        (CConcat (c1, c2'), _)) =>
-                                       (case (hnormCon env c1, hnormCon env c2') of
-                                            ((CRecord (_, [(nm', v')]), _),
-                                             (CUnif (_, _, _, rR'), _)) =>
-                                            (case (hnormCon env nm', hnormCon env v') of
-                                                 ((CUnif (_, _, _, nmR'), _),
-                                                  (CUnif (_, _, _, vR'), _)) =>
-                                                 if nmR' = nmR andalso vR' = vR andalso rR' = rR then
-                                                     hnormCon env c2
-                                                 else
-                                                     tryFusion ()
-                                               | _ => tryFusion ())
-                                          | _ => tryFusion ())
-                                     | _ => tryFusion ()
-                               end)
-                        | _ => default ())
+                     CMap (ks as (k1, k2)) =>
+                     (case #1 (hnormCon env c2) of
+                          CRecord (_, []) => (CRecord (k2, []), loc)
+                        | CRecord (_, (x, c) :: rest) =>
+                          hnormCon env
+                                   (CConcat ((CRecord (k2, [(x, (CApp (f, c), loc))]), loc),
+                                             (CApp (c1, (CRecord (k2, rest), loc)), loc)), loc)
+                        | CConcat ((CRecord (k, (x, c) :: rest), _), rest') =>
+                          let
+                              val rest'' = (CConcat ((CRecord (k, rest), loc), rest'), loc)
+                          in
+                              hnormCon env
+                                       (CConcat ((CRecord (k2, [(x, (CApp (f, c), loc))]), loc),
+                                                 (CApp (c1, rest''), loc)), loc)
+                          end
+                        | _ =>
+                          let
+                              fun unconstraint c =
+                                  case hnormCon env c of
+                                      (CDisjoint (_, _, _, c), _) => unconstraint c
+                                    | c => c
+
+                              fun tryDistributivity () =
+                                  case hnormCon env c2 of
+                                      (CConcat (c1, c2'), _) =>
+                                      let
+                                          val c = (CMap ks, loc)
+                                          val c = (CApp (c, f), loc)
+                                                  
+                                          val c1 = (CApp (c, c1), loc)
+                                          val c2 = (CApp (c, c2'), loc)
+                                          val c = (CConcat (c1, c2), loc)
+                                      in
+                                          hnormCon env c
+                                      end
+                                    | _ => default ()
+
+                              fun tryFusion () =
+                                  case #1 (hnormCon env c2) of
+                                      CApp (f', r') =>
+                                      (case #1 (hnormCon env f') of
+                                           CApp (f', inner_f) =>
+                                           (case #1 (hnormCon env f') of
+                                                CMap (dom, _) =>
+                                                let
+                                                    val f' = (CApp (inner_f, (CRel 0, loc)), loc)
+                                                    val f' = (CApp (f, f'), loc)
+                                                    val f' = (CAbs ("v", dom, f'), loc)
+
+                                                    val c = (CMap (dom, k2), loc)
+                                                    val c = (CApp (c, f'), loc)
+                                                    val c = (CApp (c, r'), loc)
+                                                in
+                                                    hnormCon env c
+                                                end
+                                              | _ => tryDistributivity ())
+                                         | _ => tryDistributivity ())
+                                    | _ => tryDistributivity ()
+
+                              fun tryIdentity () =
+                                  let
+                                      fun cunif () =
+                                          let
+                                              val r = ref NONE
+                                          in
+                                              (r, (CUnif (loc, (KType, loc), "_", r), loc))
+                                          end
+                                          
+                                      val (vR, v) = cunif ()
+
+                                      val c = (CApp (f, v), loc)
+                                  in
+                                      case unconstraint c of
+                                          (CUnif (_, _, _, vR'), _) =>
+                                          if vR' = vR then
+                                              hnormCon env c2
+                                          else
+                                              tryFusion ()
+                                        | _ => tryFusion ()
+                                  end
+                          in
+                              tryIdentity ()
+                          end)
                    | _ => default ()
              end
            | c1' => (CApp ((c1', loc), hnormCon env c2), loc))
-
+        
       | CConcat (c1, c2) =>
         (case (hnormCon env c1, hnormCon env c2) of
              ((CRecord (k, xcs1), loc), (CRecord (_, xcs2), _)) =>
diff --git a/src/elab_print.sml b/src/elab_print.sml
index 0e6c9767..098c9259 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -167,7 +167,7 @@ fun p_con' par env (c, _) =
                                               string "++",
                                               space,
                                               p_con env c2])
-      | CFold _ => string "fold"
+      | CMap _ => string "map"
 
       | CUnit => string "()"
 
diff --git a/src/elab_util.sml b/src/elab_util.sml
index 6e78907d..f052a06d 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -168,12 +168,12 @@ fun mapfoldB {kind = fk, con = fc, bind} =
                          S.map2 (mfc ctx c2,
                               fn c2' =>
                                  (CConcat (c1', c2'), loc)))
-              | CFold (k1, k2) =>
+              | CMap (k1, k2) =>
                 S.bind2 (mfk k1,
                          fn k1' =>
                             S.map2 (mfk k2,
                                     fn k2' =>
-                                       (CFold (k1', k2'), loc)))
+                                       (CMap (k1', k2'), loc)))
 
               | CUnit => S.return2 cAll
 
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 39cb85b2..fa97bdf8 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -182,13 +182,10 @@
        | L.KTuple ks => (L'.KTuple (map elabKind ks), loc)
        | L.KWild => kunif loc
 
- fun foldKind (dom, ran, loc)=
-     (L'.KArrow ((L'.KArrow ((L'.KName, loc),
-                             (L'.KArrow (dom,
-                                         (L'.KArrow (ran, ran), loc)), loc)), loc),
-                 (L'.KArrow (ran,
-                             (L'.KArrow ((L'.KRecord dom, loc),
-                                         ran), loc)), loc)), loc)
+ fun mapKind (dom, ran, loc)=
+     (L'.KArrow ((L'.KArrow (dom, ran), loc),
+                 (L'.KArrow ((L'.KRecord dom, loc),
+                             (L'.KRecord ran, loc)), loc)), loc)
 
  fun hnormKind (kAll as (k, _)) =
      case k of
@@ -355,13 +352,13 @@
              ((L'.CConcat (c1', c2'), loc), k,
               D.prove env denv (c1', c2', loc) @ gs1 @ gs2)
          end
-       | L.CFold =>
+       | L.CMap =>
          let
              val dom = kunif loc
              val ran = kunif loc
          in
-             ((L'.CFold (dom, ran), loc),
-              foldKind (dom, ran, loc),
+             ((L'.CMap (dom, ran), loc),
+              mapKind (dom, ran, loc),
               [])
          end
 
@@ -489,7 +486,7 @@
 
        | L'.CRecord (k, _) => (L'.KRecord k, loc)
        | L'.CConcat (c, _) => kindof env c
-       | L'.CFold (dom, ran) => foldKind (dom, ran, loc)
+       | L'.CMap (dom, ran) => mapKind (dom, ran, loc)
 
        | L'.CUnit => (L'.KUnit, loc)
 
@@ -504,41 +501,21 @@
 
  val hnormCon = D.hnormCon
 
- datatype con_summary =
-          Nil
-        | Cons
-        | Unknown
-
- fun compatible cs =
-     case cs of
-         (Unknown, _) => false
-       | (_, Unknown) => false
-       | (s1, s2) => s1 = s2
-
- fun summarizeCon (env, denv) c =
+ fun deConstraintCon (env, denv) c =
      let
          val (c, gs) = hnormCon (env, denv) c
      in
          case #1 c of
-             L'.CRecord (_, []) => (Nil, gs)
-           | L'.CRecord (_, _ :: _) => (Cons, gs)
-           | L'.CConcat ((L'.CRecord (_, _ :: _), _), _) => (Cons, gs)
-           | L'.CDisjoint (_, _, _, c) =>
+             L'.CDisjoint (_, _, _, c) =>
              let
-                 val (s, gs') = summarizeCon (env, denv) c
+                 val (c', gs') = deConstraintCon (env, denv) c
              in
-                 (s, gs @ gs')
+                 (c', gs @ gs')
              end
-           | _ => (Unknown, gs)
+           | _ => (c, gs)
      end
 
- fun p_con_summary s =
-     Print.PD.string (case s of
-                          Nil => "Nil"
-                        | Cons => "Cons"
-                        | Unknown => "Unknown")
-
- exception SummaryFailure
+ exception GuessFailure
 
  fun isUnitCon env (c, loc) =
      case c of
@@ -574,7 +551,7 @@
 
        | L'.CRecord _ => false
        | L'.CConcat _ => false
-       | L'.CFold _ => false
+       | L'.CMap _ => false
 
        | L'.CUnit => true
 
@@ -720,14 +697,14 @@
 
          fun isGuessable (other, fs) =
              let
-                 val gs = guessFold (env, denv) (other, (L'.CRecord (k, fs), loc), [], SummaryFailure)
+                 val gs = guessMap (env, denv) (other, (L'.CRecord (k, fs), loc), [], GuessFailure)
              in
                  List.all (fn (loc, env, denv, c1, c2) =>
                               case D.prove env denv (c1, c2, loc) of
                                   [] => true
                                 | _ => false) gs
              end
-             handle SummaryFailure => false
+             handle GuessFailure => false
 
          val (fs1, fs2, others1, others2) =
              case (fs1, fs2, others1, others2) of
@@ -783,79 +760,68 @@
                                        ("#2", p_summary env s2)]*)
      end
 
- and guessFold (env, denv) (c1, c2, gs, ex) =
+ and guessMap (env, denv) (c1, c2, gs, ex) =
      let
          val loc = #2 c1
 
-         fun unfold (dom, ran, f, i, r, c) =
+         fun unfold (dom, ran, f, r, c) =
              let
-                 val nm = cunif (loc, (L'.KName, loc))
-                 val v =
-                     case dom of
-                         (L'.KUnit, _) => (L'.CUnit, loc)
-                       | _ => cunif (loc, dom)
-                 val rest = cunif (loc, (L'.KRecord dom, loc))
-                 val acc = (L'.CFold (dom, ran), loc)
-                 val acc = (L'.CApp (acc, f), loc)
-                 val acc = (L'.CApp (acc, i), loc)
-                 val acc = (L'.CApp (acc, rest), loc)
-
-                 val (iS, gs3) = summarizeCon (env, denv) i
-
-                 val app = (L'.CApp (f, nm), loc)
-                 val app = (L'.CApp (app, v), loc)
-                 val app = (L'.CApp (app, acc), loc)
-                 val (appS, gs4) = summarizeCon (env, denv) app
-
-                 val (cS, gs5) = summarizeCon (env, denv) c
-             in
-                 (*prefaces "Summaries" [("iS", p_con_summary iS),
-                                         ("appS", p_con_summary appS),
-                                         ("cS", p_con_summary cS)];*)
-
-                 if compatible (iS, appS) then
-                     raise ex
-                 else if compatible (cS, iS) then
+                 fun unfold (r, c) =
                      let
-                         (*val () = prefaces "Same?" [("i", p_con env i),
-                                                    ("c", p_con env c)]*)
-                         val gs6 = unifyCons (env, denv) i c
-                         (*val () = TextIO.print "Yes!\n"*)
-
-                         val gs7 = unifyCons (env, denv) r (L'.CRecord (dom, []), loc)
+                         val (c', gs1) = deConstraintCon (env, denv) c
                      in
-                         gs @ gs3 @ gs5 @ gs6 @ gs7
-                     end
-                 else if compatible (cS, appS) then
-                     let
-                         (*val () = prefaces "Same?" [("app", p_con env app),
-                                                      ("c", p_con env c),
-                                                      ("app'", p_con env (#1 (hnormCon (env, denv) app)))]*)
-                         val gs6 = unifyCons (env, denv) app c
-                         (*val () = TextIO.print "Yes!\n"*)
-
-                         val singleton = (L'.CRecord (dom, [(nm, v)]), loc)
-                         val concat = (L'.CConcat (singleton, rest), loc)
-                         (*val () = prefaces "Pre-crew" [("r", p_con env r),
-                                                         ("concat", p_con env concat)]*)
-                         val gs7 = unifyCons (env, denv) r concat
-                     in
-                         (*prefaces "The crew" [("nm", p_con env nm),
-                                                ("v", p_con env v),
-                                                ("rest", p_con env rest)];*)
+                         case #1 c' of
+                             L'.CRecord (_, []) =>
+                             let
+                                 val gs2 = unifyCons (env, denv) r (L'.CRecord (dom, []), loc)
+                             in
+                                 gs1 @ gs2
+                             end
+                           | L'.CRecord (_, [(x, v)]) =>
+                             let
+                                 val v' = case dom of
+                                              (L'.KUnit, _) => (L'.CUnit, loc)
+                                            | _ => cunif (loc, dom)
+                                 val gs2 = unifyCons (env, denv) v' (L'.CApp (f, v), loc)
 
-                         gs @ gs3 @ gs4 @ gs5 @ gs6 @ gs7
+                                 val gs3 = unifyCons (env, denv) r (L'.CRecord (dom, [(x, v')]), loc)
+                             in
+                                 gs1 @ gs2 @ gs3
+                             end
+                           | L'.CRecord (_, (x, v) :: rest) =>
+                             let
+                                 val r1 = cunif (loc, (L'.KRecord dom, loc))
+                                 val r2 = cunif (loc, (L'.KRecord dom, loc))
+                                 val gs2 = unifyCons (env, denv) r (L'.CConcat (r1, r2), loc)
+
+                                 val gs3 = unfold (r1, (L'.CRecord (ran, [(x, v)]), loc))
+                                 val gs4 = unfold (r2, (L'.CRecord (ran, rest), loc))
+                             in
+                                 gs1 @ gs2 @ gs3 @ gs4
+                             end
+                           | L'.CConcat (c1', c2') =>
+                             let
+                                 val r1 = cunif (loc, (L'.KRecord dom, loc))
+                                 val r2 = cunif (loc, (L'.KRecord dom, loc))
+                                 val gs2 = unifyCons (env, denv) r (L'.CConcat (r1, r2), loc)
+
+                                 val gs3 = unfold (r1, c1')
+                                 val gs4 = unfold (r2, c2')
+                             in
+                                 gs1 @ gs2 @ gs3 @ gs4
+                             end
+                           | _ => raise ex
                      end
-                 else
-                     raise ex
+             in
+                 unfold (r, c)
              end
              handle _ => raise ex
      in
          case (#1 c1, #1 c2) of
-             (L'.CApp ((L'.CApp ((L'.CApp ((L'.CFold (dom, ran), _), f), _), i), _), r), _) =>
-             unfold (dom, ran, f, i, r, c2)
-           | (_, L'.CApp ((L'.CApp ((L'.CApp ((L'.CFold (dom, ran), _), f), _), i), _), r)) =>
-             unfold (dom, ran, f, i, r, c1)
+             (L'.CApp ((L'.CApp ((L'.CMap (dom, ran), _), f), _), r), _) =>
+             unfold (dom, ran, f, r, c2)
+           | (_, L'.CApp ((L'.CApp ((L'.CMap (dom, ran), _), f), _), r)) =>
+             unfold (dom, ran, f, r, c1)
            | _ => raise ex
      end
 
@@ -890,7 +856,7 @@
                                                                                  (Time.- (Time.now (), befor)))))];*)
                      gs1 @ gs2 @ gs3
                  end
-                 handle ex => guessFold (env, denv) (c1, c2, gs1 @ gs2, ex)
+                 handle ex => guessMap (env, denv) (c1, c2, gs1 @ gs2, ex)
              end
 
  and unifyCons'' (env, denv) (c1All as (c1, loc)) (c2All as (c2, _)) =
@@ -1017,7 +983,7 @@
                  (r := SOME c1All;
                   [])
 
-           | (L'.CFold (dom1, ran1), L'.CFold (dom2, ran2)) =>
+           | (L'.CMap (dom1, ran1), L'.CMap (dom2, ran2)) =>
              (unifyKinds dom1 dom2;
               unifyKinds ran1 ran2;
               [])
@@ -2740,7 +2706,7 @@ fun positive self =
 
               | CRecord xcs => List.all (fn (c1, c2) => none c1 andalso none c2) xcs
               | CConcat (c1, c2) => none c1 andalso none c2
-              | CFold => true
+              | CMap => true
 
               | CUnit => true
 
@@ -2766,7 +2732,7 @@ fun positive self =
 
               | CRecord xcs => List.all (fn (c1, c2) => none c1 andalso pos c2) xcs
               | CConcat (c1, c2) => pos c1 andalso pos c2
-              | CFold => true
+              | CMap => true
 
               | CUnit => true
 
diff --git a/src/elisp/urweb-defs.el b/src/elisp/urweb-defs.el
index 5551b7a2..e1382692 100644
--- a/src/elisp/urweb-defs.el
+++ b/src/elisp/urweb-defs.el
@@ -107,7 +107,7 @@ notion of \"the end of an outline\".")
                  "if" "then" "else" "case" "of" "fn" "fun" "val" "and"
                  "datatype" "type" "open" "include"
                  urweb-module-head-syms
-                 "con" "fold" "where" "extern" "constraint" "constraints"
+                 "con" "map" "where" "extern" "constraint" "constraints"
                  "table" "sequence" "class" "cookie")
   "Symbols starting an sexp.")
 
@@ -192,7 +192,7 @@ for all symbols and in all lines starting with the given symbol."
   "The starters of new expressions.")
 
 (defconst urweb-exptrail-syms
-  '("if" "then" "else" "case" "of" "fn" "with" "fold"))
+  '("if" "then" "else" "case" "of" "fn" "with" "map"))
 
 (defconst urweb-pipeheads
    '("|" "of" "fun" "fn" "and" "datatype")
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index 223006fc..e7615cc3 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -133,7 +133,7 @@ See doc for the variable `urweb-mode-info'."
 
 (defconst urweb-keywords-regexp
   (urweb-syms-re "and" "case" "class" "con" "constraint" "constraints"
-	       "datatype" "else" "end" "extern" "fn" "fold"
+	       "datatype" "else" "end" "extern" "fn" "map"
 	       "fun" "functor" "if" "include"
 	       "of" "open" "let" "in"
 	       "rec" "sequence" "sig" "signature" "cookie"
diff --git a/src/expl.sml b/src/expl.sml
index cce0fc22..c0d291b5 100644
--- a/src/expl.sml
+++ b/src/expl.sml
@@ -54,7 +54,7 @@ datatype con' =
 
        | CRecord of kind * (con * con) list
        | CConcat of con * con
-       | CFold of kind * kind
+       | CMap of kind * kind
 
        | CUnit
 
diff --git a/src/expl_print.sml b/src/expl_print.sml
index 2ce0c5e2..7044bfa2 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -149,7 +149,7 @@ fun p_con' par env (c, _) =
                                               string "++",
                                               space,
                                               p_con env c2])
-      | CFold _ => string "fold"
+      | CMap _ => string "map"
       | CUnit => string "()"
 
       | CTuple cs => box [string "(",
diff --git a/src/expl_util.sml b/src/expl_util.sml
index d2073a23..a2b5f2f6 100644
--- a/src/expl_util.sml
+++ b/src/expl_util.sml
@@ -145,12 +145,12 @@ fun mapfoldB {kind = fk, con = fc, bind} =
                          S.map2 (mfc ctx c2,
                               fn c2' =>
                                  (CConcat (c1', c2'), loc)))
-              | CFold (k1, k2) =>
+              | CMap (k1, k2) =>
                 S.bind2 (mfk k1,
                          fn k1' =>
                             S.map2 (mfk k2,
                                     fn k2' =>
-                                       (CFold (k1', k2'), loc)))
+                                       (CMap (k1', k2'), loc)))
 
               | CUnit => S.return2 cAll
 
diff --git a/src/explify.sml b/src/explify.sml
index a10037ef..a4eab0ba 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -63,7 +63,7 @@ fun explifyCon (c, loc) =
 
       | L.CRecord (k, xcs) => (L'.CRecord (explifyKind k, map (fn (c1, c2) => (explifyCon c1, explifyCon c2)) xcs), loc)
       | L.CConcat (c1, c2) => (L'.CConcat (explifyCon c1, explifyCon c2), loc)
-      | L.CFold (dom, ran) => (L'.CFold (explifyKind dom, explifyKind ran), loc)
+      | L.CMap (dom, ran) => (L'.CMap (explifyKind dom, explifyKind ran), loc)
 
       | L.CUnit => (L'.CUnit, loc)
 
diff --git a/src/monoize.sml b/src/monoize.sml
index 4efa2fea..898d3e61 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -206,7 +206,7 @@ fun monoType env =
 
                   | L.CRecord _ => poly ()
                   | L.CConcat _ => poly ()
-                  | L.CFold _ => poly ()
+                  | L.CMap _ => poly ()
                   | L.CUnit => poly ()
 
                   | L.CTuple _ => poly ()
diff --git a/src/reduce.sml b/src/reduce.sml
index b428c01f..949b2a6d 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -103,14 +103,13 @@ fun conAndExp (namedC, namedE) =
                         CAbs (_, _, b) =>
                         con (KnownC c2 :: deKnown env) b
 
-                      | CApp ((CApp ((CFold _, _), f), _), i) =>
+                      | CApp ((CMap (dom, ran), _), f) =>
                         (case #1 c2 of
-                             CRecord (_, []) => i
-                           | CRecord (k, (x, c) :: rest) =>
+                             CRecord (_, []) => (CRecord (ran, []), loc)
+                           | CRecord (_, (x, c) :: rest) =>
                              con (deKnown env)
-                                 (CApp ((CApp ((CApp (f, x), loc), c), loc),
-                                        (CApp (c1,
-                                               (CRecord (k, rest), loc)), loc)), loc)
+                                 (CConcat ((CRecord (ran, [(x, (CApp (f, c), loc))]), loc),
+                                           (CApp (c1, (CRecord (dom, rest), loc)), loc)), loc)
                            | _ => (CApp (c1, c2), loc))                           
 
                       | _ => (CApp (c1, c2), loc)
@@ -130,7 +129,7 @@ fun conAndExp (namedC, namedE) =
                         (CRecord (k, xcs1 @ xcs2), loc)
                       | _ => (CConcat (c1, c2), loc)
                 end
-              | CFold _ => all
+              | CMap _ => all
 
               | CUnit => all
 
diff --git a/src/source.sml b/src/source.sml
index a5c86f66..d70d0f5d 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -60,7 +60,7 @@ datatype con' =
 
        | CRecord of (con * con) list
        | CConcat of con * con
-       | CFold
+       | CMap
 
        | CUnit
 
diff --git a/src/source_print.sml b/src/source_print.sml
index d6568efe..148157c2 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -139,7 +139,7 @@ fun p_con' par (c, _) =
                                               string "++",
                                               space,
                                               p_con c2])
-      | CFold => string "fold"
+      | CMap => string "map"
 
       | CUnit => string "()"
 
diff --git a/src/urweb.grm b/src/urweb.grm
index 5f2c0575..d425caec 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -184,7 +184,7 @@ fun tagIn bt =
  | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
  | EQ | COMMA | COLON | DCOLON | TCOLON | DOT | HASH | UNDER | UNDERUNDER | BAR
  | PLUS | MINUS | DIVIDE | DOTDOTDOT | MOD | AT
- | CON | LTYPE | VAL | REC | AND | FUN | FOLD | UNIT | KUNIT | CLASS
+ | CON | LTYPE | VAL | REC | AND | FUN | MAP | FOLD | UNIT | KUNIT | CLASS
  | DATATYPE | OF
  | TYPE | NAME
  | ARROW | LARROW | DARROW | STAR | SEMI
@@ -681,7 +681,7 @@ cterm  : LPAREN cexp RPAREN             (#1 cexp, s (LPARENleft, RPARENright))
        | path DOT INT                   (CProj ((CVar path, s (pathleft, pathright)), Int64.toInt INT),
                                          s (pathleft, INTright))
        | UNDER                          (CWild (KWild, s (UNDERleft, UNDERright)), s (UNDERleft, UNDERright))
-       | FOLD                           (CFold, s (FOLDleft, FOLDright))
+       | MAP                            (CMap, s (MAPleft, MAPright))
        | UNIT                           (CUnit, s (UNITleft, UNITright))
        | LPAREN ctuplev RPAREN          (CTuple ctuplev, s (LPARENleft, RPARENright))
 
diff --git a/src/urweb.lex b/src/urweb.lex
index aef68ad1..29e07194 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -290,6 +290,7 @@ notags = [^<{\n]+;
 <INITIAL> "and"       => (Tokens.AND (pos yypos, pos yypos + size yytext));
 <INITIAL> "fun"       => (Tokens.FUN (pos yypos, pos yypos + size yytext));
 <INITIAL> "fn"        => (Tokens.FN (pos yypos, pos yypos + size yytext));
+<INITIAL> "map"       => (Tokens.MAP (pos yypos, pos yypos + size yytext));
 <INITIAL> "fold"      => (Tokens.FOLD (pos yypos, pos yypos + size yytext));
 <INITIAL> "case"      => (Tokens.CASE (pos yypos, pos yypos + size yytext));
 <INITIAL> "if"        => (Tokens.IF (pos yypos, pos yypos + size yytext));
-- 
cgit v1.2.3


From 85cf99a95c910841f197ca911bb13d044456de7f Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sun, 22 Feb 2009 16:10:25 -0500
Subject: Start of kind polymorphism, up to the point where demo/hello
 elaborates with updated Basis/Top

---
 lib/ur/top.ur        | 171 ++++++++++--------------------------
 lib/ur/top.urs       | 112 +++++++-----------------
 src/core.sml         |   1 -
 src/core_print.sml   |   1 -
 src/core_util.sml    |   8 --
 src/corify.sml       |   1 -
 src/elab.sml         |  11 ++-
 src/elab_env.sig     |   4 +
 src/elab_env.sml     | 130 ++++++++++++++++++++++++---
 src/elab_err.sig     |   7 +-
 src/elab_err.sml     |  61 +++++++------
 src/elab_ops.sig     |   6 ++
 src/elab_ops.sml     |  69 ++++++++++++++-
 src/elab_print.sig   |   2 +-
 src/elab_print.sml   |  95 +++++++++++++-------
 src/elab_util.sig    |  38 +++++---
 src/elab_util.sml    | 154 ++++++++++++++++++++------------
 src/elaborate.sml    | 241 +++++++++++++++++++++++++++++++++------------------
 src/expl.sml         |   1 -
 src/expl_print.sml   |   1 -
 src/expl_util.sml    |   4 -
 src/explify.sml      |   2 -
 src/monoize.sml      |   1 -
 src/reduce.sml       |  16 ----
 src/reduce_local.sml |   2 -
 src/source.sml       |   9 +-
 src/source_print.sml |  26 +++++-
 src/termination.sml  |   9 +-
 src/unnest.sml       |  18 ++--
 src/urweb.grm        |  23 +++--
 src/urweb.lex        |   3 +-
 31 files changed, 736 insertions(+), 491 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/lib/ur/top.ur b/lib/ur/top.ur
index 58e99f3c..9016fd27 100644
--- a/lib/ur/top.ur
+++ b/lib/ur/top.ur
@@ -1,3 +1,12 @@
+(** Row folding *)
+
+con folder = K ==> fn r :: {K} =>
+                      tf :: ({K} -> Type)
+                      -> (nm :: Name -> v :: K -> r :: {K} -> tf r
+                          -> fn [[nm] ~ r] => tf ([nm = v] ++ r))
+                      -> tf [] -> tf r
+
+
 fun not b = if b then False else True
 
 con idT (t :: Type) = t
@@ -27,23 +36,23 @@ fun foldUR (tf :: Type) (tr :: {Unit} -> Type)
            (f : nm :: Name -> rest :: {Unit}
                 -> fn [[nm] ~ rest] =>
                       tf -> tr rest -> tr ([nm] ++ rest))
-           (i : tr []) =
+           (i : tr []) (r ::: {Unit}) (fold : folder r)=
     fold [fn r :: {Unit} => $(mapUT tf r) -> tr r]
-             (fn (nm :: Name) (t :: Unit) (rest :: {Unit}) acc
-                              [[nm] ~ rest] r =>
-                 f [nm] [rest] r.nm (acc (r -- nm)))
-             (fn _ => i)
+         (fn (nm :: Name) (t :: Unit) (rest :: {Unit}) acc
+                          [[nm] ~ rest] r =>
+             f [nm] [rest] r.nm (acc (r -- nm)))
+         (fn _ => i)
 
 fun foldUR2 (tf1 :: Type) (tf2 :: Type) (tr :: {Unit} -> Type)
            (f : nm :: Name -> rest :: {Unit}
                 -> fn [[nm] ~ rest] =>
                       tf1 -> tf2 -> tr rest -> tr ([nm] ++ rest))
-           (i : tr []) =
+           (i : tr []) (r ::: {Unit}) (fold : folder r) =
     fold [fn r :: {Unit} => $(mapUT tf1 r) -> $(mapUT tf2 r) -> tr r]
-             (fn (nm :: Name) (t :: Unit) (rest :: {Unit}) acc
-                              [[nm] ~ rest] r1 r2 =>
-                 f [nm] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
-             (fn _ _ => i)
+         (fn (nm :: Name) (t :: Unit) (rest :: {Unit}) acc
+                          [[nm] ~ rest] r1 r2 =>
+             f [nm] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
+         (fn _ _ => i)
 
 fun foldURX2 (tf1 :: Type) (tf2 :: Type) (ctx :: {Unit})
            (f : nm :: Name -> rest :: {Unit}
@@ -54,134 +63,46 @@ fun foldURX2 (tf1 :: Type) (tf2 :: Type) (ctx :: {Unit})
                 <xml>{f [nm] [rest] v1 v2}{acc}</xml>)
             <xml/>
 
-fun foldTR (tf :: Type -> Type) (tr :: {Type} -> Type)
-           (f : nm :: Name -> t :: Type -> rest :: {Type}
+fun foldR K (tf :: K -> Type) (tr :: {K} -> Type)
+           (f : nm :: Name -> t :: K -> rest :: {K}
                 -> fn [[nm] ~ rest] =>
                       tf t -> tr rest -> tr ([nm = t] ++ rest))
-           (i : tr []) =
-    fold [fn r :: {Type} => $(map tf r) -> tr r]
-             (fn (nm :: Name) (t :: Type) (rest :: {Type}) (acc : _ -> tr rest)
+           (i : tr []) (r ::: {K}) (fold : folder r) =
+    fold [fn r :: {K} => $(map tf r) -> tr r]
+             (fn (nm :: Name) (t :: K) (rest :: {K}) (acc : _ -> tr rest)
                               [[nm] ~ rest] r =>
                  f [nm] [t] [rest] r.nm (acc (r -- nm)))
              (fn _ => i)
 
-fun foldT2R (tf :: (Type * Type) -> Type) (tr :: {(Type * Type)} -> Type)
-            (f : nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)}
-                 -> fn [[nm] ~ rest] =>
-                       tf t -> tr rest -> tr ([nm = t] ++ rest))
-            (i : tr []) =
-    fold [fn r :: {(Type * Type)} => $(map tf r) -> tr r]
-             (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
-                              (acc : _ -> tr rest) [[nm] ~ rest] r =>
-                 f [nm] [t] [rest] r.nm (acc (r -- nm)))
-             (fn _ => i)
-
-fun foldT3R (tf :: (Type * Type * Type) -> Type) (tr :: {(Type * Type * Type)} -> Type)
-            (f : nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)}
-                 -> fn [[nm] ~ rest] =>
-                       tf t -> tr rest -> tr ([nm = t] ++ rest))
-            (i : tr []) =
-    fold [fn r :: {(Type * Type * Type)} => $(map tf r) -> tr r]
-             (fn (nm :: Name) (t :: (Type * Type * Type)) (rest :: {(Type * Type * Type)})
-                              (acc : _ -> tr rest) [[nm] ~ rest] r =>
-                 f [nm] [t] [rest] r.nm (acc (r -- nm)))
-             (fn _ => i)
-
-fun foldTR2 (tf1 :: Type -> Type) (tf2 :: Type -> Type) (tr :: {Type} -> Type)
-            (f : nm :: Name -> t :: Type -> rest :: {Type}
+fun foldR2 K (tf1 :: K -> Type) (tf2 :: K -> Type) (tr :: {K} -> Type)
+            (f : nm :: Name -> t :: K -> rest :: {K}
                  -> fn [[nm] ~ rest] =>
                        tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest))
-            (i : tr []) =
-    fold [fn r :: {Type} => $(map tf1 r) -> $(map tf2 r) -> tr r]
-             (fn (nm :: Name) (t :: Type) (rest :: {Type})
-                              (acc : _ -> _ -> tr rest) [[nm] ~ rest] r1 r2 =>
-                 f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
-             (fn _ _ => i)
-
-fun foldT2R2 (tf1 :: (Type * Type) -> Type) (tf2 :: (Type * Type) -> Type)
-             (tr :: {(Type * Type)} -> Type)
-             (f : nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)}
-                  -> fn [[nm] ~ rest] =>
-                        tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest))
-             (i : tr []) =
-    fold [fn r :: {(Type * Type)} => $(map tf1 r) -> $(map tf2 r) -> tr r]
-             (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
-                              (acc : _ -> _ -> tr rest) [[nm] ~ rest] r1 r2 =>
-                 f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
-             (fn _ _ => i)
-
-fun foldT3R2 (tf1 :: (Type * Type * Type) -> Type) (tf2 :: (Type * Type * Type) -> Type)
-             (tr :: {(Type * Type * Type)} -> Type)
-             (f : nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)}
-                  -> fn [[nm] ~ rest] =>
-                        tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest))
-             (i : tr []) =
-    fold [fn r :: {(Type * Type * Type)} => $(map tf1 r) -> $(map tf2 r) -> tr r]
-             (fn (nm :: Name) (t :: (Type * Type * Type)) (rest :: {(Type * Type * Type)})
-                              (acc : _ -> _ -> tr rest) [[nm] ~ rest] r1 r2 =>
-                 f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
-             (fn _ _ => i)
-
-fun foldTRX (tf :: Type -> Type) (ctx :: {Unit})
-            (f : nm :: Name -> t :: Type -> rest :: {Type}
+            (i : tr []) (r ::: {K}) (fold : folder r) =
+    fold [fn r :: {K} => $(map tf1 r) -> $(map tf2 r) -> tr r]
+         (fn (nm :: Name) (t :: K) (rest :: {K})
+                          (acc : _ -> _ -> tr rest) [[nm] ~ rest] r1 r2 =>
+             f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
+         (fn _ _ => i)
+
+fun foldRX K (tf :: K -> Type) (ctx :: {Unit})
+            (f : nm :: Name -> t :: K -> rest :: {K}
                  -> fn [[nm] ~ rest] =>
                        tf t -> xml ctx [] []) =
-    foldTR [tf] [fn _ => xml ctx [] []]
-           (fn (nm :: Name) (t :: Type) (rest :: {Type}) [[nm] ~ rest] r acc =>
-               <xml>{f [nm] [t] [rest] r}{acc}</xml>)
-           <xml/>
-
-fun foldT2RX (tf :: (Type * Type) -> Type) (ctx :: {Unit})
-             (f : nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)}
-                  -> fn [[nm] ~ rest] =>
-                        tf t -> xml ctx [] []) =
-    foldT2R [tf] [fn _ => xml ctx [] []]
-            (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
-                             [[nm] ~ rest] r acc =>
-                <xml>{f [nm] [t] [rest] r}{acc}</xml>)
-            <xml/>
-
-fun foldT3RX (tf :: (Type * Type * Type) -> Type) (ctx :: {Unit})
-             (f : nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)}
-                  -> fn [[nm] ~ rest] =>
-                        tf t -> xml ctx [] []) =
-    foldT3R [tf] [fn _ => xml ctx [] []]
-            (fn (nm :: Name) (t :: (Type * Type * Type)) (rest :: {(Type * Type * Type)})
-                             [[nm] ~ rest] r acc =>
-                <xml>{f [nm] [t] [rest] r}{acc}</xml>)
-            <xml/>
+    foldR [tf] [fn _ => xml ctx [] []]
+          (fn (nm :: Name) (t :: K) (rest :: {K}) [[nm] ~ rest] r acc =>
+              <xml>{f [nm] [t] [rest] r}{acc}</xml>)
+          <xml/>
 
-fun foldTRX2 (tf1 :: Type -> Type) (tf2 :: Type -> Type) (ctx :: {Unit})
-             (f : nm :: Name -> t :: Type -> rest :: {Type}
+fun foldRX2 K (tf1 :: K -> Type) (tf2 :: K -> Type) (ctx :: {Unit})
+             (f : nm :: Name -> t :: K -> rest :: {K}
                   -> fn [[nm] ~ rest] =>
                         tf1 t -> tf2 t -> xml ctx [] []) =
-    foldTR2 [tf1] [tf2] [fn _ => xml ctx [] []]
-            (fn (nm :: Name) (t :: Type) (rest :: {Type}) [[nm] ~ rest]
-                             r1 r2 acc =>
-                <xml>{f [nm] [t] [rest] r1 r2}{acc}</xml>)
-            <xml/>
-
-fun foldT2RX2 (tf1 :: (Type * Type) -> Type) (tf2 :: (Type * Type) -> Type)
-              (ctx :: {Unit})
-              (f : nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)}
-                   -> fn [[nm] ~ rest] =>
-                         tf1 t -> tf2 t -> xml ctx [] []) =
-    foldT2R2 [tf1] [tf2] [fn _ => xml ctx [] []]
-             (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)})
-                              [[nm] ~ rest] r1 r2 acc =>
-                 <xml>{f [nm] [t] [rest] r1 r2}{acc}</xml>)
-             <xml/>
-
-fun foldT3RX2 (tf1 :: (Type * Type * Type) -> Type) (tf2 :: (Type * Type * Type) -> Type)
-              (ctx :: {Unit})
-              (f : nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)}
-                   -> fn [[nm] ~ rest] =>
-                         tf1 t -> tf2 t -> xml ctx [] []) =
-    foldT3R2 [tf1] [tf2] [fn _ => xml ctx [] []]
-             (fn (nm :: Name) (t :: (Type * Type * Type)) (rest :: {(Type * Type * Type)})
-                              [[nm] ~ rest] r1 r2 acc =>
-                 <xml>{f [nm] [t] [rest] r1 r2}{acc}</xml>)
-             <xml/>
+    foldR2 [tf1] [tf2] [fn _ => xml ctx [] []]
+           (fn (nm :: Name) (t :: K) (rest :: {K}) [[nm] ~ rest]
+                            r1 r2 acc =>
+               <xml>{f [nm] [t] [rest] r1 r2}{acc}</xml>)
+           <xml/>
 
 fun queryX (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit})
            (q : sql_query tables exps) [tables ~ exps]
diff --git a/lib/ur/top.urs b/lib/ur/top.urs
index 49aad50c..d891c80d 100644
--- a/lib/ur/top.urs
+++ b/lib/ur/top.urs
@@ -1,3 +1,12 @@
+(** Row folding *)
+
+con folder = K ==> fn r :: {K} =>
+                      tf :: ({K} -> Type)
+                      -> (nm :: Name -> v :: K -> r :: {K} -> tf r
+                          -> fn [[nm] ~ r] => tf ([nm = v] ++ r))
+                      -> tf [] -> tf r
+
+
 val not : bool -> bool
 
 con idT = fn t :: Type => t
@@ -25,103 +34,46 @@ val foldUR : tf :: Type -> tr :: ({Unit} -> Type)
              -> (nm :: Name -> rest :: {Unit}
                  -> fn [[nm] ~ rest] =>
                        tf -> tr rest -> tr ([nm] ++ rest))
-             -> tr [] -> r :: {Unit} -> $(mapUT tf r) -> tr r
+             -> tr [] -> r ::: {Unit} -> folder r -> $(mapUT tf r) -> tr r
 
 val foldUR2 : tf1 :: Type -> tf2 :: Type -> tr :: ({Unit} -> Type)
              -> (nm :: Name -> rest :: {Unit}
                  -> fn [[nm] ~ rest] =>
                        tf1 -> tf2 -> tr rest -> tr ([nm] ++ rest))
-             -> tr [] -> r :: {Unit} -> $(mapUT tf1 r) -> $(mapUT tf2 r) -> tr r
+             -> tr [] -> r ::: {Unit} -> folder r -> $(mapUT tf1 r) -> $(mapUT tf2 r) -> tr r
 
 val foldURX2: tf1 :: Type -> tf2 :: Type -> ctx :: {Unit}
               -> (nm :: Name -> rest :: {Unit}
                   -> fn [[nm] ~ rest] =>
                         tf1 -> tf2 -> xml ctx [] [])
-              -> r :: {Unit} -> $(mapUT tf1 r) -> $(mapUT tf2 r) -> xml ctx [] []
+              -> r ::: {Unit} -> folder r -> $(mapUT tf1 r) -> $(mapUT tf2 r) -> xml ctx [] []
 
-val foldTR : tf :: (Type -> Type) -> tr :: ({Type} -> Type)
-             -> (nm :: Name -> t :: Type -> rest :: {Type}
+val foldR : K --> tf :: (K -> Type) -> tr :: ({K} -> Type)
+             -> (nm :: Name -> t :: K -> rest :: {K}
                  -> fn [[nm] ~ rest] =>
                        tf t -> tr rest -> tr ([nm = t] ++ rest))
-             -> tr [] -> r :: {Type} -> $(map tf r) -> tr r
+             -> tr [] -> r ::: {K} -> folder r -> $(map tf r) -> tr r
 
-val foldT2R : tf :: ((Type * Type) -> Type) -> tr :: ({(Type * Type)} -> Type)
-              -> (nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)}
-                  -> fn [[nm] ~ rest] =>
-                        tf t -> tr rest -> tr ([nm = t] ++ rest))
-              -> tr [] -> r :: {(Type * Type)} -> $(map tf r) -> tr r
+val foldR2 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type)
+             -> tr :: ({K} -> Type)
+             -> (nm :: Name -> t :: K -> rest :: {K}
+                 -> fn [[nm] ~ rest] =>
+                       tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest))
+             -> tr []
+             -> r ::: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> tr r
 
-val foldT3R : tf :: ((Type * Type * Type) -> Type) -> tr :: ({(Type * Type * Type)} -> Type)
-              -> (nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)}
-                  -> fn [[nm] ~ rest] =>
-                        tf t -> tr rest -> tr ([nm = t] ++ rest))
-              -> tr [] -> r :: {(Type * Type * Type)} -> $(map tf r) -> tr r
+val foldRX : K --> tf :: (K -> Type) -> ctx :: {Unit}
+             -> (nm :: Name -> t :: K -> rest :: {K}
+                 -> fn [[nm] ~ rest] =>
+                       tf t -> xml ctx [] [])
+             -> r ::: {K} -> folder r -> $(map tf r) -> xml ctx [] []
 
-val foldTR2 : tf1 :: (Type -> Type) -> tf2 :: (Type -> Type)
-              -> tr :: ({Type} -> Type)
-              -> (nm :: Name -> t :: Type -> rest :: {Type}
-                  -> fn [[nm] ~ rest] =>
-                        tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest))
-              -> tr []
-              -> r :: {Type} -> $(map tf1 r) -> $(map tf2 r) -> tr r
-                                                                    
-val foldT2R2 : tf1 :: ((Type * Type) -> Type) -> tf2 :: ((Type * Type) -> Type)
-               -> tr :: ({(Type * Type)} -> Type)
-               -> (nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)}
-                   -> fn [[nm] ~ rest] =>
-                         tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest))
-               -> tr [] -> r :: {(Type * Type)}
-               -> $(map tf1 r) -> $(map tf2 r) -> tr r
-
-val foldT3R2 : tf1 :: ((Type * Type * Type) -> Type) -> tf2 :: ((Type * Type * Type) -> Type)
-               -> tr :: ({(Type * Type * Type)} -> Type)
-               -> (nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)}
-                   -> fn [[nm] ~ rest] =>
-                         tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest))
-               -> tr [] -> r :: {(Type * Type * Type)}
-               -> $(map tf1 r) -> $(map tf2 r) -> tr r
-
-val foldTRX : tf :: (Type -> Type) -> ctx :: {Unit}
-              -> (nm :: Name -> t :: Type -> rest :: {Type}
+val foldRX2 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> ctx :: {Unit}
+              -> (nm :: Name -> t :: K -> rest :: {K}
                   -> fn [[nm] ~ rest] =>
-                        tf t -> xml ctx [] [])
-              -> r :: {Type} -> $(map tf r) -> xml ctx [] []
-
-val foldT2RX : tf :: ((Type * Type) -> Type) -> ctx :: {Unit}
-               -> (nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)}
-                   -> fn [[nm] ~ rest] =>
-                         tf t -> xml ctx [] [])
-               -> r :: {(Type * Type)} -> $(map tf r) -> xml ctx [] []
-
-val foldT3RX : tf :: ((Type * Type * Type) -> Type) -> ctx :: {Unit}
-               -> (nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)}
-                   -> fn [[nm] ~ rest] =>
-                         tf t -> xml ctx [] [])
-               -> r :: {(Type * Type * Type)} -> $(map tf r) -> xml ctx [] []
-
-val foldTRX2 : tf1 :: (Type -> Type) -> tf2 :: (Type -> Type) -> ctx :: {Unit}
-               -> (nm :: Name -> t :: Type -> rest :: {Type}
-                   -> fn [[nm] ~ rest] =>
-                         tf1 t -> tf2 t -> xml ctx [] [])
-               -> r :: {Type}
-               -> $(map tf1 r) -> $(map tf2 r) -> xml ctx [] []
-
-val foldT2RX2 : tf1 :: ((Type * Type) -> Type) -> tf2 :: ((Type * Type) -> Type)
-                -> ctx :: {Unit}
-                -> (nm :: Name -> t :: (Type * Type) -> rest :: {(Type * Type)}
-                    -> fn [[nm] ~ rest] =>
-                          tf1 t -> tf2 t -> xml ctx [] [])
-                -> r :: {(Type * Type)}
-                -> $(map tf1 r) -> $(map tf2 r) -> xml ctx [] []
-
-
-val foldT3RX2 : tf1 :: ((Type * Type * Type) -> Type) -> tf2 :: ((Type * Type * Type) -> Type)
-                -> ctx :: {Unit}
-                -> (nm :: Name -> t :: (Type * Type * Type) -> rest :: {(Type * Type * Type)}
-                    -> fn [[nm] ~ rest] =>
-                          tf1 t -> tf2 t -> xml ctx [] [])
-                -> r :: {(Type * Type * Type)}
-                -> $(map tf1 r) -> $(map tf2 r) -> xml ctx [] []
+                        tf1 t -> tf2 t -> xml ctx [] [])
+              -> r ::: {K} -> folder r
+              -> $(map tf1 r) -> $(map tf2 r) -> xml ctx [] []
 
 val queryX : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit}
              -> sql_query tables exps
diff --git a/src/core.sml b/src/core.sml
index d7a57493..a28d93dd 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -96,7 +96,6 @@ datatype exp' =
        | EConcat of exp * con * exp * con
        | ECut of exp * con * { field : con, rest : con }
        | ECutMulti of exp * con * { rest : con }
-       | EFold of kind
 
        | ECase of exp * (pat * exp) list * { disc : con, result : con }
 
diff --git a/src/core_print.sml b/src/core_print.sml
index db8c3907..504773ab 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -342,7 +342,6 @@ fun p_exp' par env (e, _) =
                               string "---",
                               space,
                               p_con' true env c])
-      | EFold _ => string "fold"
 
       | ECase (e, pes, {disc, result}) =>
         parenIf par (box [string "case",
diff --git a/src/core_util.sml b/src/core_util.sml
index e76da387..d5f8dd05 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -454,10 +454,6 @@ fun compare ((e1, _), (e2, _)) =
       | (ECutMulti _, _) => LESS
       | (_, ECutMulti _) => GREATER
 
-      | (EFold _, EFold _) => EQUAL
-      | (EFold _, _) => LESS
-      | (_, EFold _) => GREATER
-
       | (ECase (e1, pes1, _), ECase (e2, pes2, _)) =>
         join (compare (e1, e2),
               fn () => joinL (fn ((p1, e1), (p2, e2)) =>
@@ -609,10 +605,6 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
                                  S.map2 (mfc ctx rest,
                                       fn rest' =>
                                          (ECutMulti (e', c', {rest = rest'}), loc))))
-              | EFold k =>
-                S.map2 (mfk k,
-                         fn k' =>
-                            (EFold k', loc))
 
               | ECase (e, pes, {disc, result}) =>
                 S.bind2 (mfe ctx e,
diff --git a/src/corify.sml b/src/corify.sml
index c464e5a5..802baf66 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -592,7 +592,6 @@ fun corifyExp st (e, loc) =
                                                    {field = corifyCon st field, rest = corifyCon st rest}), loc)
       | L.ECutMulti (e1, c, {rest}) => (L'.ECutMulti (corifyExp st e1, corifyCon st c,
                                                       {rest = corifyCon st rest}), loc)
-      | L.EFold k => (L'.EFold (corifyKind k), loc)
 
       | L.ECase (e, pes, {disc, result}) =>
         (L'.ECase (corifyExp st e,
diff --git a/src/elab.sml b/src/elab.sml
index ec8a910a..9ec3793e 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -40,6 +40,9 @@ datatype kind' =
        | KError
        | KUnif of ErrorMsg.span * string * kind option ref
 
+       | KRel of int
+       | KFun of string * kind
+
 withtype kind = kind' located
 
 datatype explicitness =
@@ -62,6 +65,10 @@ datatype con' =
        | CAbs of string * kind * con
        | CDisjoint of auto_instantiate * con * con * con
 
+       | CKAbs of string * con
+       | CKApp of con * kind
+       | TKFun of string * con
+
        | CName of string
 
        | CRecord of kind * (con * con) list
@@ -106,12 +113,14 @@ datatype exp' =
        | ECApp of exp * con
        | ECAbs of explicitness * string * kind * exp
 
+       | EKAbs of string * exp
+       | EKApp of exp * kind
+
        | ERecord of (con * exp * con) list
        | EField of exp * con * { field : con, rest : con }
        | EConcat of exp * con * exp * con
        | ECut of exp * con * { field : con, rest : con }
        | ECutMulti of exp * con * { rest : con }
-       | EFold of kind
 
        | ECase of exp * (pat * exp) list * { disc : con, result : con }
 
diff --git a/src/elab_env.sig b/src/elab_env.sig
index 0b436106..10d11e3b 100644
--- a/src/elab_env.sig
+++ b/src/elab_env.sig
@@ -47,6 +47,10 @@ signature ELAB_ENV = sig
            | Rel of int * 'a
            | Named of int * 'a
 
+    val pushKRel : env -> string -> env
+    val lookupKRel : env -> int -> string
+    val lookupK : env -> string -> int option
+
     val pushCRel : env -> string -> Elab.kind -> env
     val lookupCRel : env -> int -> string * Elab.kind
 
diff --git a/src/elab_env.sml b/src/elab_env.sml
index 53c934dd..083e7d55 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -45,8 +45,32 @@ exception UnboundNamed of int
 
 exception SynUnif
 
+val liftKindInKind =
+    U.Kind.mapB {kind = fn bound => fn k =>
+                                       case k of
+                                         KRel xn =>
+                                         if xn < bound then
+                                             k
+                                         else
+                                             KRel (xn + 1)
+                                       | _ => k,
+                 bind = fn (bound, _) => bound + 1}
+
+val liftKindInCon =
+    U.Con.mapB {kind = fn bound => fn k =>
+                                      case k of
+                                          KRel xn =>
+                                          if xn < bound then
+                                              k
+                                          else
+                                              KRel (xn + 1)
+                                        | _ => k,
+                con = fn _ => fn c => c,
+                bind = fn (bound, U.Con.RelK _) => bound + 1
+                        | (bound, _) => bound}
+
 val liftConInCon =
-    U.Con.mapB {kind = fn k => k,
+    U.Con.mapB {kind = fn _ => fn k => k,
                 con = fn bound => fn c =>
                                      case c of
                                          CRel xn =>
@@ -56,13 +80,27 @@ val liftConInCon =
                                              CRel (xn + 1)
                                        (*| CUnif _ => raise SynUnif*)
                                        | _ => c,
-                bind = fn (bound, U.Con.Rel _) => bound + 1
+                bind = fn (bound, U.Con.RelC _) => bound + 1
                         | (bound, _) => bound}
 
 val lift = liftConInCon 0
 
+val liftKindInExp =
+    U.Exp.mapB {kind = fn bound => fn k =>
+                                      case k of
+                                          KRel xn =>
+                                          if xn < bound then
+                                              k
+                                          else
+                                              KRel (xn + 1)
+                                        | _ => k,
+                con = fn _ => fn c => c,
+                exp = fn _ => fn e => e,
+                bind = fn (bound, U.Exp.RelK _) => bound + 1
+                        | (bound, _) => bound}
+
 val liftConInExp =
-    U.Exp.mapB {kind = fn k => k,
+    U.Exp.mapB {kind = fn _ => fn k => k,
                 con = fn bound => fn c =>
                                      case c of
                                          CRel xn =>
@@ -76,7 +114,7 @@ val liftConInExp =
                         | (bound, _) => bound}
 
 val liftExpInExp =
-    U.Exp.mapB {kind = fn k => k,
+    U.Exp.mapB {kind = fn _ => fn k => k,
                 con = fn _ => fn c => c,
                 exp = fn bound => fn e =>
                                      case e of
@@ -93,7 +131,7 @@ val liftExpInExp =
 val liftExp = liftExpInExp 0
 
 val subExpInExp =
-    U.Exp.mapB {kind = fn k => k,
+    U.Exp.mapB {kind = fn _ => fn k => k,
                 con = fn _ => fn c => c,
                 exp = fn (xn, rep) => fn e =>
                                   case e of
@@ -203,6 +241,9 @@ fun printClasses cs = (print "Classes:\n";
                                     print "\n")) cs)
 
 type env = {
+     renameK : int SM.map,
+     relK : string list,
+
      renameC : kind var' SM.map,
      relC : (string * kind) list,
      namedC : (string * kind * con option) IM.map,
@@ -234,6 +275,9 @@ fun newNamed () =
     end
 
 val empty = {
+    renameK = SM.empty,
+    relK = [],
+
     renameC = SM.empty,
     relC = [],
     namedC = IM.empty,
@@ -261,12 +305,51 @@ fun liftClassKey ck =
       | CkProj _ => ck
       | CkApp (ck1, ck2) => CkApp (liftClassKey ck1, liftClassKey ck2)
 
+fun pushKRel (env : env) x =
+    let
+        val renameK = SM.map (fn n => n+1) (#renameK env)
+    in
+        {renameK = SM.insert (renameK, x, 0),
+         relK = x :: #relK env,
+
+         renameC = SM.map (fn Rel' (n, k) => Rel' (n, liftKindInKind 0 k)
+                            | x => x) (#renameC env),
+         relC = map (fn (x, k) => (x, liftKindInKind 0 k)) (#relC env),
+         namedC = #namedC env,
+
+         datatypes = #datatypes env,
+         constructors = #constructors env,
+
+         classes = #classes env,
+
+         renameE = SM.map (fn Rel' (n, c) => Rel' (n, liftKindInCon 0 c)
+                            | Named' (n, c) => Named' (n, c)) (#renameE env),
+         relE = map (fn (x, c) => (x, liftKindInCon 0 c)) (#relE env),
+         namedE = #namedE env,
+
+         renameSgn = #renameSgn env,
+         sgn = #sgn env,
+
+         renameStr = #renameStr env,
+         str = #str env
+        }
+    end
+
+fun lookupKRel (env : env) n =
+    (List.nth (#relK env, n))
+    handle Subscript => raise UnboundRel n
+
+fun lookupK (env : env) x = SM.find (#renameK env, x)
+
 fun pushCRel (env : env) x k =
     let
         val renameC = SM.map (fn Rel' (n, k) => Rel' (n+1, k)
                                | x => x) (#renameC env)
     in
-        {renameC = SM.insert (renameC, x, Rel' (0, k)),
+        {renameK = #renameK env,
+         relK = #relK env,
+
+         renameC = SM.insert (renameC, x, Rel' (0, k)),
          relC = (x, k) :: #relC env,
          namedC = #namedC env,
 
@@ -298,7 +381,10 @@ fun lookupCRel (env : env) n =
     handle Subscript => raise UnboundRel n
 
 fun pushCNamedAs (env : env) x n k co =
-    {renameC = SM.insert (#renameC env, x, Named' (n, k)),
+    {renameK = #renameK env,
+     relK = #relK env,
+
+     renameC = SM.insert (#renameC env, x, Named' (n, k)),
      relC = #relC env,
      namedC = IM.insert (#namedC env, n, (x, k, co)),
 
@@ -340,7 +426,10 @@ fun pushDatatype (env : env) n xs xncs =
     let
         val dk = U.classifyDatatype xncs
     in
-        {renameC = #renameC env,
+        {renameK = #renameK env,
+         relK = #relK env,
+
+         renameC = #renameC env,
          relC = #relC env,
          namedC = #namedC env,
 
@@ -380,7 +469,10 @@ fun datatypeArgs (xs, _) = xs
 fun constructors (_, dt) = IM.foldri (fn (n, (x, to), ls) => (x, n, to) :: ls) [] dt
 
 fun pushClass (env : env) n =
-    {renameC = #renameC env,
+    {renameK = #renameK env,
+     relK = #relK env,
+
+     renameC = #renameC env,
      relC = #relC env,
      namedC = #namedC env,
 
@@ -468,7 +560,10 @@ fun pushERel (env : env) x t =
                                   CM.insert (classes, f, class)
                               end
     in
-        {renameC = #renameC env,
+        {renameK = #renameK env,
+         relK = #relK env,
+
+         renameC = #renameC env,
          relC = #relC env,
          namedC = #namedC env,
 
@@ -509,7 +604,10 @@ fun pushENamedAs (env : env) x n t =
                                   CM.insert (classes, f, class)
                               end
     in
-        {renameC = #renameC env,
+        {renameK = #renameK env,
+         relK = #relK env,
+
+         renameC = #renameC env,
          relC = #relC env,
          namedC = #namedC env,
 
@@ -552,7 +650,10 @@ fun lookupE (env : env) x =
       | SOME (Named' x) => Named x
 
 fun pushSgnNamedAs (env : env) x n sgis =
-    {renameC = #renameC env,
+    {renameK = #renameK env,
+     relK = #relK env,
+
+     renameC = #renameC env,
      relC = #relC env,
      namedC = #namedC env,
 
@@ -868,7 +969,10 @@ fun enrichClasses env classes (m1, ms) sgn =
       | _ => classes
 
 fun pushStrNamedAs (env : env) x n sgn =
-    {renameC = #renameC env,
+    {renameK = #renameK env,
+     relK = #relK env,
+
+     renameC = #renameC env,
      relC = #relC env,
      namedC = #namedC env,
 
diff --git a/src/elab_err.sig b/src/elab_err.sig
index d757572f..3b14406b 100644
--- a/src/elab_err.sig
+++ b/src/elab_err.sig
@@ -27,11 +27,16 @@
 
 signature ELAB_ERR = sig
 
+    datatype kind_error =
+             UnboundKind of ErrorMsg.span * string
+
+    val kindError : ElabEnv.env -> kind_error -> unit
+
     datatype kunify_error =
              KOccursCheckFailed of Elab.kind * Elab.kind
            | KIncompatible of Elab.kind * Elab.kind
 
-    val kunifyError : kunify_error -> unit
+    val kunifyError : ElabEnv.env -> kunify_error -> unit
 
     datatype con_error =
              UnboundCon of ErrorMsg.span * string
diff --git a/src/elab_err.sml b/src/elab_err.sml
index e8d7ff68..8892674c 100644
--- a/src/elab_err.sml
+++ b/src/elab_err.sml
@@ -36,7 +36,7 @@ structure U = ElabUtil
 open Print
 structure P = ElabPrint
 
-val simplCon = U.Con.mapB {kind = fn k => k,
+val simplCon = U.Con.mapB {kind = fn _ => fn k => k,
                            con = fn env => fn c =>
                                               let
                                                   val c = (c, ErrorMsg.dummySpan)
@@ -46,25 +46,34 @@ val simplCon = U.Con.mapB {kind = fn k => k,
                                                                     ("c'", P.p_con env c')];*)
                                                   #1 c'
                                               end,
-                           bind = fn (env, U.Con.Rel (x, k)) => E.pushCRel env x k
-                                   | (env, U.Con.Named (x, n, k)) => E.pushCNamedAs env x n k NONE}
+                           bind = fn (env, U.Con.RelC (x, k)) => E.pushCRel env x k
+                                   | (env, U.Con.NamedC (x, n, k)) => E.pushCNamedAs env x n k NONE
+                                   | (env, _) => env}
 
 val p_kind = P.p_kind
+             
+datatype kind_error =
+         UnboundKind of ErrorMsg.span * string
+
+fun kindError env err =
+    case err of
+        UnboundKind (loc, s) =>
+        ErrorMsg.errorAt loc ("Unbound kind variable " ^ s)
 
 datatype kunify_error =
          KOccursCheckFailed of kind * kind
        | KIncompatible of kind * kind
 
-fun kunifyError err =
+fun kunifyError env err =
     case err of
         KOccursCheckFailed (k1, k2) =>
         eprefaces "Kind occurs check failed"
-        [("Kind 1", p_kind k1),
-         ("Kind 2", p_kind k2)]
+        [("Kind 1", p_kind env k1),
+         ("Kind 2", p_kind env k2)]
       | KIncompatible (k1, k2) =>
         eprefaces "Incompatible kinds"
-        [("Kind 1", p_kind k1),
-         ("Kind 2", p_kind k2)]
+        [("Kind 1", p_kind env k1),
+         ("Kind 2", p_kind env k2)]
 
 
 fun p_con env c = P.p_con env (simplCon env c)
@@ -89,9 +98,9 @@ fun conError env err =
       | WrongKind (c, k1, k2, kerr) =>
         (ErrorMsg.errorAt (#2 c) "Wrong kind";
          eprefaces' [("Constructor", p_con env c),
-                     ("Have kind", p_kind k1),
-                     ("Need kind", p_kind k2)];
-         kunifyError kerr)
+                     ("Have kind", p_kind env k1),
+                     ("Need kind", p_kind env k2)];
+         kunifyError env kerr)
       | DuplicateField (loc, s) =>
         ErrorMsg.errorAt loc ("Duplicate record field " ^ s)
       | ProjBounds (c, n) =>
@@ -101,7 +110,7 @@ fun conError env err =
       | ProjMismatch (c, k) =>
         (ErrorMsg.errorAt (#2 c) "Projection from non-tuple constructor";
          eprefaces' [("Constructor", p_con env c),
-                     ("Kind", p_kind k)])
+                     ("Kind", p_kind env k)])
 
 
 datatype cunify_error =
@@ -116,9 +125,9 @@ fun cunifyError env err =
     case err of
         CKind (k1, k2, kerr) =>
         (eprefaces "Kind unification failure"
-                   [("Kind 1", p_kind k1),
-                    ("Kind 2", p_kind k2)];
-         kunifyError kerr)
+                   [("Kind 1", p_kind env k1),
+                    ("Kind 2", p_kind env k2)];
+         kunifyError env kerr)
       | COccursCheckFailed (c1, c2) =>
         eprefaces "Constructor occurs check failed"
                   [("Con 1", p_con env c1),
@@ -133,7 +142,7 @@ fun cunifyError env err =
                    ("Con 2", p_con env c2)]
       | CKindof (k, c, expected) =>
         eprefaces ("Unexpected kind for kindof calculation (expecting " ^ expected ^ ")")
-                  [("Kind", p_kind k),
+                  [("Kind", p_kind env k),
                    ("Con", p_con env c)]
       | CRecordFailure (c1, c2) =>
         eprefaces "Can't unify record constructors"
@@ -267,9 +276,9 @@ fun sgnError env err =
         (ErrorMsg.errorAt (#2 sgi1) "Kind unification failure in signature matching:";
          eprefaces' [("Have", p_sgn_item env sgi1),
                      ("Need", p_sgn_item env sgi2),
-                     ("Kind 1", p_kind k1),
-                     ("Kind 2", p_kind k2)];
-         kunifyError kerr)
+                     ("Kind 1", p_kind env k1),
+                     ("Kind 2", p_kind env k2)];
+         kunifyError env kerr)
       | SgiWrongCon (sgi1, c1, sgi2, c2, cerr) =>
         (ErrorMsg.errorAt (#2 sgi1) "Constructor unification failure in signature matching:";
          eprefaces' [("Have", p_sgn_item env sgi1),
@@ -296,9 +305,9 @@ fun sgnError env err =
                      ("Field", PD.string x)])
       | WhereWrongKind (k1, k2, kerr) =>
         (ErrorMsg.errorAt (#2 k1) "Wrong kind for 'where'";
-         eprefaces' [("Have", p_kind k1),
-                     ("Need", p_kind k2)];
-         kunifyError kerr)
+         eprefaces' [("Have", p_kind env k1),
+                     ("Need", p_kind env k2)];
+         kunifyError env kerr)
       | NotIncludable sgn =>
         (ErrorMsg.errorAt (#2 sgn) "Invalid signature to 'include'";
          eprefaces' [("Signature", p_sgn env sgn)])
@@ -337,10 +346,10 @@ fun strError env err =
          eprefaces' [("Signature", p_sgn env sgn)])
       | NotType (k, (k1, k2, ue)) =>
         (ErrorMsg.errorAt (#2 k) "'val' type kind is not 'Type'";
-         eprefaces' [("Kind", p_kind k),
-                     ("Subkind 1", p_kind k1),
-                     ("Subkind 2", p_kind k2)];
-         kunifyError ue)
+         eprefaces' [("Kind", p_kind env k),
+                     ("Subkind 1", p_kind env k1),
+                     ("Subkind 2", p_kind env k2)];
+         kunifyError env ue)
       | DuplicateConstructor (x, loc) =>
         ErrorMsg.errorAt loc ("Duplicate datatype constructor " ^ x)
       | NotDatatype loc =>
diff --git a/src/elab_ops.sig b/src/elab_ops.sig
index 62af9638..7088bf06 100644
--- a/src/elab_ops.sig
+++ b/src/elab_ops.sig
@@ -27,6 +27,12 @@
 
 signature ELAB_OPS = sig
 
+    val liftKindInKind : int -> Elab.kind -> Elab.kind
+    val subKindInKind : int * Elab.kind -> Elab.kind -> Elab.kind
+
+    val liftKindInCon : int -> Elab.con -> Elab.con
+    val subKindInCon : int * Elab.kind -> Elab.con -> Elab.con
+
     val liftConInCon : int -> Elab.con -> Elab.con
     val subConInCon : int * Elab.con -> Elab.con -> Elab.con
     val subStrInSgn : int * int -> Elab.sgn -> Elab.sgn
diff --git a/src/elab_ops.sml b/src/elab_ops.sml
index c3e9274c..60a7639d 100644
--- a/src/elab_ops.sml
+++ b/src/elab_ops.sml
@@ -32,8 +32,64 @@ open Elab
 structure E = ElabEnv
 structure U = ElabUtil
 
+fun liftKindInKind' by =
+    U.Kind.mapB {kind = fn bound => fn k =>
+                                       case k of
+                                         KRel xn =>
+                                         if xn < bound then
+                                             k
+                                         else
+                                             KRel (xn + by)
+                                       | _ => k,
+                bind = fn (bound, _) => bound + 1}
+
+fun subKindInKind' rep =
+    U.Kind.mapB {kind = fn (by, xn) => fn k =>
+                                          case k of
+                                              KRel xn' =>
+                                              (case Int.compare (xn', xn) of
+                                                   EQUAL => #1 (liftKindInKind' by 0 rep)
+                                                 | GREATER => KRel (xn' - 1)
+                                                 | LESS => k)
+                                            | _ => k,
+                 bind = fn ((by, xn), _) => (by+1, xn+1)}
+
+val liftKindInKind = liftKindInKind' 1
+
+fun subKindInKind (xn, rep) = subKindInKind' rep (0, xn)
+
+fun liftKindInCon by =
+    U.Con.mapB {kind = fn bound => fn k =>
+                                      case k of
+                                          KRel xn =>
+                                          if xn < bound then
+                                              k
+                                          else
+                                              KRel (xn + by)
+                                        | _ => k,
+                con = fn _ => fn c => c,
+                bind = fn (bound, U.Con.RelK _) => bound + 1
+                        | (bound, _) => bound}
+
+fun subKindInCon' rep =
+    U.Con.mapB {kind = fn (by, xn) => fn k =>
+                                         case k of
+                                             KRel xn' =>
+                                             (case Int.compare (xn', xn) of
+                                                  EQUAL => #1 (liftKindInKind' by 0 rep)
+                                                | GREATER => KRel (xn' - 1)
+                                                | LESS => k)
+                                           | _ => k,
+                con = fn _ => fn c => c,
+                bind = fn ((by, xn), U.Con.RelK _) => (by+1, xn+1)
+                        | (st, _) => st}
+
+val liftKindInCon = liftKindInCon 1
+
+fun subKindInCon (xn, rep) = subKindInCon' rep (0, xn)
+
 fun liftConInCon by =
-    U.Con.mapB {kind = fn k => k,
+    U.Con.mapB {kind = fn _ => fn k => k,
                 con = fn bound => fn c =>
                                      case c of
                                          CRel xn =>
@@ -43,11 +99,11 @@ fun liftConInCon by =
                                              CRel (xn + by)
                                        (*| CUnif _ => raise SynUnif*)
                                        | _ => c,
-                bind = fn (bound, U.Con.Rel _) => bound + 1
+                bind = fn (bound, U.Con.RelC _) => bound + 1
                         | (bound, _) => bound}
 
 fun subConInCon' rep =
-    U.Con.mapB {kind = fn k => k,
+    U.Con.mapB {kind = fn _ => fn k => k,
                 con = fn (by, xn) => fn c =>
                                         case c of
                                             CRel xn' =>
@@ -57,7 +113,7 @@ fun subConInCon' rep =
                                                | LESS => c)
                                           (*| CUnif _ => raise SynUnif*)
                                           | _ => c,
-                bind = fn ((by, xn), U.Con.Rel _) => (by+1, xn+1)
+                bind = fn ((by, xn), U.Con.RelC _) => (by+1, xn+1)
                         | (ctx, _) => ctx}
 
 val liftConInCon = liftConInCon 1
@@ -205,6 +261,11 @@ fun hnormCon env (cAll as (c, loc)) =
                    | _ => default ()
              end
            | c1' => (CApp ((c1', loc), hnormCon env c2), loc))
+
+      | CKApp (c1, k) =>
+        (case hnormCon env c1 of
+             (CKAbs (_, body), _) => hnormCon env (subKindInCon (0, k) body)
+           | _ => cAll)
         
       | CConcat (c1, c2) =>
         (case (hnormCon env c1, hnormCon env c2) of
diff --git a/src/elab_print.sig b/src/elab_print.sig
index 3d078576..41d72ca7 100644
--- a/src/elab_print.sig
+++ b/src/elab_print.sig
@@ -28,7 +28,7 @@
 (* Pretty-printing Ur/Web *)
 
 signature ELAB_PRINT = sig
-    val p_kind : Elab.kind Print.printer
+    val p_kind : ElabEnv.env -> Elab.kind Print.printer
     val p_explicitness : Elab.explicitness Print.printer
     val p_con : ElabEnv.env -> Elab.con Print.printer
     val p_pat : ElabEnv.env -> Elab.pat Print.printer
diff --git a/src/elab_print.sml b/src/elab_print.sml
index 098c9259..a0e1a54a 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -38,25 +38,36 @@ structure E = ElabEnv
 
 val debug = ref false
 
-fun p_kind' par (k, _) =
+fun p_kind' par env (k, _) =
     case k of
         KType => string "Type"
-      | KArrow (k1, k2) => parenIf par (box [p_kind' true k1,
+      | KArrow (k1, k2) => parenIf par (box [p_kind' true env k1,
                                              space,
                                              string "->",
                                              space,
-                                             p_kind k2])
+                                             p_kind env k2])
       | KName => string "Name"
-      | KRecord k => box [string "{", p_kind k, string "}"]
+      | KRecord k => box [string "{", p_kind env k, string "}"]
       | KUnit => string "Unit"
       | KTuple ks => box [string "(",
-                          p_list_sep (box [space, string "*", space]) p_kind ks,
+                          p_list_sep (box [space, string "*", space]) (p_kind env) ks,
                           string ")"]
 
       | KError => string "<ERROR>"
-      | KUnif (_, _, ref (SOME k)) => p_kind' par k
+      | KUnif (_, _, ref (SOME k)) => p_kind' par env k
       | KUnif (_, s, _) => string ("<UNIF:" ^ s ^ ">")
 
+      | KRel n => ((if !debug then
+                         string (E.lookupKRel env n ^ "_" ^ Int.toString n)
+                     else
+                         string (E.lookupKRel env n))
+                    handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n))
+      | KFun (x, k) => box [string x,
+                            space,
+                            string "-->",
+                            space,
+                            p_kind (E.pushKRel env x) k]
+
 and p_kind k = p_kind' false k
 
 fun p_explicitness e =
@@ -66,7 +77,7 @@ fun p_explicitness e =
 
 fun p_con' par env (c, _) =
     case c of
-        TFun (t1, t2) => parenIf par (box [p_con' true env t1,
+        TFun (t1, t2) => parenIf true (box [p_con' true env t1,
                                            space,
                                            string "->",
                                            space,
@@ -75,20 +86,22 @@ fun p_con' par env (c, _) =
                                                 space,
                                                 p_explicitness e,
                                                 space,
-                                                p_kind k,
+                                                p_kind env k,
                                                 space,
                                                 string "->",
                                                 space,
                                                 p_con (E.pushCRel env x k) c])
-      | CDisjoint (_, c1, c2, c3) => parenIf par (box [p_con env c1,
-                                                       space,
-                                                       string "~",
-                                                       space,
-                                                       p_con env c2,
-                                                       space,
-                                                       string "=>",
-                                                       space,
-                                                       p_con env c3])
+      | CDisjoint (ai, c1, c2, c3) => parenIf par (box [p_con env c1,
+                                                        space,
+                                                        string (case ai of
+                                                                    Instantiate => "~"
+                                                                  | LeaveAlone => "~~"),
+                                                        space,
+                                                        p_con env c2,
+                                                        space,
+                                                        string "=>",
+                                                        space,
+                                                        p_con env c3])
       | TRecord (CRecord (_, xcs), _) => box [string "{",
                                               p_list (fn (x, c) =>
                                                          box [p_name env x,
@@ -134,7 +147,7 @@ fun p_con' par env (c, _) =
                                              space,
                                              string "::",
                                              space,
-                                             p_kind k,
+                                             p_kind env k,
                                              space,
                                              string "=>",
                                              space,
@@ -152,7 +165,7 @@ fun p_con' par env (c, _) =
                                               space,
                                               p_con env c]) xcs,
                               string "]::",
-                              p_kind k])
+                              p_kind env k])
         else
             parenIf par (box [string "[",
                               p_list (fn (x, c) =>
@@ -181,8 +194,24 @@ fun p_con' par env (c, _) =
       | CError => string "<ERROR>"
       | CUnif (_, _, _, ref (SOME c)) => p_con' par env c
       | CUnif (_, k, s, _) => box [string ("<UNIF:" ^ s ^ "::"),
-                                   p_kind k,
+                                   p_kind env k,
                                    string ">"]
+
+      | CKAbs (x, c) => box [string x,
+                             space,
+                             string "==>",
+                             space,
+                             p_con (E.pushKRel env x) c]
+      | CKApp (c, k) => box [p_con env c,
+                             string "[[",
+                             p_kind env k,
+                             string "]]"]
+      | TKFun (x, c) => box [string x,
+                             space,
+                             string "-->",
+                             space,
+                             p_con (E.pushKRel env x) c]
+
         
 and p_con env = p_con' false env
 
@@ -286,7 +315,7 @@ fun p_exp' par env (e, _) =
                                                   space,
                                                   p_explicitness exp,
                                                   space,
-                                                  p_kind k,
+                                                  p_kind env k,
                                                   space,
                                                   string "=>",
                                                   space,
@@ -377,8 +406,6 @@ fun p_exp' par env (e, _) =
                               space,
                               p_con' true env c])
 
-      | EFold _ => string "fold"
-
       | ECase (e, pes, _) => parenIf par (box [string "case",
                                                space,
                                                p_exp env e,
@@ -415,6 +442,16 @@ fun p_exp' par env (e, _) =
                  string "end"]
         end
 
+      | EKAbs (x, e) => box [string x,
+                             space,
+                             string "==>",
+                             space,
+                             p_exp (E.pushKRel env x) e]
+      | EKApp (e, k) => box [p_exp env e,
+                             string "[[",
+                             p_kind env k,
+                             string "]]"]
+
 and p_exp env = p_exp' false env
 
 and p_edecl env (dAll as (d, _)) =
@@ -478,14 +515,14 @@ fun p_sgn_item env (sgi, _) =
                                     space,
                                     string "::",
                                     space,
-                                    p_kind k]
+                                    p_kind env k]
       | SgiCon (x, n, k, c) => box [string "con",
                                     space,
                                     p_named x n,
                                     space,
                                     string "::",
                                     space,
-                                    p_kind k,
+                                    p_kind env k,
                                     space,
                                     string "=",
                                     space,
@@ -540,14 +577,14 @@ fun p_sgn_item env (sgi, _) =
                                       space,
                                       string "::",
                                       space,
-                                      p_kind k]
+                                      p_kind env k]
       | SgiClass (x, n, k, c) => box [string "class",
                                       space,
                                       p_named x n,
                                       space,
                                       string "::",
                                       space,
-                                      p_kind k,
+                                      p_kind env k,
                                       space,
                                       string "=",
                                       space,
@@ -627,7 +664,7 @@ fun p_decl env (dAll as (d, _) : decl) =
                                   space,
                                   string "::",
                                   space,
-                                  p_kind k,
+                                  p_kind env k,
                                   space,
                                   string "=",
                                   space,
@@ -719,7 +756,7 @@ fun p_decl env (dAll as (d, _) : decl) =
                                     space,
                                     string "::",
                                     space,
-                                    p_kind k,
+                                    p_kind env k,
                                     space,
                                     string "=",
                                     space,
diff --git a/src/elab_util.sig b/src/elab_util.sig
index f9988981..817f885f 100644
--- a/src/elab_util.sig
+++ b/src/elab_util.sig
@@ -30,17 +30,24 @@ signature ELAB_UTIL = sig
 val classifyDatatype : (string * int * 'a option) list -> Elab.datatype_kind
 
 structure Kind : sig
+    val mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB,
+                    bind : 'context * string -> 'context}
+                   -> ('context, Elab.kind, 'state, 'abort) Search.mapfolderB
     val mapfold : (Elab.kind', 'state, 'abort) Search.mapfolder
                   -> (Elab.kind, 'state, 'abort) Search.mapfolder
     val exists : (Elab.kind' -> bool) -> Elab.kind -> bool
+    val mapB : {kind : 'context -> Elab.kind' -> Elab.kind',
+                bind : 'context * string -> 'context}
+               -> 'context -> (Elab.kind -> Elab.kind)
 end
 
 structure Con : sig
     datatype binder =
-             Rel of string * Elab.kind
-           | Named of string * int * Elab.kind
+             RelK of string
+           | RelC of string * Elab.kind
+           | NamedC of string * int * Elab.kind
 
-    val mapfoldB : {kind : (Elab.kind', 'state, 'abort) Search.mapfolder,
+    val mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB,
                     con : ('context, Elab.con', 'state, 'abort) Search.mapfolderB,
                     bind : 'context * binder -> 'context}
                    -> ('context, Elab.con, 'state, 'abort) Search.mapfolderB
@@ -48,7 +55,7 @@ structure Con : sig
                    con : (Elab.con', 'state, 'abort) Search.mapfolder}
                   -> (Elab.con, 'state, 'abort) Search.mapfolder
 
-    val mapB : {kind : Elab.kind' -> Elab.kind',
+    val mapB : {kind : 'context -> Elab.kind' -> Elab.kind',
                 con : 'context -> Elab.con' -> Elab.con',
                 bind : 'context * binder -> 'context}
                -> 'context -> (Elab.con -> Elab.con)
@@ -58,7 +65,7 @@ structure Con : sig
     val exists : {kind : Elab.kind' -> bool,
                   con : Elab.con' -> bool} -> Elab.con -> bool
 
-    val foldB : {kind : Elab.kind' * 'state -> 'state,
+    val foldB : {kind : 'context * Elab.kind' * 'state -> 'state,
                  con : 'context * Elab.con' * 'state -> 'state,
                  bind : 'context * binder -> 'context}
                 -> 'context -> 'state -> Elab.con -> 'state
@@ -66,12 +73,13 @@ end
 
 structure Exp : sig
     datatype binder =
-             RelC of string * Elab.kind
+             RelK of string
+           | RelC of string * Elab.kind
            | NamedC of string * int * Elab.kind
            | RelE of string * Elab.con
            | NamedE of string * Elab.con
 
-    val mapfoldB : {kind : (Elab.kind', 'state, 'abort) Search.mapfolder,
+    val mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB,
                     con : ('context, Elab.con', 'state, 'abort) Search.mapfolderB,
                     exp : ('context, Elab.exp', 'state, 'abort) Search.mapfolderB,
                     bind : 'context * binder -> 'context}
@@ -80,7 +88,7 @@ structure Exp : sig
                    con : (Elab.con', 'state, 'abort) Search.mapfolder,
                    exp : (Elab.exp', 'state, 'abort) Search.mapfolder}
                   -> (Elab.exp, 'state, 'abort) Search.mapfolder
-    val mapB : {kind : Elab.kind' -> Elab.kind',
+    val mapB : {kind : 'context -> Elab.kind' -> Elab.kind',
                 con : 'context -> Elab.con' -> Elab.con',
                 exp : 'context -> Elab.exp' -> Elab.exp',
                 bind : 'context * binder -> 'context}
@@ -89,7 +97,7 @@ structure Exp : sig
                   con : Elab.con' -> bool,
                   exp : Elab.exp' -> bool} -> Elab.exp -> bool
 
-    val foldB : {kind : Elab.kind' * 'state -> 'state,
+    val foldB : {kind : 'context * Elab.kind' * 'state -> 'state,
                  con : 'context * Elab.con' * 'state -> 'state,
                  exp : 'context * Elab.exp' * 'state -> 'state,
                  bind : 'context * binder -> 'context}
@@ -98,12 +106,13 @@ end
 
 structure Sgn : sig
     datatype binder =
-             RelC of string * Elab.kind
+             RelK of string
+           | RelC of string * Elab.kind
            | NamedC of string * int * Elab.kind
            | Str of string * Elab.sgn
            | Sgn of string * Elab.sgn
 
-    val mapfoldB : {kind : (Elab.kind', 'state, 'abort) Search.mapfolder,
+    val mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB,
                     con : ('context, Elab.con', 'state, 'abort) Search.mapfolderB,
                     sgn_item : ('context, Elab.sgn_item', 'state, 'abort) Search.mapfolderB,
                     sgn : ('context, Elab.sgn', 'state, 'abort) Search.mapfolderB,
@@ -127,14 +136,15 @@ end
 
 structure Decl : sig
     datatype binder =
-             RelC of string * Elab.kind
+             RelK of string
+           | RelC of string * Elab.kind
            | NamedC of string * int * Elab.kind
            | RelE of string * Elab.con
            | NamedE of string * Elab.con
            | Str of string * Elab.sgn
            | Sgn of string * Elab.sgn
 
-    val mapfoldB : {kind : (Elab.kind', 'state, 'abort) Search.mapfolder,
+    val mapfoldB : {kind : ('context, Elab.kind', 'state, 'abort) Search.mapfolderB,
                     con : ('context, Elab.con', 'state, 'abort) Search.mapfolderB,
                     exp : ('context, Elab.exp', 'state, 'abort) Search.mapfolderB,
                     sgn_item : ('context, Elab.sgn_item', 'state, 'abort) Search.mapfolderB,
@@ -168,7 +178,7 @@ structure Decl : sig
                   decl : Elab.decl' -> 'a option}
                  -> Elab.decl -> 'a option
 
-    val foldMapB : {kind : Elab.kind' * 'state -> Elab.kind' * 'state,
+    val foldMapB : {kind : 'context * Elab.kind' * 'state -> Elab.kind' * 'state,
                     con : 'context * Elab.con' * 'state -> Elab.con' * 'state,
                     exp : 'context * Elab.exp' * 'state -> Elab.exp' * 'state,
                     sgn_item : 'context * Elab.sgn_item' * 'state -> Elab.sgn_item' * 'state,
diff --git a/src/elab_util.sml b/src/elab_util.sml
index f052a06d..be1c9459 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -43,44 +43,60 @@ structure S = Search
 
 structure Kind = struct
 
-fun mapfold f =
+fun mapfoldB {kind, bind} =
     let
-        fun mfk k acc =
-            S.bindP (mfk' k acc, f)
+        fun mfk ctx k acc =
+            S.bindP (mfk' ctx k acc, kind ctx)
 
-        and mfk' (kAll as (k, loc)) =
+        and mfk' ctx (kAll as (k, loc)) =
             case k of
                 KType => S.return2 kAll
 
               | KArrow (k1, k2) =>
-                S.bind2 (mfk k1,
+                S.bind2 (mfk ctx k1,
                       fn k1' =>
-                         S.map2 (mfk k2,
+                         S.map2 (mfk ctx k2,
                               fn k2' =>
                                  (KArrow (k1', k2'), loc)))
 
               | KName => S.return2 kAll
 
               | KRecord k =>
-                S.map2 (mfk k,
+                S.map2 (mfk ctx k,
                         fn k' =>
                            (KRecord k', loc))
 
               | KUnit => S.return2 kAll
 
               | KTuple ks =>
-                S.map2 (ListUtil.mapfold mfk ks,
+                S.map2 (ListUtil.mapfold (mfk ctx) ks,
                         fn ks' =>
                            (KTuple ks', loc))
 
               | KError => S.return2 kAll
 
-              | KUnif (_, _, ref (SOME k)) => mfk' k
+              | KUnif (_, _, ref (SOME k)) => mfk' ctx k
               | KUnif _ => S.return2 kAll
+
+              | KRel _ => S.return2 kAll
+              | KFun (x, k) =>
+                S.map2 (mfk (bind (ctx, x)) k,
+                        fn k' =>
+                           (KFun (x, k'), loc))
     in
         mfk
     end
 
+fun mapfold fk =
+    mapfoldB {kind = fn () => fk,
+              bind = fn ((), _) => ()} ()
+
+fun mapB {kind, bind} ctx k =
+    case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()),
+                   bind = bind} ctx k () of
+        S.Continue (k, ()) => k
+      | S.Return _ => raise Fail "ElabUtil.Kind.mapB: Impossible"
+
 fun exists f k =
     case mapfold (fn k => fn () =>
                              if f k then
@@ -95,12 +111,13 @@ end
 structure Con = struct
 
 datatype binder =
-         Rel of string * Elab.kind
-       | Named of string * int * Elab.kind
+         RelK of string
+       | RelC of string * Elab.kind
+       | NamedC of string * int * Elab.kind
 
 fun mapfoldB {kind = fk, con = fc, bind} =
     let
-        val mfk = Kind.mapfold fk
+        val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, s) => bind (ctx, RelK s)}
 
         fun mfc ctx c acc =
             S.bindP (mfc' ctx c acc, fc ctx)
@@ -114,9 +131,9 @@ fun mapfoldB {kind = fk, con = fc, bind} =
                               fn c2' =>
                                  (TFun (c1', c2'), loc)))
               | TCFun (e, x, k, c) =>
-                S.bind2 (mfk k,
+                S.bind2 (mfk ctx k,
                       fn k' =>
-                         S.map2 (mfc (bind (ctx, Rel (x, k))) c,
+                         S.map2 (mfc (bind (ctx, RelC (x, k))) c,
                               fn c' =>
                                  (TCFun (e, x, k', c'), loc)))
               | CDisjoint (ai, c1, c2, c3) =>
@@ -142,16 +159,16 @@ fun mapfoldB {kind = fk, con = fc, bind} =
                               fn c2' =>
                                  (CApp (c1', c2'), loc)))
               | CAbs (x, k, c) =>
-                S.bind2 (mfk k,
+                S.bind2 (mfk ctx k,
                       fn k' =>
-                         S.map2 (mfc (bind (ctx, Rel (x, k))) c,
+                         S.map2 (mfc (bind (ctx, RelC (x, k))) c,
                               fn c' =>
                                  (CAbs (x, k', c'), loc)))
 
               | CName _ => S.return2 cAll
 
               | CRecord (k, xcs) =>
-                S.bind2 (mfk k,
+                S.bind2 (mfk ctx k,
                       fn k' =>
                          S.map2 (ListUtil.mapfold (fn (x, c) =>
                                                       S.bind2 (mfc ctx x,
@@ -169,9 +186,9 @@ fun mapfoldB {kind = fk, con = fc, bind} =
                               fn c2' =>
                                  (CConcat (c1', c2'), loc)))
               | CMap (k1, k2) =>
-                S.bind2 (mfk k1,
+                S.bind2 (mfk ctx k1,
                          fn k1' =>
-                            S.map2 (mfk k2,
+                            S.map2 (mfk ctx k2,
                                     fn k2' =>
                                        (CMap (k1', k2'), loc)))
 
@@ -190,17 +207,32 @@ fun mapfoldB {kind = fk, con = fc, bind} =
               | CError => S.return2 cAll
               | CUnif (_, _, _, ref (SOME c)) => mfc' ctx c
               | CUnif _ => S.return2 cAll
+
+              | CKAbs (x, c) =>
+                S.map2 (mfc (bind (ctx, RelK x)) c,
+                        fn c' =>
+                           (CKAbs (x, c'), loc))
+              | CKApp (c, k) =>
+                S.bind2 (mfc ctx c,
+                      fn c' =>
+                         S.map2 (mfk ctx k,
+                                 fn k' =>
+                                    (CKApp (c', k'), loc)))
+              | TKFun (x, c) =>
+                S.map2 (mfc (bind (ctx, RelK x)) c,
+                        fn c' =>
+                           (TKFun (x, c'), loc))
     in
         mfc
     end
 
 fun mapfold {kind = fk, con = fc} =
-    mapfoldB {kind = fk,
+    mapfoldB {kind = fn () => fk,
               con = fn () => fc,
               bind = fn ((), _) => ()} ()
 
 fun mapB {kind, con, bind} ctx c =
-    case mapfoldB {kind = fn k => fn () => S.Continue (kind k, ()),
+    case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()),
                    con = fn ctx => fn c => fn () => S.Continue (con ctx c, ()),
                    bind = bind} ctx c () of
         S.Continue (c, ()) => c
@@ -227,7 +259,7 @@ fun exists {kind, con} k =
       | S.Continue _ => false
 
 fun foldB {kind, con, bind} ctx st c =
-    case mapfoldB {kind = fn k => fn st => S.Continue (k, kind (k, st)),
+    case mapfoldB {kind = fn ctx => fn k => fn st => S.Continue (k, kind (ctx, k, st)),
                    con = fn ctx => fn c => fn st => S.Continue (c, con (ctx, c, st)),
                    bind = bind} ctx c st of
         S.Continue (_, st) => st
@@ -238,20 +270,22 @@ end
 structure Exp = struct
 
 datatype binder =
-         RelC of string * Elab.kind
+         RelK of string
+       | RelC of string * Elab.kind
        | NamedC of string * int * Elab.kind
        | RelE of string * Elab.con
        | NamedE of string * Elab.con
 
 fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
     let
-        val mfk = Kind.mapfold fk
+        val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, x) => bind (ctx, RelK x)}
 
         fun bind' (ctx, b) =
             let
                 val b' = case b of
-                             Con.Rel x => RelC x
-                           | Con.Named x => NamedC x
+                             Con.RelK x => RelK x
+                           | Con.RelC x => RelC x
+                           | Con.NamedC x => NamedC x
             in
                 bind (ctx, b')
             end
@@ -288,7 +322,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
                               fn c' =>
                                  (ECApp (e', c'), loc)))
               | ECAbs (expl, x, k, e) =>
-                S.bind2 (mfk k,
+                S.bind2 (mfk ctx k,
                       fn k' =>
                          S.map2 (mfe (bind (ctx, RelC (x, k))) e,
                               fn e' =>
@@ -347,11 +381,6 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
                                       fn rest' =>
                                          (ECutMulti (e', c', {rest = rest'}), loc))))
 
-              | EFold k =>
-                S.map2 (mfk k,
-                         fn k' =>
-                            (EFold k', loc))
-
               | ECase (e, pes, {disc, result}) =>
                 S.bind2 (mfe ctx e,
                          fn e' =>
@@ -406,6 +435,17 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
                                        (ELet (des', e'), loc)))
                 end
 
+              | EKAbs (x, e) =>
+                S.map2 (mfe (bind (ctx, RelK x)) e,
+                        fn e' =>
+                           (EKAbs (x, e'), loc))
+              | EKApp (e, k) =>
+                S.bind2 (mfe ctx e,
+                        fn e' =>
+                           S.map2 (mfk ctx k,
+                                   fn k' =>
+                                      (EKApp (e', k'), loc)))
+
         and mfed ctx (dAll as (d, loc)) =
             case d of
                 EDVal vi =>
@@ -432,7 +472,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
     end
 
 fun mapfold {kind = fk, con = fc, exp = fe} =
-    mapfoldB {kind = fk,
+    mapfoldB {kind = fn () => fk,
               con = fn () => fc,
               exp = fn () => fe,
               bind = fn ((), _) => ()} ()
@@ -457,7 +497,7 @@ fun exists {kind, con, exp} k =
       | S.Continue _ => false
 
 fun mapB {kind, con, exp, bind} ctx e =
-    case mapfoldB {kind = fn k => fn () => S.Continue (kind k, ()),
+    case mapfoldB {kind = fn ctx => fn k => fn () => S.Continue (kind ctx k, ()),
                    con = fn ctx => fn c => fn () => S.Continue (con ctx c, ()),
                    exp = fn ctx => fn e => fn () => S.Continue (exp ctx e, ()),
                    bind = bind} ctx e () of
@@ -465,7 +505,7 @@ fun mapB {kind, con, exp, bind} ctx e =
       | S.Return _ => raise Fail "ElabUtil.Exp.mapB: Impossible"
 
 fun foldB {kind, con, exp, bind} ctx st e =
-    case mapfoldB {kind = fn k => fn st => S.Continue (k, kind (k, st)),
+    case mapfoldB {kind = fn ctx => fn k => fn st => S.Continue (k, kind (ctx, k, st)),
                    con = fn ctx => fn c => fn st => S.Continue (c, con (ctx, c, st)),
                    exp = fn ctx => fn e => fn st => S.Continue (e, exp (ctx, e, st)),
                    bind = bind} ctx e st of
@@ -477,7 +517,8 @@ end
 structure Sgn = struct
 
 datatype binder =
-         RelC of string * Elab.kind
+         RelK of string
+       | RelC of string * Elab.kind
        | NamedC of string * int * Elab.kind
        | Str of string * Elab.sgn
        | Sgn of string * Elab.sgn
@@ -487,14 +528,15 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} =
         fun bind' (ctx, b) =
             let
                 val b' = case b of
-                             Con.Rel x => RelC x
-                           | Con.Named x => NamedC x
+                             Con.RelK x => RelK x
+                           | Con.RelC x => RelC x
+                           | Con.NamedC x => NamedC x
             in
                 bind (ctx, b')
             end
         val con = Con.mapfoldB {kind = kind, con = con, bind = bind'}
 
-        val kind = Kind.mapfold kind
+        val kind = Kind.mapfoldB {kind = kind, bind = fn (ctx, x) => bind (ctx, RelK x)}
 
         fun sgi ctx si acc =
             S.bindP (sgi' ctx si acc, sgn_item ctx)
@@ -502,11 +544,11 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} =
         and sgi' ctx (siAll as (si, loc)) =
             case si of
                 SgiConAbs (x, n, k) =>
-                S.map2 (kind k,
+                S.map2 (kind ctx k,
                      fn k' =>
                         (SgiConAbs (x, n, k'), loc))
               | SgiCon (x, n, k, c) =>
-                S.bind2 (kind k,
+                S.bind2 (kind ctx k,
                      fn k' =>
                         S.map2 (con ctx c,
                              fn c' =>
@@ -548,11 +590,11 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} =
                                     fn c2' =>
                                        (SgiConstraint (c1', c2'), loc)))
               | SgiClassAbs (x, n, k) =>
-                S.map2 (kind k,
+                S.map2 (kind ctx k,
                         fn k' =>
                            (SgiClassAbs (x, n, k'), loc))
               | SgiClass (x, n, k, c) =>
-                S.bind2 (kind k,
+                S.bind2 (kind ctx k,
                       fn k' => 
                          S.map2 (con ctx c,
                               fn c' =>
@@ -608,7 +650,7 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} =
     end
 
 fun mapfold {kind, con, sgn_item, sgn} =
-    mapfoldB {kind = kind,
+    mapfoldB {kind = fn () => kind,
               con = fn () => con,
               sgn_item = fn () => sgn_item,
               sgn = fn () => sgn,
@@ -627,7 +669,8 @@ end
 structure Decl = struct
 
 datatype binder =
-         RelC of string * Elab.kind
+         RelK of string
+       | RelC of string * Elab.kind
        | NamedC of string * int * Elab.kind
        | RelE of string * Elab.con
        | NamedE of string * Elab.con
@@ -636,13 +679,14 @@ datatype binder =
 
 fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = fst, decl = fd, bind} =
     let
-        val mfk = Kind.mapfold fk
+        val mfk = Kind.mapfoldB {kind = fk, bind = fn (ctx, x) => bind (ctx, RelK x)}
 
         fun bind' (ctx, b) =
             let
                 val b' = case b of
-                             Con.Rel x => RelC x
-                           | Con.Named x => NamedC x
+                             Con.RelK x => RelK x
+                           | Con.RelC x => RelC x
+                           | Con.NamedC x => NamedC x
             in
                 bind (ctx, b')
             end
@@ -651,7 +695,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
         fun bind' (ctx, b) =
             let
                 val b' = case b of
-                             Exp.RelC x => RelC x
+                             Exp.RelK x => RelK x
+                           | Exp.RelC x => RelC x
                            | Exp.NamedC x => NamedC x
                            | Exp.RelE x => RelE x
                            | Exp.NamedE x => NamedE x
@@ -663,7 +708,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
         fun bind' (ctx, b) =
             let
                 val b' = case b of
-                             Sgn.RelC x => RelC x
+                             Sgn.RelK x => RelK x
+                           | Sgn.RelC x => RelC x
                            | Sgn.NamedC x => NamedC x
                            | Sgn.Sgn x => Sgn x
                            | Sgn.Str x => Str x
@@ -760,7 +806,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
         and mfd' ctx (dAll as (d, loc)) =
             case d of
                 DCon (x, n, k, c) =>
-                S.bind2 (mfk k,
+                S.bind2 (mfk ctx k,
                          fn k' =>
                             S.map2 (mfc ctx c,
                                     fn c' =>
@@ -825,7 +871,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
               | DSequence _ => S.return2 dAll
 
               | DClass (x, n, k, c) =>
-                S.bind2 (mfk k,
+                S.bind2 (mfk ctx k,
                          fn k' =>
                             S.map2 (mfc ctx c,
                                  fn c' =>
@@ -849,7 +895,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
     end
 
 fun mapfold {kind, con, exp, sgn_item, sgn, str, decl} =
-    mapfoldB {kind = kind,
+    mapfoldB {kind = fn () => kind,
               con = fn () => con,
               exp = fn () => exp,
               sgn_item = fn () => sgn_item,
@@ -938,7 +984,7 @@ fun search {kind, con, exp, sgn_item, sgn, str, decl} k =
       | S.Continue _ => NONE
 
 fun foldMapB {kind, con, exp, sgn_item, sgn, str, decl, bind} ctx st d =
-    case mapfoldB {kind = fn x => fn st => S.Continue (kind (x, st)),
+    case mapfoldB {kind = fn ctx => fn x => fn st => S.Continue (kind (ctx, x, st)),
                    con = fn ctx => fn x => fn st => S.Continue (con (ctx, x, st)),
                    exp = fn ctx => fn x => fn st => S.Continue (exp (ctx, x, st)),
                    sgn_item = fn ctx => fn x => fn st => S.Continue (sgn_item (ctx, x, st)),
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 0c335603..54543ae9 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -61,7 +61,7 @@
 
  exception KUnify' of kunify_error
 
- fun unifyKinds' (k1All as (k1, _)) (k2All as (k2, _)) =
+ fun unifyKinds' env (k1All as (k1, _)) (k2All as (k2, _)) =
      let
          fun err f = raise KUnify' (f (k1All, k2All))
      in
@@ -70,19 +70,27 @@
            | (L'.KUnit, L'.KUnit) => ()
 
            | (L'.KArrow (d1, r1), L'.KArrow (d2, r2)) =>
-             (unifyKinds' d1 d2;
-              unifyKinds' r1 r2)
+             (unifyKinds' env d1 d2;
+              unifyKinds' env r1 r2)
            | (L'.KName, L'.KName) => ()
-           | (L'.KRecord k1, L'.KRecord k2) => unifyKinds' k1 k2
+           | (L'.KRecord k1, L'.KRecord k2) => unifyKinds' env k1 k2
            | (L'.KTuple ks1, L'.KTuple ks2) =>
-             ((ListPair.appEq (fn (k1, k2) => unifyKinds' k1 k2) (ks1, ks2))
+             ((ListPair.appEq (fn (k1, k2) => unifyKinds' env k1 k2) (ks1, ks2))
               handle ListPair.UnequalLengths => err KIncompatible)
 
+           | (L'.KRel n1, L'.KRel n2) =>
+             if n1 = n2 then
+                 ()
+             else
+                 err KIncompatible
+           | (L'.KFun (x, k1), L'.KFun (_, k2)) =>
+             unifyKinds' (E.pushKRel env x) k1 k2
+
            | (L'.KError, _) => ()
            | (_, L'.KError) => ()
 
-           | (L'.KUnif (_, _, ref (SOME k1All)), _) => unifyKinds' k1All k2All
-           | (_, L'.KUnif (_, _, ref (SOME k2All))) => unifyKinds' k1All k2All
+           | (L'.KUnif (_, _, ref (SOME k1All)), _) => unifyKinds' env k1All k2All
+           | (_, L'.KUnif (_, _, ref (SOME k2All))) => unifyKinds' env k1All k2All
 
            | (L'.KUnif (_, _, r1), L'.KUnif (_, _, r2)) =>
              if r1 = r2 then
@@ -106,12 +114,12 @@
 
  exception KUnify of L'.kind * L'.kind * kunify_error
 
- fun unifyKinds k1 k2 =
-     unifyKinds' k1 k2
+ fun unifyKinds env k1 k2 =
+     unifyKinds' env k1 k2
      handle KUnify' err => raise KUnify (k1, k2, err)
 
  fun checkKind env c k1 k2 =
-     unifyKinds k1 k2
+     unifyKinds env k1 k2
      handle KUnify (k1, k2, err) =>
             conError env (WrongKind (c, k1, k2, err))
 
@@ -172,16 +180,23 @@
 
  end
 
- fun elabKind (k, loc) =
+ fun elabKind env (k, loc) =
      case k of
          L.KType => (L'.KType, loc)
-       | L.KArrow (k1, k2) => (L'.KArrow (elabKind k1, elabKind k2), loc)
+       | L.KArrow (k1, k2) => (L'.KArrow (elabKind env k1, elabKind env k2), loc)
        | L.KName => (L'.KName, loc)
-       | L.KRecord k => (L'.KRecord (elabKind k), loc)
+       | L.KRecord k => (L'.KRecord (elabKind env k), loc)
        | L.KUnit => (L'.KUnit, loc)
-       | L.KTuple ks => (L'.KTuple (map elabKind ks), loc)
+       | L.KTuple ks => (L'.KTuple (map (elabKind env) ks), loc)
        | L.KWild => kunif loc
 
+       | L.KVar s => (case E.lookupK env s of
+                          NONE =>
+                          (kindError env (UnboundKind (loc, s));
+                           kerror)
+                        | SOME n => (L'.KRel n, loc))
+       | L.KFun (x, k) => (L'.KFun (x, elabKind (E.pushKRel env x) k), loc)
+
  fun mapKind (dom, ran, loc)=
      (L'.KArrow ((L'.KArrow (dom, ran), loc),
                  (L'.KArrow ((L'.KRecord dom, loc),
@@ -192,11 +207,31 @@
          L'.KUnif (_, _, ref (SOME k)) => hnormKind k
        | _ => kAll
 
+ open ElabOps
+ val hnormCon = D.hnormCon
+
+ fun elabConHead (c as (_, loc)) k =
+     let
+         fun unravel (k, c) =
+             case hnormKind k of
+                 (L'.KFun (x, k'), _) =>
+                 let
+                     val u = kunif loc
+                             
+                     val k'' = subKindInKind (0, u) k'
+                 in
+                     unravel (k'', (L'.CKApp (c, u), loc))
+                 end
+               | _ => (c, k)
+    in
+         unravel (k, c)
+    end
+
  fun elabCon (env, denv) (c, loc) =
      case c of
          L.CAnnot (c, k) =>
          let
-             val k' = elabKind k
+             val k' = elabKind env k
              val (c', ck, gs) = elabCon (env, denv) c
          in
              checkKind env c' ck k';
@@ -215,13 +250,21 @@
        | L.TCFun (e, x, k, t) =>
          let
              val e' = elabExplicitness e
-             val k' = elabKind k
+             val k' = elabKind env k
              val env' = E.pushCRel env x k'
              val (t', tk, gs) = elabCon (env', D.enter denv) t
          in
              checkKind env t' tk ktype;
              ((L'.TCFun (e', x, k', t'), loc), ktype, gs)
          end
+       | L.TKFun (x, t) =>
+         let
+             val env' = E.pushKRel env x
+             val (t', tk, gs) = elabCon (env', denv) t
+         in
+             checkKind env t' tk ktype;
+             ((L'.TKFun (x, t'), loc), ktype, gs)
+         end
        | L.CDisjoint (c1, c2, c) =>
          let
              val (c1', k1, gs1) = elabCon (env, denv) c1
@@ -253,9 +296,17 @@
               (conError env (UnboundCon (loc, s));
                (cerror, kerror, []))
             | E.Rel (n, k) =>
-              ((L'.CRel n, loc), k, [])
+              let
+                  val (c, k) = elabConHead (L'.CRel n, loc) k
+              in
+                  (c, k, [])
+              end
             | E.Named (n, k) =>
-              ((L'.CNamed n, loc), k, []))
+              let
+                  val (c, k) = elabConHead (L'.CNamed n, loc) k
+              in
+                  (c, k, [])
+              end)
        | L.CVar (m1 :: ms, s) =>
          (case E.lookupStr env m1 of
               NONE => (conError env (UnboundStrInCon (loc, m1));
@@ -292,7 +343,7 @@
          let
              val k' = case ko of
                           NONE => kunif loc
-                        | SOME k => elabKind k
+                        | SOME k => elabKind env k
              val env' = E.pushCRel env x k'
              val (t', tk, gs) = elabCon (env', D.enter denv) t
          in
@@ -300,6 +351,15 @@
               (L'.KArrow (k', tk), loc),
               gs)
          end
+       | L.CKAbs (x, t) =>
+         let
+             val env' = E.pushKRel env x
+             val (t', tk, gs) = elabCon (env', denv) t
+         in
+             ((L'.CKAbs (x, t'), loc),
+              (L'.KFun (x, tk), loc),
+              gs)
+         end
 
        | L.CName s =>
          ((L'.CName s, loc), kname, [])
@@ -392,7 +452,7 @@
 
        | L.CWild k =>
          let
-             val k' = elabKind k
+             val k' = elabKind env k
          in
              (cunif (loc, k'), k', [])
          end
@@ -431,8 +491,6 @@
 
  exception SynUnif = E.SynUnif
 
- open ElabOps
-
  type record_summary = {
       fields : (L'.con * L'.con) list,
       unifs : (L'.con * L'.con option ref) list,
@@ -499,7 +557,12 @@
        | L'.CError => kerror
        | L'.CUnif (_, k, _, _) => k
 
- val hnormCon = D.hnormCon
+       | L'.CKAbs (x, c) => (L'.KFun (x, kindof (E.pushKRel env x) c), loc)
+       | L'.CKApp (c, k) =>
+         (case hnormKind (kindof env c) of
+              (L'.KFun (_, k'), _) => subKindInKind (0, k) k'
+            | k => raise CUnify' (CKindof (k, c, "kapp")))
+       | L'.TKFun _ => ktype
 
  fun deConstraintCon (env, denv) c =
      let
@@ -564,6 +627,10 @@
        | L'.CError => false
        | L'.CUnif (_, k, _, _) => #1 k = L'.KUnit
 
+       | L'.CKAbs _ => false
+       | L'.CKApp _ => false
+       | L'.TKFun _ => false
+
  fun unifyRecordCons (env, denv) (c1, c2) =
      let
          fun rkindof c =
@@ -578,7 +645,7 @@
          val (r1, gs1) = recordSummary (env, denv) c1
          val (r2, gs2) = recordSummary (env, denv) c2
      in
-         unifyKinds k1 k2;
+         unifyKinds env k1 k2;
          unifySummaries (env, denv) (k1, r1, r2);
          gs1 @ gs2
      end
@@ -848,12 +915,13 @@
                  val (c2, gs2) = hnormCon (env, denv) c2
              in
                  let
+                     (*val () = prefaces "unifyCons'" [("old1", p_con env old1),
+                                                     ("old2", p_con env old2),
+                                                     ("c1", p_con env c1),
+                                                     ("c2", p_con env c2)]*)
+
                      val gs3 = unifyCons'' (env, denv) c1 c2
                  in
-                     (*prefaces "unifyCons'" [("c1", p_con env old1),
-                                            ("c2", p_con env old2),
-                                            ("t", PD.string (LargeReal.toString (Time.toReal
-                                                                                 (Time.- (Time.now (), befor)))))];*)
                      gs1 @ gs2 @ gs3
                  end
                  handle ex => guessMap (env, denv) (c1, c2, gs1 @ gs2, ex)
@@ -878,7 +946,7 @@
              if expl1 <> expl2 then
                  err CExplicitness
              else
-                 (unifyKinds d1 d2;
+                 (unifyKinds env d1 d2;
                   let
                       val denv' = D.enter denv
                       (*val befor = Time.now ()*)
@@ -906,7 +974,7 @@
              (unifyCons' (env, denv) d1 d2;
               unifyCons' (env, denv) r1 r2)
            | (L'.CAbs (x1, k1, c1), L'.CAbs (_, k2, c2)) =>
-             (unifyKinds k1 k2;
+             (unifyKinds env k1 k2;
               unifyCons' (E.pushCRel env x1 k1, D.enter denv) c1 c2)
 
            | (L'.CName n1, L'.CName n2) =>
@@ -954,6 +1022,19 @@
              else
                  err CIncompatible
 
+           | (L'.CMap (dom1, ran1), L'.CMap (dom2, ran2)) =>
+             (unifyKinds env dom1 dom2;
+              unifyKinds env ran1 ran2;
+              [])
+
+           | (L'.CKAbs (x, c1), L'.CKAbs (_, c2)) =>
+             unifyCons' (E.pushKRel env x, denv) c1 c2
+           | (L'.CKApp (c1, k1), L'.CKApp (c2, k2)) =>
+             (unifyKinds env k1 k2;
+              unifyCons' (env, denv) c1 c2)
+           | (L'.TKFun (x, c1), L'.TKFun (_, c2)) =>
+             unifyCons' (E.pushKRel env x, denv) c1 c2
+
            | (L'.CError, _) => []
            | (_, L'.CError) => []
 
@@ -966,7 +1047,7 @@
              if r1 = r2 then
                  []
              else
-                 (unifyKinds k1 k2;
+                 (unifyKinds env k1 k2;
                   r1 := SOME c2All;
                   [])
 
@@ -983,11 +1064,6 @@
                  (r := SOME c1All;
                   [])
 
-           | (L'.CMap (dom1, ran1), L'.CMap (dom2, ran2)) =>
-             (unifyKinds dom1 dom2;
-              unifyKinds ran1 ran2;
-              [])
-
            | _ => err CIncompatible
      end
 
@@ -1013,36 +1089,7 @@
          P.Int _ => !int
        | P.Float _ => !float
        | P.String _ => !string
-
- fun recCons (k, nm, v, rest, loc) =
-     (L'.CConcat ((L'.CRecord (k, [(nm, v)]), loc),
-                  rest), loc)
-
- fun foldType (dom, loc) =
-     (L'.TCFun (L'.Explicit, "ran", (L'.KArrow ((L'.KRecord dom, loc), (L'.KType, loc)), loc),
-                (L'.TFun ((L'.TCFun (L'.Explicit, "nm", (L'.KName, loc),
-                                     (L'.TCFun (L'.Explicit, "v", dom,
-                                                (L'.TCFun (L'.Explicit, "rest", (L'.KRecord dom, loc),
-                                                           (L'.TFun ((L'.CApp ((L'.CRel 3, loc), (L'.CRel 0, loc)), loc),
-                                                                     (L'.CDisjoint (L'.Instantiate,
-                                                                                    (L'.CRecord
-                                                                                         ((L'.KUnit, loc),
-                                                                                          [((L'.CRel 2, loc),
-                                                                                            (L'.CUnit, loc))]), loc),
-                                                                                    (L'.CRel 0, loc),
-                                                                                    (L'.CApp ((L'.CRel 3, loc),
-                                                                                              recCons (dom,
-                                                                                                       (L'.CRel 2, loc),
-                                                                                                       (L'.CRel 1, loc),
-                                                                                                       (L'.CRel 0, loc),
-                                                                                                       loc)), loc)),
-                                                                      loc)), loc)),
-                                                 loc)), loc)), loc),
-                          (L'.TFun ((L'.CApp ((L'.CRel 0, loc), (L'.CRecord (dom, []), loc)), loc),
-                                    (L'.TCFun (L'.Explicit, "r", (L'.KRecord dom, loc),
-                                               (L'.CApp ((L'.CRel 1, loc), (L'.CRel 0, loc)), loc)), loc)),
-                           loc)), loc)), loc)
-
+                           
  datatype constraint =
           Disjoint of D.goal
         | TypeClass of E.env * L'.con * L'.exp option ref * ErrorMsg.span
@@ -1056,7 +1103,16 @@
                  val (t, gs) = hnormCon (env, denv) t
              in
                  case t of
-                     (L'.TCFun (L'.Implicit, x, k, t'), _) =>
+                     (L'.TKFun (x, t'), _) =>
+                     let
+                         val u = kunif loc
+
+                         val t'' = subKindInCon (0, u) t'
+                         val (e, t, gs') = unravel (t'', (L'.EKApp (e, u), loc))
+                     in
+                         (e, t, enD gs @ gs')
+                     end
+                   | (L'.TCFun (L'.Implicit, x, k, t'), _) =>
                      let
                          val u = cunif (loc, k)
 
@@ -1575,7 +1631,7 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
           | L.ECAbs (expl, x, k, e) =>
             let
                 val expl' = elabExplicitness expl
-                val k' = elabKind k
+                val k' = elabKind env k
 
                 val env' = E.pushCRel env x k'
                 val (e', et, gs) = elabExp (env', D.enter denv) e
@@ -1584,6 +1640,15 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
                  (L'.TCFun (expl', x, k', et), loc),
                  gs)
             end
+          | L.EKAbs (x, e) =>
+            let
+                val env' = E.pushKRel env x
+                val (e', et, gs) = elabExp (env', denv) e
+            in
+                ((L'.EKAbs (x, e'), loc),
+                 (L'.TKFun (x, et), loc),
+                 gs)
+            end
 
           | L.EDisjoint (c1, c2, e) =>
             let
@@ -1710,13 +1775,6 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
                  gs1 @ enD gs2 @ enD gs3 @ enD gs4)
             end
 
-          | L.EFold =>
-            let
-                val dom = kunif loc
-            in
-                ((L'.EFold dom, loc), foldType (dom, loc), [])
-            end
-
           | L.ECase (e, pes) =>
             let
                 val (e', et, gs1) = elabExp (env, denv) e
@@ -1781,6 +1839,7 @@ and elabEdecl denv (dAll as (d, loc), (env, gs : constraint list)) =
                         case e of
                             L.EAbs _ => true
                           | L.ECAbs (_, _, _, e) => allowable e
+                          | L.EKAbs (_, e) => allowable e
                           | L.EDisjoint (_, _, e) => allowable e
                           | _ => false
 
@@ -1859,7 +1918,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) =
     case sgi of
         L.SgiConAbs (x, k) =>
         let
-            val k' = elabKind k
+            val k' = elabKind env k
 
             val (env', n) = E.pushCNamed env x k' NONE
         in
@@ -1870,7 +1929,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) =
         let
             val k' = case ko of
                          NONE => kunif loc
-                       | SOME k => elabKind k
+                       | SOME k => elabKind env k
 
             val (c', ck, gs') = elabCon (env, denv) c
             val (env', n) = E.pushCNamed env x k' (SOME c')
@@ -1979,7 +2038,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) =
             val (env', n) = E.pushENamed env x c'
             val c' = normClassConstraint env c'
         in
-            (unifyKinds ck ktype
+            (unifyKinds env ck ktype
              handle KUnify ue => strError env (NotType (ck, ue)));
 
             ([(L'.SgiVal (x, n, c'), loc)], (env', denv, gs' @ gs))
@@ -2027,7 +2086,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) =
 
       | L.SgiClassAbs (x, k) =>
         let
-            val k = elabKind k
+            val k = elabKind env k
             val k' = (L'.KArrow (k, (L'.KType, loc)), loc)
             val (env, n) = E.pushCNamed env x k' NONE
             val env = E.pushClass env n
@@ -2037,7 +2096,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) =
 
       | L.SgiClass (x, k, c) =>
         let
-            val k = elabKind k
+            val k = elabKind env k
             val k' = (L'.KArrow (k, (L'.KType, loc)), loc)
             val (c', ck, gs) = elabCon (env, denv) c
             val (env, n) = E.pushCNamed env x k' (SOME c')
@@ -2149,7 +2208,7 @@ and elabSgn (env, denv) (sgn, loc) =
               | L'.SgnConst sgis =>
                 if List.exists (fn (L'.SgiConAbs (x', _, k), _) =>
                                    x' = x andalso
-                                   (unifyKinds k ck
+                                   (unifyKinds env k ck
                                     handle KUnify x => sgnError env (WhereWrongKind x);
                                     true)
                                  | _ => false) sgis then
@@ -2355,7 +2414,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
                                      fun found (x', n1, k1, co1) =
                                          if x = x' then
                                              let
-                                                 val () = unifyKinds k1 k2
+                                                 val () = unifyKinds env k1 k2
                                                      handle KUnify (k1, k2, err) =>
                                                             sgnError env (SgiWrongKind (sgi1All, k1, sgi2All, k2, err))
                                                  val env = E.pushCNamedAs env x n1 k1 co1
@@ -2606,7 +2665,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
                                      fun found (x', n1, k1, co) =
                                          if x = x' then
                                              let
-                                                 val () = unifyKinds k1 k2
+                                                 val () = unifyKinds env k1 k2
                                                      handle KUnify (k1, k2, err) =>
                                                             sgnError env (SgiWrongKind (sgi1All, k1, sgi2All, k2, err))
 
@@ -2635,7 +2694,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) =
                                      fun found (x', n1, k1, c1) =
                                          if x = x' then
                                              let
-                                                 val () = unifyKinds k1 k2
+                                                 val () = unifyKinds env k1 k2
                                                      handle KUnify (k1, k2, err) =>
                                                             sgnError env (SgiWrongKind (sgi1All, k1, sgi2All, k2, err))
 
@@ -2702,6 +2761,9 @@ fun positive self =
               | CAbs _ => false
               | CDisjoint (c1, c2, c3) => none c1 andalso none c2 andalso none c3
 
+              | CKAbs _ => false
+              | TKFun _ => false
+
               | CName _ => true
 
               | CRecord xcs => List.all (fn (c1, c2) => none c1 andalso none c2) xcs
@@ -2728,6 +2790,9 @@ fun positive self =
               | CAbs _ => false
               | CDisjoint (c1, c2, c3) => none c1 andalso none c2 andalso none c3
 
+              | CKAbs _ => false
+              | TKFun _ => false
+
               | CName _ => true
 
               | CRecord xcs => List.all (fn (c1, c2) => none c1 andalso pos c2) xcs
@@ -2777,6 +2842,9 @@ fun wildifyStr env (str, sgn) =
                        | L'.KUnif (_, _, ref (SOME k)) => decompileKind k
                        | L'.KUnif _ => NONE
 
+                       | L'.KRel _ => NONE
+                       | L'.KFun _ => NONE
+
                  fun decompileCon env (c, loc) =
                      case c of
                          L'.CRel i =>
@@ -2914,7 +2982,7 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) =
                 let
                     val k' = case ko of
                                  NONE => kunif loc
-                               | SOME k => elabKind k
+                               | SOME k => elabKind env k
 
                     val (c', ck, gs') = elabCon (env, denv) c
                     val (env', n) = E.pushCNamed env x k' (SOME c')
@@ -3047,6 +3115,7 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) =
                         case e of
                             L.EAbs _ => true
                           | L.ECAbs (_, _, _, e) => allowable e
+                          | L.EKAbs (_, e) => allowable e
                           | L.EDisjoint (_, _, e) => allowable e
                           | _ => false
 
@@ -3264,7 +3333,7 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) =
 
               | L.DClass (x, k, c) =>
                 let
-                    val k = elabKind k
+                    val k = elabKind env k
                     val k' = (L'.KArrow (k, (L'.KType, loc)), loc)
                     val (c', ck, gs') = elabCon (env, denv) c
                     val (env, n) = E.pushCNamed env x k' (SOME c')
diff --git a/src/expl.sml b/src/expl.sml
index c0d291b5..0101dd1f 100644
--- a/src/expl.sml
+++ b/src/expl.sml
@@ -93,7 +93,6 @@ datatype exp' =
        | EConcat of exp * con * exp * con
        | ECut of exp * con * { field : con, rest : con }
        | ECutMulti of exp * con * { rest : con }
-       | EFold of kind
 
        | ECase of exp * (pat * exp) list * { disc : con, result : con }
 
diff --git a/src/expl_print.sml b/src/expl_print.sml
index 7044bfa2..313fef5c 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -351,7 +351,6 @@ fun p_exp' par env (e, loc) =
                               string "---",
                               space,
                               p_con' true env c])
-      | EFold _ => string "fold"
 
       | EWrite e => box [string "write(",
                          p_exp env e,
diff --git a/src/expl_util.sml b/src/expl_util.sml
index a2b5f2f6..febf3586 100644
--- a/src/expl_util.sml
+++ b/src/expl_util.sml
@@ -311,10 +311,6 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
                                  S.map2 (mfc ctx rest,
                                       fn rest' =>
                                          (ECutMulti (e', c', {rest = rest'}), loc))))
-              | EFold k =>
-                S.map2 (mfk k,
-                         fn k' =>
-                            (EFold k', loc))
 
               | EWrite e =>
                 S.map2 (mfe ctx e,
diff --git a/src/explify.sml b/src/explify.sml
index a4eab0ba..5bce9268 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -107,8 +107,6 @@ fun explifyExp (e, loc) =
                                                      {field = explifyCon field, rest = explifyCon rest}), loc)
       | L.ECutMulti (e1, c, {rest}) => (L'.ECutMulti (explifyExp e1, explifyCon c,
                                                       {rest = explifyCon rest}), loc)
-      | L.EFold k => (L'.EFold (explifyKind k), loc)
-
       | L.ECase (e, pes, {disc, result}) =>
         (L'.ECase (explifyExp e,
                    map (fn (p, e) => (explifyPat p, explifyExp e)) pes,
diff --git a/src/monoize.sml b/src/monoize.sml
index 898d3e61..96ef2c6a 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2183,7 +2183,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
           | L.EConcat _ => poly ()
           | L.ECut _ => poly ()
           | L.ECutMulti _ => poly ()
-          | L.EFold _ => poly ()
 
           | L.ECase (e, pes, {disc, result}) =>
             let
diff --git a/src/reduce.sml b/src/reduce.sml
index 949b2a6d..77718b66 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -214,20 +214,6 @@ fun conAndExp (namedC, namedE) =
                 in
                     case #1 e of
                         ECAbs (_, _, b) => exp (KnownC c :: deKnown env) b
-
-                      | EApp ((EApp ((ECApp ((EFold _, _), _), _), f), _), i) =>
-                        (case #1 c of
-                             CRecord (_, []) => i
-                           | CRecord (k, (nm, v) :: rest) =>
-                             let
-                                 val rest = (CRecord (k, rest), loc)
-                             in
-                                 exp (deKnown env)
-                                     (EApp ((ECApp ((ECApp ((ECApp (f, nm), loc), v), loc), rest), loc),
-                                            (ECApp (e, rest), loc)), loc)
-                             end
-                           | _ => (ECApp (e, c), loc))
-
                       | _ => (ECApp (e, c), loc)
                 end
 
@@ -334,8 +320,6 @@ fun conAndExp (namedC, namedE) =
                       | _ => default ()
                 end
 
-              | EFold _ => all
-
               | ECase (e, pes, {disc, result}) =>
                 let
                     fun patBinds (p, _) =
diff --git a/src/reduce_local.sml b/src/reduce_local.sml
index 7de7d799..25b1023a 100644
--- a/src/reduce_local.sml
+++ b/src/reduce_local.sml
@@ -107,8 +107,6 @@ fun exp env (all as (e, loc)) =
       | ECut (e, c, others) => (ECut (exp env e, c, others), loc)
       | ECutMulti (e, c, others) => (ECutMulti (exp env e, c, others), loc)
 
-      | EFold _ => all
-
       | ECase (e, pes, others) =>
         let
             fun patBinds (p, _) =
diff --git a/src/source.sml b/src/source.sml
index d70d0f5d..e9531245 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -38,6 +38,9 @@ datatype kind' =
        | KTuple of kind list
        | KWild
 
+       | KFun of string * kind
+       | KVar of string
+
 withtype kind = kind' located
 
 datatype explicitness =
@@ -56,6 +59,9 @@ datatype con' =
        | CAbs of string * kind option * con
        | CDisjoint of con * con * con
 
+       | CKAbs of string * con
+       | TKFun of string * con
+
        | CName of string
 
        | CRecord of (con * con) list
@@ -119,12 +125,13 @@ datatype exp' =
        | ECAbs of explicitness * string * kind * exp
        | EDisjoint of con * con * exp
 
+       | EKAbs of string * exp
+
        | ERecord of (con * exp) list
        | EField of exp * con
        | EConcat of exp * exp
        | ECut of exp * con
        | ECutMulti of exp * con
-       | EFold
 
        | EWild
 
diff --git a/src/source_print.sml b/src/source_print.sml
index 148157c2..f2420947 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -50,6 +50,13 @@ fun p_kind' par (k, _) =
                           p_list_sep (box [space, string "*", space]) p_kind ks,
                           string ")"]
 
+      | KVar x => string x
+      | KFun (x, k) => box [string x,
+                            space,
+                            string "-->",
+                            space,
+                            p_kind k]
+
 and p_kind k = p_kind' false k
 
 fun p_explicitness e =
@@ -156,6 +163,17 @@ fun p_con' par (c, _) =
       | CProj (c, n) => box [p_con c,
                              string ".",
                              string (Int.toString n)]
+
+      | CKAbs (x, c) => box [string x,
+                             space,
+                             string "==>",
+                             space,
+                             p_con c]
+      | TKFun (x, c) => box [string x,
+                             space,
+                             string "-->",
+                             space,
+                             p_con c]
         
 and p_con c = p_con' false c
 
@@ -273,8 +291,6 @@ fun p_exp' par (e, _) =
                                               string "---",
                                               space,
                                               p_con' true c])
-      | EFold => string "fold"
-
       | ECase (e, pes) => parenIf par (box [string "case",
                                             space,
                                             p_exp e,
@@ -300,6 +316,12 @@ fun p_exp' par (e, _) =
                              newline,
                              string "end"]
 
+      | EKAbs (x, e) => box [string x,
+                             space,
+                             string "-->",
+                             space,
+                             p_exp e]
+
 and p_exp e = p_exp' false e
 
 and p_edecl (d, _) =
diff --git a/src/termination.sml b/src/termination.sml
index e89f329e..5dd95f46 100644
--- a/src/termination.sml
+++ b/src/termination.sml
@@ -190,6 +190,7 @@ fun declOk' env (d, loc) =
                                     in
                                         (p, ps, calls)
                                     end
+                                  | EKApp (e, _) => combiner calls e
                                   | _ =>
                                     let
                                         val (p, calls) = exp parent (penv, calls) e
@@ -239,6 +240,13 @@ fun declOk' env (d, loc) =
                         in
                             (Rabble, calls)
                         end
+                      | EKApp _ => apps ()
+                      | EKAbs (_, e) =>
+                        let
+                            val (_, calls) = exp parent (penv, calls) e
+                        in
+                            (Rabble, calls)
+                        end
 
                       | ERecord xets =>
                         let
@@ -278,7 +286,6 @@ fun declOk' env (d, loc) =
                         in
                             (Rabble, calls)
                         end
-                      | EFold _ => (Rabble, calls)
 
                       | ECase (e, pes, _) =>
                         let
diff --git a/src/unnest.sml b/src/unnest.sml
index 8e363301..1d0c2388 100644
--- a/src/unnest.sml
+++ b/src/unnest.sml
@@ -37,7 +37,7 @@ structure U = ElabUtil
 structure IS = IntBinarySet
 
 fun liftExpInExp by =
-    U.Exp.mapB {kind = fn k => k,
+    U.Exp.mapB {kind = fn _ => fn k => k,
                 con = fn _ => fn c => c,
                 exp = fn bound => fn e =>
                                      case e of
@@ -51,7 +51,7 @@ fun liftExpInExp by =
                         | (bound, _) => bound}
 
 val subExpInExp =
-    U.Exp.mapB {kind = fn k => k,
+    U.Exp.mapB {kind = fn _ => fn k => k,
                 con = fn _ => fn c => c,
                 exp = fn (xn, rep) => fn e =>
                                   case e of
@@ -65,7 +65,7 @@ val subExpInExp =
                         | ((xn, rep), U.Exp.RelC _) => (xn, E.liftConInExp 0 rep)
                         | (ctx, _) => ctx}
 
-val fvsCon = U.Con.foldB {kind = fn (_, st) => st,
+val fvsCon = U.Con.foldB {kind = fn (_, _, st) => st,
                           con = fn (cb, c, cvs) =>
                                    case c of
                                        CRel n =>
@@ -76,11 +76,11 @@ val fvsCon = U.Con.foldB {kind = fn (_, st) => st,
                                      | _ => cvs,
                           bind = fn (cb, b) =>
                                     case b of
-                                        U.Con.Rel _ => cb + 1
+                                        U.Con.RelC _ => cb + 1
                                       | _ => cb}
                          0 IS.empty
 
-fun fvsExp nr = U.Exp.foldB {kind = fn (_, st) => st,
+fun fvsExp nr = U.Exp.foldB {kind = fn (_, _, st) => st,
                              con = fn ((cb, eb), c, st as (cvs, evs)) =>
                                       case c of
                                           CRel n =>
@@ -124,7 +124,7 @@ fun positionOf (x : int) ls =
     end
 
 fun squishCon cfv =
-    U.Con.mapB {kind = fn k => k,
+    U.Con.mapB {kind = fn _ => fn k => k,
                 con = fn cb => fn c =>
                                   case c of
                                       CRel n =>
@@ -135,12 +135,12 @@ fun squishCon cfv =
                                     | _ => c,
                 bind = fn (cb, b) =>
                           case b of
-                              U.Con.Rel _ => cb + 1
+                              U.Con.RelC _ => cb + 1
                             | _ => cb}
                0
 
 fun squishExp (nr, cfv, efv) =
-    U.Exp.mapB {kind = fn k => k,
+    U.Exp.mapB {kind = fn _ => fn k => k,
                 con = fn (cb, eb) => fn c =>
                                         case c of
                                             CRel n =>
@@ -169,7 +169,7 @@ type state = {
      decls : (string * int * con * exp) list
 }
 
-fun kind (k, st) = (k, st)
+fun kind (_, k, st) = (k, st)
 
 fun exp ((ks, ts), e as old, st : state) =
     case e of
diff --git a/src/urweb.grm b/src/urweb.grm
index d425caec..b6e4ce72 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -184,10 +184,10 @@ fun tagIn bt =
  | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
  | EQ | COMMA | COLON | DCOLON | TCOLON | DOT | HASH | UNDER | UNDERUNDER | BAR
  | PLUS | MINUS | DIVIDE | DOTDOTDOT | MOD | AT
- | CON | LTYPE | VAL | REC | AND | FUN | MAP | FOLD | UNIT | KUNIT | CLASS
+ | CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS
  | DATATYPE | OF
  | TYPE | NAME
- | ARROW | LARROW | DARROW | STAR | SEMI
+ | ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW
  | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE
  | LET | IN
  | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL
@@ -327,6 +327,8 @@ fun tagIn bt =
 
 %name Urweb
 
+%right KARROW
+%nonassoc DKARROW
 %right SEMI
 %nonassoc LARROW
 %nonassoc IF THEN ELSE
@@ -575,6 +577,8 @@ kind   : TYPE                           (KType, s (TYPEleft, TYPEright))
        | KUNIT                          (KUnit, s (KUNITleft, KUNITright))
        | UNDERUNDER                     (KWild, s (UNDERUNDERleft, UNDERUNDERright))
        | LPAREN ktuple RPAREN           (KTuple ktuple, s (LPARENleft, RPARENright))
+       | CSYMBOL                        (KVar CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
+       | CSYMBOL KARROW kind            (KFun (CSYMBOL, kind), s (CSYMBOLleft, kindright))
 
 ktuple : kind STAR kind                 ([kind1, kind2])
        | kind STAR ktuple               (kind :: ktuple)
@@ -585,10 +589,12 @@ capps  : cterm                          (cterm)
 cexp   : capps                          (capps)
        | cexp ARROW cexp                (TFun (cexp1, cexp2), s (cexp1left, cexp2right))
        | SYMBOL kcolon kind ARROW cexp  (TCFun (kcolon, SYMBOL, kind, cexp), s (SYMBOLleft, cexpright))
+       | CSYMBOL KARROW cexp            (TKFun (CSYMBOL, cexp), s (CSYMBOLleft, cexpright))
 
        | cexp PLUSPLUS cexp             (CConcat (cexp1, cexp2), s (cexp1left, cexp1right))
 
        | FN cargs DARROW cexp           (#1 (cargs (cexp, (KWild, s (FNleft, cexpright)))))
+       | CSYMBOL DKARROW cexp           (CKAbs (CSYMBOL, cexp), s (CSYMBOLleft, cexpright))
 
        | LPAREN cexp RPAREN DCOLON kind (CAnnot (cexp, kind), s (LPARENleft, kindright))
 
@@ -651,7 +657,7 @@ cargp  : SYMBOL                         (fn (c, k) =>
                                                   ((CAbs (SYMBOL, SOME kind, c), loc),
                                                    (KArrow (kind, k), loc))
                                               end)
-       | LBRACK cexp TWIDDLE cexp RBRACK (fn (c, k) =>
+       | LBRACK cexp TWIDDLE cexp RBRACK  (fn (c, k) =>
                                             let
                                                 val loc = s (LBRACKleft, RBRACKright)
                                             in
@@ -716,6 +722,7 @@ eexp   : eapps                          (eapps)
                                          in
                                              #1 (eargs (eexp, (CWild (KType, loc), loc)))
                                          end)
+       | CSYMBOL DKARROW eexp           (EKAbs (CSYMBOL, eexp), s (CSYMBOLleft, eexpright))
        | eexp COLON cexp                (EAnnot (eexp, cexp), s (eexpleft, cexpright))
        | eexp MINUSMINUS cexp           (ECut (eexp, cexp), s (eexpleft, cexpright))
        | eexp MINUSMINUSMINUS cexp      (ECutMulti (eexp, cexp), s (eexpleft, cexpright))
@@ -851,6 +858,13 @@ eargp  : SYMBOL                         (fn (e, t) =>
                                                 ((EDisjoint (cexp1, cexp2, e), loc),
                                                  (CDisjoint (cexp1, cexp2, t), loc))
                                             end)
+       | CSYMBOL                           (fn (e, t) =>
+                                               let
+                                                   val loc = s (CSYMBOLleft, CSYMBOLright)
+                                               in
+                                                   ((EKAbs (CSYMBOL, e), loc),
+                                                    (TKFun (CSYMBOL, t), loc))
+                                               end)
 
 eterm  : LPAREN eexp RPAREN             (#1 eexp, s (LPARENleft, RPARENright))
        | LPAREN etuple RPAREN           (let
@@ -895,7 +909,6 @@ eterm  : LPAREN eexp RPAREN             (#1 eexp, s (LPARENleft, RPARENright))
                                                        (EField (e, ident), loc))
                                                    (EVar (#1 path, #2 path, DontInfer), s (pathleft, pathright)) idents
                                          end)
-       | FOLD                           (EFold, s (FOLDleft, FOLDright))
 
        | XML_BEGIN xml XML_END          (let
                                              val loc = s (XML_BEGINleft, XML_ENDright)
@@ -1070,7 +1083,7 @@ xmlOne : NOTAGS                         (EApp ((EVar (["Basis"], "cdata", Infer)
                                                       ()
                                                   else
                                                       ErrorMsg.errorAt pos "Begin and end tags don't match.";
-                                                  (EFold, pos))
+                                                  (EWild, pos))
                                          end)
        | LBRACE eexp RBRACE             (eexp)
        | LBRACE LBRACK eexp RBRACK RBRACE (let
diff --git a/src/urweb.lex b/src/urweb.lex
index 29e07194..bb57f03d 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -247,7 +247,9 @@ notags = [^<{\n]+;
 <INITIAL> "}"         => (exitBrace ();
                           Tokens.RBRACE (pos yypos, pos yypos + size yytext));
 
+<INITIAL> "-->"       => (Tokens.KARROW (pos yypos, pos yypos + size yytext));
 <INITIAL> "->"        => (Tokens.ARROW (pos yypos, pos yypos + size yytext));
+<INITIAL> "==>"       => (Tokens.DKARROW (pos yypos, pos yypos + size yytext));
 <INITIAL> "=>"        => (Tokens.DARROW (pos yypos, pos yypos + size yytext));
 <INITIAL> "++"        => (Tokens.PLUSPLUS (pos yypos, pos yypos + size yytext));
 <INITIAL> "--"        => (Tokens.MINUSMINUS (pos yypos, pos yypos + size yytext));
@@ -291,7 +293,6 @@ notags = [^<{\n]+;
 <INITIAL> "fun"       => (Tokens.FUN (pos yypos, pos yypos + size yytext));
 <INITIAL> "fn"        => (Tokens.FN (pos yypos, pos yypos + size yytext));
 <INITIAL> "map"       => (Tokens.MAP (pos yypos, pos yypos + size yytext));
-<INITIAL> "fold"      => (Tokens.FOLD (pos yypos, pos yypos + size yytext));
 <INITIAL> "case"      => (Tokens.CASE (pos yypos, pos yypos + size yytext));
 <INITIAL> "if"        => (Tokens.IF (pos yypos, pos yypos + size yytext));
 <INITIAL> "then"      => (Tokens.THEN (pos yypos, pos yypos + size yytext));
-- 
cgit v1.2.3


From 541bd325e7e0be52aa27dd56f16f489c44e05d2b Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Tue, 24 Feb 2009 13:46:08 -0500
Subject: Top.Fold.concat elaborates

---
 lib/ur/basis.urs     | 44 ++++++++++++++++-----------------
 lib/ur/top.ur        | 51 +++++++++++++++++++-------------------
 lib/ur/top.urs       | 48 +++++++++++++++++------------------
 src/elaborate.sml    | 70 +++++++++++++++++++++++++++++++++++++---------------
 src/source.sml       |  1 +
 src/source_print.sml |  3 +++
 src/urweb.grm        |  3 ++-
 src/urweb.lex        |  1 +
 8 files changed, 129 insertions(+), 92 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index cd2468ba..c2a55168 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -277,7 +277,7 @@ val sql_current_timestamp : sql_nfunc time
 (*** Executing queries *)
 
 val query : tables ::: {{Type}} -> exps ::: {Type}
-            -> fn [tables ~ exps] =>
+            -> [tables ~ exps] =>
                   state ::: Type
                   -> sql_query tables exps
                   -> ($(exps ++ map (fn fields :: {Type} => $fields) tables)
@@ -298,7 +298,7 @@ val insert : fields ::: {Type}
              -> dml
 
 val update : unchanged ::: {Type} -> changed :: {Type} ->
-             fn [changed ~ unchanged] =>
+             [changed ~ unchanged] =>
                 $(map (fn t :: Type => sql_exp [T = changed ++ unchanged] [] [] t) changed)
                 -> sql_table (changed ++ unchanged)
                 -> sql_exp [T = changed ++ unchanged] [] [] bool
@@ -326,23 +326,23 @@ val tag : attrsGiven ::: {Type} -> attrsAbsent ::: {Type}
           -> ctxOuter ::: {Unit} -> ctxInner ::: {Unit}
           -> useOuter ::: {Type} -> useInner ::: {Type}
           -> bindOuter ::: {Type} -> bindInner ::: {Type}
-          -> fn [attrsGiven ~ attrsAbsent]
-                    [useOuter ~ useInner]
-                    [bindOuter ~ bindInner] =>
-                $attrsGiven
-                -> tag (attrsGiven ++ attrsAbsent)
-                       ctxOuter ctxInner useOuter bindOuter
-                -> xml ctxInner useInner bindInner
-                -> xml ctxOuter (useOuter ++ useInner) (bindOuter ++ bindInner)
+          -> [attrsGiven ~ attrsAbsent] =>
+             [useOuter ~ useInner] =>
+             [bindOuter ~ bindInner] =>
+           $attrsGiven
+           -> tag (attrsGiven ++ attrsAbsent)
+                  ctxOuter ctxInner useOuter bindOuter
+           -> xml ctxInner useInner bindInner
+           -> xml ctxOuter (useOuter ++ useInner) (bindOuter ++ bindInner)
 val join : ctx ::: {Unit} 
         -> use1 ::: {Type} -> bind1 ::: {Type} -> bind2 ::: {Type}
-        -> fn [use1 ~ bind1] [bind1 ~ bind2] =>
+        -> [use1 ~ bind1] => [bind1 ~ bind2] =>
               xml ctx use1 bind1
               -> xml ctx (use1 ++ bind1) bind2
               -> xml ctx use1 (bind1 ++ bind2)
 val useMore : ctx ::: {Unit} -> use1 ::: {Type} -> use2 ::: {Type}
               -> bind ::: {Type}
-              -> fn [use1 ~ use2] =>
+              -> [use1 ~ use2] =>
                     xml ctx use1 bind
                     -> xml ctx (use1 ++ use2) bind
 
@@ -370,11 +370,11 @@ val title : unit -> tag [] head [] [] []
 val body : unit -> tag [] html body [] []
 con bodyTag = fn (attrs :: {Type}) =>
                  ctx ::: {Unit} ->
-                 fn [[Body] ~ ctx] =>
+                 [[Body] ~ ctx] =>
                     unit -> tag attrs ([Body] ++ ctx) ([Body] ++ ctx) [] []
 con bodyTagStandalone = fn (attrs :: {Type}) =>
                            ctx ::: {Unit}
-                           -> fn [[Body] ~ ctx] =>
+                           -> [[Body] ~ ctx] =>
                                  unit -> tag attrs ([Body] ++ ctx) [] [] []
 
 val br : bodyTagStandalone []
@@ -399,12 +399,12 @@ val hr : bodyTag []
 val a : bodyTag [Link = transaction page, Onclick = transaction unit]
 
 val form : ctx ::: {Unit} -> bind ::: {Type}
-            -> fn [[Body] ~ ctx] =>
+            -> [[Body] ~ ctx] =>
                   xml form [] bind
                   -> xml ([Body] ++ ctx) [] []
 con formTag = fn (ty :: Type) (inner :: {Unit}) (attrs :: {Type}) =>
                   ctx ::: {Unit}
-                  -> fn [[Form] ~ ctx] =>
+                  -> [[Form] ~ ctx] =>
                         nm :: Name -> unit
                         -> tag attrs ([Form] ++ ctx) inner [] [nm = ty]
 val textbox : formTag string [] [Value = string, Size = int, Source = source string]
@@ -422,7 +422,7 @@ val select : formTag string select []
 val option : unit -> tag [Value = string, Selected = bool] select [] [] []
 
 val submit : ctx ::: {Unit} -> use ::: {Type}
-             -> fn [[Form] ~ ctx] =>
+             -> [[Form] ~ ctx] =>
                    unit
                    -> tag [Value = string, Action = $use -> transaction page]
                           ([Form] ++ ctx) ([Form] ++ ctx) use []
@@ -431,7 +431,7 @@ val submit : ctx ::: {Unit} -> use ::: {Type}
 
 con cformTag = fn (attrs :: {Type}) =>
                   ctx ::: {Unit}
-                  -> fn [[Body] ~ ctx] =>
+                  -> [[Body] ~ ctx] =>
                         unit -> tag attrs ([Body] ++ ctx) [] [] []
 
 val ctextbox : cformTag [Value = string, Size = int, Source = source string]
@@ -439,13 +439,13 @@ val button : cformTag [Value = string, Onclick = transaction unit]
 
 (*** Tables *)
 
-val tabl : other ::: {Unit} -> fn [other ~ [Body, Table]] =>
+val tabl : other ::: {Unit} -> [other ~ [Body, Table]] =>
                                   unit -> tag [Border = int] ([Body] ++ other) ([Body, Table] ++ other) [] []
-val tr : other ::: {Unit} -> fn [other ~ [Body, Table, Tr]] =>
+val tr : other ::: {Unit} -> [other ~ [Body, Table, Tr]] =>
                                 unit -> tag [] ([Body, Table] ++ other) ([Body, Tr] ++ other) [] []
-val th : other ::: {Unit} -> fn [other ~ [Body, Tr]] =>
+val th : other ::: {Unit} -> [other ~ [Body, Tr]] =>
                                 unit -> tag [] ([Body, Tr] ++ other) ([Body] ++ other) [] []
-val td : other ::: {Unit} -> fn [other ~ [Body, Tr]] =>
+val td : other ::: {Unit} -> [other ~ [Body, Tr]] =>
                                 unit -> tag [] ([Body, Tr] ++ other) ([Body] ++ other) [] []
 
 
diff --git a/lib/ur/top.ur b/lib/ur/top.ur
index 79d30354..0fca0a5b 100644
--- a/lib/ur/top.ur
+++ b/lib/ur/top.ur
@@ -3,32 +3,32 @@
 con folder = K ==> fn r :: {K} =>
                       tf :: ({K} -> Type)
                       -> (nm :: Name -> v :: K -> r :: {K} -> tf r
-                          -> fn [[nm] ~ r] => tf ([nm = v] ++ r))
+                          -> [[nm] ~ r] => tf ([nm = v] ++ r))
                       -> tf [] -> tf r
 
 structure Folder = struct
     fun nil K (tf :: {K} -> Type)
             (f : nm :: Name -> v :: K -> r :: {K} -> tf r
-                 -> fn [[nm] ~ r] => tf ([nm = v] ++ r))
+                 -> [[nm] ~ r] => tf ([nm = v] ++ r))
             (i : tf []) = i
 
     fun cons K (r ::: {K}) (nm :: Name) (v :: K) [[nm] ~ r] (fold : folder r)
              (tf :: {K} -> Type)
              (f : nm :: Name -> v :: K -> r :: {K} -> tf r
-                  -> fn [[nm] ~ r] => tf ([nm = v] ++ r))
-             (i : tf []) = f [nm] [v] [r] (fold [tf] f i)
+                  -> [[nm] ~ r] => tf ([nm = v] ++ r))
+             (i : tf []) = f [nm] [v] [r] (fold [tf] f i) !
 
     fun concat K (r1 ::: {K}) (r2 ::: {K}) [r1 ~ r2]
         (f1 : folder r1) (f2 : folder r2)
         (tf :: {K} -> Type)
         (f : nm :: Name -> v :: K -> r :: {K} -> tf r
-             -> fn [[nm] ~ r] => tf ([nm = v] ++ r))
+             -> [[nm] ~ r] => tf ([nm = v] ++ r))
         (i : tf []) =
-        f1 [fn r1' [r1' ~ r2] => tf (r1' ++ r2)] 0
-           (*(fn (nm :: Name) (v :: K) (r1' :: {K}) (acc : fn [r1' ~ r2] => tf (r1' ++ r2))
+        f1 [fn r1' => [r1' ~ r2] => tf (r1' ++ r2)]
+           (fn (nm :: Name) (v :: K) (r1' :: {K}) (acc : [r1' ~ r2] => tf (r1' ++ r2))
                             [[nm] ~ r1'] [[nm = v] ++ r1' ~ r2] =>
-               f [nm] [v] [r1' ++ r2] acc)
-           (f2 [tf] f i)*)
+               f [nm] [v] [r1' ++ r2] acc !)
+           (fn [[] ~ r2] => f2 [tf] f i) !
 end
 
 
@@ -59,74 +59,74 @@ fun txt (t ::: Type) (ctx ::: {Unit}) (use ::: {Type}) (_ : show t) (v : t) =
 
 fun foldUR (tf :: Type) (tr :: {Unit} -> Type)
            (f : nm :: Name -> rest :: {Unit}
-                -> fn [[nm] ~ rest] =>
+                -> [[nm] ~ rest] =>
                       tf -> tr rest -> tr ([nm] ++ rest))
            (i : tr []) (r ::: {Unit}) (fold : folder r)=
     fold [fn r :: {Unit} => $(mapUT tf r) -> tr r]
          (fn (nm :: Name) (t :: Unit) (rest :: {Unit}) acc
                           [[nm] ~ rest] r =>
-             f [nm] [rest] r.nm (acc (r -- nm)))
+             f [nm] [rest] ! r.nm (acc (r -- nm)))
          (fn _ => i)
 
 fun foldUR2 (tf1 :: Type) (tf2 :: Type) (tr :: {Unit} -> Type)
            (f : nm :: Name -> rest :: {Unit}
-                -> fn [[nm] ~ rest] =>
+                -> [[nm] ~ rest] =>
                       tf1 -> tf2 -> tr rest -> tr ([nm] ++ rest))
            (i : tr []) (r ::: {Unit}) (fold : folder r) =
     fold [fn r :: {Unit} => $(mapUT tf1 r) -> $(mapUT tf2 r) -> tr r]
          (fn (nm :: Name) (t :: Unit) (rest :: {Unit}) acc
                           [[nm] ~ rest] r1 r2 =>
-             f [nm] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
+             f [nm] [rest] ! r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
          (fn _ _ => i)
 
 fun foldURX2 (tf1 :: Type) (tf2 :: Type) (ctx :: {Unit})
            (f : nm :: Name -> rest :: {Unit}
-                -> fn [[nm] ~ rest] =>
+                -> [[nm] ~ rest] =>
                       tf1 -> tf2 -> xml ctx [] []) =
     foldUR2 [tf1] [tf2] [fn _ => xml ctx [] []]
             (fn (nm :: Name) (rest :: {Unit}) [[nm] ~ rest] v1 v2 acc =>
-                <xml>{f [nm] [rest] v1 v2}{acc}</xml>)
+                <xml>{f [nm] [rest] ! v1 v2}{acc}</xml>)
             <xml/>
 
 fun foldR K (tf :: K -> Type) (tr :: {K} -> Type)
            (f : nm :: Name -> t :: K -> rest :: {K}
-                -> fn [[nm] ~ rest] =>
+                -> [[nm] ~ rest] =>
                       tf t -> tr rest -> tr ([nm = t] ++ rest))
            (i : tr []) (r ::: {K}) (fold : folder r) =
     fold [fn r :: {K} => $(map tf r) -> tr r]
              (fn (nm :: Name) (t :: K) (rest :: {K}) (acc : _ -> tr rest)
                               [[nm] ~ rest] r =>
-                 f [nm] [t] [rest] r.nm (acc (r -- nm)))
+                 f [nm] [t] [rest] ! r.nm (acc (r -- nm)))
              (fn _ => i)
 
 fun foldR2 K (tf1 :: K -> Type) (tf2 :: K -> Type) (tr :: {K} -> Type)
             (f : nm :: Name -> t :: K -> rest :: {K}
-                 -> fn [[nm] ~ rest] =>
+                 -> [[nm] ~ rest] =>
                        tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest))
             (i : tr []) (r ::: {K}) (fold : folder r) =
     fold [fn r :: {K} => $(map tf1 r) -> $(map tf2 r) -> tr r]
          (fn (nm :: Name) (t :: K) (rest :: {K})
                           (acc : _ -> _ -> tr rest) [[nm] ~ rest] r1 r2 =>
-             f [nm] [t] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
+             f [nm] [t] [rest] ! r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
          (fn _ _ => i)
 
 fun foldRX K (tf :: K -> Type) (ctx :: {Unit})
             (f : nm :: Name -> t :: K -> rest :: {K}
-                 -> fn [[nm] ~ rest] =>
+                 -> [[nm] ~ rest] =>
                        tf t -> xml ctx [] []) =
     foldR [tf] [fn _ => xml ctx [] []]
           (fn (nm :: Name) (t :: K) (rest :: {K}) [[nm] ~ rest] r acc =>
-              <xml>{f [nm] [t] [rest] r}{acc}</xml>)
+              <xml>{f [nm] [t] [rest] ! r}{acc}</xml>)
           <xml/>
 
 fun foldRX2 K (tf1 :: K -> Type) (tf2 :: K -> Type) (ctx :: {Unit})
              (f : nm :: Name -> t :: K -> rest :: {K}
-                  -> fn [[nm] ~ rest] =>
+                  -> [[nm] ~ rest] =>
                         tf1 t -> tf2 t -> xml ctx [] []) =
     foldR2 [tf1] [tf2] [fn _ => xml ctx [] []]
            (fn (nm :: Name) (t :: K) (rest :: {K}) [[nm] ~ rest]
                             r1 r2 acc =>
-               <xml>{f [nm] [t] [rest] r1 r2}{acc}</xml>)
+               <xml>{f [nm] [t] [rest] ! r1 r2}{acc}</xml>)
            <xml/>
 
 fun queryX (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit})
@@ -148,13 +148,14 @@ fun queryX' (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit})
           <xml/>
 
 fun oneOrNoRows (tables ::: {{Type}}) (exps ::: {Type})
-                (q : sql_query tables exps) [tables ~ exps] =
+                [tables ~ exps]
+                (q : sql_query tables exps)  =
     query q
           (fn fs _ => return (Some fs))
           None
 
 fun oneRow (tables ::: {{Type}}) (exps ::: {Type})
-                (q : sql_query tables exps) [tables ~ exps] =
+                [tables ~ exps] (q : sql_query tables exps) =
     o <- oneOrNoRows q;
     return (case o of
                 None => error <xml>Query returned no rows</xml>
diff --git a/lib/ur/top.urs b/lib/ur/top.urs
index 563f6afd..a32a87a3 100644
--- a/lib/ur/top.urs
+++ b/lib/ur/top.urs
@@ -3,15 +3,15 @@
 con folder = K ==> fn r :: {K} =>
                       tf :: ({K} -> Type)
                       -> (nm :: Name -> v :: K -> r :: {K} -> tf r
-                          -> fn [[nm] ~ r] => tf ([nm = v] ++ r))
+                          -> [[nm] ~ r] => tf ([nm = v] ++ r))
                       -> tf [] -> tf r
 
 structure Folder : sig
     val nil : K --> folder (([]) :: {K})
     val cons : K --> r ::: {K} -> nm :: Name -> v :: K
-               -> fn [[nm] ~ r] => folder r -> folder ([nm = v] ++ r)
+               -> [[nm] ~ r] => folder r -> folder ([nm = v] ++ r)
     val concat : K --> r1 ::: {K} -> r2 ::: {K}
-                 -> fn [r1 ~ r2] => folder r1 -> folder r2 -> folder (r1 ++ r2)
+                 -> [r1 ~ r2] => folder r1 -> folder r2 -> folder (r1 ++ r2)
 end
 
 
@@ -40,78 +40,78 @@ val txt : t ::: Type -> ctx ::: {Unit} -> use ::: {Type} -> show t -> t
 
 val foldUR : tf :: Type -> tr :: ({Unit} -> Type)
              -> (nm :: Name -> rest :: {Unit}
-                 -> fn [[nm] ~ rest] =>
+                 -> [[nm] ~ rest] =>
                        tf -> tr rest -> tr ([nm] ++ rest))
              -> tr [] -> r ::: {Unit} -> folder r -> $(mapUT tf r) -> tr r
 
 val foldUR2 : tf1 :: Type -> tf2 :: Type -> tr :: ({Unit} -> Type)
              -> (nm :: Name -> rest :: {Unit}
-                 -> fn [[nm] ~ rest] =>
+                 -> [[nm] ~ rest] =>
                        tf1 -> tf2 -> tr rest -> tr ([nm] ++ rest))
              -> tr [] -> r ::: {Unit} -> folder r -> $(mapUT tf1 r) -> $(mapUT tf2 r) -> tr r
 
 val foldURX2: tf1 :: Type -> tf2 :: Type -> ctx :: {Unit}
               -> (nm :: Name -> rest :: {Unit}
-                  -> fn [[nm] ~ rest] =>
+                  -> [[nm] ~ rest] =>
                         tf1 -> tf2 -> xml ctx [] [])
               -> r ::: {Unit} -> folder r -> $(mapUT tf1 r) -> $(mapUT tf2 r) -> xml ctx [] []
 
 val foldR : K --> tf :: (K -> Type) -> tr :: ({K} -> Type)
              -> (nm :: Name -> t :: K -> rest :: {K}
-                 -> fn [[nm] ~ rest] =>
+                 -> [[nm] ~ rest] =>
                        tf t -> tr rest -> tr ([nm = t] ++ rest))
              -> tr [] -> r ::: {K} -> folder r -> $(map tf r) -> tr r
 
 val foldR2 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type)
              -> tr :: ({K} -> Type)
              -> (nm :: Name -> t :: K -> rest :: {K}
-                 -> fn [[nm] ~ rest] =>
+                 -> [[nm] ~ rest] =>
                        tf1 t -> tf2 t -> tr rest -> tr ([nm = t] ++ rest))
              -> tr []
              -> r ::: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> tr r
 
 val foldRX : K --> tf :: (K -> Type) -> ctx :: {Unit}
              -> (nm :: Name -> t :: K -> rest :: {K}
-                 -> fn [[nm] ~ rest] =>
+                 -> [[nm] ~ rest] =>
                        tf t -> xml ctx [] [])
              -> r ::: {K} -> folder r -> $(map tf r) -> xml ctx [] []
 
 val foldRX2 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> ctx :: {Unit}
               -> (nm :: Name -> t :: K -> rest :: {K}
-                  -> fn [[nm] ~ rest] =>
+                  -> [[nm] ~ rest] =>
                         tf1 t -> tf2 t -> xml ctx [] [])
               -> r ::: {K} -> folder r
               -> $(map tf1 r) -> $(map tf2 r) -> xml ctx [] []
 
 val queryX : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit}
              -> sql_query tables exps
-             -> fn [tables ~ exps] =>
+             -> [tables ~ exps] =>
                    ($(exps ++ map (fn fields :: {Type} => $fields) tables)
                     -> xml ctx [] [])
                    -> transaction (xml ctx [] [])
 
 val queryX' : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit}
               -> sql_query tables exps
-              -> fn [tables ~ exps] =>
+              -> [tables ~ exps] =>
                     ($(exps ++ map (fn fields :: {Type} => $fields) tables)
                      -> transaction (xml ctx [] []))
                     -> transaction (xml ctx [] [])
                        
 val oneOrNoRows : tables ::: {{Type}} -> exps ::: {Type}
-                  -> sql_query tables exps
-                  -> fn [tables ~ exps] =>
-                        transaction
-                            (option
-                                 $(exps
-                                       ++ map (fn fields :: {Type} => $fields) tables))
+                  -> [tables ~ exps] =>
+                  sql_query tables exps
+                  -> transaction
+                         (option
+                              $(exps
+                                    ++ map (fn fields :: {Type} => $fields) tables))
 
 val oneRow : tables ::: {{Type}} -> exps ::: {Type}
-             -> sql_query tables exps
-             -> fn [tables ~ exps] =>
-                   transaction
-                       $(exps
-                             ++ map (fn fields :: {Type} => $fields) tables)
-
+             -> [tables ~ exps] =>
+             sql_query tables exps
+             -> transaction
+                    $(exps
+                          ++ map (fn fields :: {Type} => $fields) tables)
+                
 val eqNullable : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
                  -> t ::: Type -> sql_injectable (option t)
                  -> sql_exp tables agg exps (option t)
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 6c55626f..201b9150 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1025,7 +1025,7 @@
 
  val enD = map Disjoint
 
- fun elabHead env infer (e as (_, loc)) t =
+ fun elabHead (env, denv) infer (e as (_, loc)) t =
      let
          fun unravel (t, e) =
              case hnormCon env t of
@@ -1059,6 +1059,16 @@
                      else
                          (e, t, [])
                  end
+               | (L'.TDisjoint (r1, r2, t'), loc) =>
+                 if infer <> L.TypesOnly then
+                     let
+                         val gs = D.prove env denv (r1, r2, loc)
+                         val (e, t, gs') = unravel (t', e)
+                     in
+                         (e, t, enD gs @ gs')
+                     end
+                 else
+                     (e, t, [])
                | t => (e, t, [])
     in
         case infer of
@@ -1185,7 +1195,7 @@ fun c2s c =
       | Datatype _ => "Datatype"
       | Record _ => "Record"
 
-fun exhaustive (env, t, ps) =
+fun exhaustive (env, t, ps, loc) =
     let
         fun depth (p, _) =
             case p of
@@ -1364,7 +1374,8 @@ fun exhaustive (env, t, ps) =
                         end
                       | L'.CError => true
                       | c =>
-                        (prefaces "Not a datatype" [("c", p_con env (c, ErrorMsg.dummySpan))];
+                        (prefaces "Not a datatype" [("loc", PD.string (ErrorMsg.spanToString loc)),
+                                                    ("c", p_con env (c, ErrorMsg.dummySpan))];
                          raise Fail "isTotal: Not a datatype")
                 end
               | Record _ => List.all (fn c2 => coverageImp (c, c2)) (enumerateCases depth t)
@@ -1437,8 +1448,8 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
                  E.NotBound =>
                  (expError env (UnboundExp (loc, s));
                   (eerror, cerror, []))
-               | E.Rel (n, t) => elabHead env infer (L'.ERel n, loc) t
-               | E.Named (n, t) => elabHead env infer (L'.ENamed n, loc) t)
+               | E.Rel (n, t) => elabHead (env, denv) infer (L'.ERel n, loc) t
+               | E.Named (n, t) => elabHead (env, denv) infer (L'.ENamed n, loc) t)
           | L.EVar (m1 :: ms, s, infer) =>
             (case E.lookupStr env m1 of
                  NONE => (expError env (UnboundStrInExp (loc, m1));
@@ -1457,7 +1468,7 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
                                           cerror)
                                | SOME t => t
                  in
-                     elabHead env infer (L'.EModProj (n, ms, s), loc) t
+                     elabHead (env, denv) infer (L'.EModProj (n, ms, s), loc) t
                  end)
 
           | L.EWild =>
@@ -1566,6 +1577,20 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
 
                 (e', (L'.TDisjoint (c1', c2', t), loc), enD gs1 @ enD gs2 @ gs3)
             end
+          | L.EDisjointApp e =>
+            let
+                val (e', t, gs1) = elabExp (env, denv) e
+
+                val k1 = kunif loc
+                val c1 = cunif (loc, (L'.KRecord k1, loc))
+                val k2 = kunif loc
+                val c2 = cunif (loc, (L'.KRecord k2, loc))
+                val t' = cunif (loc, ktype)
+                val () = checkCon env e' t (L'.TDisjoint (c1, c2, t'), loc)
+                val gs2 = D.prove env denv (c1, c2, loc)
+            in
+                (e', t', enD gs2 @ gs1)
+            end
 
           | L.ERecord xes =>
             let
@@ -1617,11 +1642,10 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
                 val ft = cunif (loc, ktype)
                 val rest = cunif (loc, ktype_record)
                 val first = (L'.CRecord (ktype, [(c', ft)]), loc)
-                            
+                val () = checkCon env e' et
+                                  (L'.TRecord (L'.CConcat (first, rest), loc), loc);
                 val gs3 = D.prove env denv (first, rest, loc)
             in
-                checkCon env e' et
-                         (L'.TRecord (L'.CConcat (first, rest), loc), loc);
                 ((L'.EField (e', c', {field = ft, rest = rest}), loc), ft, gs1 @ enD gs2 @ enD gs3)
             end
 
@@ -1633,10 +1657,11 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
                 val r1 = cunif (loc, ktype_record)
                 val r2 = cunif (loc, ktype_record)
 
+                val () = checkCon env e1' e1t (L'.TRecord r1, loc)
+                val () = checkCon env e2' e2t (L'.TRecord r2, loc)
+
                 val gs3 = D.prove env denv (r1, r2, loc)
             in
-                checkCon env e1' e1t (L'.TRecord r1, loc);
-                checkCon env e2' e2t (L'.TRecord r2, loc);
                 ((L'.EConcat (e1', r1, e2', r2), loc),
                  (L'.TRecord ((L'.CConcat (r1, r2), loc)), loc),
                  gs1 @ gs2 @ enD gs3)
@@ -1649,11 +1674,12 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
                 val ft = cunif (loc, ktype)
                 val rest = cunif (loc, ktype_record)
                 val first = (L'.CRecord (ktype, [(c', ft)]), loc)
+
+                val () = checkCon env e' et
+                                  (L'.TRecord (L'.CConcat (first, rest), loc), loc)
                             
                 val gs3 = D.prove env denv (first, rest, loc)
             in
-                checkCon env e' et
-                         (L'.TRecord (L'.CConcat (first, rest), loc), loc);
                 ((L'.ECut (e', c', {field = ft, rest = rest}), loc), (L'.TRecord rest, loc),
                  gs1 @ enD gs2 @ enD gs3)
             end
@@ -1663,11 +1689,12 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
                 val (c', ck, gs2) = elabCon (env, denv) c
 
                 val rest = cunif (loc, ktype_record)
+
+                val () = checkCon env e' et
+                                  (L'.TRecord (L'.CConcat (c', rest), loc), loc)
                             
                 val gs3 = D.prove env denv (c', rest, loc)
             in
-                checkCon env e' et
-                         (L'.TRecord (L'.CConcat (c', rest), loc), loc);
                 ((L'.ECutMulti (e', c', {rest = rest}), loc), (L'.TRecord rest, loc),
                  gs1 @ enD gs2 @ enD gs3)
             end
@@ -1681,15 +1708,15 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
                                      let
                                          val ((p', pt), (env, _)) = elabPat (p, (env, SS.empty))
 
-                                         val (e', et, gs1) = elabExp (env, denv) e
+                                         val (e', et', gs1) = elabExp (env, denv) e
                                      in
                                          checkPatCon env p' pt et;
-                                         checkCon env e' et result;
+                                         checkCon env e' et' result;
                                          ((p', e'), gs1 @ gs)
                                      end)
                                  gs1 pes
             in
-                if exhaustive (env, et, map #1 pes') then
+                if exhaustive (env, et, map #1 pes', loc) then
                     ()
                 else
                     expError env (Inexhaustive loc);
@@ -1722,10 +1749,11 @@ and elabEdecl denv (dAll as (d, loc), (env, gs)) =
 
                     val (e', et, gs2) = elabExp (env, denv) e
 
+                    val () = checkCon env e' et c'
+
                     val c' = normClassConstraint env c'
                     val env' = E.pushERel env x c'
                 in
-                    checkCon env e' et c';
                     ((L'.EDVal (x, c', e'), loc), (env', enD gs1 @ gs2 @ gs))
                 end
               | L.EDValRec vis =>
@@ -2958,10 +2986,12 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs)) =
                                          | SOME c => elabCon (env, denv) c
 
                     val (e', et, gs2) = elabExp (env, denv) e
+
+                    val () = checkCon env e' et c'
+
                     val c = normClassConstraint env c'
                     val (env', n) = E.pushENamed env x c'
                 in
-                    checkCon env e' et c';
                     (*prefaces "DVal" [("x", Print.PD.string x),
                                      ("c'", p_con env c')];*)
                     ([(L'.DVal (x, n, c', e'), loc)], (env', denv, enD gs1 @ gs2 @ gs))
diff --git a/src/source.sml b/src/source.sml
index 6c117777..9ef14fd9 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -124,6 +124,7 @@ datatype exp' =
        | ECApp of exp * con
        | ECAbs of explicitness * string * kind * exp
        | EDisjoint of con * con * exp
+       | EDisjointApp of exp
 
        | EKAbs of string * exp
 
diff --git a/src/source_print.sml b/src/source_print.sml
index 4453454d..8d8b28c3 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -267,6 +267,9 @@ fun p_exp' par (e, _) =
                                                    string "=>",
                                                    space,
                                                    p_exp e])
+      | EDisjointApp e => parenIf par (box [p_exp e,
+                                            space,
+                                            string "!"])
 
       | ERecord xes => box [string "{",
                             p_list (fn (x, e) =>
diff --git a/src/urweb.grm b/src/urweb.grm
index 86e8a5df..43c9947a 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -187,7 +187,7 @@ fun tagIn bt =
  | CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS
  | DATATYPE | OF
  | TYPE | NAME
- | ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW
+ | ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW | BANG
  | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE
  | LET | IN
  | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL
@@ -710,6 +710,7 @@ ident  : CSYMBOL                        (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLr
 eapps  : eterm                          (eterm)
        | eapps eterm                    (EApp (eapps, eterm), s (eappsleft, etermright))
        | eapps LBRACK cexp RBRACK       (ECApp (eapps, cexp), s (eappsleft, RBRACKright))
+       | eapps BANG                     (EDisjointApp eapps, s (eappsleft, BANGright))
 
 eexp   : eapps                          (eapps)
        | FN eargs DARROW eexp           (let
diff --git a/src/urweb.lex b/src/urweb.lex
index bb57f03d..cbbf2a52 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -276,6 +276,7 @@ notags = [^<{\n]+;
 <INITIAL> "*"         => (Tokens.STAR (pos yypos, pos yypos + size yytext));
 <INITIAL> "<-"        => (Tokens.LARROW (pos yypos, pos yypos + size yytext));
 <INITIAL> ";"         => (Tokens.SEMI (pos yypos, pos yypos + size yytext));
+<INITIAL> "!"         => (Tokens.BANG (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "+"         => (Tokens.PLUS (pos yypos, pos yypos + size yytext));
 <INITIAL> "-"         => (Tokens.MINUS (pos yypos, pos yypos + size yytext));
-- 
cgit v1.2.3


From 732a583f6601793bb0ba9246649e45de89fe1067 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Thu, 26 Mar 2009 14:37:31 -0400
Subject: Type class reductions, but no inclusions yet

---
 src/elab_env.sml     | 322 ++++++++++++++++++++++++++++++++++++---------------
 src/elaborate.sml    |  11 +-
 src/urweb.grm        |   6 +-
 src/urweb.lex        |   1 +
 tests/type_class.ur  |  58 +++++++---
 tests/type_class.urp |   3 +
 6 files changed, 288 insertions(+), 113 deletions(-)
 create mode 100644 tests/type_class.urp

(limited to 'src/urweb.lex')

diff --git a/src/elab_env.sml b/src/elab_env.sml
index 083e7d55..1768ce7d 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008, Adam Chlipala
+(* Copyright (c) 2008-2009, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
@@ -197,12 +197,16 @@ fun ck2s ck =
       | CkProj (m, ms, x) => "Proj(" ^ Int.toString m ^ "," ^ String.concatWith "," ms ^ "," ^ x ^ ")"
       | CkApp (ck1, ck2) => "App(" ^ ck2s ck1 ^ ", " ^ ck2s ck2 ^ ")"
 
+type class_key_n = class_key * int
+
+fun ckn2s (ck, n) = ck2s ck ^ "[" ^ Int.toString n ^ "]"
+
 fun cp2s (cn, ck) = "(" ^ cn2s cn ^ "," ^ ck2s ck ^ ")"
 
 structure KK = struct
-type ord_key = class_key
+type ord_key = class_key_n
 open Order
-fun compare x =
+fun compare' x =
     case x of
         (CkNamed n1, CkNamed n2) => Int.compare (n1, n2)
       | (CkNamed _, _) => LESS
@@ -220,24 +224,22 @@ fun compare x =
       | (_, CkProj _) => GREATER
 
       | (CkApp (f1, x1), CkApp (f2, x2)) =>
-        join (compare (f1, f2),
-              fn () => compare (x1, x2))
+        join (compare' (f1, f2),
+              fn () => compare' (x1, x2))
+fun compare ((k1, n1), (k2, n2)) =
+    join (Int.compare (n1, n2),
+       fn () => compare' (k1, k2))
 end
 
 structure KM = BinaryMapFn(KK)
 
-type class = {
-     ground : exp KM.map
-}
-
-val empty_class = {
-    ground = KM.empty
-}
+type class = ((class_name * class_key) list * exp) KM.map
+val empty_class = KM.empty
 
 fun printClasses cs = (print "Classes:\n";
-                       CM.appi (fn (cn, {ground = km}) =>
+                       CM.appi (fn (cn, km) =>
                                    (print (cn2s cn ^ ":");
-                                    KM.appi (fn (ck, _) => print (" " ^ ck2s ck)) km;
+                                    KM.appi (fn (ck, _) => print (" " ^ ckn2s ck)) km;
                                     print "\n")) cs)
 
 type env = {
@@ -298,12 +300,14 @@ val empty = {
     str = IM.empty
 }
 
-fun liftClassKey ck =
+fun liftClassKey' ck =
     case ck of
         CkNamed _ => ck
       | CkRel n => CkRel (n + 1)
       | CkProj _ => ck
-      | CkApp (ck1, ck2) => CkApp (liftClassKey ck1, liftClassKey ck2)
+      | CkApp (ck1, ck2) => CkApp (liftClassKey' ck1, liftClassKey' ck2)
+
+fun liftClassKey (ck, n) = (liftClassKey' ck, n)
 
 fun pushKRel (env : env) x =
     let
@@ -356,11 +360,10 @@ fun pushCRel (env : env) x k =
          datatypes = #datatypes env,
          constructors = #constructors env,
 
-         classes = CM.map (fn class => {
-                              ground = KM.foldli (fn (ck, e, km) =>
-                                                     KM.insert (km, liftClassKey ck, e))
-                                                 KM.empty (#ground class)
-                          })
+         classes = CM.map (fn class =>
+                              KM.foldli (fn (ck, e, km) =>
+                                            KM.insert (km, liftClassKey ck, e))
+                                        KM.empty class)
                           (#classes env),
 
          renameE = SM.map (fn Rel' (n, c) => Rel' (n, lift c)
@@ -479,7 +482,7 @@ fun pushClass (env : env) n =
      datatypes = #datatypes env,
      constructors = #constructors env,
 
-     classes = CM.insert (#classes env, ClNamed n, {ground = KM.empty}),
+     classes = CM.insert (#classes env, ClNamed n, KM.empty),
 
      renameE = #renameE env,
      relE = #relE env,
@@ -518,6 +521,18 @@ fun class_key_in (c, _) =
            | _ => NONE)
       | _ => NONE
 
+fun class_key_out loc =
+    let
+        fun cko k =
+            case k of
+                CkRel n => (CRel n, loc)
+              | CkNamed n => (CNamed n, loc)
+              | CkProj x => (CModProj x, loc)
+              | CkApp (k1, k2) => (CApp (cko k1, cko k2), loc)
+    in
+        cko
+    end
+
 fun class_pair_in (c, _) =
     case c of
         CApp (f, x) =>
@@ -527,25 +542,80 @@ fun class_pair_in (c, _) =
       | CUnif (_, _, _, ref (SOME c)) => class_pair_in c
       | _ => NONE
 
+fun sub_class_key (n, c) =
+    let
+        fun csk k =
+            case k of
+                CkRel n' => if n' = n then
+                                c
+                            else
+                                k
+              | CkNamed _ => k
+              | CkProj _ => k
+              | CkApp (k1, k2) => CkApp (csk k1, csk k2)
+    in
+        csk
+    end
+
 fun resolveClass (env : env) c =
-    case class_pair_in c of
-        SOME (f, x) =>
-        (case CM.find (#classes env, f) of
-             NONE => NONE
-           | SOME class =>
-             case KM.find (#ground class, x) of
-                 NONE => NONE
-               | SOME e => SOME e)
-      | _ => NONE
+    let
+        fun doPair (f, x) =
+            case CM.find (#classes env, f) of
+                NONE => NONE
+              | SOME class =>
+                let
+                    val loc = #2 c
+                              
+                    fun tryRules (k, args) =
+                        let
+                            val len = length args
+                        in
+                            case KM.find (class, (k, length args)) of
+                                SOME (cs, e) =>
+                                let
+                                    val es = map (fn (cn, ck) =>
+                                                     let
+                                                         val ck = ListUtil.foldli (fn (i, arg, ck) =>
+                                                                                      sub_class_key (len - i - 1,
+                                                                                                     arg)
+                                                                                                    ck)
+                                                                                  ck args
+                                                     in
+                                                         doPair (cn, ck)
+                                                     end) cs
+                                in
+                                    if List.exists (not o Option.isSome) es then
+                                        NONE
+                                    else
+                                        let
+                                            val e = foldl (fn (arg, e) => (ECApp (e, class_key_out loc arg), loc))
+                                                          e args
+                                            val e = foldr (fn (pf, e) => (EApp (e, pf), loc))
+                                                          e (List.mapPartial (fn x => x) es)
+                                        in
+                                            SOME e
+                                        end
+                                end
+                              | NONE =>
+                                case k of
+                                    CkApp (k1, k2) => tryRules (k1, k2 :: args)
+                                  | _ => NONE
+                        end
+                in
+                    tryRules (x, [])
+                end
+    in
+        case class_pair_in c of
+            SOME p => doPair p
+          | _ => NONE
+    end
 
 fun pushERel (env : env) x t =
     let
         val renameE = SM.map (fn Rel' (n, t) => Rel' (n+1, t)
                                | x => x) (#renameE env)
 
-        val classes = CM.map (fn class => {
-                                 ground = KM.map liftExp (#ground class)
-                             }) (#classes env)
+        val classes = CM.map (KM.map (fn (ps, e) => (ps, liftExp e))) (#classes env)
         val classes = case class_pair_in t of
                           NONE => classes
                         | SOME (f, x) =>
@@ -553,9 +623,7 @@ fun pushERel (env : env) x t =
                               NONE => classes
                             | SOME class =>
                               let
-                                  val class = {
-                                      ground = KM.insert (#ground class, x, (ERel 0, #2 t))
-                                  }
+                                  val class = KM.insert (class, (x, 0), ([], (ERel 0, #2 t)))
                               in
                                   CM.insert (classes, f, class)
                               end
@@ -587,19 +655,55 @@ fun lookupERel (env : env) n =
     (List.nth (#relE env, n))
     handle Subscript => raise UnboundRel n
 
+fun rule_in c =
+    let
+        fun quantifiers (c, nvars) =
+            case #1 c of
+                TCFun (_, _, _, c) => quantifiers (c, nvars + 1)
+              | _ =>
+                let
+                    fun clauses (c, hyps) =
+                        case #1 c of
+                            TFun (hyp, c) =>
+                            (case class_pair_in hyp of
+                                 NONE => NONE
+                               | SOME p => clauses (c, p :: hyps))
+                          | _ =>
+                            case class_pair_in c of
+                                NONE => NONE
+                              | SOME (cn, ck) =>
+                                let
+                                    fun dearg (ck, i) =
+                                        if i >= nvars then
+                                            SOME (nvars, hyps, (cn, ck))
+                                        else case ck of
+                                                 CkApp (ck, CkRel i') =>
+                                                 if i' = i then
+                                                     dearg (ck, i + 1)
+                                                 else
+                                                     NONE
+                                               | _ => NONE
+                                in
+                                    dearg (ck, 0)
+                                end
+                in
+                    clauses (c, [])
+                end
+    in
+        quantifiers (c, 0)
+    end
+
 fun pushENamedAs (env : env) x n t =
     let
         val classes = #classes env
-        val classes = case class_pair_in t of
+        val classes = case rule_in t of
                           NONE => classes
-                        | SOME (f, x) =>
+                        | SOME (nvars, hyps, (f, x)) =>
                           case CM.find (classes, f) of
                               NONE => classes
                             | SOME class =>
                               let
-                                  val class = {
-                                      ground = KM.insert (#ground class, x, (ENamed n, #2 t))
-                                  }
+                                  val class = KM.insert (class, (x, nvars), (hyps, (ENamed n, #2 t)))
                               in
                                   CM.insert (classes, f, class)
                               end
@@ -784,6 +888,31 @@ fun sgnS_con' (arg as (m1, ms', (sgns, strs, cons))) c =
                                (sgnS_con' arg (#1 c2), #2 c2))
       | _ => c
 
+fun sgnS_class_name (arg as (m1, ms', (sgns, strs, cons))) nm =
+    case nm of
+        ClProj (m1, ms, x) =>
+        (case IM.find (strs, m1) of
+             NONE => nm
+           | SOME m1x => ClProj (m1, ms' @ m1x :: ms, x))
+      | ClNamed n =>
+        (case IM.find (cons, n) of
+             NONE => nm
+           | SOME nx => ClProj (m1, ms', nx))
+
+fun sgnS_class_key (arg as (m1, ms', (sgns, strs, cons))) k =
+    case k of
+        CkProj (m1, ms, x) =>
+        (case IM.find (strs, m1) of
+             NONE => k
+           | SOME m1x => CkProj (m1, ms' @ m1x :: ms, x))
+      | CkNamed n =>
+        (case IM.find (cons, n) of
+             NONE => k
+           | SOME nx => CkProj (m1, ms', nx))
+      | CkApp (k1, k2) => CkApp (sgnS_class_key arg k1,
+                                 sgnS_class_key arg k2)
+      | _ => k
+
 fun sgnS_sgn (str, (sgns, strs, cons)) sgn =
     case sgn of
         SgnProj (m1, ms, x) =>
@@ -891,38 +1020,45 @@ fun enrichClasses env classes (m1, ms) sgn =
 
                                 | SgiClassAbs (x, n, _) => found (x, n)
                                 | SgiClass (x, n, _, _) => found (x, n)
-                                | SgiVal (x, n, (CApp (f, a), _)) =>
-                                  let
-                                      fun unravel c =
-                                          case #1 c of
-                                              CUnif (_, _, _, ref (SOME c)) => unravel c
-                                            | CNamed n =>
-                                              ((case lookupCNamed env n of
-                                                    (_, _, SOME c) => unravel c
-                                                  | _ => c)
-                                               handle UnboundNamed _ => c)
-                                            | _ => c
-
-                                      val nc =
-                                          case f of
-                                              (CNamed f, _) => IM.find (newClasses, f)
-                                            | _ => NONE
-                                  in
-                                      case nc of
-                                          NONE =>
-                                          (case (class_name_in (unravel f),
-                                                 class_key_in (sgnS_con' (m1, ms, fmap) (#1 a), #2 a)) of
-                                               (SOME cn, SOME ck) =>
+                                | SgiVal (x, n, c) =>
+                                  (case rule_in c of
+                                       NONE => default ()
+                                     | SOME (nvars, hyps, (cn, a)) =>
+                                       let
+                                           val globalize = sgnS_class_key (m1, ms, fmap)
+                                           val ck = globalize a
+                                           val hyps = map (fn (n, k) => (sgnS_class_name (m1, ms, fmap) n,
+                                                                         globalize k)) hyps
+
+                                           fun unravel c =
+                                               case c of
+                                                   ClNamed n =>
+                                                   ((case lookupCNamed env n of
+                                                         (_, _, SOME c') =>
+                                                         (case class_name_in c' of
+                                                              NONE => c
+                                                            | SOME k => unravel k)
+                                                       | _ => c)
+                                                    handle UnboundNamed _ => c)
+                                                 | _ => c
+
+                                           val nc =
+                                               case cn of
+                                                   ClNamed f => IM.find (newClasses, f)
+                                                 | _ => NONE
+                                       in
+                                           case nc of
+                                               NONE =>
                                                let
                                                    val classes =
                                                        case CM.find (classes, cn) of
                                                            NONE => classes
                                                          | SOME class =>
                                                            let
-                                                               val class = {
-                                                                   ground = KM.insert (#ground class, ck,
-                                                                                       (EModProj (m1, ms, x), #2 sgn))
-                                                               }
+                                                               val class = KM.insert (class, (ck, nvars),
+                                                                                      (hyps,
+                                                                                       (EModProj (m1, ms, x),
+                                                                                        #2 sgn)))
                                                            in
                                                                CM.insert (classes, cn, class)
                                                            end
@@ -932,34 +1068,28 @@ fun enrichClasses env classes (m1, ms) sgn =
                                                     fmap,
                                                     env)
                                                end
-                                             | _ => default ())
-                                        | SOME fx =>
-                                          case class_key_in (sgnS_con' (m1, ms, fmap) (#1 a), #2 a) of
-                                              NONE => default ()
-                                            | SOME ck =>
-                                              let
-                                                  val cn = ClProj (m1, ms, fx)
-
-                                                  val classes =
-                                                      case CM.find (classes, cn) of
-                                                          NONE => classes
-                                                        | SOME class =>
-                                                          let
-                                                              val class = {
-                                                                  ground = KM.insert (#ground class, ck,
-                                                                                      (EModProj (m1, ms, x), #2 sgn))
-                                                              }
-                                                          in
-                                                              CM.insert (classes, cn, class)
-                                                          end
-                                              in
-                                                  (classes,
-                                                   newClasses,
-                                                   fmap,
-                                                   env)
-                                              end
-                                  end
-                                | SgiVal _ => default ()
+                                             | SOME fx =>
+                                               let
+                                                   val cn = ClProj (m1, ms, fx)
+
+                                                   val classes =
+                                                       case CM.find (classes, cn) of
+                                                           NONE => classes
+                                                         | SOME class =>
+                                                           let
+                                                               val class = KM.insert (class, (ck, nvars),
+                                                                                      (hyps,
+                                                                                       (EModProj (m1, ms, x), #2 sgn)))
+                                                           in
+                                                               CM.insert (classes, cn, class)
+                                                           end
+                                               in
+                                                   (classes,
+                                                    newClasses,
+                                                    fmap,
+                                                    env)
+                                               end
+                                       end)
                                 | _ => default ()
                           end)
                       (classes, IM.empty, (IM.empty, IM.empty, IM.empty), env) sgis
diff --git a/src/elaborate.sml b/src/elaborate.sml
index daa6e004..81af6a79 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1480,6 +1480,14 @@ fun normClassConstraint env (c, loc) =
         in
             (L'.CApp (f, x), loc)
         end
+      | L'.TFun (c1, c2) =>
+        let
+            val c1 = normClassConstraint env c1
+            val c2 = normClassConstraint env c2
+        in
+            (L'.TFun (c1, c2), loc)
+        end
+      | L'.TCFun (expl, x, k, c1) => (L'.TCFun (expl, x, k, normClassConstraint env c1), loc)
       | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint env c
       | _ => (c, loc)
 
@@ -3045,7 +3053,7 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs)) =
 
                     val () = checkCon env e' et c'
 
-                    val c = normClassConstraint env c'
+                    val c' = normClassConstraint env c'
                     val (env', n) = E.pushENamed env x c'
                 in
                     (*prefaces "DVal" [("x", Print.PD.string x),
@@ -3068,6 +3076,7 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs)) =
                                                 val (c', _, gs1) = case co of
                                                                        NONE => (cunif (loc, ktype), ktype, [])
                                                                      | SOME c => elabCon (env, denv) c
+                                                val c' = normClassConstraint env c'
                                             in
                                                 ((x, c', e), enD gs1 @ gs)
                                             end) gs vis
diff --git a/src/urweb.grm b/src/urweb.grm
index 1cd3e5c9..e6f0ddeb 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -188,7 +188,7 @@ fun tagIn bt =
  | DATATYPE | OF
  | TYPE | NAME
  | ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW | BANG
- | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE
+ | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE | CARET
  | LET | IN
  | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL
  | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE
@@ -341,7 +341,7 @@ fun tagIn bt =
 %right CAND
 %nonassoc EQ NE LT LE GT GE IS
 %right ARROW
-%right PLUSPLUS MINUSMINUS MINUSMINUSMINUS
+%right CARET PLUSPLUS MINUSMINUS MINUSMINUSMINUS
 %left PLUS MINUS
 %left STAR DIVIDE MOD
 %left NOT
@@ -753,6 +753,8 @@ eexp   : eapps                          (eapps)
 
        | eexp PLUSPLUS eexp             (EConcat (eexp1, eexp2), s (eexp1left, eexp2right))
 
+       | eexp CARET eexp                (native_op ("strcat", eexp1, eexp2, s (eexp1left, eexp2right)))
+
 bind   : SYMBOL LARROW eapps            (SYMBOL, NONE, eapps)
        | UNIT LARROW eapps              (let
                                              val loc = s (UNITleft, eappsright)
diff --git a/src/urweb.lex b/src/urweb.lex
index cbbf2a52..4a7ceaeb 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -254,6 +254,7 @@ notags = [^<{\n]+;
 <INITIAL> "++"        => (Tokens.PLUSPLUS (pos yypos, pos yypos + size yytext));
 <INITIAL> "--"        => (Tokens.MINUSMINUS (pos yypos, pos yypos + size yytext));
 <INITIAL> "---"       => (Tokens.MINUSMINUSMINUS (pos yypos, pos yypos + size yytext));
+<INITIAL> "^"         => (Tokens.CARET (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "="         => (Tokens.EQ (pos yypos, pos yypos + size yytext));
 <INITIAL> "<>"        => (Tokens.NE (pos yypos, pos yypos + size yytext));
diff --git a/tests/type_class.ur b/tests/type_class.ur
index 0acca7cd..42cbe82f 100644
--- a/tests/type_class.ur
+++ b/tests/type_class.ur
@@ -1,18 +1,48 @@
-class default t = t
+datatype pair a b = Pair of a * b
 
-val string_default : default string = "Hi"
-val int_default : default int = 0
+structure M : sig
+    class default
+    val get : t ::: Type -> default t -> t
 
-val default : t :: Type -> default t -> t =
-        fn t :: Type => fn d : default t => d
-val hi = default [string] _
-val zero = default [int] _
+    val string_default : default string
+    val int_default : default int
 
-val frob : t :: Type -> default t -> t =
-        fn t :: Type => fn _ : default t => default [t] _
-val hi_again = frob [string] _
-val zero_again = frob [int] _
+    val option_default : t ::: Type -> default t -> default (option t)
+    val pair_default : a ::: Type -> b ::: Type -> default a -> default b -> default (pair a b)
+end = struct
+    class default t = t
+    fun get (t ::: Type) (x : t) = x
 
-val main : unit -> page = fn () => <html><body>
-        {cdata hi_again}
-</body></html>
+    val string_default = "Hi"
+    val int_default = 0
+
+    fun option_default (t ::: Type) (x : t) = Some x
+    fun pair_default (a ::: Type) (b ::: Type) (x : a) (y : b) = Pair (x, y)
+end
+
+open M
+
+fun default (t ::: Type) (_ : default t) : t = get
+val hi : string = default
+val zero : int = default
+val some_zero : option int = default
+val hi_zero : pair string int = default
+
+fun frob (t ::: Type) (_ : default t) : t = default
+val hi_again : string = frob
+val zero_again : int = frob
+
+fun show_option (t ::: Type) (_ : show t) : show (option t) =
+    mkShow (fn x =>
+               case x of
+                   None => "None"
+                 | Some y => show y)
+
+fun show_pair (a ::: Type) (b ::: Type) (_ : show a) (_ : show b) : show (pair a b) =
+    mkShow (fn x =>
+               case x of
+                   Pair (y, z) => "(" ^ show y ^ "," ^ show z ^ ")")
+
+fun main () : transaction page = return <xml><body>
+  {[hi_again]}, {[zero_again]}, {[some_zero]}, {[hi_zero]}
+</body></xml>
diff --git a/tests/type_class.urp b/tests/type_class.urp
new file mode 100644
index 00000000..1a346623
--- /dev/null
+++ b/tests/type_class.urp
@@ -0,0 +1,3 @@
+debug
+
+type_class
-- 
cgit v1.2.3


From e52d6c0bc6e2e911515d21c6acc1e311a8e30db9 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Tue, 7 Apr 2009 12:24:31 -0400
Subject: UNIQUE constraints

---
 lib/ur/basis.urs     | 14 ++++++++++++++
 src/cjr.sml          |  2 +-
 src/cjr_print.sml    | 43 +++++++++++++++++++++++++++++++++--------
 src/cjrize.sml       | 14 ++++++++++++--
 src/core.sml         |  2 +-
 src/core_env.sml     |  2 +-
 src/core_print.sml   | 26 ++++++++++++++-----------
 src/core_util.sml    | 12 +++++++-----
 src/corify.sml       |  6 +++---
 src/elab.sml         |  2 +-
 src/elab_env.sml     |  2 +-
 src/elab_print.sml   | 18 +++++++++++-------
 src/elab_util.sml    | 12 +++++++-----
 src/elaborate.sml    | 23 ++++++++++++++--------
 src/expl.sml         |  2 +-
 src/expl_env.sml     |  2 +-
 src/expl_print.sml   | 18 +++++++++++-------
 src/explify.sml      |  2 +-
 src/mono.sml         |  2 +-
 src/mono_print.sml   | 28 +++++++++++++++------------
 src/mono_util.sml    |  5 ++++-
 src/monoize.sml      | 44 ++++++++++++++++++++++++++++++++++++------
 src/pathcheck.sml    | 34 ++++++++++++++++++++++++++-------
 src/reduce.sml       |  3 ++-
 src/shake.sml        | 47 +++++++++++++++++++++++++++++----------------
 src/source.sml       |  2 +-
 src/source_print.sml | 18 +++++++++++-------
 src/urweb.grm        | 54 +++++++++++++++++++++++++++++++++++++++++++++++++++-
 src/urweb.lex        |  3 +++
 tests/cst.ur         | 13 +++++++++++++
 tests/cst.urp        |  5 +++++
 31 files changed, 343 insertions(+), 117 deletions(-)
 create mode 100644 tests/cst.ur
 create mode 100644 tests/cst.urp

(limited to 'src/urweb.lex')

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 1cbca61d..dcf2a13d 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -124,6 +124,20 @@ val self : transaction client
 
 con sql_table :: {Type} -> Type
 
+(*** Constraints *)
+
+con sql_constraints :: {Unit} -> {Type} -> Type
+con sql_constraint :: {Type} -> Type
+
+val no_constraint : fs ::: {Type} -> sql_constraints [] fs
+val one_constraint : fs ::: {Type} -> name :: Name -> sql_constraint fs -> sql_constraints [name] fs
+val join_constraints : names1 ::: {Unit} -> names2 ::: {Unit} -> fs ::: {Type} -> [names1 ~ names2]
+    => sql_constraints names1 fs -> sql_constraints names2 fs
+       -> sql_constraints (names1 ++ names2) fs
+
+val unique : rest ::: {Type} -> unique :: {Type} -> [unique ~ rest] => sql_constraint (unique ++ rest)
+
+
 (*** Queries *)
 
 con sql_query :: {{Type}} -> {Type} -> Type
diff --git a/src/cjr.sml b/src/cjr.sml
index 78c2e63b..7f8b2434 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -104,7 +104,7 @@ datatype decl' =
        | DFun of string * int * (string * typ) list * typ * exp
        | DFunRec of (string * int * (string * typ) list * typ * exp) list
 
-       | DTable of string * (string * typ) list
+       | DTable of string * (string * typ) list * (string * string) list
        | DSequence of string
        | DDatabase of {name : string, expunge : int, initialize : int}
        | DPreparedStatements of (string * int) list
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 54ec3cbf..9fc1511f 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1435,7 +1435,7 @@ fun p_exp' par env (e, loc) =
             val wontLeakAnything = notLeaky env false state
         in
             box [if wontLeakAnything then
-                     string "uw_begin_region(ctx), "
+                     string "(uw_begin_region(ctx), "
                  else
                      box [],
                  string "({",
@@ -1585,7 +1585,11 @@ fun p_exp' par env (e, loc) =
                      box [],
                  string "acc;",
                  newline,
-                 string "})"]
+                 string "})",
+                 if wontLeakAnything then
+                     string ")"
+                 else
+                     box []]
         end
 
       | EDml {dml, prepared} =>
@@ -1937,10 +1941,19 @@ fun p_decl env (dAll as (d, _) : decl) =
                  p_list_sep newline (p_fun env) vis,
                  newline]
         end
-      | DTable (x, _) => box [string "/* SQL table ",
-                              string x,
-                              string " */",
-                              newline]
+      | DTable (x, _, csts) => box [string "/* SQL table ",
+                                    string x,
+                                    space,
+                                    string "constraints",
+                                    space,
+                                    p_list (fn (x, v) => box [string x,
+                                                              space,
+                                                              string ":",
+                                                              space,
+                                                              string v]) csts,
+                                    space,
+                                    string " */",
+                                    newline]
       | DSequence x => box [string "/* SQL sequence ",
                             string x,
                             string " */",
@@ -2454,7 +2467,7 @@ fun p_file env (ds, ps) =
 
         val pds' = map p_page ps
 
-        val tables = List.mapPartial (fn (DTable (s, xts), _) => SOME (s, xts)
+        val tables = List.mapPartial (fn (DTable (s, xts, _), _) => SOME (s, xts)
                                        | _ => NONE) ds
         val sequences = List.mapPartial (fn (DSequence s, _) => SOME s
                                           | _ => NONE) ds
@@ -2798,7 +2811,7 @@ fun p_sql env (ds, _) =
                        (fn (dAll as (d, _), env) =>
                            let
                                val pp = case d of
-                                            DTable (s, xts) =>
+                                            DTable (s, xts, csts) =>
                                             box [string "CREATE TABLE ",
                                                  string s,
                                                  string "(",
@@ -2807,6 +2820,20 @@ fun p_sql env (ds, _) =
                                                                  string (CharVector.map Char.toLower x),
                                                                  space,
                                                                  p_sqltype env (t, ErrorMsg.dummySpan)]) xts,
+                                                 case csts of
+                                                     [] => box []
+                                                   | _ => box [string ","],
+                                                 cut,
+                                                 p_list_sep (box [string ",", newline])
+                                                            (fn (x, c) =>
+                                                                box [string "CONSTRAINT",
+                                                                     space,
+                                                                     string s,
+                                                                     string "_",
+                                                                     string x,
+                                                                     space,
+                                                                     string c]) csts,
+                                                 newline,
                                                  string ");",
                                                  newline,
                                                  newline]
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 5e4b647a..839c0c57 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -524,7 +524,7 @@ fun cifyDecl ((d, loc), sm) =
             (NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndPullAndPush), sm)
         end
 
-      | L.DTable (s, xts) =>
+      | L.DTable (s, xts, e) =>
         let
             val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
                                                   let
@@ -532,8 +532,18 @@ fun cifyDecl ((d, loc), sm) =
                                                   in
                                                       ((x, t), sm)
                                                   end) sm xts
+
+            fun flatten e =
+                case #1 e of
+                    L.ERecord [] => []
+                  | L.ERecord [(x, (L.EPrim (Prim.String v), _), _)] => [(x, v)]
+                  | L.EStrcat (e1, e2) => flatten e1 @ flatten e2
+                  | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined";
+                          Print.prefaces "Undetermined constraint"
+                          [("e", MonoPrint.p_exp MonoEnv.empty e)];
+                          [])
         in
-            (SOME (L'.DTable (s, xts), loc), NONE, sm)
+            (SOME (L'.DTable (s, xts, flatten e), loc), NONE, sm)
         end
       | L.DSequence s =>
         (SOME (L'.DSequence s, loc), NONE, sm)
diff --git a/src/core.sml b/src/core.sml
index b384c576..74ef138c 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -130,7 +130,7 @@ datatype decl' =
        | DVal of string * int * con * exp * string
        | DValRec of (string * int * con * exp * string) list
        | DExport of export_kind * int
-       | DTable of string * int * con * string
+       | DTable of string * int * con * string * exp
        | DSequence of string * int * string
        | DDatabase of string
        | DCookie of string * int * con * string
diff --git a/src/core_env.sml b/src/core_env.sml
index dd77e3fb..d1e956d8 100644
--- a/src/core_env.sml
+++ b/src/core_env.sml
@@ -313,7 +313,7 @@ fun declBinds env (d, loc) =
       | DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s
       | DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis
       | DExport _ => env
-      | DTable (x, n, c, s) =>
+      | DTable (x, n, c, s, _) =>
         let
             val t = (CApp ((CFfi ("Basis", "sql_table"), loc), c), loc)
         in
diff --git a/src/core_print.sml b/src/core_print.sml
index cc6e5428..d68ba288 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -546,17 +546,21 @@ fun p_decl env (dAll as (d, _) : decl) =
                                 space,
                                 (p_con env (#2 (E.lookupENamed env n))
                                  handle E.UnboundNamed _ => string "UNBOUND")]
-      | DTable (x, n, c, s) => box [string "table",
-                                    space,
-                                    p_named x n,
-                                    space,
-                                    string "as",
-                                    space,
-                                    string s,
-                                    space,
-                                    string ":",
-                                    space,
-                                    p_con env c]
+      | DTable (x, n, c, s, e) => box [string "table",
+                                       space,
+                                       p_named x n,
+                                       space,
+                                       string "as",
+                                       space,
+                                       string s,
+                                       space,
+                                       string ":",
+                                       space,
+                                       p_con env c,
+                                       space,
+                                       string "constraints",
+                                       space,
+                                       p_exp env e]
       | DSequence (x, n, s) => box [string "sequence",
                                     space,
                                     p_named x n,
diff --git a/src/core_util.sml b/src/core_util.sml
index b1d07b79..b342f2f7 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -933,10 +933,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} =
                             (DValRec vis', loc))
                 end
               | DExport _ => S.return2 dAll
-              | DTable (x, n, c, s) =>
-                S.map2 (mfc ctx c,
+              | DTable (x, n, c, s, e) =>
+                S.bind2 (mfc ctx c,
                      fn c' =>
-                        (DTable (x, n, c', s), loc))
+                        S.map2 (mfe ctx e,
+                                fn e' =>
+                                   (DTable (x, n, c', s, e'), loc)))
               | DSequence _ => S.return2 dAll
               | DDatabase _ => S.return2 dAll
               | DCookie (x, n, c, s) =>
@@ -1058,7 +1060,7 @@ fun mapfoldB (all as {bind, ...}) =
                                         foldl (fn ((x, n, t, e, s), ctx) => bind (ctx, NamedE (x, n, t, NONE, s)))
                                         ctx vis
                                       | DExport _ => ctx
-                                      | DTable (x, n, c, s) =>
+                                      | DTable (x, n, c, s, _) =>
                                         let
                                             val t = (CApp ((CFfi ("Basis", "sql_table"), #2 d'), c), #2 d')
                                         in
@@ -1134,7 +1136,7 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
                           | DVal (_, n, _, _, _) => Int.max (n, count)
                           | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis
                           | DExport _ => count
-                          | DTable (_, n, _, _) => Int.max (n, count)
+                          | DTable (_, n, _, _, _) => Int.max (n, count)
                           | DSequence (_, n, _) => Int.max (n, count)
                           | DDatabase _ => count
                           | DCookie (_, n, _, _) => Int.max (n, count)) 0
diff --git a/src/corify.sml b/src/corify.sml
index 9ca6c915..fc8bb1de 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -976,12 +976,12 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
              end
            | _ => raise Fail "Non-const signature for 'export'")
 
-      | L.DTable (_, x, n, c) =>
+      | L.DTable (_, x, n, c, e) =>
         let
             val (st, n) = St.bindVal st x n
             val s = relify (doRestify (mods, x))
         in
-            ([(L'.DTable (x, n, corifyCon st c, s), loc)], st)
+            ([(L'.DTable (x, n, corifyCon st c, s, corifyExp st e), loc)], st)
         end
       | L.DSequence (_, x, n) =>
         let
@@ -1052,7 +1052,7 @@ fun maxName ds = foldl (fn ((d, _), n) =>
                              | L.DStr (_, n', _, str) => Int.max (n, Int.max (n', maxNameStr str))
                              | L.DFfiStr (_, n', _) => Int.max (n, n')
                              | L.DExport _ => n
-                             | L.DTable (_, _, n', _) => Int.max (n, n')
+                             | L.DTable (_, _, n', _, _) => Int.max (n, n')
                              | L.DSequence (_, _, n') => Int.max (n, n')
                              | L.DDatabase _ => n
                              | L.DCookie (_, _, n', _) => Int.max (n, n'))
diff --git a/src/elab.sml b/src/elab.sml
index 3fed1918..dd2952d2 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -166,7 +166,7 @@ datatype decl' =
        | DFfiStr of string * int * sgn
        | DConstraint of con * con
        | DExport of int * sgn * str
-       | DTable of int * string * int * con
+       | DTable of int * string * int * con * exp
        | DSequence of int * string * int
        | DClass of string * int * kind * con
        | DDatabase of string
diff --git a/src/elab_env.sml b/src/elab_env.sml
index 370e504f..7adc8dd9 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -1532,7 +1532,7 @@ fun declBinds env (d, loc) =
       | DFfiStr (x, n, sgn) => pushStrNamedAs env x n sgn
       | DConstraint _ => env
       | DExport _ => env
-      | DTable (tn, x, n, c) =>
+      | DTable (tn, x, n, c, _) =>
         let
             val t = (CApp ((CModProj (tn, [], "sql_table"), loc), c), loc)
         in
diff --git a/src/elab_print.sml b/src/elab_print.sml
index 64d8cfab..f98592cc 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -740,13 +740,17 @@ fun p_decl env (dAll as (d, _) : decl) =
                                       string ":",
                                       space,
                                       p_sgn env sgn]
-      | DTable (_, x, n, c) => box [string "table",
-                                    space,
-                                    p_named x n,
-                                    space,
-                                    string ":",
-                                    space,
-                                    p_con env c]
+      | DTable (_, x, n, c, e) => box [string "table",
+                                       space,
+                                       p_named x n,
+                                       space,
+                                       string ":",
+                                       space,
+                                       p_con env c,
+                                       space,
+                                       string "constraints",
+                                       space,
+                                       p_exp env e]
       | DSequence (_, x, n) => box [string "sequence",
                                     space,
                                     p_named x n]
diff --git a/src/elab_util.sml b/src/elab_util.sml
index e2dd0ce6..6700686d 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -766,7 +766,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
                                                    bind (ctx, Str (x, sgn))
                                                  | DConstraint _ => ctx
                                                  | DExport _ => ctx
-                                                 | DTable (tn, x, n, c) =>
+                                                 | DTable (tn, x, n, c, _) =>
                                                    bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "sql_table"), loc),
                                                                                 c), loc)))
                                                  | DSequence (tn, x, n) =>
@@ -864,10 +864,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
                                     fn str' =>
                                        (DExport (en, sgn', str'), loc)))
 
-              | DTable (tn, x, n, c) =>
-                S.map2 (mfc ctx c,
+              | DTable (tn, x, n, c, e) =>
+                S.bind2 (mfc ctx c,
                         fn c' =>
-                           (DTable (tn, x, n, c'), loc))
+                           S.map2 (mfe ctx e,
+                                   fn e' =>
+                                      (DTable (tn, x, n, c', e'), loc)))
               | DSequence _ => S.return2 dAll
 
               | DClass (x, n, k, c) =>
@@ -1018,7 +1020,7 @@ and maxNameDecl (d, _) =
       | DConstraint _ => 0
       | DClass (_, n, _, _) => n
       | DExport _ => 0
-      | DTable (n1, _, n2, _) => Int.max (n1, n2)
+      | DTable (n1, _, n2, _, _) => Int.max (n1, n2)
       | DSequence (n1, _, n2) => Int.max (n1, n2)
       | DDatabase _ => 0
       | DCookie (n1, _, n2, _) => Int.max (n1, n2)
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 81af6a79..0beab9e7 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1126,11 +1126,11 @@
                  else
                      (e, t, [])
                | t => (e, t, [])
-    in
-        case infer of
-            L.DontInfer => (e, t, [])
-          | _ => unravel (t, e)
-    end
+     in
+         case infer of
+             L.DontInfer => (e, t, [])
+           | _ => unravel (t, e)
+     end
 
 fun elabPat (pAll as (p, loc), (env, bound)) =
     let
@@ -2319,7 +2319,7 @@ fun sgiOfDecl (d, loc) =
       | L'.DFfiStr (x, n, sgn) => [(L'.SgiStr (x, n, sgn), loc)]
       | L'.DConstraint cs => [(L'.SgiConstraint cs, loc)]
       | L'.DExport _ => []
-      | L'.DTable (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (tableOf (), c), loc)), loc)]
+      | L'.DTable (tn, x, n, c, _) => [(L'.SgiVal (x, n, (L'.CApp (tableOf (), c), loc)), loc)]
       | L'.DSequence (tn, x, n) => [(L'.SgiVal (x, n, sequenceOf ()), loc)]
       | L'.DClass (x, n, k, c) => [(L'.SgiClass (x, n, k, c), loc)]
       | L'.DDatabase _ => []
@@ -3265,13 +3265,20 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs)) =
                     ([(L'.DExport (E.newNamed (), sgn, str'), loc)], (env, denv, gs' @ gs))
                 end
 
-              | L.DTable (x, c) =>
+              | L.DTable (x, c, e) =>
                 let
                     val (c', k, gs') = elabCon (env, denv) c
                     val (env, n) = E.pushENamed env x (L'.CApp (tableOf (), c'), loc)
+                    val (e', et, gs'') = elabExp (env, denv) e
+
+                    val names = cunif (loc, (L'.KRecord (L'.KUnit, loc), loc))
+                    val cst = (L'.CModProj (!basis_r, [], "sql_constraints"), loc)
+                    val cst = (L'.CApp (cst, names), loc)
+                    val cst = (L'.CApp (cst, c'), loc)
                 in
                     checkKind env c' k (L'.KRecord (L'.KType, loc), loc);
-                    ([(L'.DTable (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs))
+                    checkCon env e' et cst;
+                    ([(L'.DTable (!basis_r, x, n, c', e'), loc)], (env, denv, gs'' @ enD gs' @ gs))
                 end
               | L.DSequence x =>
                 let
diff --git a/src/expl.sml b/src/expl.sml
index d7138620..a347a8e8 100644
--- a/src/expl.sml
+++ b/src/expl.sml
@@ -141,7 +141,7 @@ datatype decl' =
        | DStr of string * int * sgn * str
        | DFfiStr of string * int * sgn
        | DExport of int * sgn * str
-       | DTable of int * string * int * con
+       | DTable of int * string * int * con * exp
        | DSequence of int * string * int
        | DDatabase of string
        | DCookie of int * string * int * con
diff --git a/src/expl_env.sml b/src/expl_env.sml
index 403a826a..f4e16cb5 100644
--- a/src/expl_env.sml
+++ b/src/expl_env.sml
@@ -298,7 +298,7 @@ fun declBinds env (d, loc) =
       | DStr (x, n, sgn, _) => pushStrNamed env x n sgn
       | DFfiStr (x, n, sgn) => pushStrNamed env x n sgn
       | DExport _ => env
-      | DTable (tn, x, n, c) =>
+      | DTable (tn, x, n, c, _) =>
         let
             val t = (CApp ((CModProj (tn, [], "sql_table"), loc), c), loc)
         in
diff --git a/src/expl_print.sml b/src/expl_print.sml
index e7fb51f6..c7a506b1 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -663,13 +663,17 @@ fun p_decl env (dAll as (d, _) : decl) =
                                       string ":",
                                       space,
                                       p_sgn env sgn]
-      | DTable (_, x, n, c) => box [string "table",
-                                    space,
-                                    p_named x n,
-                                    space,
-                                    string ":",
-                                    space,
-                                    p_con env c]
+      | DTable (_, x, n, c, e) => box [string "table",
+                                       space,
+                                       p_named x n,
+                                       space,
+                                       string ":",
+                                       space,
+                                       p_con env c,
+                                       space,
+                                       string "constraints",
+                                       space,
+                                       p_exp env e]
       | DSequence (_, x, n) => box [string "sequence",
                                     space,
                                     p_named x n]
diff --git a/src/explify.sml b/src/explify.sml
index f9f58c65..d567bde3 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -178,7 +178,7 @@ fun explifyDecl (d, loc : EM.span) =
       | L.DFfiStr (x, n, sgn) => SOME (L'.DFfiStr (x, n, explifySgn sgn), loc)
       | L.DConstraint (c1, c2) => NONE
       | L.DExport (en, sgn, str) => SOME (L'.DExport (en, explifySgn sgn, explifyStr str), loc)
-      | L.DTable (nt, x, n, c) => SOME (L'.DTable (nt, x, n, explifyCon c), loc)
+      | L.DTable (nt, x, n, c, e) => SOME (L'.DTable (nt, x, n, explifyCon c, explifyExp e), loc)
       | L.DSequence (nt, x, n) => SOME (L'.DSequence (nt, x, n), loc)
       | L.DClass (x, n, k, c) => SOME (L'.DCon (x, n,
                                                 (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), explifyCon c), loc)
diff --git a/src/mono.sml b/src/mono.sml
index 02afb2c0..5a65a9f9 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -121,7 +121,7 @@ datatype decl' =
        | DValRec of (string * int * typ * exp * string) list
        | DExport of Core.export_kind * string * int * typ list * typ
 
-       | DTable of string * (string * typ) list
+       | DTable of string * (string * typ) list * exp
        | DSequence of string
        | DDatabase of {name : string, expunge : int, initialize : int}
 
diff --git a/src/mono_print.sml b/src/mono_print.sml
index a8ece085..935f8368 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -403,18 +403,22 @@ fun p_decl env (dAll as (d, _) : decl) =
                                           space,
                                           p_typ env t]
 
-      | DTable (s, xts) => box [string "(* SQL table ",
-                                string s,
-                                space,
-                                string ":",
-                                space,
-                                p_list (fn (x, t) => box [string x,
-                                                          space,
-                                                          string ":",
-                                                          space,
-                                                          p_typ env t]) xts,
-                                space,
-                                string "*)"]
+      | DTable (s, xts, e) => box [string "(* SQL table ",
+                                   string s,
+                                   space,
+                                   string ":",
+                                   space,
+                                   p_list (fn (x, t) => box [string x,
+                                                             space,
+                                                             string ":",
+                                                             space,
+                                                             p_typ env t]) xts,
+                                   space,
+                                   string "constraints",
+                                   space,
+                                   p_exp env e,
+                                   space,
+                                   string "*)"]
       | DSequence s => box [string "(* SQL sequence ",
                             string s,
                             string "*)"]
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 9455435c..ca5cf5cb 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -465,7 +465,10 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
                            S.map2 (mft t,
                                    fn t' =>
                                       (DExport (ek, s, n, ts', t'), loc)))
-              | DTable _ => S.return2 dAll
+              | DTable (s, xts, e) =>
+                S.map2 (mfe ctx e,
+                        fn e' =>
+                           (DTable (s, xts, e'), loc))
               | DSequence _ => S.return2 dAll
               | DDatabase _ => S.return2 dAll
               | DJavaScript _ => S.return2 dAll
diff --git a/src/monoize.sml b/src/monoize.sml
index 620e43a5..af414c08 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -149,6 +149,10 @@ fun monoType env =
                     (L'.TFfi ("Basis", "string"), loc)
                   | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _) =>
                     (L'.TFfi ("Basis", "string"), loc)
+                  | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraints"), _), _), _), _) =>
+                    (L'.TFfi ("Basis", "sql_constraints"), loc)
+                  | L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _) =>
+                    (L'.TFfi ("Basis", "string"), loc)
 
                   | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_subset"), _), _), _), _) =>
                     (L'.TRecord [], loc)
@@ -1155,6 +1159,32 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                  fm)
             end
 
+          | L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) =>
+            ((L'.ERecord [], loc),
+             fm)
+          | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "one_constraint"), _), _), _), (L.CName name, _)) =>
+            ((L'.EAbs ("c",
+                       (L'.TFfi ("Basis", "string"), loc),
+                       (L'.TFfi ("Basis", "sql_constraints"), loc),
+                       (L'.ERecord [(name, (L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))], loc)), loc),
+             fm)
+          | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "join_constraints"), _), _), _), _), _), _) =>
+            let
+                val constraints = (L'.TFfi ("Basis", "sql_constraints"), loc)
+            in
+                ((L'.EAbs ("cs1", constraints, (L'.TFun (constraints, constraints), loc),
+                           (L'.EAbs ("cs2", constraints, constraints,
+                                     (L'.EStrcat ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
+                 fm)
+            end
+
+          | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "unique"), _), _), _),
+                     (L.CRecord (_, unique), _)) =>
+            ((L'.EPrim (Prim.String ("UNIQUE ("
+                                     ^ String.concatWith ", " (map (fn (x, _) => "uw_" ^ monoName env x) unique)
+                                     ^ ")")), loc),
+             fm)
+
           | L.EFfiApp ("Basis", "dml", [e]) =>
             let
                 val (e, fm) = monoExp (env, st, fm) e
@@ -2451,19 +2481,21 @@ fun monoDecl (env, fm) (all as (d, loc)) =
             in
                 SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)])
             end
-          | L.DTable (x, n, (L.CRecord (_, xts), _), s) =>
+          | L.DTable (x, n, (L.CRecord (_, xts), _), s, e) =>
             let
                 val t = (L.CFfi ("Basis", "string"), loc)
                 val t' = (L'.TFfi ("Basis", "string"), loc)
                 val s = "uw_" ^ s
-                val e = (L'.EPrim (Prim.String s), loc)
+                val e_name = (L'.EPrim (Prim.String s), loc)
 
                 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
+
+                val (e, fm) = monoExp (env, St.empty, fm) e
             in
                 SOME (Env.pushENamed env x n t NONE s,
                       fm,
-                      [(L'.DTable (s, xts), loc),
-                       (L'.DVal (x, n, t', e, s), loc)])
+                      [(L'.DTable (s, xts, e), loc),
+                       (L'.DVal (x, n, t', e_name, s), loc)])
             end
           | L.DTable _ => poly ()
           | L.DSequence (x, n, s) =>
@@ -2583,7 +2615,7 @@ fun monoize env file =
             in
                 foldl (fn ((d, _), e) =>
                           case d of
-                              L.DTable (_, _, xts, tab) => doTable (tab, #1 xts, e)
+                              L.DTable (_, _, xts, tab, _) => doTable (tab, #1 xts, e)
                             | _ => e) e file
             end
 
@@ -2628,7 +2660,7 @@ fun monoize env file =
             in
                 foldl (fn ((d, _), e) =>
                           case d of
-                              L.DTable (_, _, xts, tab) => doTable (tab, #1 xts, e)
+                              L.DTable (_, _, xts, tab, _) => doTable (tab, #1 xts, e)
                             | _ => e) e file
             end
 
diff --git a/src/pathcheck.sml b/src/pathcheck.sml
index 036d286f..6771e628 100644
--- a/src/pathcheck.sml
+++ b/src/pathcheck.sml
@@ -38,6 +38,13 @@ structure SS = BinarySetFn(struct
 
 fun checkDecl ((d, loc), (funcs, rels)) =
     let
+        fun doFunc s =
+            (if SS.member (funcs, s) then
+                 E.errorAt loc ("Duplicate function path " ^ s)
+             else
+                 ();
+             (SS.add (funcs, s), rels))
+
         fun doRel s =
             (if SS.member (rels, s) then
                  E.errorAt loc ("Duplicate table/sequence path " ^ s)
@@ -46,14 +53,27 @@ fun checkDecl ((d, loc), (funcs, rels)) =
              (funcs, SS.add (rels, s)))
     in
         case d of
-            DExport (_, s, _, _, _) =>
-            (if SS.member (funcs, s) then
-                 E.errorAt loc ("Duplicate function path " ^ s)
-             else
-                 ();
-             (SS.add (funcs, s), rels))
+            DExport (_, s, _, _, _) => doFunc s
             
-          | DTable (s, _) => doRel s
+          | DTable (s, _, e) =>
+            let
+                fun constraints (e, rels) =
+                    case #1 e of
+                        ERecord [(s', _, _)] =>
+                        let
+                            val s' = s ^ "_" ^ s'
+                        in
+                            if SS.member (rels, s') then
+                                E.errorAt loc ("Duplicate constraint path " ^ s')
+                            else
+                                ();
+                            SS.add (rels, s')
+                        end
+                      | EStrcat (e1, e2) => constraints (e2, constraints (e1, rels))
+                      | _ => rels
+            in
+                (funcs, constraints (e, #2 (doRel s)))
+            end
           | DSequence s => doRel s
 
           | _ => (funcs, rels)
diff --git a/src/reduce.sml b/src/reduce.sml
index 8664d38d..6754d708 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -461,7 +461,8 @@ fun reduce file =
                 ((DValRec (map (fn (x, n, t, e, s) => (x, n, con namedC [] t, exp (namedC, namedE) [] e, s)) vis), loc),
                  st)
               | DExport _ => (d, st)
-              | DTable (s, n, c, s') => ((DTable (s, n, con namedC [] c, s'), loc), st)
+              | DTable (s, n, c, s', e) => ((DTable (s, n, con namedC [] c, s',
+                                                     exp (namedC, namedE) [] e), loc), st)
               | DSequence _ => (d, st)
               | DDatabase _ => (d, st)
               | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st)
diff --git a/src/shake.sml b/src/shake.sml
index 4df64efa..2f873e94 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -46,11 +46,26 @@ val dummye = (EPrim (Prim.String ""), ErrorMsg.dummySpan)
 
 fun shake file =
     let
-        val (page_es, table_cs) =
+        val usedVars = U.Exp.fold {kind = fn (_, st) => st,
+                                   con = fn (c, st as (es, cs)) =>
+                                            case c of
+                                                CNamed n => (es, IS.add (cs, n))
+                                              | _ => st,
+                                   exp = fn (e, st as (es, cs)) =>
+                                            case e of
+                                                ENamed n => (IS.add (es, n), cs)
+                                              | _ => st}
+
+        val (usedE, usedC, table_cs) =
             List.foldl
-                (fn ((DExport (_, n), _), (page_es, table_cs)) => (n :: page_es, table_cs)
-                  | ((DTable (_, _, c, _), _), (page_es, table_cs)) => (page_es, c :: table_cs)
-                  | (_, acc) => acc) ([], []) file
+                (fn ((DExport (_, n), _), (usedE, usedC, table_cs)) => (IS.add (usedE, n), usedE, table_cs)
+                  | ((DTable (_, _, c, _, e), _), (usedE, usedC, table_cs)) =>
+                    let
+                        val (usedE, usedC) = usedVars (usedE, usedC) e
+                    in
+                        (usedE, usedC, c :: table_cs)
+                    end
+                  | (_, acc) => acc) (IS.empty, IS.empty, []) file
 
         val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef)
                                    | ((DDatatype (_, n, _, xncs), _), (cdef, edef)) =>
@@ -64,7 +79,7 @@ fun shake file =
                                                           IM.insert (edef, n, (all_ns, t, e))) edef vis)
                                      end
                                    | ((DExport _, _), acc) => acc
-                                   | ((DTable (_, n, c, _), _), (cdef, edef)) =>
+                                   | ((DTable (_, n, c, _, _), _), (cdef, edef)) =>
                                      (cdef, IM.insert (edef, n, ([], c, dummye)))
                                    | ((DSequence (_, n, _), _), (cdef, edef)) =>
                                      (cdef, IM.insert (edef, n, ([], dummyt, dummye)))
@@ -122,17 +137,17 @@ fun shake file =
 
         and shakeExp s = U.Exp.fold {kind = kind, con = con, exp = exp} s
 
-        val s = {con = IS.empty, exp = IS.addList (IS.empty, page_es)}
-
-        val s = foldl (fn (n, s) =>
-                          case IM.find (edef, n) of
-                              NONE => raise Fail "Shake: Couldn't find 'val'"
-                            | SOME (ns, t, e) =>
-                              let
-                                  val s = shakeExp (shakeCon s t) e
-                              in
-                                  foldl (fn (n, s) => exp (ENamed n, s)) s ns
-                              end) s page_es
+        val s = {con = usedC, exp = usedE}
+
+        val s = IS.foldl (fn (n, s) =>
+                             case IM.find (edef, n) of
+                                 NONE => raise Fail "Shake: Couldn't find 'val'"
+                               | SOME (ns, t, e) =>
+                                 let
+                                     val s = shakeExp (shakeCon s t) e
+                                 in
+                                     foldl (fn (n, s) => exp (ENamed n, s)) s ns
+                                 end) s usedE
 
         val s = foldl (fn (c, s) => shakeCon s c) s table_cs
     in
diff --git a/src/source.sml b/src/source.sml
index 9ef14fd9..42927ef3 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -160,7 +160,7 @@ datatype decl' =
        | DConstraint of con * con
        | DOpenConstraints of string * string list
        | DExport of str
-       | DTable of string * con
+       | DTable of string * con * exp
        | DSequence of string
        | DClass of string * kind * con
        | DDatabase of string
diff --git a/src/source_print.sml b/src/source_print.sml
index 8d8b28c3..d1c9b6df 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -588,13 +588,17 @@ fun p_decl ((d, _) : decl) =
       | DExport str => box [string "export",
                             space,
                             p_str str]
-      | DTable (x, c) => box [string "table",
-                              space,
-                              string x,
-                              space,
-                              string ":",
-                              space,
-                              p_con c]
+      | DTable (x, c, e) => box [string "table",
+                                 space,
+                                 string x,
+                                 space,
+                                 string ":",
+                                 space,
+                                 p_con c,
+                                 space,
+                                 string "constraints",
+                                 space,
+                                 p_exp e]
       | DSequence x => box [string "sequence",
                             space,
                             string x]
diff --git a/src/urweb.grm b/src/urweb.grm
index 98ba295a..784c62ee 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -208,6 +208,7 @@ fun tagIn bt =
  | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS
  | CURRENT_TIMESTAMP
  | NE | LT | LE | GT | GE
+ | CCONSTRAINT | UNIQUE
 
 %nonterm
    file of decl list
@@ -222,6 +223,10 @@ fun tagIn bt =
  | dcons of (string * con option) list
  | dcon of string * con option
 
+ | cst of exp
+ | csts of exp
+ | cstopt of exp
+
  | sgn of sgn
  | sgntm of sgn
  | sgi of sgn_item
@@ -289,6 +294,9 @@ fun tagIn bt =
  | query1 of exp
  | tables of (con * exp) list
  | tname of con
+ | tnameW of (con * con)
+ | tnames of con
+ | tnames' of (con * con) list
  | table of con * exp
  | tident of con
  | fident of con
@@ -410,7 +418,7 @@ decl   : CON SYMBOL cargl2 kopt EQ cexp (let
                                            | m :: ms => [(DOpenConstraints (m, ms), s (OPENleft, mpathright))])
        | CONSTRAINT cterm TWIDDLE cterm ([(DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))])
        | EXPORT spath                   ([(DExport spath, s (EXPORTleft, spathright))])
-       | TABLE SYMBOL COLON cexp        ([(DTable (SYMBOL, entable cexp), s (TABLEleft, cexpright))])
+       | TABLE SYMBOL COLON cterm cstopt([(DTable (SYMBOL, entable cterm, cstopt), s (TABLEleft, cstoptright))])
        | SEQUENCE SYMBOL                ([(DSequence SYMBOL, s (SEQUENCEleft, SYMBOLright))])
        | CLASS SYMBOL EQ cexp           (let
                                              val loc = s (CLASSleft, cexpright)
@@ -460,6 +468,50 @@ vali   : SYMBOL eargl2 copt EQ eexp     (let
 copt   :                                (NONE)
        | COLON cexp                     (SOME cexp)
 
+cstopt :                                (EVar (["Basis"], "no_constraint", Infer), dummy)
+       | csts                           (csts)
+
+csts   : CCONSTRAINT tname cst          (let
+                                             val loc = s (CCONSTRAINTleft, cstright)
+                                                       
+                                             val e = (EVar (["Basis"], "one_constraint", Infer), loc)
+                                             val e = (ECApp (e, tname), loc)
+                                         in
+                                             (EApp (e, cst), loc)
+                                         end)
+       | csts COMMA csts                (let
+                                             val loc = s (csts1left, csts2right)
+
+                                             val e = (EVar (["Basis"], "join_constraints", Infer), loc)
+                                             val e = (EApp (e, csts1), loc)
+                                         in
+                                             (EApp (e, csts2), loc)
+                                         end)
+       | LBRACE LBRACE eexp RBRACE RBRACE (eexp)
+
+cst    : UNIQUE tnames                  (let
+                                             val loc = s (UNIQUEleft, tnamesright)
+                                                       
+                                             val e = (EVar (["Basis"], "unique", Infer), loc)
+                                             val e = (ECApp (e, tnames), loc)
+                                         in
+                                             (EDisjointApp e, loc)
+                                         end)
+       | LBRACE eexp RBRACE             (eexp)
+
+tnameW : tname                          (let
+                                             val loc = s (tnameleft, tnameright)
+                                         in
+                                             (tname, (CWild (KType, loc), loc))
+                                         end)
+
+tnames : tnameW                         (CRecord [tnameW], s (tnameWleft, tnameWright))
+       | LPAREN tnames' RPAREN          (CRecord tnames', s (LPARENleft, RPARENright))
+       | LBRACE LBRACE cexp RBRACE RBRACE (cexp)
+
+tnames': tnameW                         ([tnameW])
+       | tnameW COMMA tnames'           (tnameW :: tnames')
+
 valis  : vali                           ([vali])
        | vali AND valis                 (vali :: valis)
 
diff --git a/src/urweb.lex b/src/urweb.lex
index 4a7ceaeb..735d230d 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -365,6 +365,9 @@ notags = [^<{\n]+;
 <INITIAL> "NULL"      => (Tokens.NULL (pos yypos, pos yypos + size yytext));
 <INITIAL> "IS"        => (Tokens.IS (pos yypos, pos yypos + size yytext));
 
+<INITIAL> "CONSTRAINT"=> (Tokens.CCONSTRAINT (pos yypos, pos yypos + size yytext));
+<INITIAL> "UNIQUE"    => (Tokens.UNIQUE (pos yypos, pos yypos + size yytext));
+
 <INITIAL> "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext));
 
 <INITIAL> {id}        => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext));
diff --git a/tests/cst.ur b/tests/cst.ur
new file mode 100644
index 00000000..104a9f34
--- /dev/null
+++ b/tests/cst.ur
@@ -0,0 +1,13 @@
+table t : {A : int, B : int}
+  CONSTRAINT UniA UNIQUE A,
+  CONSTRAINT UniB UNIQUE B,
+  CONSTRAINT UniBoth UNIQUE (A, B),
+
+  CONSTRAINT UniAm UNIQUE {#A},
+  CONSTRAINT UniAm2 UNIQUE {{[A = _]}},
+  CONSTRAINT UniAm3 {unique [[A = _]] !},
+  {{one_constraint [#UniAm4] (unique [[A = _]] !)}}
+
+fun main () : transaction page =
+    queryI (SELECT * FROM t) (fn _ => return ());
+    return <xml/>
diff --git a/tests/cst.urp b/tests/cst.urp
new file mode 100644
index 00000000..b9deaa44
--- /dev/null
+++ b/tests/cst.urp
@@ -0,0 +1,5 @@
+debug
+database dbname=cst
+sql cst.sql
+
+cst
-- 
cgit v1.2.3


From 26ad31287745567b98b357de9793a0e795c63334 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Tue, 7 Apr 2009 16:14:31 -0400
Subject: PRIMARY KEY

---
 lib/ur/basis.urs     | 30 +++++++++++++++++++---------
 src/cjr.sml          |  2 +-
 src/cjr_print.sml    | 55 +++++++++++++++++++++++++++++++++++-----------------
 src/cjrize.sml       | 13 ++++++++++---
 src/core.sml         |  2 +-
 src/core_env.sml     |  4 ++--
 src/core_print.sml   | 34 ++++++++++++++++++--------------
 src/core_util.sml    | 22 ++++++++++++---------
 src/corify.sml       |  8 +++++---
 src/elab.sml         |  2 +-
 src/elab_env.sml     |  4 ++--
 src/elab_print.sml   | 26 ++++++++++++++-----------
 src/elab_util.sml    | 22 ++++++++++++---------
 src/elaborate.sml    | 51 ++++++++++++++++++++++++++++++++++--------------
 src/expl.sml         |  2 +-
 src/expl_env.sml     |  4 ++--
 src/expl_print.sml   | 26 ++++++++++++++-----------
 src/explify.sml      |  5 ++++-
 src/mono.sml         |  2 +-
 src/mono_print.sml   | 36 +++++++++++++++++++---------------
 src/mono_util.sml    | 10 ++++++----
 src/monoize.sml      | 32 +++++++++++++++++++++++++-----
 src/pathcheck.sml    | 18 +++++++++++++++--
 src/reduce.sml       |  8 +++++---
 src/shake.sml        |  7 ++++---
 src/source.sml       |  6 ++----
 src/source_print.sml | 52 ++++++++++++++++++++++++++++---------------------
 src/urweb.grm        | 39 ++++++++++++++++++++++++++++++-------
 src/urweb.lex        |  2 ++
 tests/cst.ur         |  2 ++
 tests/pkey.ur        |  6 ++++++
 tests/pkey.urp       |  5 +++++
 32 files changed, 356 insertions(+), 181 deletions(-)
 create mode 100644 tests/pkey.ur
 create mode 100644 tests/pkey.urp

(limited to 'src/urweb.lex')

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 4e926f87..997495b1 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -126,6 +126,27 @@ con sql_table :: {Type} -> {{Unit}} -> Type
 
 (*** Constraints *)
 
+(**** Primary keys *)
+
+class sql_injectable_prim
+val sql_bool : sql_injectable_prim bool
+val sql_int : sql_injectable_prim int
+val sql_float : sql_injectable_prim float
+val sql_string : sql_injectable_prim string
+val sql_time : sql_injectable_prim time
+val sql_channel : t ::: Type -> sql_injectable_prim (channel t)
+val sql_client : sql_injectable_prim client
+
+con primary_key :: {Type} -> {{Unit}} -> Type
+val no_primary_key : fs ::: {Type} -> primary_key fs []
+val primary_key : rest ::: {Type} -> t ::: Type -> key1 :: Name -> keys :: {Type}
+                  -> [[key1] ~ keys] => [[key1 = t] ++ keys ~ rest]
+    => $([key1 = sql_injectable_prim t] ++ map sql_injectable_prim keys)
+       -> primary_key ([key1 = t] ++ keys ++ rest)
+          [Pkey = [key1] ++ map (fn _ => ()) keys]
+
+(**** Other constraints *)
+
 con sql_constraints :: {Type} -> {{Unit}} -> Type
 (* Arguments: column types, uniqueness implications of constraints *)
 
@@ -224,15 +245,6 @@ val sql_exp : tabs ::: {{Type}} -> agg ::: {{Type}} -> t ::: Type -> rest ::: {T
               -> nm :: Name
               -> sql_exp tabs agg ([nm = t] ++ rest) t
 
-class sql_injectable_prim
-val sql_bool : sql_injectable_prim bool
-val sql_int : sql_injectable_prim int
-val sql_float : sql_injectable_prim float
-val sql_string : sql_injectable_prim string
-val sql_time : sql_injectable_prim time
-val sql_channel : t ::: Type -> sql_injectable_prim (channel t)
-val sql_client : sql_injectable_prim client
-
 class sql_injectable
 val sql_prim : t ::: Type -> sql_injectable_prim t -> sql_injectable t
 val sql_option_prim : t ::: Type -> sql_injectable_prim t -> sql_injectable (option t)
diff --git a/src/cjr.sml b/src/cjr.sml
index 7f8b2434..33cf07c9 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -104,7 +104,7 @@ datatype decl' =
        | DFun of string * int * (string * typ) list * typ * exp
        | DFunRec of (string * int * (string * typ) list * typ * exp) list
 
-       | DTable of string * (string * typ) list * (string * string) list
+       | DTable of string * (string * typ) list * string * (string * string) list
        | DSequence of string
        | DDatabase of {name : string, expunge : int, initialize : int}
        | DPreparedStatements of (string * int) list
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 9fc1511f..f86d4928 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1941,19 +1941,25 @@ fun p_decl env (dAll as (d, _) : decl) =
                  p_list_sep newline (p_fun env) vis,
                  newline]
         end
-      | DTable (x, _, csts) => box [string "/* SQL table ",
-                                    string x,
-                                    space,
-                                    string "constraints",
-                                    space,
-                                    p_list (fn (x, v) => box [string x,
-                                                              space,
-                                                              string ":",
-                                                              space,
-                                                              string v]) csts,
-                                    space,
-                                    string " */",
-                                    newline]
+      | DTable (x, _, pk, csts) => box [string "/* SQL table ",
+                                        string x,
+                                        space,
+                                        case pk of
+                                            "" => box []
+                                          | _ => box [string "keys",
+                                                      space,
+                                                      string pk,
+                                                      space],
+                                        string "constraints",
+                                        space,
+                                        p_list (fn (x, v) => box [string x,
+                                                                  space,
+                                                                  string ":",
+                                                                  space,
+                                                                  string v]) csts,
+                                        space,
+                                        string " */",
+                                        newline]
       | DSequence x => box [string "/* SQL sequence ",
                             string x,
                             string " */",
@@ -2467,7 +2473,7 @@ fun p_file env (ds, ps) =
 
         val pds' = map p_page ps
 
-        val tables = List.mapPartial (fn (DTable (s, xts, _), _) => SOME (s, xts)
+        val tables = List.mapPartial (fn (DTable (s, xts, _, _), _) => SOME (s, xts)
                                        | _ => NONE) ds
         val sequences = List.mapPartial (fn (DSequence s, _) => SOME s
                                           | _ => NONE) ds
@@ -2811,7 +2817,7 @@ fun p_sql env (ds, _) =
                        (fn (dAll as (d, _), env) =>
                            let
                                val pp = case d of
-                                            DTable (s, xts, csts) =>
+                                            DTable (s, xts, pk, csts) =>
                                             box [string "CREATE TABLE ",
                                                  string s,
                                                  string "(",
@@ -2820,10 +2826,23 @@ fun p_sql env (ds, _) =
                                                                  string (CharVector.map Char.toLower x),
                                                                  space,
                                                                  p_sqltype env (t, ErrorMsg.dummySpan)]) xts,
-                                                 case csts of
-                                                     [] => box []
-                                                   | _ => box [string ","],
+                                                 case (pk, csts) of
+                                                     ("", []) => box []
+                                                   | _ => string ",",
                                                  cut,
+                                                 case pk of
+                                                     "" => box []
+                                                   | _ => box [string "PRIMARY",
+                                                               space,
+                                                               string "KEY",
+                                                               space,
+                                                               string "(",
+                                                               string pk,
+                                                               string ")",
+                                                               case csts of
+                                                                   [] => box []
+                                                                 | _ => string ",",
+                                                               newline],
                                                  p_list_sep (box [string ",", newline])
                                                             (fn (x, c) =>
                                                                 box [string "CONSTRAINT",
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 839c0c57..e0341c64 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -524,7 +524,7 @@ fun cifyDecl ((d, loc), sm) =
             (NONE, SOME (ek, "/" ^ s, n, ts, t, L'.ServerAndPullAndPush), sm)
         end
 
-      | L.DTable (s, xts, e) =>
+      | L.DTable (s, xts, pe, ce) =>
         let
             val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
                                                   let
@@ -540,10 +540,17 @@ fun cifyDecl ((d, loc), sm) =
                   | L.EStrcat (e1, e2) => flatten e1 @ flatten e2
                   | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined";
                           Print.prefaces "Undetermined constraint"
-                          [("e", MonoPrint.p_exp MonoEnv.empty e)];
+                                         [("e", MonoPrint.p_exp MonoEnv.empty e)];
                           [])
+
+            val pe = case #1 pe of
+                         L.EPrim (Prim.String s) => s
+                       | _ => (ErrorMsg.errorAt loc "Primary key has not been fully determined";
+                               Print.prefaces "Undetermined constraint"
+                                              [("e", MonoPrint.p_exp MonoEnv.empty pe)];
+                               "")
         in
-            (SOME (L'.DTable (s, xts, flatten e), loc), NONE, sm)
+            (SOME (L'.DTable (s, xts, pe, flatten ce), loc), NONE, sm)
         end
       | L.DSequence s =>
         (SOME (L'.DSequence s, loc), NONE, sm)
diff --git a/src/core.sml b/src/core.sml
index 687b913f..a8e0de13 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -130,7 +130,7 @@ datatype decl' =
        | DVal of string * int * con * exp * string
        | DValRec of (string * int * con * exp * string) list
        | DExport of export_kind * int
-       | DTable of string * int * con * string * exp * con
+       | DTable of string * int * con * string * exp * con * exp * con
        | DSequence of string * int * string
        | DDatabase of string
        | DCookie of string * int * con * string
diff --git a/src/core_env.sml b/src/core_env.sml
index 4c4cc68f..95226bb7 100644
--- a/src/core_env.sml
+++ b/src/core_env.sml
@@ -313,11 +313,11 @@ fun declBinds env (d, loc) =
       | DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s
       | DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis
       | DExport _ => env
-      | DTable (x, n, c, s, _, cc) =>
+      | DTable (x, n, c, s, _, pc, _, cc) =>
         let
             val ct = (CFfi ("Basis", "sql_table"), loc)
             val ct = (CApp (ct, c), loc)
-            val ct = (CApp (ct, cc), loc)
+            val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc)
         in
             pushENamed env x n ct NONE s
         end
diff --git a/src/core_print.sml b/src/core_print.sml
index 216cc8ac..ed401d29 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -546,21 +546,25 @@ fun p_decl env (dAll as (d, _) : decl) =
                                 space,
                                 (p_con env (#2 (E.lookupENamed env n))
                                  handle E.UnboundNamed _ => string "UNBOUND")]
-      | DTable (x, n, c, s, e, _) => box [string "table",
-                                          space,
-                                          p_named x n,
-                                          space,
-                                          string "as",
-                                          space,
-                                          string s,
-                                          space,
-                                          string ":",
-                                          space,
-                                          p_con env c,
-                                          space,
-                                          string "constraints",
-                                          space,
-                                          p_exp env e]
+      | DTable (x, n, c, s, pe, _, ce, _) => box [string "table",
+                                                  space,
+                                                  p_named x n,
+                                                  space,
+                                                  string "as",
+                                                  space,
+                                                  string s,
+                                                  space,
+                                                  string ":",
+                                                  space,
+                                                  p_con env c,
+                                                  space,
+                                                  string "keys",
+                                                  space,
+                                                  p_exp env pe,
+                                                  space,
+                                                  string "constraints",
+                                                  space,
+                                                  p_exp env ce]
       | DSequence (x, n, s) => box [string "sequence",
                                     space,
                                     p_named x n,
diff --git a/src/core_util.sml b/src/core_util.sml
index df8bb271..320a0326 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -933,14 +933,18 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} =
                             (DValRec vis', loc))
                 end
               | DExport _ => S.return2 dAll
-              | DTable (x, n, c, s, e, cc) =>
+              | DTable (x, n, c, s, pe, pc, ce, cc) =>
                 S.bind2 (mfc ctx c,
                      fn c' =>
-                        S.bind2 (mfe ctx e,
-                                fn e' =>
-                                   S.map2 (mfc ctx cc,
-                                           fn cc' =>
-                                              (DTable (x, n, c', s, e', cc'), loc))))
+                        S.bind2 (mfe ctx pe,
+                                fn pe' =>
+                                   S.bind2 (mfc ctx pc,
+                                           fn pc' =>
+                                              S.bind2 (mfe ctx ce,
+                                                    fn ce' =>
+                                                       S.map2 (mfc ctx cc,
+                                                            fn cc' =>
+                                                               (DTable (x, n, c', s, pe', pc', ce', cc'), loc))))))
               | DSequence _ => S.return2 dAll
               | DDatabase _ => S.return2 dAll
               | DCookie (x, n, c, s) =>
@@ -1062,11 +1066,11 @@ fun mapfoldB (all as {bind, ...}) =
                                         foldl (fn ((x, n, t, e, s), ctx) => bind (ctx, NamedE (x, n, t, NONE, s)))
                                         ctx vis
                                       | DExport _ => ctx
-                                      | DTable (x, n, c, s, _, cc) =>
+                                      | DTable (x, n, c, s, _, pc, _, cc) =>
                                         let
                                             val loc = #2 d'
                                             val ct = (CFfi ("Basis", "sql_table"), loc)
-                                            val ct = (CApp (ct, c), loc)
+                                            val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc)
                                             val ct = (CApp (ct, cc), loc)
                                         in
                                             bind (ctx, NamedE (x, n, ct, NONE, s))
@@ -1141,7 +1145,7 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
                           | DVal (_, n, _, _, _) => Int.max (n, count)
                           | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis
                           | DExport _ => count
-                          | DTable (_, n, _, _, _, _) => Int.max (n, count)
+                          | DTable (_, n, _, _, _, _, _, _) => Int.max (n, count)
                           | DSequence (_, n, _) => Int.max (n, count)
                           | DDatabase _ => count
                           | DCookie (_, n, _, _) => Int.max (n, count)) 0
diff --git a/src/corify.sml b/src/corify.sml
index 3387e73a..e3b9a365 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -976,12 +976,14 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
              end
            | _ => raise Fail "Non-const signature for 'export'")
 
-      | L.DTable (_, x, n, c, e, cc) =>
+      | L.DTable (_, x, n, c, pe, pc, ce, cc) =>
         let
             val (st, n) = St.bindVal st x n
             val s = relify (doRestify (mods, x))
         in
-            ([(L'.DTable (x, n, corifyCon st c, s, corifyExp st e, corifyCon st cc), loc)], st)
+            ([(L'.DTable (x, n, corifyCon st c, s,
+                          corifyExp st pe, corifyCon st pc,
+                          corifyExp st ce, corifyCon st cc), loc)], st)
         end
       | L.DSequence (_, x, n) =>
         let
@@ -1052,7 +1054,7 @@ fun maxName ds = foldl (fn ((d, _), n) =>
                              | L.DStr (_, n', _, str) => Int.max (n, Int.max (n', maxNameStr str))
                              | L.DFfiStr (_, n', _) => Int.max (n, n')
                              | L.DExport _ => n
-                             | L.DTable (_, _, n', _, _, _) => Int.max (n, n')
+                             | L.DTable (_, _, n', _, _, _, _, _) => Int.max (n, n')
                              | L.DSequence (_, _, n') => Int.max (n, n')
                              | L.DDatabase _ => n
                              | L.DCookie (_, _, n', _) => Int.max (n, n'))
diff --git a/src/elab.sml b/src/elab.sml
index c31483ec..83a7f929 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -166,7 +166,7 @@ datatype decl' =
        | DFfiStr of string * int * sgn
        | DConstraint of con * con
        | DExport of int * sgn * str
-       | DTable of int * string * int * con * exp * con
+       | DTable of int * string * int * con * exp * con * exp * con
        | DSequence of int * string * int
        | DClass of string * int * kind * con
        | DDatabase of string
diff --git a/src/elab_env.sml b/src/elab_env.sml
index 8bb769c1..8da78375 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -1532,11 +1532,11 @@ fun declBinds env (d, loc) =
       | DFfiStr (x, n, sgn) => pushStrNamedAs env x n sgn
       | DConstraint _ => env
       | DExport _ => env
-      | DTable (tn, x, n, c, _, cc) =>
+      | DTable (tn, x, n, c, _, pc, _, cc) =>
         let
             val ct = (CModProj (tn, [], "sql_table"), loc)
             val ct = (CApp (ct, c), loc)
-            val ct = (CApp (ct, cc), loc)
+            val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc)
         in
             pushENamedAs env x n ct
         end
diff --git a/src/elab_print.sml b/src/elab_print.sml
index b65e1bd6..7eb853af 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -740,17 +740,21 @@ fun p_decl env (dAll as (d, _) : decl) =
                                       string ":",
                                       space,
                                       p_sgn env sgn]
-      | DTable (_, x, n, c, e, _) => box [string "table",
-                                          space,
-                                          p_named x n,
-                                          space,
-                                          string ":",
-                                          space,
-                                          p_con env c,
-                                          space,
-                                          string "constraints",
-                                          space,
-                                          p_exp env e]
+      | DTable (_, x, n, c, pe, _, ce, _) => box [string "table",
+                                                  space,
+                                                  p_named x n,
+                                                  space,
+                                                  string ":",
+                                                  space,
+                                                  p_con env c,
+                                                  space,
+                                                  string "keys",
+                                                  space,
+                                                  p_exp env pe,
+                                                  space,
+                                                  string "constraints",
+                                                  space,
+                                                  p_exp env ce]
       | DSequence (_, x, n) => box [string "sequence",
                                     space,
                                     p_named x n]
diff --git a/src/elab_util.sml b/src/elab_util.sml
index 32f399dc..ff4abbfb 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -766,11 +766,11 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
                                                    bind (ctx, Str (x, sgn))
                                                  | DConstraint _ => ctx
                                                  | DExport _ => ctx
-                                                 | DTable (tn, x, n, c, _, cc) =>
+                                                 | DTable (tn, x, n, c, _, pc, _, cc) =>
                                                    let
                                                        val ct = (CModProj (n, [], "sql_table"), loc)
                                                        val ct = (CApp (ct, c), loc)
-                                                       val ct = (CApp (ct, cc), loc)
+                                                       val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc)
                                                    in
                                                        bind (ctx, NamedE (x, ct))
                                                    end
@@ -869,14 +869,18 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
                                     fn str' =>
                                        (DExport (en, sgn', str'), loc)))
 
-              | DTable (tn, x, n, c, e, cc) =>
+              | DTable (tn, x, n, c, pe, pc, ce, cc) =>
                 S.bind2 (mfc ctx c,
                         fn c' =>
-                           S.bind2 (mfe ctx e,
-                                   fn e' =>
-                                      S.map2 (mfc ctx cc,
-                                              fn cc' =>
-                                                 (DTable (tn, x, n, c', e', cc'), loc))))
+                           S.bind2 (mfe ctx pe,
+                                   fn pe' =>
+                                      S.bind2 (mfc ctx pc,
+                                            fn pc' =>
+                                               S.bind2 (mfe ctx ce,
+                                                     fn ce' =>
+                                                        S.map2 (mfc ctx cc,
+                                                              fn cc' =>
+                                                                 (DTable (tn, x, n, c', pe', pc', ce', cc'), loc))))))
               | DSequence _ => S.return2 dAll
 
               | DClass (x, n, k, c) =>
@@ -1027,7 +1031,7 @@ and maxNameDecl (d, _) =
       | DConstraint _ => 0
       | DClass (_, n, _, _) => n
       | DExport _ => 0
-      | DTable (n1, _, n2, _, _, _) => Int.max (n1, n2)
+      | DTable (n1, _, n2, _, _, _, _, _) => Int.max (n1, n2)
       | DSequence (n1, _, n2) => Int.max (n1, n2)
       | DDatabase _ => 0
       | DCookie (n1, _, n2, _) => Int.max (n1, n2)
diff --git a/src/elaborate.sml b/src/elaborate.sml
index d83af65b..c2ac31a4 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -2027,7 +2027,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) =
             ([(L'.SgiVal (x, n, c'), loc)], (env', denv, gs' @ gs))
         end
 
-      | L.SgiTable (x, c, e) =>
+      | L.SgiTable (x, c, pe, ce) =>
         let
             val cstK = (L'.KRecord (L'.KRecord (L'.KUnit, loc), loc), loc)
             val x' = x ^ "_hidden_constraints"
@@ -2035,28 +2035,38 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) =
             val hidden = (L'.CNamed hidden_n, loc)
 
             val (c', ck, gs') = elabCon (env, denv) c
+            val pkey = cunif (loc, cstK)
             val visible = cunif (loc, cstK)
             val uniques = (L'.CConcat (visible, hidden), loc)
 
             val ct = tableOf ()
             val ct = (L'.CApp (ct, c'), loc)
-            val ct = (L'.CApp (ct, uniques), loc)
+            val ct = (L'.CApp (ct, (L'.CConcat (pkey, uniques), loc)), loc)
+
+            val (pe', pet, gs'') = elabExp (env', denv) pe
+            val gs'' = List.mapPartial (fn Disjoint x => SOME x
+                                          | _ => NONE) gs''
+
+            val pst = (L'.CModProj (!basis_r, [], "primary_key"), loc)
+            val pst = (L'.CApp (pst, c'), loc)
+            val pst = (L'.CApp (pst, pkey), loc)
 
             val (env', n) = E.pushENamed env' x ct
 
-            val (e', et, gs'') = elabExp (env, denv) e
-            val gs'' = List.mapPartial (fn Disjoint x => SOME x
-                                         | _ => NONE) gs''
+            val (ce', cet, gs''') = elabExp (env', denv) ce
+            val gs''' = List.mapPartial (fn Disjoint x => SOME x
+                                         | _ => NONE) gs'''
 
             val cst = (L'.CModProj (!basis_r, [], "sql_constraints"), loc)
             val cst = (L'.CApp (cst, c'), loc)
             val cst = (L'.CApp (cst, visible), loc)
         in
             checkKind env c' ck (L'.KRecord (L'.KType, loc), loc);
-            checkCon env' e' et cst;
+            checkCon env' pe' pet pst;
+            checkCon env' ce' cet cst;
 
             ([(L'.SgiConAbs (x', hidden_n, cstK), loc),
-              (L'.SgiVal (x, n, ct), loc)], (env', denv, gs'' @ gs' @ gs))
+              (L'.SgiVal (x, n, ct), loc)], (env', denv, gs''' @ gs'' @ gs' @ gs))
         end
 
       | L.SgiStr (x, sgn) =>
@@ -2360,8 +2370,9 @@ and sgiOfDecl (d, loc) =
       | L'.DFfiStr (x, n, sgn) => [(L'.SgiStr (x, n, sgn), loc)]
       | L'.DConstraint cs => [(L'.SgiConstraint cs, loc)]
       | L'.DExport _ => []
-      | L'.DTable (tn, x, n, c, _, cc) =>
-        [(L'.SgiVal (x, n, (L'.CApp ((L'.CApp (tableOf (), c), loc), cc), loc)), loc)]
+      | L'.DTable (tn, x, n, c, _, pc, _, cc) =>
+        [(L'.SgiVal (x, n, (L'.CApp ((L'.CApp (tableOf (), c), loc),
+                                     (L'.CConcat (pc, cc), loc)), loc)), loc)]
       | L'.DSequence (tn, x, n) => [(L'.SgiVal (x, n, sequenceOf ()), loc)]
       | L'.DClass (x, n, k, c) => [(L'.SgiClass (x, n, k, c), loc)]
       | L'.DDatabase _ => []
@@ -3307,25 +3318,35 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
                     ([(L'.DExport (E.newNamed (), sgn, str'), loc)], (env, denv, gs' @ gs))
                 end
 
-              | L.DTable (x, c, e) =>
+              | L.DTable (x, c, pe, ce) =>
                 let
+                    val cstK = (L'.KRecord (L'.KRecord (L'.KUnit, loc), loc), loc)
+
                     val (c', k, gs') = elabCon (env, denv) c
-                    val uniques = cunif (loc, (L'.KRecord (L'.KRecord (L'.KUnit, loc), loc), loc))
+                    val pkey = cunif (loc, cstK)
+                    val uniques = cunif (loc, cstK)
 
                     val ct = tableOf ()
                     val ct = (L'.CApp (ct, c'), loc)
-                    val ct = (L'.CApp (ct, uniques), loc)
+                    val ct = (L'.CApp (ct, (L'.CConcat (pkey, uniques), loc)), loc)
 
                     val (env, n) = E.pushENamed env x ct
-                    val (e', et, gs'') = elabExp (env, denv) e
+                    val (pe', pet, gs'') = elabExp (env, denv) pe
+                    val (ce', cet, gs''') = elabExp (env, denv) ce
+
+                    val pst = (L'.CModProj (!basis_r, [], "primary_key"), loc)
+                    val pst = (L'.CApp (pst, c'), loc)
+                    val pst = (L'.CApp (pst, pkey), loc)
 
                     val cst = (L'.CModProj (!basis_r, [], "sql_constraints"), loc)
                     val cst = (L'.CApp (cst, c'), loc)
                     val cst = (L'.CApp (cst, uniques), loc)
                 in
                     checkKind env c' k (L'.KRecord (L'.KType, loc), loc);
-                    checkCon env e' et cst;
-                    ([(L'.DTable (!basis_r, x, n, c', e', uniques), loc)], (env, denv, gs'' @ enD gs' @ gs))
+                    checkCon env pe' pet pst;
+                    checkCon env ce' cet cst;
+                    ([(L'.DTable (!basis_r, x, n, c', pe', pkey, ce', uniques), loc)],
+                     (env, denv, gs''' @ gs'' @ enD gs' @ gs))
                 end
               | L.DSequence x =>
                 let
diff --git a/src/expl.sml b/src/expl.sml
index 6cd9b7a8..b9cbdaf1 100644
--- a/src/expl.sml
+++ b/src/expl.sml
@@ -141,7 +141,7 @@ datatype decl' =
        | DStr of string * int * sgn * str
        | DFfiStr of string * int * sgn
        | DExport of int * sgn * str
-       | DTable of int * string * int * con * exp * con
+       | DTable of int * string * int * con * exp * con * exp * con
        | DSequence of int * string * int
        | DDatabase of string
        | DCookie of int * string * int * con
diff --git a/src/expl_env.sml b/src/expl_env.sml
index 31b1c0a3..64f4edc4 100644
--- a/src/expl_env.sml
+++ b/src/expl_env.sml
@@ -298,11 +298,11 @@ fun declBinds env (d, loc) =
       | DStr (x, n, sgn, _) => pushStrNamed env x n sgn
       | DFfiStr (x, n, sgn) => pushStrNamed env x n sgn
       | DExport _ => env
-      | DTable (tn, x, n, c, _, cc) =>
+      | DTable (tn, x, n, c, _, pc, _, cc) =>
         let
             val ct = (CModProj (tn, [], "sql_table"), loc)
             val ct = (CApp (ct, c), loc)
-            val ct = (CApp (ct, cc), loc)
+            val ct = (CApp (ct, (CConcat (pc, cc), loc)), loc)
         in
             pushENamed env x n ct
         end
diff --git a/src/expl_print.sml b/src/expl_print.sml
index 05d68941..84002c00 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -663,17 +663,21 @@ fun p_decl env (dAll as (d, _) : decl) =
                                       string ":",
                                       space,
                                       p_sgn env sgn]
-      | DTable (_, x, n, c, e, _) => box [string "table",
-                                          space,
-                                          p_named x n,
-                                          space,
-                                          string ":",
-                                          space,
-                                          p_con env c,
-                                          space,
-                                          string "constraints",
-                                          space,
-                                          p_exp env e]
+      | DTable (_, x, n, c, pe, _, ce, _) => box [string "table",
+                                                  space,
+                                                  p_named x n,
+                                                  space,
+                                                  string ":",
+                                                  space,
+                                                  p_con env c,
+                                                  space,
+                                                  string "keys",
+                                                  space,
+                                                  p_exp env pe,
+                                                  space,
+                                                  string "constraints",
+                                                  space,
+                                                  p_exp env ce]
       | DSequence (_, x, n) => box [string "sequence",
                                     space,
                                     p_named x n]
diff --git a/src/explify.sml b/src/explify.sml
index fa35bd0d..01a57d2e 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -178,7 +178,10 @@ fun explifyDecl (d, loc : EM.span) =
       | L.DFfiStr (x, n, sgn) => SOME (L'.DFfiStr (x, n, explifySgn sgn), loc)
       | L.DConstraint (c1, c2) => NONE
       | L.DExport (en, sgn, str) => SOME (L'.DExport (en, explifySgn sgn, explifyStr str), loc)
-      | L.DTable (nt, x, n, c, e, cc) => SOME (L'.DTable (nt, x, n, explifyCon c, explifyExp e, explifyCon cc), loc)
+      | L.DTable (nt, x, n, c, pe, pc, ce, cc) =>
+        SOME (L'.DTable (nt, x, n, explifyCon c,
+                         explifyExp pe, explifyCon pc,
+                         explifyExp ce, explifyCon cc), loc)
       | L.DSequence (nt, x, n) => SOME (L'.DSequence (nt, x, n), loc)
       | L.DClass (x, n, k, c) => SOME (L'.DCon (x, n,
                                                 (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), explifyCon c), loc)
diff --git a/src/mono.sml b/src/mono.sml
index 5a65a9f9..35db52bd 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -121,7 +121,7 @@ datatype decl' =
        | DValRec of (string * int * typ * exp * string) list
        | DExport of Core.export_kind * string * int * typ list * typ
 
-       | DTable of string * (string * typ) list * exp
+       | DTable of string * (string * typ) list * exp * exp
        | DSequence of string
        | DDatabase of {name : string, expunge : int, initialize : int}
 
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 935f8368..c75e81ba 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -403,22 +403,26 @@ fun p_decl env (dAll as (d, _) : decl) =
                                           space,
                                           p_typ env t]
 
-      | DTable (s, xts, e) => box [string "(* SQL table ",
-                                   string s,
-                                   space,
-                                   string ":",
-                                   space,
-                                   p_list (fn (x, t) => box [string x,
-                                                             space,
-                                                             string ":",
-                                                             space,
-                                                             p_typ env t]) xts,
-                                   space,
-                                   string "constraints",
-                                   space,
-                                   p_exp env e,
-                                   space,
-                                   string "*)"]
+      | DTable (s, xts, pe, ce) => box [string "(* SQL table ",
+                                        string s,
+                                        space,
+                                        string ":",
+                                        space,
+                                        p_list (fn (x, t) => box [string x,
+                                                                  space,
+                                                                  string ":",
+                                                                  space,
+                                                                  p_typ env t]) xts,
+                                        space,
+                                        string "keys",
+                                        space,
+                                        p_exp env pe,
+                                        space,
+                                        string "constraints",
+                                        space,
+                                        p_exp env ce,
+                                        space,
+                                        string "*)"]
       | DSequence s => box [string "(* SQL sequence ",
                             string s,
                             string "*)"]
diff --git a/src/mono_util.sml b/src/mono_util.sml
index ca5cf5cb..485e64f6 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -465,10 +465,12 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
                            S.map2 (mft t,
                                    fn t' =>
                                       (DExport (ek, s, n, ts', t'), loc)))
-              | DTable (s, xts, e) =>
-                S.map2 (mfe ctx e,
-                        fn e' =>
-                           (DTable (s, xts, e'), loc))
+              | DTable (s, xts, pe, ce) =>
+                S.bind2 (mfe ctx pe,
+                      fn pe' =>
+                         S.map2 (mfe ctx ce,
+                              fn ce' =>
+                                 (DTable (s, xts, pe', ce'), loc)))
               | DSequence _ => S.return2 dAll
               | DDatabase _ => S.return2 dAll
               | DJavaScript _ => S.return2 dAll
diff --git a/src/monoize.sml b/src/monoize.sml
index 057a9222..2e514b4e 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -149,6 +149,8 @@ fun monoType env =
                     (L'.TFfi ("Basis", "string"), loc)
                   | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _) =>
                     (L'.TFfi ("Basis", "string"), loc)
+                  | L.CApp ((L.CApp ((L.CFfi ("Basis", "primary_key"), _), _), _), _) =>
+                    (L'.TFfi ("Basis", "string"), loc)
                   | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraints"), _), _), _), _) =>
                     (L'.TFfi ("Basis", "sql_constraints"), loc)
                   | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _), _), _) =>
@@ -1159,6 +1161,25 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                  fm)
             end
 
+          | L.ECApp ((L.EFfi ("Basis", "no_primary_key"), _), _) =>
+            ((L'.EPrim (Prim.String ""), loc),
+             fm)
+          | L.ECApp (
+            (L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "primary_key"), _), _), _), t), _),
+                      nm), _),
+            (L.CRecord (_, unique), _)) =>
+            let
+                val unique = (nm, t) :: unique
+                val witnesses = (L'.TRecord (map (fn (nm, _) => (monoName env nm, (L'.TRecord [], loc))) unique), loc)
+            in
+                ((L'.EAbs ("_", witnesses, (L'.TFfi ("Basis", "string"), loc),
+                           (L'.EPrim (Prim.String
+                                          (String.concatWith ", "
+                                                             (map (fn (x, _) => "uw_" ^ monoName env x) unique))),
+                            loc)), loc),
+                 fm)
+            end
+
           | L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) =>
             ((L'.ERecord [], loc),
              fm)
@@ -2499,7 +2520,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
             in
                 SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)])
             end
-          | L.DTable (x, n, (L.CRecord (_, xts), _), s, e, _) =>
+          | L.DTable (x, n, (L.CRecord (_, xts), _), s, pe, _, ce, _) =>
             let
                 val t = (L.CFfi ("Basis", "string"), loc)
                 val t' = (L'.TFfi ("Basis", "string"), loc)
@@ -2508,11 +2529,12 @@ fun monoDecl (env, fm) (all as (d, loc)) =
 
                 val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
 
-                val (e, fm) = monoExp (env, St.empty, fm) e
+                val (pe, fm) = monoExp (env, St.empty, fm) pe
+                val (ce, fm) = monoExp (env, St.empty, fm) ce
             in
                 SOME (Env.pushENamed env x n t NONE s,
                       fm,
-                      [(L'.DTable (s, xts, e), loc),
+                      [(L'.DTable (s, xts, pe, ce), loc),
                        (L'.DVal (x, n, t', e_name, s), loc)])
             end
           | L.DTable _ => poly ()
@@ -2633,7 +2655,7 @@ fun monoize env file =
             in
                 foldl (fn ((d, _), e) =>
                           case d of
-                              L.DTable (_, _, xts, tab, _, _) => doTable (tab, #1 xts, e)
+                              L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e)
                             | _ => e) e file
             end
 
@@ -2678,7 +2700,7 @@ fun monoize env file =
             in
                 foldl (fn ((d, _), e) =>
                           case d of
-                              L.DTable (_, _, xts, tab, _, _) => doTable (tab, #1 xts, e)
+                              L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e)
                             | _ => e) e file
             end
 
diff --git a/src/pathcheck.sml b/src/pathcheck.sml
index 6771e628..3f4f6be4 100644
--- a/src/pathcheck.sml
+++ b/src/pathcheck.sml
@@ -55,7 +55,7 @@ fun checkDecl ((d, loc), (funcs, rels)) =
         case d of
             DExport (_, s, _, _, _) => doFunc s
             
-          | DTable (s, _, e) =>
+          | DTable (s, _, pe, ce) =>
             let
                 fun constraints (e, rels) =
                     case #1 e of
@@ -71,8 +71,22 @@ fun checkDecl ((d, loc), (funcs, rels)) =
                         end
                       | EStrcat (e1, e2) => constraints (e2, constraints (e1, rels))
                       | _ => rels
+
+                val rels = #2 (doRel s)
+                val rels = case #1 pe of
+                               EPrim (Prim.String "") => rels
+                             | _ =>
+                               let
+                                   val s' = s ^ "_Pkey"
+                               in
+                                   if SS.member (rels, s') then
+                                       E.errorAt loc ("Duplicate primary key constraint path " ^ s')
+                                   else
+                                       ();
+                                   SS.add (rels, s')
+                               end
             in
-                (funcs, constraints (e, #2 (doRel s)))
+                (funcs, constraints (ce, rels))
             end
           | DSequence s => doRel s
 
diff --git a/src/reduce.sml b/src/reduce.sml
index d6357f1b..25cc6274 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -461,9 +461,11 @@ fun reduce file =
                 ((DValRec (map (fn (x, n, t, e, s) => (x, n, con namedC [] t, exp (namedC, namedE) [] e, s)) vis), loc),
                  st)
               | DExport _ => (d, st)
-              | DTable (s, n, c, s', e, cc) => ((DTable (s, n, con namedC [] c, s',
-                                                         exp (namedC, namedE) [] e,
-                                                         con namedC [] cc), loc), st)
+              | DTable (s, n, c, s', pe, pc, ce, cc) => ((DTable (s, n, con namedC [] c, s',
+                                                                  exp (namedC, namedE) [] pe,
+                                                                  con namedC [] pc,
+                                                                  exp (namedC, namedE) [] ce,
+                                                                  con namedC [] cc), loc), st)
               | DSequence _ => (d, st)
               | DDatabase _ => (d, st)
               | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st)
diff --git a/src/shake.sml b/src/shake.sml
index 19204ebb..378e8276 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -59,9 +59,10 @@ fun shake file =
         val (usedE, usedC, table_cs) =
             List.foldl
                 (fn ((DExport (_, n), _), (usedE, usedC, table_cs)) => (IS.add (usedE, n), usedE, table_cs)
-                  | ((DTable (_, _, c, _, e, _), _), (usedE, usedC, table_cs)) =>
+                  | ((DTable (_, _, c, _, pe, _, ce, _), _), (usedE, usedC, table_cs)) =>
                     let
-                        val (usedE, usedC) = usedVars (usedE, usedC) e
+                        val (usedE, usedC) = usedVars (usedE, usedC) pe
+                        val (usedE, usedC) = usedVars (usedE, usedC) ce
                     in
                         (usedE, usedC, c :: table_cs)
                     end
@@ -79,7 +80,7 @@ fun shake file =
                                                           IM.insert (edef, n, (all_ns, t, e))) edef vis)
                                      end
                                    | ((DExport _, _), acc) => acc
-                                   | ((DTable (_, n, c, _, _, _), _), (cdef, edef)) =>
+                                   | ((DTable (_, n, c, _, _, _, _, _), _), (cdef, edef)) =>
                                      (cdef, IM.insert (edef, n, ([], c, dummye)))
                                    | ((DSequence (_, n, _), _), (cdef, edef)) =>
                                      (cdef, IM.insert (edef, n, ([], dummyt, dummye)))
diff --git a/src/source.sml b/src/source.sml
index 0dca39ab..3bd8e22a 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -88,7 +88,7 @@ datatype sgn_item' =
        | SgiDatatype of string * string list * (string * con option) list
        | SgiDatatypeImp of string * string list * string
        | SgiVal of string * con
-       | SgiTable of string * con * exp
+       | SgiTable of string * con * exp * exp
        | SgiStr of string * sgn
        | SgiSgn of string * sgn
        | SgiInclude of sgn
@@ -146,8 +146,6 @@ and pat = pat' located
 and exp = exp' located
 and edecl = edecl' located
 
-
-
 datatype decl' =
          DCon of string * kind option * con
        | DDatatype of string * string list * (string * con option) list
@@ -161,7 +159,7 @@ datatype decl' =
        | DConstraint of con * con
        | DOpenConstraints of string * string list
        | DExport of str
-       | DTable of string * con * exp
+       | DTable of string * con * exp * exp
        | DSequence of string
        | DClass of string * kind * con
        | DDatabase of string
diff --git a/src/source_print.sml b/src/source_print.sml
index c145dc63..94a175ac 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -417,17 +417,21 @@ fun p_sgn_item (sgi, _) =
                               string ":",
                               space,
                               p_con c]
-      | SgiTable (x, c, e) => box [string "table",
-                                space,
-                                string x,
-                                space,
-                                string ":",
-                                space,
-                                p_con c,
-                                space,
-                                string "constraints",
-                                space,
-                                p_exp e]
+      | SgiTable (x, c, pe, ce) => box [string "table",
+                                        space,
+                                        string x,
+                                        space,
+                                        string ":",
+                                        space,
+                                        p_con c,
+                                        space,
+                                        string "keys",
+                                        space,
+                                        p_exp pe,
+                                        space,
+                                        string "constraints",
+                                        space,
+                                        p_exp ce]
       | SgiStr (x, sgn) => box [string "structure",
                                 space,
                                 string x,
@@ -599,17 +603,21 @@ fun p_decl ((d, _) : decl) =
       | DExport str => box [string "export",
                             space,
                             p_str str]
-      | DTable (x, c, e) => box [string "table",
-                                 space,
-                                 string x,
-                                 space,
-                                 string ":",
-                                 space,
-                                 p_con c,
-                                 space,
-                                 string "constraints",
-                                 space,
-                                 p_exp e]
+      | DTable (x, c, pe, ce) => box [string "table",
+                                      space,
+                                      string x,
+                                      space,
+                                      string ":",
+                                      space,
+                                      p_con c,
+                                      space,
+                                      string "keys",
+                                      space,
+                                      p_exp pe,
+                                      space,
+                                      string "constraints",
+                                      space,
+                                      p_exp ce]
       | DSequence x => box [string "sequence",
                             space,
                             string x]
diff --git a/src/urweb.grm b/src/urweb.grm
index 0f4b58d7..a507e52e 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -208,7 +208,7 @@ fun tagIn bt =
  | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS
  | CURRENT_TIMESTAMP
  | NE | LT | LE | GT | GE
- | CCONSTRAINT | UNIQUE
+ | CCONSTRAINT | UNIQUE | PRIMARY | KEY
 
 %nonterm
    file of decl list
@@ -223,6 +223,9 @@ fun tagIn bt =
  | dcons of (string * con option) list
  | dcon of string * con option
 
+ | pkopt of exp
+ | commaOpt of unit
+
  | cst of exp
  | csts of exp
  | cstopt of exp
@@ -418,7 +421,8 @@ decl   : CON SYMBOL cargl2 kopt EQ cexp (let
                                            | m :: ms => [(DOpenConstraints (m, ms), s (OPENleft, mpathright))])
        | CONSTRAINT cterm TWIDDLE cterm ([(DConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright))])
        | EXPORT spath                   ([(DExport spath, s (EXPORTleft, spathright))])
-       | TABLE SYMBOL COLON cterm cstopt([(DTable (SYMBOL, entable cterm, cstopt), s (TABLEleft, cstoptright))])
+       | TABLE SYMBOL COLON cterm pkopt commaOpt cstopt([(DTable (SYMBOL, entable cterm, pkopt, cstopt),
+                                                 s (TABLEleft, cstoptright))])
        | SEQUENCE SYMBOL                ([(DSequence SYMBOL, s (SEQUENCEleft, SYMBOLright))])
        | CLASS SYMBOL EQ cexp           (let
                                              val loc = s (CLASSleft, cexpright)
@@ -513,6 +517,27 @@ tnames : tnameW                         (tnameW, [])
 tnames': tnameW                         (tnameW, [])
        | tnameW COMMA tnames'           (#1 tnames', tnameW :: #2 tnames')
 
+commaOpt:                               ()
+        | COMMA                         ()
+
+pkopt  :                                (EVar (["Basis"], "no_primary_key", Infer), ErrorMsg.dummySpan)
+       | PRIMARY KEY tnames             (let
+                                             val loc = s (PRIMARYleft, tnamesright)
+
+                                             val e = (EVar (["Basis"], "primary_key", Infer), loc)
+                                             val e = (ECApp (e, #1 (#1 tnames)), loc)
+                                             val e = (ECApp (e, (CRecord (#2 tnames), loc)), loc)
+                                             val e = (EDisjointApp e, loc)
+                                             val e = (EDisjointApp e, loc)
+
+                                             val witness = map (fn (c, _) =>
+                                                                   (c, (EWild, loc)))
+                                                           (#1 tnames :: #2 tnames)
+                                             val witness = (ERecord witness, loc)
+                                         in
+                                             (EApp (e, witness), loc)
+                                         end)
+
 valis  : vali                           ([vali])
        | vali AND valis                 (vali :: valis)
 
@@ -554,11 +579,11 @@ sgi    : CON SYMBOL DCOLON kind         ((SgiConAbs (SYMBOL, kind), s (CONleft,
                                           s (FUNCTORleft, sgn2right)))
        | INCLUDE sgn                    ((SgiInclude sgn, s (INCLUDEleft, sgnright)))
        | CONSTRAINT cterm TWIDDLE cterm ((SgiConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright)))
-       | TABLE SYMBOL COLON cterm cstopt(let
-                                             val loc = s (TABLEleft, ctermright)
-                                         in
-                                             (SgiTable (SYMBOL, entable cterm, cstopt), loc)
-                                         end)
+       | TABLE SYMBOL COLON cterm pkopt commaOpt cstopt (let
+                                                    val loc = s (TABLEleft, ctermright)
+                                                in
+                                                    (SgiTable (SYMBOL, entable cterm, pkopt, cstopt), loc)
+                                                end)
        | SEQUENCE SYMBOL                (let
                                              val loc = s (SEQUENCEleft, SYMBOLright)
                                              val t = (CVar (["Basis"], "sql_sequence"), loc)
diff --git a/src/urweb.lex b/src/urweb.lex
index 735d230d..31c0a362 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -367,6 +367,8 @@ notags = [^<{\n]+;
 
 <INITIAL> "CONSTRAINT"=> (Tokens.CCONSTRAINT (pos yypos, pos yypos + size yytext));
 <INITIAL> "UNIQUE"    => (Tokens.UNIQUE (pos yypos, pos yypos + size yytext));
+<INITIAL> "PRIMARY"   => (Tokens.PRIMARY (pos yypos, pos yypos + size yytext));
+<INITIAL> "KEY"       => (Tokens.KEY (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext));
 
diff --git a/tests/cst.ur b/tests/cst.ur
index 0ebcc977..fc3b0816 100644
--- a/tests/cst.ur
+++ b/tests/cst.ur
@@ -1,4 +1,6 @@
 table t : {A : int, B : int}
+  PRIMARY KEY B,
+
   CONSTRAINT UniA UNIQUE A,
   CONSTRAINT UniB UNIQUE B,
   CONSTRAINT UniBoth UNIQUE (A, B),
diff --git a/tests/pkey.ur b/tests/pkey.ur
new file mode 100644
index 00000000..4efbd032
--- /dev/null
+++ b/tests/pkey.ur
@@ -0,0 +1,6 @@
+table t : {A : int, B : int}
+  PRIMARY KEY (A, B)
+
+fun main () : transaction page =
+    queryI (SELECT * FROM t) (fn _ => return ());
+    return <xml/>
diff --git a/tests/pkey.urp b/tests/pkey.urp
new file mode 100644
index 00000000..40ff2589
--- /dev/null
+++ b/tests/pkey.urp
@@ -0,0 +1,5 @@
+debug
+database dbname=pkey
+sql pkey.sql
+
+pkey
-- 
cgit v1.2.3


From ab0bbbf29220a995f6fa83ae43e0a4a88c9b5159 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Tue, 7 Apr 2009 18:47:47 -0400
Subject: FOREIGN KEY, without ability to link NULL to NOT NULL (and with some
 lingering problems in row inference)

---
 demo/broadcast.ur       |   2 +-
 lib/ur/basis.urs        |  27 ++++++++++++
 src/disjoint.sml        |   3 +-
 src/elaborate.sml       |  92 +++++++++++++++++++++++++++++------------
 src/elisp/urweb-mode.el |   3 +-
 src/monoize.sml         | 107 ++++++++++++++++++++++++++++++++++++++++++++++++
 src/urweb.grm           |  70 ++++++++++++++++++++++++++++++-
 src/urweb.lex           |   9 ++++
 tests/cst.ur            |  18 +++++++-
 9 files changed, 300 insertions(+), 31 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/demo/broadcast.ur b/demo/broadcast.ur
index 29d8d8fb..0b04b136 100644
--- a/demo/broadcast.ur
+++ b/demo/broadcast.ur
@@ -1,7 +1,7 @@
 functor Make(M : sig type t end) = struct
     sequence s
     table t : {Id : int, Client : client, Channel : channel M.t}
-      PRIMARY KEY Id
+      PRIMARY KEY (Id, Client)
 
     type topic = int
 
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 997495b1..d69ddfcb 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -161,10 +161,37 @@ val join_constraints : fs ::: {Type}
     => sql_constraints fs uniques1 -> sql_constraints fs uniques2
        -> sql_constraints fs (uniques1 ++ uniques2)
 
+
 val unique : rest ::: {Type} -> t ::: Type -> unique1 :: Name -> unique :: {Type}
              -> [[unique1] ~ unique] => [[unique1 = t] ++ unique ~ rest]
     => sql_constraint ([unique1 = t] ++ unique ++ rest) ([unique1] ++ map (fn _ => ()) unique)
 
+con matching :: {Type} -> {Type} -> Type
+val mat_nil : matching [] []
+val mat_cons : t ::: Type -> rest1 ::: {Type} -> rest2 ::: {Type}
+               -> nm1 :: Name -> nm2 :: Name
+               -> [[nm1] ~ rest1] => [[nm2] ~ rest2]
+    => matching rest1 rest2
+       -> matching ([nm1 = t] ++ rest1) ([nm2 = t] ++ rest2)
+
+con propagation_mode :: {Type} -> Type
+val restrict : fs ::: {Type} -> propagation_mode fs
+val cascade : fs ::: {Type} -> propagation_mode fs
+val no_action : fs ::: {Type} -> propagation_mode fs
+val set_null : fs ::: {Type} -> propagation_mode (map option fs)
+
+
+val foreign_key : mine1 ::: Name -> t ::: Type -> mine ::: {Type} -> munused ::: {Type}
+                  -> foreign ::: {Type} -> funused ::: {Type}
+                  -> nm ::: Name -> uniques ::: {{Unit}}
+                  -> [[mine1] ~ mine] => [[mine1 = t] ++ mine ~ munused]
+    => [foreign ~ funused] => [[nm] ~ uniques]
+    => matching ([mine1 = t] ++ mine) foreign
+       -> sql_table (foreign ++ funused) ([nm = map (fn _ => ()) foreign] ++ uniques)
+       -> {OnDelete : propagation_mode ([mine1 = t] ++ mine),
+           OnUpdate : propagation_mode ([mine1 = t] ++ mine)}
+       -> sql_constraint ([mine1 = t] ++ mine ++ munused) []
+
 
 (*** Queries *)
 
diff --git a/src/disjoint.sml b/src/disjoint.sml
index 503544af..5cc9d1fb 100644
--- a/src/disjoint.sml
+++ b/src/disjoint.sml
@@ -254,7 +254,8 @@ and prove env denv (c1, c2, loc) =
         val hasUnknown = List.exists (fn Unknown _ => true | _ => false)
         val unUnknown = List.mapPartial (fn Unknown _ => NONE | Piece p => SOME p)
     in
-        if hasUnknown ps1 orelse hasUnknown ps2 then
+        if (hasUnknown ps1 andalso not (List.null ps2))
+           orelse (hasUnknown ps2 andalso not (List.null ps1)) then
             [(loc, env, denv, c1, c2)]
         else
             let
diff --git a/src/elaborate.sml b/src/elaborate.sml
index c2ac31a4..4971ec4c 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -463,7 +463,10 @@
        | _ => false
  fun cunifsRemain c =
      case c of
-         L'.CUnif (loc, _, _, ref NONE) => SOME loc
+         L'.CUnif (loc, (L'.KRecord k, _), _, r as ref NONE) =>
+         (r := SOME (L'.CRecord (k, []), loc);
+          NONE)
+       | L'.CUnif (loc, _, _, ref NONE) => SOME loc
        | _ => NONE
 
  val kunifsInDecl = U.Decl.exists {kind = kunifsRemain,
@@ -618,6 +621,8 @@
        | L'.CKApp _ => false
        | L'.TKFun _ => false
 
+ val recdCounter = ref 0
+
  fun unifyRecordCons env (c1, c2) =
      let
          fun rkindof c =
@@ -711,6 +716,41 @@
          (*val () = eprefaces "Summaries3" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}),
                                           ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*)
 
+         fun unsummarize {fields, unifs, others} =
+             let
+                 val c = (L'.CRecord (k, fields), loc)
+
+                 val c = foldl (fn ((c1, _), c2) => (L'.CConcat (c1, c2), loc))
+                               c unifs
+             in
+                 foldl (fn (c1, c2) => (L'.CConcat (c1, c2), loc))
+                       c others
+             end
+
+         val (unifs1, fs1, others1, unifs2, fs2, others2) =
+             case (unifs1, fs1, others1, unifs2, fs2, others2) of
+                 orig as ([(_, r)], [], [], _, _, _) =>
+                 let
+                     val c = unsummarize {fields = fs2, others = others2, unifs = unifs2}
+                 in
+                     if occursCon r c then
+                         orig
+                     else
+                         (r := SOME c;
+                          ([], [], [], [], [], []))
+                 end
+               | orig as (_, _, _, [(_, r)], [], []) =>
+                 let
+                     val c = unsummarize {fields = fs1, others = others1, unifs = unifs1}
+                 in
+                     if occursCon r c then
+                         orig
+                     else
+                         (r := SOME c;
+                          ([], [], [], [], [], []))
+                 end
+               | orig => orig
+
          fun unifFields (fs, others, unifs) =
              case (fs, others, unifs) of
                  ([], [], _) => ([], [], unifs)
@@ -719,7 +759,8 @@
                  let
                      val r' = ref NONE
                      val kr = (L'.KRecord k, dummy)
-                     val cr' = (L'.CUnif (dummy, kr, "recd", r'), dummy)
+                     val cr' = (L'.CUnif (dummy, kr, ("recd" ^ Int.toString (!recdCounter)), r'), dummy)
+                     val () = recdCounter := 1 + !recdCounter
 
                      val prefix = case (fs, others) of
                                       ([], other :: others) =>
@@ -762,6 +803,8 @@
                      (fs1, fs2, others1, others2)
                | _ => (fs1, fs2, others1, others2)
 
+         val (unifs1, unifs2) = eatMatching (fn ((_, r1), (_, r2)) => r1 = r2) (unifs1, unifs2)
+
          (*val () = eprefaces "Summaries5" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}),
                                           ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*)
 
@@ -770,34 +813,31 @@
                         | _ => false
          val empty = (L'.CRecord (k, []), dummy)
 
-         fun unsummarize {fields, unifs, others} =
+         fun failure () = raise CUnify' (CRecordFailure (unsummarize s1, unsummarize s2))
+     in
+         case (unifs1, fs1, others1, unifs2, fs2, others2) of
+             ([(_, r)], [], [], _, _, _) =>
              let
-                 val c = (L'.CRecord (k, fields), loc)
-
-                 val c = foldl (fn ((c1, _), c2) => (L'.CConcat (c1, c2), loc))
-                               c unifs
+                 val c = unsummarize {fields = fs2, others = others2, unifs = unifs2}
              in
-                 foldl (fn (c1, c2) => (L'.CConcat (c1, c2), loc))
-                       c others
-             end
-
-         fun pairOffUnifs (unifs1, unifs2) =
-             case (unifs1, unifs2) of
-                 ([], _) =>
-                 if clear then
-                     List.app (fn (_, r) => r := SOME empty) unifs2
+                 if occursCon r c then
+                     failure ()
                  else
-                     raise CUnify' (CRecordFailure (unsummarize s1, unsummarize s2))
-               | (_, []) =>
-                 if clear then
-                     List.app (fn (_, r) => r := SOME empty) unifs1
+                     r := SOME c
+             end
+           | (_, _, _, [(_, r)], [], []) =>
+             let
+                 val c = unsummarize {fields = fs1, others = others1, unifs = unifs1}
+             in
+                 if occursCon r c then
+                     failure ()
                  else
-                     raise CUnify' (CRecordFailure (unsummarize s1, unsummarize s2))
-               | ((c1, _) :: rest1, (_, r2) :: rest2) =>
-                 (r2 := SOME c1;
-                  pairOffUnifs (rest1, rest2))
-     in
-         pairOffUnifs (unifs1, unifs2)
+                     r := SOME c
+             end
+           | _ => if clear then
+                      ()
+                  else
+                      failure ()
          (*before eprefaces "Summaries'" [("#1", p_summary env s1),
                                        ("#2", p_summary env s2)]*)
      end
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index 65cd8abf..545902ac 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -148,7 +148,8 @@ See doc for the variable `urweb-mode-info'."
                  "HAVING" "LIMIT" "OFFSET" "ALL" "UNION" "INTERSECT" "EXCEPT"
                  "TRUE" "FALSE" "AND" "OR" "NOT" "COUNT" "AVG" "SUM" "MIN" "MAX"
                  "ASC" "DESC" "INSERT" "INTO" "VALUES" "UPDATE" "SET" "DELETE"
-                 "PRIMARY" "KEY" "CONSTRAINT" "UNIQUE")
+                 "PRIMARY" "KEY" "CONSTRAINT" "UNIQUE"
+                 "FOREIGN" "REFERENCES" "ON" "NO" "ACTION" "CASCADE" "RESTRICT" "NULL")
   "A regexp that matches SQL keywords.")
 
 (defconst urweb-lident-regexp "\\<[a-z_][A-Za-z0-9_']*\\>"
diff --git a/src/monoize.sml b/src/monoize.sml
index 2e514b4e..84707b6e 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -155,6 +155,14 @@ fun monoType env =
                     (L'.TFfi ("Basis", "sql_constraints"), loc)
                   | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _), _), _) =>
                     (L'.TFfi ("Basis", "string"), loc)
+                  | L.CApp ((L.CApp ((L.CFfi ("Basis", "matching"), _), _), _), _) =>
+                    let
+                        val string = (L'.TFfi ("Basis", "string"), loc)
+                    in
+                        (L'.TRecord [("1", string), ("2", string)], loc)
+                    end
+                  | L.CApp ((L.CFfi ("Basis", "propagation_mode"), _), _) =>
+                    (L'.TFfi ("Basis", "string"), loc)
 
                   | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_subset"), _), _), _), _) =>
                     (L'.TRecord [], loc)
@@ -1218,6 +1226,105 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                  fm)
             end
 
+          | L.EFfi ("Basis", "mat_nil") =>
+            let
+                val string = (L'.TFfi ("Basis", "string"), loc)
+                val stringE = (L'.EPrim (Prim.String ""), loc)
+            in
+                ((L'.ERecord [("1", stringE, string),
+                              ("2", stringE, string)], loc), fm)
+            end
+          | L.ECApp (
+            (L.ECApp (
+             (L.ECApp (
+              (L.ECApp (
+               (L.ECApp (
+                (L.EFfi ("Basis", "mat_cons"), _),
+                _), _),
+               _), _),
+              _), _),
+             (L.CName nm1, _)), _),
+            (L.CName nm2, _)) =>
+            let
+                val string = (L'.TFfi ("Basis", "string"), loc)
+                val mat = (L'.TRecord [("1", string), ("2", string)], loc)
+            in
+                ((L'.EAbs ("m", mat, mat,
+                           (L'.ECase ((L'.EField ((L'.ERel 0, loc), "1"), loc),
+                                      [((L'.PPrim (Prim.String ""), loc),
+                                        (L'.ERecord [("1", (L'.EPrim (Prim.String ("uw_" ^ nm1)), loc), string),
+                                                     ("2", (L'.EPrim (Prim.String ("uw_" ^ nm2)), loc), string)], loc)),
+                                       ((L'.PWild, loc),
+                                        (L'.ERecord [("1", (L'.EStrcat (
+                                                            (L'.EPrim (Prim.String ("uw_" ^ nm1 ^ ", ")), loc),
+                                                            (L'.EField ((L'.ERel 0, loc), "1"), loc)), loc), string),
+                                                     ("2", (L'.EStrcat (
+                                                            (L'.EPrim (Prim.String ("uw_" ^ nm2 ^ ", ")), loc),
+                                                            (L'.EField ((L'.ERel 0, loc), "2"), loc)), loc), string)],
+                                         loc))],
+                                      {disc = string,
+                                       result = mat}), loc)), loc),
+                 fm)
+            end
+
+          | L.ECApp ((L.EFfi ("Basis", "restrict"), _), _) => ((L'.EPrim (Prim.String "RESTRICT"), loc), fm)
+          | L.ECApp ((L.EFfi ("Basis", "cascade"), _), _) => ((L'.EPrim (Prim.String "CASCADE"), loc), fm)
+          | L.ECApp ((L.EFfi ("Basis", "no_action"), _), _) => ((L'.EPrim (Prim.String "NO ACTION"), loc), fm)
+          | L.ECApp ((L.EFfi ("Basis", "set_null"), _), _) => ((L'.EPrim (Prim.String "SET NULL"), loc), fm)
+
+          | L.ECApp (
+            (L.ECApp (
+             (L.ECApp (
+              (L.ECApp (
+               (L.ECApp (
+                (L.ECApp (
+                 (L.ECApp (
+                  (L.ECApp (
+                   (L.EFfi ("Basis", "foreign_key"), _),
+                   _), _),
+                  _), _),
+                 _), _),
+                _), _),
+               _), _),
+              _), _),
+             _), _),
+            _) =>
+            let
+                val unit = (L'.TRecord [], loc)
+                val string = (L'.TFfi ("Basis", "string"), loc)
+                val mat = (L'.TRecord [("1", string), ("2", string)], loc)
+                val recd = (L'.TRecord [("OnDelete", string),
+                                        ("OnUpdate", string)], loc)
+
+                fun strcat [] = raise Fail "Monoize.strcat"
+                  | strcat [e] = e
+                  | strcat (e1 :: es) = (L'.EStrcat (e1, strcat es), loc)
+
+                fun prop (fd, kw) =
+                    (L'.ECase ((L'.EField ((L'.ERel 0, loc), fd), loc),
+                               [((L'.PPrim (Prim.String "NO ACTION"), loc),
+                                 (L'.EPrim (Prim.String ""), loc)),
+                                ((L'.PWild, loc),
+                                 strcat [(L'.EPrim (Prim.String (" ON " ^ kw ^ " ")), loc),
+                                         (L'.EField ((L'.ERel 0, loc), fd), loc)])],
+                               {disc = string,
+                                result = string}), loc)
+            in
+                ((L'.EAbs ("m", mat, (L'.TFun (string, (L'.TFun (recd, string), loc)), loc),
+                           (L'.EAbs ("tab", string, (L'.TFun (recd, string), loc),
+                                     (L'.EAbs ("pr", recd, string,
+                                               strcat [(L'.EPrim (Prim.String "FOREIGN KEY ("), loc),
+                                                       (L'.EField ((L'.ERel 2, loc), "1"), loc),
+                                                       (L'.EPrim (Prim.String ") REFERENCES "), loc),
+                                                       (L'.ERel 1, loc),
+                                                       (L'.EPrim (Prim.String " ("), loc),
+                                                       (L'.EField ((L'.ERel 2, loc), "2"), loc),
+                                                       (L'.EPrim (Prim.String ")"), loc),
+                                                       prop ("OnDelete", "DELETE"),
+                                                       prop ("OnUpdate", "UPDATE")]), loc)), loc)), loc),
+                 fm)
+            end
+
           | L.EFfiApp ("Basis", "dml", [e]) =>
             let
                 val (e, fm) = monoExp (env, st, fm) e
diff --git a/src/urweb.grm b/src/urweb.grm
index a507e52e..5539feff 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -174,6 +174,8 @@ fun tagIn bt =
         "table" => "tabl"
       | _ => bt
 
+datatype prop_kind = Delete | Update
+
 %%
 %header (functor UrwebLrValsFn(structure Token : TOKEN))
 
@@ -208,7 +210,7 @@ fun tagIn bt =
  | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS
  | CURRENT_TIMESTAMP
  | NE | LT | LE | GT | GE
- | CCONSTRAINT | UNIQUE | PRIMARY | KEY
+ | CCONSTRAINT | UNIQUE | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES
 
 %nonterm
    file of decl list
@@ -230,6 +232,11 @@ fun tagIn bt =
  | csts of exp
  | cstopt of exp
 
+ | pmode of prop_kind * exp
+ | pkind of prop_kind
+ | prule of exp
+ | pmodes of (prop_kind * exp) list
+
  | sgn of sgn
  | sgntm of sgn
  | sgi of sgn_item
@@ -503,6 +510,54 @@ cst    : UNIQUE tnames                  (let
                                          in
                                              (EDisjointApp e, loc)
                                          end)
+
+       | FOREIGN KEY tnames REFERENCES texp LPAREN tnames' RPAREN pmodes
+                                        (let
+                                             val loc = s (FOREIGNleft, pmodesright)
+
+                                             val mat = ListPair.foldrEq
+                                                       (fn ((nm1, _), (nm2, _), mat) =>
+                                                           let
+                                                               val e = (EVar (["Basis"], "mat_cons", Infer), loc)
+                                                               val e = (ECApp (e, nm1), loc)
+                                                               val e = (ECApp (e, nm2), loc)
+                                                               val e = (EDisjointApp e, loc)
+                                                               val e = (EDisjointApp e, loc)
+                                                           in
+                                                               (EApp (e, mat), loc)
+                                                           end)
+                                                       (EVar (["Basis"], "mat_nil", Infer), loc)
+                                                       (#1 tnames :: #2 tnames, #1 tnames' :: #2 tnames')
+
+                                             fun findMode mode =
+                                                 let
+                                                     fun findMode' pmodes =
+                                                         case pmodes of
+                                                             [] => (EVar (["Basis"], "no_action", Infer), loc)
+                                                           | (mode', rule) :: pmodes' =>
+                                                             if mode' = mode then
+                                                                 (if List.exists (fn (mode', _) => mode' = mode)
+                                                                                 pmodes' then
+                                                                      ErrorMsg.errorAt loc "Duplicate propagation rule"
+                                                                  else
+                                                                      ();
+                                                                  rule)
+                                                             else
+                                                                 findMode' pmodes'
+                                                 in
+                                                     findMode' pmodes
+                                                 end
+
+                                             val e = (EVar (["Basis"], "foreign_key", Infer), loc)
+                                             val e = (EApp (e, mat), loc)
+                                             val e = (EApp (e, texp), loc)
+                                         in
+                                             (EApp (e, (ERecord [((CName "OnDelete", loc),
+                                                                  findMode Delete),
+                                                                 ((CName "OnUpdate", loc),
+                                                                  findMode Update)], loc)), loc)
+                                         end)
+
        | LBRACE eexp RBRACE             (eexp)
 
 tnameW : tname                          (let
@@ -517,6 +572,19 @@ tnames : tnameW                         (tnameW, [])
 tnames': tnameW                         (tnameW, [])
        | tnameW COMMA tnames'           (#1 tnames', tnameW :: #2 tnames')
 
+pmode  : ON pkind prule                 (pkind, prule)
+
+pkind  : DELETE                         (Delete)
+       | UPDATE                         (Update)
+
+prule  : NO ACTION                      (EVar (["Basis"], "no_action", Infer), s (NOleft, ACTIONright))
+       | RESTRICT                       (EVar (["Basis"], "restrict", Infer), s (RESTRICTleft, RESTRICTright))
+       | CASCADE                        (EVar (["Basis"], "cascade", Infer), s (CASCADEleft, CASCADEright))
+       | SET NULL                       (EVar (["Basis"], "set_null", Infer), s (SETleft, NULLright))
+
+pmodes :                                ([])
+       | pmode pmodes                   (pmode :: pmodes)
+
 commaOpt:                               ()
         | COMMA                         ()
 
diff --git a/src/urweb.lex b/src/urweb.lex
index 31c0a362..c01f018b 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -368,7 +368,16 @@ notags = [^<{\n]+;
 <INITIAL> "CONSTRAINT"=> (Tokens.CCONSTRAINT (pos yypos, pos yypos + size yytext));
 <INITIAL> "UNIQUE"    => (Tokens.UNIQUE (pos yypos, pos yypos + size yytext));
 <INITIAL> "PRIMARY"   => (Tokens.PRIMARY (pos yypos, pos yypos + size yytext));
+<INITIAL> "FOREIGN"   => (Tokens.FOREIGN (pos yypos, pos yypos + size yytext));
 <INITIAL> "KEY"       => (Tokens.KEY (pos yypos, pos yypos + size yytext));
+<INITIAL> "ON"        => (Tokens.ON (pos yypos, pos yypos + size yytext));
+<INITIAL> "NO"        => (Tokens.NO (pos yypos, pos yypos + size yytext));
+<INITIAL> "ACTION"    => (Tokens.ACTION (pos yypos, pos yypos + size yytext));
+<INITIAL> "RESTRICT"  => (Tokens.RESTRICT (pos yypos, pos yypos + size yytext));
+<INITIAL> "CASCADE"   => (Tokens.CASCADE (pos yypos, pos yypos + size yytext));
+<INITIAL> "REFERENCES"=> (Tokens.REFERENCES (pos yypos, pos yypos + size yytext));
+
+<INITIAL> "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext));
 
diff --git a/tests/cst.ur b/tests/cst.ur
index fc3b0816..548862be 100644
--- a/tests/cst.ur
+++ b/tests/cst.ur
@@ -1,3 +1,7 @@
+table u : {C : int, D : int, E : int}
+  PRIMARY KEY C,
+  CONSTRAINT U UNIQUE (C, D)
+
 table t : {A : int, B : int}
   PRIMARY KEY B,
 
@@ -11,7 +15,19 @@ table t : {A : int, B : int}
 
   CONSTRAINT UniBothm UNIQUE ({#A}, {#B}),
   CONSTRAINT UniBothm2 {unique [#A] [[B = _]] ! !},
-  {{one_constraint [#UniBothm3] (unique [#A] [[B = _]] ! !)}}
+  {{one_constraint [#UniBothm3] (unique [#A] [[B = _]] ! !)}},
+
+  CONSTRAINT ForA FOREIGN KEY A REFERENCES u (C),
+  CONSTRAINT ForAB FOREIGN KEY (A, B) REFERENCES u (D, C) ON DELETE CASCADE ON UPDATE RESTRICT,
+  CONSTRAINT ForBA FOREIGN KEY (A, B) REFERENCES u (C, D) ON UPDATE NO ACTION,
+
+  CONSTRAINT Self FOREIGN KEY B REFERENCES t (B)
+
+table s : {B : option int}
+  CONSTRAINT UniB UNIQUE B
+
+table s2 : {B : option int}
+  CONSTRAINT ForB FOREIGN KEY B REFERENCES s (B) ON DELETE SET NULL
 
 fun main () : transaction page =
     queryI (SELECT * FROM t) (fn _ => return ());
-- 
cgit v1.2.3


From 8f29d5ead0c09b99291f729001e6aabd24d8aa8c Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Thu, 9 Apr 2009 15:30:15 -0400
Subject: CHECK constraints

---
 lib/ur/basis.urs        |  8 +++++++-
 src/elisp/urweb-mode.el |  2 +-
 src/mono_opt.sml        | 36 +++++++++++++++++++++++++++++++++++-
 src/monoize.sml         | 11 +++++++++++
 src/urweb.grm           |  9 ++++++++-
 src/urweb.lex           |  1 +
 tests/cst.ur            |  8 ++++++--
 7 files changed, 69 insertions(+), 6 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 454b10b2..f652165d 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -198,12 +198,18 @@ val foreign_key : mine1 ::: Name -> t ::: Type -> mine ::: {Type} -> munused :::
            OnUpdate : propagation_mode ([mine1 = t] ++ mine)}
        -> sql_constraint ([mine1 = t] ++ mine ++ munused) []
 
+con sql_exp :: {{Type}} -> {{Type}} -> {Type} -> Type -> Type
+
+val check : fs ::: {Type}
+            -> sql_exp [] [] fs bool
+            -> sql_constraint fs []
+
+
 
 (*** Queries *)
 
 con sql_query :: {{Type}} -> {Type} -> Type
 con sql_query1 :: {{Type}} -> {{Type}} -> {Type} -> Type
-con sql_exp :: {{Type}} -> {{Type}} -> {Type} -> Type -> Type
 
 con sql_subset :: {{Type}} -> {{Type}} -> Type
 val sql_subset : keep_drop :: {({Type} * {Type})}
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index 545902ac..1f2a52be 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -148,7 +148,7 @@ See doc for the variable `urweb-mode-info'."
                  "HAVING" "LIMIT" "OFFSET" "ALL" "UNION" "INTERSECT" "EXCEPT"
                  "TRUE" "FALSE" "AND" "OR" "NOT" "COUNT" "AVG" "SUM" "MIN" "MAX"
                  "ASC" "DESC" "INSERT" "INTO" "VALUES" "UPDATE" "SET" "DELETE"
-                 "PRIMARY" "KEY" "CONSTRAINT" "UNIQUE"
+                 "PRIMARY" "KEY" "CONSTRAINT" "UNIQUE" "CHECK"
                  "FOREIGN" "REFERENCES" "ON" "NO" "ACTION" "CASCADE" "RESTRICT" "NULL")
   "A regexp that matches SQL keywords.")
 
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 7f23d8b1..dfa0420c 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -87,7 +87,13 @@ fun sqlifyInt n = attrifyInt n ^ "::int8"
 fun sqlifyFloat n = attrifyFloat n ^ "::float8"
 
 fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'"
-                                               | ch => str ch)
+                                               | #"\\" => "\\\\"
+                                               | ch =>
+                                                 if Char.isPrint ch then
+                                                     str ch
+                                                 else
+                                                     "\\" ^ StringCvt.padLeft #"0" 3
+                                                                              (Int.fmt StringCvt.OCT (ord ch)))
                                              (String.toString s) ^ "'::text"
 
 fun exp e =
@@ -365,6 +371,34 @@ fun exp e =
 
       | EJavaScript (_, _, SOME (e, _)) => e
 
+      | EFfiApp ("Basis", "checkString", [(EPrim (Prim.String s), loc)]) => 
+        let
+            fun uwify (cs, acc) =
+                case cs of
+                    [] => String.concat (rev acc)
+                  | #"(" :: #"_" :: cs => uwify (cs, "(uw_" :: acc)
+                  | #" " :: #"_" :: cs => uwify (cs, " uw_" :: acc)
+                  | #"'" :: cs =>
+                    let
+                        fun waitItOut (cs, acc) =
+                            case cs of
+                                [] => raise Fail "MonoOpt: Unterminated SQL string literal"
+                              | #"'" :: cs => uwify (cs, "'" :: acc)
+                              | #"\\" :: #"'" :: cs => waitItOut (cs, "\\'" :: acc)
+                              | #"\\" :: #"\\" :: cs => waitItOut (cs, "\\\\" :: acc)
+                              | c :: cs => waitItOut (cs, str c :: acc)
+                    in
+                        waitItOut (cs, "'" :: acc)
+                    end
+                  | c :: cs => uwify (cs, str c :: acc)
+
+            val s = case String.explode s of
+                        #"_" :: cs => uwify (cs, ["uw_"])
+                      | cs => uwify (cs, [])
+        in
+            EPrim (Prim.String s)
+        end
+
       | _ => e
 
 and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
diff --git a/src/monoize.sml b/src/monoize.sml
index bc44c550..950de1e1 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1342,6 +1342,17 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                  fm)
             end
 
+          | L.ECApp ((L.EFfi ("Basis", "check"), _), _) =>
+            let
+                val string = (L'.TFfi ("Basis", "string"), loc)
+            in
+                ((L'.EAbs ("e", string, string,
+                           (L'.EStrcat ((L'.EPrim (Prim.String "CHECK "), loc),
+                                        (L'.EFfiApp ("Basis", "checkString",
+                                                     [(L'.ERel 0, loc)]), loc)), loc)), loc),
+                 fm)
+            end
+
           | L.EFfiApp ("Basis", "dml", [e]) =>
             let
                 val (e, fm) = monoExp (env, st, fm) e
diff --git a/src/urweb.grm b/src/urweb.grm
index 50fb6cb3..7e1f6757 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -210,7 +210,7 @@ datatype prop_kind = Delete | Update
  | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS
  | CURRENT_TIMESTAMP
  | NE | LT | LE | GT | GE
- | CCONSTRAINT | UNIQUE | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES
+ | CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES
 
 %nonterm
    file of decl list
@@ -511,6 +511,13 @@ cst    : UNIQUE tnames                  (let
                                              (EDisjointApp e, loc)
                                          end)
 
+       | CHECK sqlexp                   (let
+                                             val loc = s (CHECKleft, sqlexpright)
+                                         in
+                                             (EApp ((EVar (["Basis"], "check", Infer), loc),
+                                                    sqlexp), loc)
+                                         end)
+
        | FOREIGN KEY tnames REFERENCES texp LPAREN tnames' RPAREN pmodes
                                         (let
                                              val loc = s (FOREIGNleft, pmodesright)
diff --git a/src/urweb.lex b/src/urweb.lex
index c01f018b..4b3eb2af 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -367,6 +367,7 @@ notags = [^<{\n]+;
 
 <INITIAL> "CONSTRAINT"=> (Tokens.CCONSTRAINT (pos yypos, pos yypos + size yytext));
 <INITIAL> "UNIQUE"    => (Tokens.UNIQUE (pos yypos, pos yypos + size yytext));
+<INITIAL> "CHECK"     => (Tokens.CHECK (pos yypos, pos yypos + size yytext));
 <INITIAL> "PRIMARY"   => (Tokens.PRIMARY (pos yypos, pos yypos + size yytext));
 <INITIAL> "FOREIGN"   => (Tokens.FOREIGN (pos yypos, pos yypos + size yytext));
 <INITIAL> "KEY"       => (Tokens.KEY (pos yypos, pos yypos + size yytext));
diff --git a/tests/cst.ur b/tests/cst.ur
index 2db083f7..a0ccf539 100644
--- a/tests/cst.ur
+++ b/tests/cst.ur
@@ -1,7 +1,11 @@
-table u : {C : int, D : int, E : option int}
+table u : {C : int, D : int, E : option int, F : string}
   PRIMARY KEY C,
   CONSTRAINT U UNIQUE (C, D),
-  CONSTRAINT U2 UNIQUE E
+  CONSTRAINT U2 UNIQUE E,
+
+  CONSTRAINT Pos CHECK D > 0,
+  CONSTRAINT NoNo CHECK C + D <> 2,
+  CONSTRAINT Known CHECK F = "_E = 6"
 
 table t : {A : int, B : int, C : option int}
   PRIMARY KEY B,
-- 
cgit v1.2.3


From 30eeaff2c92fb1d0ba029a7688fc7b547a60c150 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sun, 12 Apr 2009 10:08:11 -0400
Subject: style declarations

---
 lib/ur/basis.urs        |  4 ++++
 src/cjr.sml             |  1 +
 src/cjr_env.sml         |  2 +-
 src/cjr_print.sml       | 11 +++++++++++
 src/cjrize.sml          |  1 +
 src/core.sml            |  1 +
 src/core_env.sml        |  6 ++++++
 src/core_print.sml      | 11 +++++++++++
 src/core_util.sml       | 13 ++++++++++++-
 src/corify.sml          | 10 +++++++++-
 src/elab.sml            |  1 +
 src/elab_env.sml        |  6 ++++++
 src/elab_print.sml      |  7 +++++++
 src/elab_util.sml       |  8 ++++++++
 src/elaborate.sml       | 10 ++++++++++
 src/elisp/urweb-mode.el |  4 ++--
 src/expl.sml            |  1 +
 src/expl_env.sml        |  6 ++++++
 src/expl_print.sml      |  7 +++++++
 src/explify.sml         |  1 +
 src/mono.sml            |  2 ++
 src/mono_env.sml        |  1 +
 src/mono_print.sml      |  8 ++++++++
 src/mono_shake.sml      |  6 ++++--
 src/mono_util.sml       |  5 ++++-
 src/monoize.sml         | 17 +++++++++++++++++
 src/prepare.sml         |  1 +
 src/reduce.sml          |  1 +
 src/reduce_local.sml    |  1 +
 src/shake.sml           |  5 ++++-
 src/source.sml          |  1 +
 src/source_print.sml    |  7 +++++++
 src/unnest.sml          |  1 +
 src/urweb.grm           | 10 +++++++++-
 src/urweb.lex           |  1 +
 tests/style.ur          |  6 ++++++
 tests/style.urp         |  3 +++
 37 files changed, 177 insertions(+), 10 deletions(-)
 create mode 100644 tests/style.ur
 create mode 100644 tests/style.urp

(limited to 'src/urweb.lex')

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index f2f378ee..9eeb4891 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -405,6 +405,9 @@ val nextval : sql_sequence -> transaction int
 
 (** XML *)
 
+con css_class :: {Unit} -> Type
+(* The argument lists categories of properties that this class could set usefully. *)
+
 con tag :: {Type} -> {Unit} -> {Unit} -> {Type} -> {Type} -> Type
 
 
@@ -440,6 +443,7 @@ con xbody = xml [Body] [] []
 con xtr = xml [Body, Tr] [] []
 con xform = xml [Body, Form] [] []
 
+
 (*** HTML details *)
 
 con html = [Html]
diff --git a/src/cjr.sml b/src/cjr.sml
index 33cf07c9..031a14f8 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -110,6 +110,7 @@ datatype decl' =
        | DPreparedStatements of (string * int) list
 
        | DJavaScript of string
+       | DStyle of string * string list
 
 withtype decl = decl' located
 
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index 9921ee48..cb5caee9 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -167,6 +167,6 @@ fun declBinds env (d, loc) =
       | DDatabase _ => env
       | DPreparedStatements _ => env
       | DJavaScript _ => env
-
+      | DStyle _ => env
 
 end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index f86d4928..cabfc77f 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2146,6 +2146,17 @@ fun p_decl env (dAll as (d, _) : decl) =
       | DJavaScript s => box [string "static char jslib[] = \"",
                               string (String.toString s),
                               string "\";"]
+      | DStyle (s, xs) => box [string "/*",
+                               space,
+                               string "style",
+                               space,
+                               string s,
+                               space,
+                               string ":",
+                               space,
+                               p_list string xs,
+                               space,
+                               string "*/"]
 
 datatype 'a search =
          Found of 'a
diff --git a/src/cjrize.sml b/src/cjrize.sml
index e0341c64..b432cd44 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -556,6 +556,7 @@ fun cifyDecl ((d, loc), sm) =
         (SOME (L'.DSequence s, loc), NONE, sm)
       | L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm)
       | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm)
+      | L.DStyle args => (SOME (L'.DStyle args, loc), NONE, sm)
 
 fun cjrize ds =
     let
diff --git a/src/core.sml b/src/core.sml
index a8e0de13..bbd1a9b6 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -134,6 +134,7 @@ datatype decl' =
        | DSequence of string * int * string
        | DDatabase of string
        | DCookie of string * int * con * string
+       | DStyle of string * int * con * string
 
 withtype decl = decl' located
 
diff --git a/src/core_env.sml b/src/core_env.sml
index 95226bb7..01a791a0 100644
--- a/src/core_env.sml
+++ b/src/core_env.sml
@@ -334,6 +334,12 @@ fun declBinds env (d, loc) =
         in
             pushENamed env x n t NONE s
         end
+      | DStyle (x, n, c, s) =>
+        let
+            val t = (CApp ((CFfi ("Basis", "css_class"), loc), c), loc)
+        in
+            pushENamed env x n t NONE s
+        end
 
 fun patBinds env (p, loc) =
     case p of
diff --git a/src/core_print.sml b/src/core_print.sml
index ed401d29..caf55adb 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -586,6 +586,17 @@ fun p_decl env (dAll as (d, _) : decl) =
                                      string ":",
                                      space,
                                      p_con env c]
+      | DStyle (x, n, c, s) => box [string "style",
+                                    space,
+                                    p_named x n,
+                                    space,
+                                    string "as",
+                                    space,
+                                    string s,
+                                    space,
+                                    string ":",
+                                    space,
+                                    p_con env c]
 
 fun p_file env file =
     let
diff --git a/src/core_util.sml b/src/core_util.sml
index 320a0326..8ccd520a 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -951,6 +951,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} =
                 S.map2 (mfc ctx c,
                      fn c' =>
                         (DCookie (x, n, c', s), loc))
+              | DStyle (x, n, c, s) =>
+                S.map2 (mfc ctx c,
+                     fn c' =>
+                        (DStyle (x, n, c', s), loc))
 
         and mfvi ctx (x, n, t, e, s) =
             S.bind2 (mfc ctx t,
@@ -1088,6 +1092,12 @@ fun mapfoldB (all as {bind, ...}) =
                                         in
                                             bind (ctx, NamedE (x, n, t, NONE, s))
                                         end
+                                      | DStyle (x, n, c, s) =>
+                                        let
+                                            val t = (CApp ((CFfi ("Basis", "css_class"), #2 d'), c), #2 d')
+                                        in
+                                            bind (ctx, NamedE (x, n, t, NONE, s))
+                                        end
                             in
                                 S.map2 (mff ctx' ds',
                                      fn ds' =>
@@ -1148,7 +1158,8 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
                           | DTable (_, n, _, _, _, _, _, _) => Int.max (n, count)
                           | DSequence (_, n, _) => Int.max (n, count)
                           | DDatabase _ => count
-                          | DCookie (_, n, _, _) => Int.max (n, count)) 0
+                          | DCookie (_, n, _, _) => Int.max (n, count)
+                          | DStyle (_, n, _, _) => Int.max (n, count)) 0
               
 end
 
diff --git a/src/corify.sml b/src/corify.sml
index e3b9a365..1a5bab06 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -1002,6 +1002,13 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
         in
             ([(L'.DCookie (x, n, corifyCon st c, s), loc)], st)
         end
+      | L.DStyle (_, x, n, c) =>
+        let
+            val (st, n) = St.bindVal st x n
+            val s = doRestify (mods, x)
+        in
+            ([(L'.DStyle (x, n, corifyCon st c, s), loc)], st)
+        end
 
 and corifyStr mods ((str, _), st) =
     case str of
@@ -1057,7 +1064,8 @@ fun maxName ds = foldl (fn ((d, _), n) =>
                              | L.DTable (_, _, n', _, _, _, _, _) => Int.max (n, n')
                              | L.DSequence (_, _, n') => Int.max (n, n')
                              | L.DDatabase _ => n
-                             | L.DCookie (_, _, n', _) => Int.max (n, n'))
+                             | L.DCookie (_, _, n', _) => Int.max (n, n')
+                             | L.DStyle (_, _, n', _) => Int.max (n, n'))
                        0 ds
 
 and maxNameStr (str, _) =
diff --git a/src/elab.sml b/src/elab.sml
index 83a7f929..cabe0a94 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -171,6 +171,7 @@ datatype decl' =
        | DClass of string * int * kind * con
        | DDatabase of string
        | DCookie of int * string * int * con
+       | DStyle of int * string * int * con
 
      and str' =
          StrConst of decl list
diff --git a/src/elab_env.sml b/src/elab_env.sml
index 1c3eb62e..828dface 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -1434,6 +1434,12 @@ fun declBinds env (d, loc) =
         in
             pushENamedAs env x n t
         end
+      | DStyle (tn, x, n, c) =>
+        let
+            val t = (CApp ((CModProj (tn, [], "css_class"), loc), c), loc)
+        in
+            pushENamedAs env x n t
+        end
 
 fun patBinds env (p, loc) =
     case p of
diff --git a/src/elab_print.sml b/src/elab_print.sml
index 7eb853af..5028ff44 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -779,6 +779,13 @@ fun p_decl env (dAll as (d, _) : decl) =
                                      string ":",
                                      space,
                                      p_con env c]
+      | DStyle (_, x, n, c) => box [string "style",
+                                    space,
+                                    p_named x n,
+                                    space,
+                                    string ":",
+                                    space,
+                                    p_con env c]
 
 and p_str env (str, _) =
     case str of
diff --git a/src/elab_util.sml b/src/elab_util.sml
index 17e67787..24a92e3f 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -796,6 +796,9 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
                                                  | DDatabase _ => ctx
                                                  | DCookie (tn, x, n, c) =>
                                                    bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "cookie"), loc),
+                                                                                c), loc)))
+                                                 | DStyle (tn, x, n, c) =>
+                                                   bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "css_class"), loc),
                                                                                 c), loc))),
                                                mfd ctx d)) ctx ds,
                      fn ds' => (StrConst ds', loc))
@@ -911,6 +914,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
                 S.map2 (mfc ctx c,
                         fn c' =>
                            (DCookie (tn, x, n, c'), loc))
+              | DStyle (tn, x, n, c) =>
+                S.map2 (mfc ctx c,
+                        fn c' =>
+                           (DStyle (tn, x, n, c'), loc))
 
         and mfvi ctx (x, n, c, e) =
             S.bind2 (mfc ctx c,
@@ -1050,6 +1057,7 @@ and maxNameDecl (d, _) =
       | DSequence (n1, _, n2) => Int.max (n1, n2)
       | DDatabase _ => 0
       | DCookie (n1, _, n2, _) => Int.max (n1, n2)
+      | DStyle (n1, _, n2, _) => Int.max (n1, n2)
 
 and maxNameStr (str, _) =
     case str of
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 21b32f40..922c9c32 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1902,6 +1902,7 @@ val hnormSgn = E.hnormSgn
 fun tableOf () = (L'.CModProj (!basis_r, [], "sql_table"), ErrorMsg.dummySpan)
 fun sequenceOf () = (L'.CModProj (!basis_r, [], "sql_sequence"), ErrorMsg.dummySpan)
 fun cookieOf () = (L'.CModProj (!basis_r, [], "http_cookie"), ErrorMsg.dummySpan)
+fun styleOf () = (L'.CModProj (!basis_r, [], "css_class"), ErrorMsg.dummySpan)
 
 fun dopenConstraints (loc, env, denv) {str, strs} =
     case E.lookupStr env str of
@@ -2401,6 +2402,7 @@ and sgiOfDecl (d, loc) =
       | L'.DClass (x, n, k, c) => [(L'.SgiClass (x, n, k, c), loc)]
       | L'.DDatabase _ => []
       | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)]
+      | L'.DStyle (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (styleOf (), c), loc)), loc)]
 
 and subSgn env sgn1 (sgn2 as (_, loc2)) =
     ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1),
@@ -3390,6 +3392,14 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
                     checkKind env c' k (L'.KType, loc);
                     ([(L'.DCookie (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs))
                 end
+              | L.DStyle (x, c) =>
+                let
+                    val (c', k, gs') = elabCon (env, denv) c
+                    val (env, n) = E.pushENamed env x (L'.CApp (styleOf (), c'), loc)
+                in
+                    checkKind env c' k (L'.KRecord (L'.KUnit, loc), loc);
+                    ([(L'.DStyle (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs))
+                end
 
         (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*)
     in
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index 1f2a52be..834c28da 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -136,7 +136,7 @@ See doc for the variable `urweb-mode-info'."
 	       "datatype" "else" "end" "extern" "fn" "map"
 	       "fun" "functor" "if" "include"
 	       "of" "open" "let" "in"
-	       "rec" "sequence" "sig" "signature" "cookie"
+	       "rec" "sequence" "sig" "signature" "cookie" "style"
 	       "struct" "structure" "table" "then" "type" "val" "where"
 	       "with"
 
@@ -225,7 +225,7 @@ See doc for the variable `urweb-mode-info'."
     ("\\<\\(\\(data\\)?type\\|con\\|class\\)\\s-+\\(\\sw+\\)"
      (1 font-lock-keyword-face)
      (3 (amAttribute font-lock-type-def-face)))
-    ("\\<\\(val\\|table\\|sequence\\|cookie\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
+    ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
      (1 font-lock-keyword-face)
      (3 (amAttribute font-lock-variable-name-face)))
     ("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)"
diff --git a/src/expl.sml b/src/expl.sml
index b9cbdaf1..ed4de953 100644
--- a/src/expl.sml
+++ b/src/expl.sml
@@ -145,6 +145,7 @@ datatype decl' =
        | DSequence of int * string * int
        | DDatabase of string
        | DCookie of int * string * int * con
+       | DStyle of int * string * int * con
 
      and str' =
          StrConst of decl list
diff --git a/src/expl_env.sml b/src/expl_env.sml
index 64f4edc4..790c3aa8 100644
--- a/src/expl_env.sml
+++ b/src/expl_env.sml
@@ -319,6 +319,12 @@ fun declBinds env (d, loc) =
         in
             pushENamed env x n t
         end
+      | DStyle (tn, x, n, c) =>
+        let
+            val t = (CApp ((CModProj (tn, [], "css_class"), loc), c), loc)
+        in
+            pushENamed env x n t
+        end
 
 fun sgiBinds env (sgi, loc) =
     case sgi of
diff --git a/src/expl_print.sml b/src/expl_print.sml
index 84002c00..c912bd66 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -691,6 +691,13 @@ fun p_decl env (dAll as (d, _) : decl) =
                                      string ":",
                                      space,
                                      p_con env c]
+      | DStyle (_, x, n, c) => box [string "style",
+                                    space,
+                                    p_named x n,
+                                    space,
+                                    string ":",
+                                    space,
+                                    p_con env c]
 
 and p_str env (str, _) =
     case str of
diff --git a/src/explify.sml b/src/explify.sml
index 01a57d2e..32983619 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -187,6 +187,7 @@ fun explifyDecl (d, loc : EM.span) =
                                                 (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), explifyCon c), loc)
       | L.DDatabase s => SOME (L'.DDatabase s, loc)
       | L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc)
+      | L.DStyle (nt, x, n, c) => SOME (L'.DStyle (nt, x, n, explifyCon c), loc)
 
 and explifyStr (str, loc) =
     case str of
diff --git a/src/mono.sml b/src/mono.sml
index 35db52bd..4723e30a 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -127,6 +127,8 @@ datatype decl' =
 
        | DJavaScript of string
 
+       | DStyle of string * string list
+
 
 withtype decl = decl' located
 
diff --git a/src/mono_env.sml b/src/mono_env.sml
index 248567de..df255325 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.sml
@@ -111,6 +111,7 @@ fun declBinds env (d, loc) =
       | DSequence _ => env
       | DDatabase _ => env
       | DJavaScript _ => env
+      | DStyle _ => env
 
 fun patBinds env (p, loc) =
     case p of
diff --git a/src/mono_print.sml b/src/mono_print.sml
index c75e81ba..3870ce41 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -440,6 +440,14 @@ fun p_decl env (dAll as (d, _) : decl) =
                               string s,
                               string ")"]
 
+      | DStyle (s, xs) => box [string "style",
+                               space,
+                               string s,
+                               space,
+                               string ":",
+                               space,
+                               p_list string xs]
+
                           
 fun p_file env file =
     let
diff --git a/src/mono_shake.sml b/src/mono_shake.sml
index 343ec728..d2426f9f 100644
--- a/src/mono_shake.sml
+++ b/src/mono_shake.sml
@@ -58,7 +58,8 @@ fun shake file =
                                    | ((DTable _, _), acc) => acc
                                    | ((DSequence _, _), acc) => acc
                                    | ((DDatabase _, _), acc) => acc
-                                   | ((DJavaScript _, _), acc) => acc)
+                                   | ((DJavaScript _, _), acc) => acc
+                                   | ((DStyle _, _), acc) => acc)
                                  (IM.empty, IM.empty) file
 
         fun typ (c, s) =
@@ -115,7 +116,8 @@ fun shake file =
                       | (DTable _, _) => true
                       | (DSequence _, _) => true
                       | (DDatabase _, _) => true
-                      | (DJavaScript _, _) => true) file
+                      | (DJavaScript _, _) => true
+                      | (DStyle _, _) => true) file
     end
 
 end
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 485e64f6..62a2dfe0 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -474,6 +474,7 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
               | DSequence _ => S.return2 dAll
               | DDatabase _ => S.return2 dAll
               | DJavaScript _ => S.return2 dAll
+              | DStyle _ => S.return2 dAll
 
         and mfvi ctx (x, n, t, e, s) =
             S.bind2 (mft t,
@@ -555,6 +556,7 @@ fun mapfoldB (all as {bind, ...}) =
                                       | DSequence _ => ctx
                                       | DDatabase _ => ctx
                                       | DJavaScript _ => ctx
+                                      | DStyle _ => ctx
                             in
                                 S.map2 (mff ctx' ds',
                                      fn ds' =>
@@ -603,7 +605,8 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
                           | DTable _ => count
                           | DSequence _ => count
                           | DDatabase _ => count
-                          | DJavaScript _ => count) 0
+                          | DJavaScript _ => count
+                          | DStyle _ => count) 0
 
 end
 
diff --git a/src/monoize.sml b/src/monoize.sml
index bf26fda2..8030b7ba 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2705,6 +2705,23 @@ fun monoDecl (env, fm) (all as (d, loc)) =
                       fm,
                       [(L'.DVal (x, n, t', e, s), loc)])
             end
+          | L.DStyle (x, n, (L.CRecord (_, xcs), _), s) =>
+            let
+                val xs = map (fn ((L.CName x, _), _) => x
+                               | (x, _) => (E.errorAt (#2 x) "Undetermined style component";
+                                            Print.eprefaces' [("Name", CorePrint.p_con env x)];
+                                            "")) xcs
+
+                val t = (L.CFfi ("Basis", "string"), loc)
+                val t' = (L'.TFfi ("Basis", "string"), loc)
+                val e = (L'.EPrim (Prim.String s), loc)
+            in
+                SOME (Env.pushENamed env x n t NONE s,
+                      fm,
+                      [(L'.DStyle (s, xs), loc),
+                       (L'.DVal (x, n, t', e, s), loc)])
+            end
+          | L.DStyle _ => poly ()
     end
 
 datatype expungable = Client | Channel
diff --git a/src/prepare.sml b/src/prepare.sml
index 258b9dcf..8e31b73d 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -259,6 +259,7 @@ fun prepDecl (d as (_, loc), sns) =
       | DDatabase _ => (d, sns)
       | DPreparedStatements _ => (d, sns)
       | DJavaScript _ => (d, sns)
+      | DStyle _ => (d, sns)
 
 fun prepare (ds, ps) =
     let
diff --git a/src/reduce.sml b/src/reduce.sml
index 25cc6274..714b55d7 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -469,6 +469,7 @@ fun reduce file =
               | DSequence _ => (d, st)
               | DDatabase _ => (d, st)
               | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st)
+              | DStyle (s, n, c, s') => ((DStyle (s, n, con namedC [] c, s'), loc), st)
 
         val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty) file
     in
diff --git a/src/reduce_local.sml b/src/reduce_local.sml
index a49d7115..cf602406 100644
--- a/src/reduce_local.sml
+++ b/src/reduce_local.sml
@@ -152,6 +152,7 @@ fun reduce file =
               | DSequence _ => d
               | DDatabase _ => d
               | DCookie _ => d
+              | DStyle _ => d
     in
         map doDecl file
     end
diff --git a/src/shake.sml b/src/shake.sml
index 378e8276..9c95d6a3 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -86,6 +86,8 @@ fun shake file =
                                      (cdef, IM.insert (edef, n, ([], dummyt, dummye)))
                                    | ((DDatabase _, _), acc) => acc
                                    | ((DCookie (_, n, c, _), _), (cdef, edef)) =>
+                                     (cdef, IM.insert (edef, n, ([], c, dummye)))
+                                   | ((DStyle (_, n, c, _), _), (cdef, edef)) =>
                                      (cdef, IM.insert (edef, n, ([], c, dummye))))
                                  (IM.empty, IM.empty) file
 
@@ -160,7 +162,8 @@ fun shake file =
                       | (DTable _, _) => true
                       | (DSequence _, _) => true
                       | (DDatabase _, _) => true
-                      | (DCookie _, _) => true) file
+                      | (DCookie _, _) => true
+                      | (DStyle _, _) => true) file
     end
 
 end
diff --git a/src/source.sml b/src/source.sml
index 3bd8e22a..a35c61be 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -164,6 +164,7 @@ datatype decl' =
        | DClass of string * kind * con
        | DDatabase of string
        | DCookie of string * con
+       | DStyle of string * con
 
      and str' =
          StrConst of decl list
diff --git a/src/source_print.sml b/src/source_print.sml
index 94a175ac..bc933d57 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -640,6 +640,13 @@ fun p_decl ((d, _) : decl) =
                                string ":",
                                space,
                                p_con c]
+      | DStyle (x, c) => box [string "style",
+                              space,
+                              string x,
+                              space,
+                              string ":",
+                              space,
+                              p_con c]
 
 and p_str (str, _) =
     case str of
diff --git a/src/unnest.sml b/src/unnest.sml
index 1d0c2388..c321b34d 100644
--- a/src/unnest.sml
+++ b/src/unnest.sml
@@ -407,6 +407,7 @@ fun unnest file =
                   | DClass _ => default ()
                   | DDatabase _ => default ()
                   | DCookie _ => default ()
+                  | DStyle _ => default ()
             end
 
         and doStr (all as (str, loc), st) =
diff --git a/src/urweb.grm b/src/urweb.grm
index 7288359a..0d750679 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -194,7 +194,7 @@ datatype prop_kind = Delete | Update
  | LET | IN
  | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL
  | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE
- | COOKIE
+ | COOKIE | STYLE
  | CASE | IF | THEN | ELSE
 
  | XML_BEGIN of string | XML_END | XML_BEGIN_END of string
@@ -451,6 +451,7 @@ decl   : CON SYMBOL cargl2 kopt EQ cexp (let
                                              [(DClass (SYMBOL1, kind, c), s (CLASSleft, cexpright))]
                                          end)
        | COOKIE SYMBOL COLON cexp       ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))])
+       | STYLE SYMBOL COLON cexp        ([(DStyle (SYMBOL, cexp), s (STYLEleft, cexpright))])
 
 kopt   :                                (NONE)
        | DCOLON kind                    (SOME kind)
@@ -707,6 +708,13 @@ sgi    : CON SYMBOL DCOLON kind         ((SgiConAbs (SYMBOL, kind), s (CONleft,
                                          in
                                              (SgiVal (SYMBOL, t), loc)
                                          end)
+       | STYLE SYMBOL COLON cexp        (let
+                                             val loc = s (STYLEleft, cexpright)
+                                             val t = (CApp ((CVar (["Basis"], "css_class"), loc),
+                                                            cexp), loc)
+                                         in
+                                             (SgiVal (SYMBOL, t), loc)
+                                         end)
 
 sgis   :                                ([])
        | sgi sgis                       (sgi :: sgis)
diff --git a/src/urweb.lex b/src/urweb.lex
index 4b3eb2af..534d51c6 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -319,6 +319,7 @@ notags = [^<{\n]+;
 <INITIAL> "sequence"  => (Tokens.SEQUENCE (pos yypos, pos yypos + size yytext));
 <INITIAL> "class"     => (Tokens.CLASS (pos yypos, pos yypos + size yytext));
 <INITIAL> "cookie"    => (Tokens.COOKIE (pos yypos, pos yypos + size yytext));
+<INITIAL> "style"     => (Tokens.STYLE (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "Type"      => (Tokens.TYPE (pos yypos, pos yypos + size yytext));
 <INITIAL> "Name"      => (Tokens.NAME (pos yypos, pos yypos + size yytext));
diff --git a/tests/style.ur b/tests/style.ur
new file mode 100644
index 00000000..f622ecfd
--- /dev/null
+++ b/tests/style.ur
@@ -0,0 +1,6 @@
+style q : []
+style r : [Table, List]
+
+fun main () : transaction page = return <xml><body>
+  Hi.
+</body></xml>
diff --git a/tests/style.urp b/tests/style.urp
new file mode 100644
index 00000000..fdb25a8b
--- /dev/null
+++ b/tests/style.urp
@@ -0,0 +1,3 @@
+debug
+
+style
-- 
cgit v1.2.3


From 04dd6b3727c7786a4824897e78b0b2982ecd6f5b Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Tue, 28 Apr 2009 10:11:56 -0400
Subject: INNER JOIN

---
 lib/ur/basis.urs        |  5 +++++
 src/elisp/urweb-mode.el |  3 ++-
 src/monoize.sml         | 16 ++++++++++++++++
 src/urweb.grm           | 46 +++++++++++++++++++++++++++++++++++++++++-----
 src/urweb.lex           |  4 ++++
 tests/join.ur           |  2 ++
 6 files changed, 70 insertions(+), 6 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index c6ba7b2c..a81ba30a 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -229,6 +229,11 @@ val sql_from_comma : tabs1 ::: {{Type}} -> tabs2 ::: {{Type}}
                      -> [tabs1 ~ tabs2]
     => sql_from_items tabs1 -> sql_from_items tabs2
        -> sql_from_items (tabs1 ++ tabs2)
+val sql_inner_join : tabs1 ::: {{Type}} -> tabs2 ::: {{Type}}
+                     -> [tabs1 ~ tabs2]
+    => sql_from_items tabs1 -> sql_from_items tabs2
+       -> sql_exp (tabs1 ++ tabs2) [] [] bool
+       -> sql_from_items (tabs1 ++ tabs2)
 
 val sql_query1 : tables ::: {{Type}}
                  -> grouped ::: {{Type}}
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index 834c28da..2cd27fcc 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -149,7 +149,8 @@ See doc for the variable `urweb-mode-info'."
                  "TRUE" "FALSE" "AND" "OR" "NOT" "COUNT" "AVG" "SUM" "MIN" "MAX"
                  "ASC" "DESC" "INSERT" "INTO" "VALUES" "UPDATE" "SET" "DELETE"
                  "PRIMARY" "KEY" "CONSTRAINT" "UNIQUE" "CHECK"
-                 "FOREIGN" "REFERENCES" "ON" "NO" "ACTION" "CASCADE" "RESTRICT" "NULL")
+                 "FOREIGN" "REFERENCES" "ON" "NO" "ACTION" "CASCADE" "RESTRICT" "NULL"
+                 "JOIN" "INNER" "OUTER" "LEFT" "RIGHT" "FULL" "CROSS")
   "A regexp that matches SQL keywords.")
 
 (defconst urweb-lident-regexp "\\<[a-z_][A-Za-z0-9_']*\\>"
diff --git a/src/monoize.sml b/src/monoize.sml
index 8d8f07d4..98a32492 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1728,6 +1728,22 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                              (L'.ERel 0, loc)]), loc)), loc),
                  fm)
             end
+          | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_inner_join"), _), _), _), _) =>
+            let
+                val s = (L'.TFfi ("Basis", "string"), loc)
+            in
+                ((L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
+                           (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
+                                     (L'.EAbs ("on", s, s,
+                                               strcat [(L'.EPrim (Prim.String "("), loc),
+                                                       (L'.ERel 2, loc),
+                                                       (L'.EPrim (Prim.String " JOIN "), loc),
+                                                       (L'.ERel 1, loc),
+                                                       (L'.EPrim (Prim.String " ON "), loc),
+                                                       (L'.ERel 0, loc),
+                                                       (L'.EPrim (Prim.String ")"), loc)]), loc)), loc)), loc),
+                 fm)
+            end
 
           | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) =>
             ((L'.EPrim (Prim.String ""), loc), fm)
diff --git a/src/urweb.grm b/src/urweb.grm
index 21030b4d..723ed8b1 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -213,6 +213,7 @@ datatype attr = Class of exp | Normal of con * exp
  | CURRENT_TIMESTAMP
  | NE | LT | LE | GT | GE
  | CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES
+ | JOIN | INNER | CROSS
 
 %nonterm
    file of decl list
@@ -305,6 +306,7 @@ datatype attr = Class of exp | Normal of con * exp
  | query of exp
  | query1 of exp
  | tables of con list * exp
+ | fitem of con list * exp
  | tname of con
  | tnameW of con * con
  | tnames of (con * con) * (con * con) list
@@ -359,6 +361,7 @@ datatype attr = Class of exp | Normal of con * exp
 %nonassoc DCOLON TCOLON
 %left UNION INTERSECT EXCEPT
 %right COMMA
+%right JOIN INNER CROSS
 %right OR
 %right CAND
 %nonassoc EQ NE LT LE GT GE IS
@@ -1422,17 +1425,50 @@ query1 : SELECT select FROM tables wopt gopt hopt
        | query1 INTERSECT query1        (sql_relop ("intersect", query11, query12, s (query11left, query12right)))
        | query1 EXCEPT query1           (sql_relop ("except", query11, query12, s (query11left, query12right)))
 
-tables : table'                         ([#1 table'], #2 table')
-       | table' COMMA tables            (let
-                                             val loc = s (table'left, tablesright)
+tables : fitem                          (fitem)
+       | fitem COMMA tables             (let
+                                             val loc = s (fitemleft, tablesright)
                                                        
                                              val e = (EVar (["Basis"], "sql_from_comma", Infer), loc)
-                                             val e = (EApp (e, #2 table'), loc)
+                                             val e = (EApp (e, #2 fitem), loc)
                                          in
-                                             (#1 table' :: #1 tables,
+                                             (#1 fitem @ #1 tables,
                                               (EApp (e, #2 tables), loc))
                                          end)
 
+fitem  : table'                         ([#1 table'], #2 table')
+       | fitem JOIN fitem ON sqlexp     (let
+                                             val loc = s (fitem1left, sqlexpright)
+                                                       
+                                             val e = (EVar (["Basis"], "sql_inner_join", Infer), loc)
+                                             val e = (EApp (e, #2 fitem1), loc)
+                                             val e = (EApp (e, #2 fitem2), loc)
+                                         in
+                                             (#1 fitem1 @ #1 fitem2,
+                                              (EApp (e, sqlexp), loc))
+                                         end)
+       | fitem INNER JOIN fitem ON sqlexp (let
+                                             val loc = s (fitem1left, sqlexpright)
+                                                       
+                                             val e = (EVar (["Basis"], "sql_inner_join", Infer), loc)
+                                             val e = (EApp (e, #2 fitem1), loc)
+                                             val e = (EApp (e, #2 fitem2), loc)
+                                         in
+                                             (#1 fitem1 @ #1 fitem2,
+                                              (EApp (e, sqlexp), loc))
+                                         end)
+       | fitem CROSS JOIN fitem         (let
+                                             val loc = s (fitem1left, fitem2right)
+                                                       
+                                             val e = (EVar (["Basis"], "sql_inner_join", Infer), loc)
+                                             val e = (EApp (e, #2 fitem1), loc)
+                                             val e = (EApp (e, #2 fitem2), loc)
+                                             val tru = sql_inject (EVar (["Basis"], "True", Infer), loc)
+                                         in
+                                             (#1 fitem1 @ #1 fitem2,
+                                              (EApp (e, tru), loc))
+                                         end)
+
 tname  : CSYMBOL                        (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
        | LBRACE cexp RBRACE             (cexp)
 
diff --git a/src/urweb.lex b/src/urweb.lex
index 534d51c6..c20e9206 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -338,6 +338,10 @@ notags = [^<{\n]+;
 <INITIAL> "OFFSET"    => (Tokens.OFFSET (pos yypos, pos yypos + size yytext));
 <INITIAL> "ALL"       => (Tokens.ALL (pos yypos, pos yypos + size yytext));
 
+<INITIAL> "JOIN"      => (Tokens.JOIN (pos yypos, pos yypos + size yytext));
+<INITIAL> "INNER"     => (Tokens.INNER (pos yypos, pos yypos + size yytext));
+<INITIAL> "CROSS"     => (Tokens.CROSS (pos yypos, pos yypos + size yytext));
+
 <INITIAL> "UNION"     => (Tokens.UNION (pos yypos, pos yypos + size yytext));
 <INITIAL> "INTERSECT" => (Tokens.INTERSECT (pos yypos, pos yypos + size yytext));
 <INITIAL> "EXCEPT"    => (Tokens.EXCEPT (pos yypos, pos yypos + size yytext));
diff --git a/tests/join.ur b/tests/join.ur
index a883e45f..30a0e744 100644
--- a/tests/join.ur
+++ b/tests/join.ur
@@ -3,4 +3,6 @@ table t : { A : int }
 fun main () =
     r <- oneRow (SELECT * FROM t);
     r <- oneRow (SELECT * FROM t AS T1, t AS T2);
+    r <- oneRow (SELECT * FROM t AS T1 CROSS JOIN t AS T2);
+    r <- oneRow (SELECT * FROM t AS T1 JOIN t AS T2 ON T1.A = T2.A);
     return <xml/>
-- 
cgit v1.2.3


From 008b594412606bbf78fff76daff219a102ce2daa Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Tue, 28 Apr 2009 11:05:28 -0400
Subject: LEFT JOIN

---
 lib/ur/basis.urs  | 11 +++++++
 src/elab_env.sig  |  2 +-
 src/elab_env.sml  | 87 +++++++++++++++++++++++++++++++++++++++++++++++++++----
 src/elaborate.sml | 61 +++++++++++++++++++++-----------------
 src/monoize.sml   | 37 +++++++++++++++++++++++
 src/urweb.grm     | 14 +++++++--
 src/urweb.lex     |  1 +
 tests/join.ur     |  3 +-
 8 files changed, 181 insertions(+), 35 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index a81ba30a..a67d007a 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -235,6 +235,17 @@ val sql_inner_join : tabs1 ::: {{Type}} -> tabs2 ::: {{Type}}
        -> sql_exp (tabs1 ++ tabs2) [] [] bool
        -> sql_from_items (tabs1 ++ tabs2)
 
+class nullify :: Type -> Type -> Type
+val nullify_option : t ::: Type -> nullify (option t) (option t)
+val nullify_prim : t ::: Type -> sql_injectable_prim t -> nullify t (option t)
+
+val sql_left_join : tabs1 ::: {{Type}} -> tabs2 ::: {{(Type * Type)}}
+                     -> [tabs1 ~ tabs2]
+    => $(map (fn r => $(map (fn p :: (Type * Type) => nullify p.1 p.2) r)) tabs2)
+       -> sql_from_items tabs1 -> sql_from_items (map (map (fn p :: (Type * Type) => p.1)) tabs2)
+       -> sql_exp (tabs1 ++ map (map (fn p :: (Type * Type) => p.1)) tabs2) [] [] bool
+       -> sql_from_items (tabs1 ++ map (map (fn p :: (Type * Type) => p.2)) tabs2)
+
 val sql_query1 : tables ::: {{Type}}
                  -> grouped ::: {{Type}}
                  -> selectedFields ::: {{Type}}
diff --git a/src/elab_env.sig b/src/elab_env.sig
index 4b927a16..1621722f 100644
--- a/src/elab_env.sig
+++ b/src/elab_env.sig
@@ -71,7 +71,7 @@ signature ELAB_ENV = sig
 
     val pushClass : env -> int -> env
     val isClass : env -> Elab.con -> bool
-    val resolveClass : env -> Elab.con -> Elab.exp option
+    val resolveClass : (Elab.con -> Elab.con) -> env -> Elab.con -> Elab.exp option
     val listClasses : env -> (Elab.con * (Elab.con * Elab.exp) list) list
 
     val pushERel : env -> string -> Elab.con -> env
diff --git a/src/elab_env.sml b/src/elab_env.sml
index 62a310f2..7b20a700 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -507,6 +507,8 @@ fun unifyCons rs =
                 (CUnif (_, _, _, ref (SOME c1)), _) => unify d (c1, c2)
               | (_, CUnif (_, _, _, ref (SOME c2))) => unify d (c1, c2)
 
+              | (CUnif _, _) => ()
+
               | (c1', CRel n2) =>
                 if n2 < d then
                     case c1' of
@@ -587,7 +589,56 @@ fun unifySubst (rs : con list) =
                         | (d, _) => d}
                0
 
-fun resolveClass (env : env) =
+fun postUnify x =
+    let
+        fun unify (c1, c2) =
+            case (#1 c1, #1 c2) of
+                (CUnif (_, _, _, ref (SOME c1)), _) => unify (c1, c2)
+              | (_, CUnif (_, _, _, ref (SOME c2))) => unify (c1, c2)
+
+              | (CUnif (_, _, _, r), _) => r := SOME c2
+
+              | (TFun (d1, r1), TFun (d2, r2)) => (unify (d1, d2); unify (r1, r2))
+              | (TCFun (_, _, k1, r1), TCFun (_, _, k2, r2)) => (unifyKinds (k1, k2); unify (r1, r2))
+              | (TRecord c1, TRecord c2) => unify (c1, c2)
+              | (TDisjoint (a1, b1, c1), TDisjoint (a2, b2, c2)) =>
+                (unify (a1, a2); unify (b1, b2); unify (c1, c2))
+
+              | (CRel n1, CRel n2) => if n1 = n2 then () else raise Unify
+              | (CNamed n1, CNamed n2) => if n1 = n2 then () else raise Unify
+              | (CModProj (n1, ms1, x1), CModProj (n2, ms2, x2)) =>
+                if n1 = n2 andalso ms1 = ms2 andalso x1 = x2 then () else raise Unify
+              | (CApp (f1, x1), CApp (f2, x2)) => (unify (f1, f2); unify (x1, x2))
+              | (CAbs (_, k1, b1), CAbs (_, k2, b2)) => (unifyKinds (k1, k2); unify (b1, b2))
+
+              | (CKAbs (_, b1), CKAbs (_, b2)) => unify (b1, b2)
+              | (CKApp (c1, k1), CKApp (c2, k2)) => (unify (c1, c2); unifyKinds (k1, k2))
+              | (TKFun (_, c1), TKFun (_, c2)) => unify (c1, c2)
+
+              | (CName s1, CName s2) => if s1 = s2 then () else raise Unify
+
+              | (CRecord (k1, xcs1), CRecord (k2, xcs2)) =>
+                (unifyKinds (k1, k2);
+                 ListPair.appEq (fn ((x1, c1), (x2, c2)) => (unify (x1, x2); unify (c1, c2))) (xcs1, xcs2)
+                 handle ListPair.UnequalLengths => raise Unify)
+              | (CConcat (f1, x1), CConcat (f2, x2)) => (unify (f1, f2); unify (x1, x2))
+              | (CMap (d1, r1), CMap (d2, r2)) => (unifyKinds (d1, d2); unifyKinds (r1, r2))
+
+              | (CUnit, CUnit) => ()
+
+              | (CTuple cs1, CTuple cs2) => (ListPair.appEq unify (cs1, cs2)
+                                             handle ListPair.UnequalLengths => raise Unify)
+              | (CProj (c1, n1), CProj (c2, n2)) => (unify (c1, c2);
+                                                     if n1 = n2 then () else raise Unify)
+
+              | _ => raise Unify
+    in
+        unify x
+    end
+
+fun postUnifies x = (postUnify x; true) handle Unify => false
+
+fun resolveClass (hnorm : con -> con) (env : env) =
     let
         fun resolve c =
             let
@@ -608,7 +659,8 @@ fun resolveClass (env : env) =
                                         let
                                             val eos = map (resolve o unifySubst rs) cs
                                         in
-                                            if List.exists (not o Option.isSome) eos then
+                                            if List.exists (not o Option.isSome) eos
+                                               orelse not (postUnifies (c, unifySubst rs c')) then
                                                 tryRules rules'
                                             else
                                                 let
@@ -634,9 +686,34 @@ fun resolveClass (env : env) =
                             tryGrounds (#ground class)
                         end
             in
-                case class_head_in c of
-                    SOME f => doHead f
-                  | _ => NONE
+                case #1 c of
+                    TRecord c =>
+                    (case #1 (hnorm c) of
+                         CRecord (_, xts) =>
+                         let
+                             fun resolver (xts, acc) =
+                                 case xts of
+                                     [] => SOME (ERecord acc, #2 c)
+                                   | (x, t) :: xts =>
+                                     let
+                                         val t = hnorm t
+
+                                         val t = case t of
+                                                     (CApp (f, x), loc) => (CApp (hnorm f, hnorm x), loc)
+                                                   | _ => t
+                                     in
+                                         case resolve t of
+                                             NONE => NONE
+                                           | SOME e => resolver (xts, (x, e, t) :: acc)
+                                     end
+                         in
+                             resolver (xts, [])
+                         end
+                       | _ => NONE)
+                  | _ =>
+                    case class_head_in c of
+                        SOME f => doHead f
+                      | _ => NONE
             end
     in
         resolve
diff --git a/src/elaborate.sml b/src/elaborate.sml
index ea4c28bd..709871da 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1131,26 +1131,35 @@
                | (L'.TFun (dom, ran), _) =>
                  let
                      fun default () = (e, t, [])
+
+                     fun isInstance () =
+                         if infer <> L.TypesOnly then
+                             let
+                                 val r = ref NONE
+                                 val (e, t, gs) = unravel (ran, (L'.EApp (e, (L'.EUnif r, loc)), loc))
+                             in
+                                 (e, t, TypeClass (env, dom, r, loc) :: gs)
+                             end
+                         else
+                             default ()
+
+                     fun hasInstance c =
+                         case #1 (hnormCon env c) of
+                             L'.CApp (cl, x) =>
+                             let
+                                 val cl = hnormCon env cl
+                             in
+                                 isClassOrFolder env cl
+                             end
+                           | L'.TRecord c => U.Con.exists {kind = fn _ => false,
+                                                           con = fn c =>
+                                                                    E.isClass env (hnormCon env (c, loc))} c
+                           | _ => false
                  in
-                     case #1 (hnormCon env dom) of
-                         L'.CApp (cl, x) =>
-                         let
-                             val cl = hnormCon env cl
-                         in
-                             if infer <> L.TypesOnly then
-                                 if isClassOrFolder env cl then
-                                     let
-                                         val r = ref NONE
-                                         val (e, t, gs) = unravel (ran, (L'.EApp (e, (L'.EUnif r, loc)), loc))
-                                     in
-                                         (e, t, TypeClass (env, dom, r, loc) :: gs)
-                                     end
-                                 else
-                                     default ()
-                             else
-                                 default ()
-                         end
-                       | _ => default ()
+                     if hasInstance dom then
+                         isInstance ()
+                     else
+                         default ()
                  end
                | (L'.TDisjoint (r1, r2, t'), loc) =>
                  if infer <> L.TypesOnly then
@@ -3638,7 +3647,7 @@ fun elabFile basis topStr topSgn env file =
                                   let
                                       val c = normClassKey env c
                                   in
-                                      case E.resolveClass env c of
+                                      case E.resolveClass (hnormCon env) env c of
                                           SOME e => r := SOME e
                                         | NONE => expError env (Unresolvable (loc, c))
                                   end) gs
@@ -3685,11 +3694,6 @@ fun elabFile basis topStr topSgn env file =
             (!delayedUnifs);
         delayedUnifs := [];
 
-        if ErrorMsg.anyErrors () then
-            ()
-        else
-            app (fn f => f ()) (!checks);
-
         if ErrorMsg.anyErrors () then
             ()
         else
@@ -3708,7 +3712,7 @@ fun elabFile basis topStr topSgn env file =
 
                         val c = normClassKey env c
                     in
-                        case E.resolveClass env c of
+                        case E.resolveClass (hnormCon env) env c of
                             SOME e => r := SOME e
                           | NONE =>
                             case #1 (hnormCon env c) of
@@ -3747,6 +3751,11 @@ fun elabFile basis topStr topSgn env file =
                               | _ => default ()
                     end) gs;
 
+        if ErrorMsg.anyErrors () then
+            ()
+        else
+            app (fn f => f ()) (!checks);
+
         (L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan)
         :: ds
         @ (L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan)
diff --git a/src/monoize.sml b/src/monoize.sml
index 98a32492..1a502e51 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -189,6 +189,8 @@ fun monoType env =
                     (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
                   | L.CApp ((L.CFfi ("Basis", "sql_injectable"), _), t) =>
                     (L'.TFun (mt env dtmap t, (L'.TFfi ("Basis", "string"), loc)), loc)
+                  | L.CApp ((L.CApp ((L.CFfi ("Basis", "nullify"), _), _), _), _) =>
+                    (L'.TRecord [], loc)
                   | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_unary"), _), _), _), _) =>
                     (L'.TFfi ("Basis", "string"), loc)
                   | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_binary"), _), _), _), _), _), _) =>
@@ -581,6 +583,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             ((L'.ERecord [("Lt", lt, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc)),
                           ("Le", le, (L'.TFun (t, (L'.TFun (t, (L'.TFfi ("Basis", "bool"), loc)), loc)), loc))],
               loc), fm)
+
+        fun outerRec xts =
+            (L'.TRecord (map (fn ((L.CName x, _), (L.CRecord (_, xts), _)) =>
+                                 (x, (L'.TRecord (map (fn (x', _) => (x, (L'.TRecord [], loc))) xts), loc))
+                               | (x, all as (_, loc)) =>
+                                 (E.errorAt loc "Unsupported record field constructor";
+                                  Print.eprefaces' [("Name", CorePrint.p_con env x),
+                                                    ("Constructor", CorePrint.p_con env all)];
+                                  ("", dummyTyp))) xts), loc)
     in
         case e of
             L.EPrim p => ((L'.EPrim p, loc), fm)
@@ -1702,6 +1713,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                  fm)
             end
 
+          | L.ECApp ((L.EFfi ("Basis", "nullify_option"), _), _) =>
+            ((L'.ERecord [], loc), fm)
+          | L.ECApp ((L.EFfi ("Basis", "nullify_prim"), _), _) =>
+            ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
+                       (L'.ERecord [], loc)), loc),
+             fm)
+
           | L.ECApp ((L.EFfi ("Basis", "sql_subset"), _), _) =>
             ((L'.ERecord [], loc), fm)
           | L.ECApp ((L.EFfi ("Basis", "sql_subset_all"), _), _) =>
@@ -1744,6 +1762,25 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                        (L'.EPrim (Prim.String ")"), loc)]), loc)), loc)), loc),
                  fm)
             end
+          | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_left_join"), _), _), _), (L.CRecord (_, right), _)) =>
+            let
+                val s = (L'.TFfi ("Basis", "string"), loc)
+            in
+                ((L'.EAbs ("_", outerRec right,
+                           (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
+                           (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
+                                     (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
+                                               (L'.EAbs ("on", s, s,
+                                                         strcat [(L'.EPrim (Prim.String "("), loc),
+                                                                 (L'.ERel 2, loc),
+                                                                 (L'.EPrim (Prim.String " LEFT JOIN "), loc),
+                                                                 (L'.ERel 1, loc),
+                                                                 (L'.EPrim (Prim.String " ON "), loc),
+                                                                 (L'.ERel 0, loc),
+                                                                 (L'.EPrim (Prim.String ")"), loc)]),
+                                                loc)), loc)), loc)), loc),
+                 fm)
+            end
 
           | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) =>
             ((L'.EPrim (Prim.String ""), loc), fm)
diff --git a/src/urweb.grm b/src/urweb.grm
index 723ed8b1..c1f0b1ca 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -213,7 +213,7 @@ datatype attr = Class of exp | Normal of con * exp
  | CURRENT_TIMESTAMP
  | NE | LT | LE | GT | GE
  | CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES
- | JOIN | INNER | CROSS
+ | JOIN | INNER | CROSS | LEFT
 
 %nonterm
    file of decl list
@@ -361,7 +361,7 @@ datatype attr = Class of exp | Normal of con * exp
 %nonassoc DCOLON TCOLON
 %left UNION INTERSECT EXCEPT
 %right COMMA
-%right JOIN INNER CROSS
+%right JOIN INNER CROSS LEFT
 %right OR
 %right CAND
 %nonassoc EQ NE LT LE GT GE IS
@@ -1468,6 +1468,16 @@ fitem  : table'                         ([#1 table'], #2 table')
                                              (#1 fitem1 @ #1 fitem2,
                                               (EApp (e, tru), loc))
                                          end)
+       | fitem LEFT JOIN fitem ON sqlexp (let
+                                             val loc = s (fitem1left, sqlexpright)
+                                                       
+                                             val e = (EVar (["Basis"], "sql_left_join", Infer), loc)
+                                             val e = (EApp (e, #2 fitem1), loc)
+                                             val e = (EApp (e, #2 fitem2), loc)
+                                         in
+                                             (#1 fitem1 @ #1 fitem2,
+                                              (EApp (e, sqlexp), loc))
+                                         end)
 
 tname  : CSYMBOL                        (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
        | LBRACE cexp RBRACE             (cexp)
diff --git a/src/urweb.lex b/src/urweb.lex
index c20e9206..517054b3 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -341,6 +341,7 @@ notags = [^<{\n]+;
 <INITIAL> "JOIN"      => (Tokens.JOIN (pos yypos, pos yypos + size yytext));
 <INITIAL> "INNER"     => (Tokens.INNER (pos yypos, pos yypos + size yytext));
 <INITIAL> "CROSS"     => (Tokens.CROSS (pos yypos, pos yypos + size yytext));
+<INITIAL> "LEFT"      => (Tokens.LEFT (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "UNION"     => (Tokens.UNION (pos yypos, pos yypos + size yytext));
 <INITIAL> "INTERSECT" => (Tokens.INTERSECT (pos yypos, pos yypos + size yytext));
diff --git a/tests/join.ur b/tests/join.ur
index 30a0e744..74f49eec 100644
--- a/tests/join.ur
+++ b/tests/join.ur
@@ -1,8 +1,9 @@
-table t : { A : int }
+table t : { A : int, B : string, C : option string }
 
 fun main () =
     r <- oneRow (SELECT * FROM t);
     r <- oneRow (SELECT * FROM t AS T1, t AS T2);
     r <- oneRow (SELECT * FROM t AS T1 CROSS JOIN t AS T2);
     r <- oneRow (SELECT * FROM t AS T1 JOIN t AS T2 ON T1.A = T2.A);
+    r <- oneRow (SELECT * FROM t AS T1 LEFT JOIN t AS T2 ON T1.A = T2.A);
     return <xml/>
-- 
cgit v1.2.3


From ce12549593feae055d778b34ec9c5abef2b83123 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Tue, 28 Apr 2009 11:14:24 -0400
Subject: RIGHT and FULL JOIN

---
 lib/ur/basis.urs | 15 +++++++++++++++
 src/monoize.sml  | 39 +++++++++++++++++++++++++++++++++++++++
 src/urweb.grm    | 54 ++++++++++++++++++++++++++++++++++++++++++++++++++++--
 src/urweb.lex    |  3 +++
 tests/join.ur    |  2 ++
 5 files changed, 111 insertions(+), 2 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index a67d007a..c80dde7c 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -246,6 +246,21 @@ val sql_left_join : tabs1 ::: {{Type}} -> tabs2 ::: {{(Type * Type)}}
        -> sql_exp (tabs1 ++ map (map (fn p :: (Type * Type) => p.1)) tabs2) [] [] bool
        -> sql_from_items (tabs1 ++ map (map (fn p :: (Type * Type) => p.2)) tabs2)
 
+val sql_right_join : tabs1 ::: {{(Type * Type)}} -> tabs2 ::: {{Type}}
+                     -> [tabs1 ~ tabs2]
+    => $(map (fn r => $(map (fn p :: (Type * Type) => nullify p.1 p.2) r)) tabs1)
+       -> sql_from_items (map (map (fn p :: (Type * Type) => p.1)) tabs1) -> sql_from_items tabs2
+       -> sql_exp (map (map (fn p :: (Type * Type) => p.1)) tabs1 ++ tabs2) [] [] bool
+       -> sql_from_items (map (map (fn p :: (Type * Type) => p.2)) tabs1 ++ tabs2)
+
+val sql_full_join : tabs1 ::: {{(Type * Type)}} -> tabs2 ::: {{(Type * Type)}}
+                     -> [tabs1 ~ tabs2]
+    => $(map (fn r => $(map (fn p :: (Type * Type) => nullify p.1 p.2) r)) (tabs1 ++ tabs2))
+       -> sql_from_items (map (map (fn p :: (Type * Type) => p.1)) tabs1)
+       -> sql_from_items (map (map (fn p :: (Type * Type) => p.1)) tabs2)
+       -> sql_exp (map (map (fn p :: (Type * Type) => p.1)) (tabs1 ++ tabs2)) [] [] bool
+       -> sql_from_items (map (map (fn p :: (Type * Type) => p.2)) (tabs1 ++ tabs2))
+
 val sql_query1 : tables ::: {{Type}}
                  -> grouped ::: {{Type}}
                  -> selectedFields ::: {{Type}}
diff --git a/src/monoize.sml b/src/monoize.sml
index 1a502e51..16839cf9 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1781,6 +1781,45 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                 loc)), loc)), loc)), loc),
                  fm)
             end
+          | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_right_join"), _), (L.CRecord (_, left), _)), _), _) =>
+            let
+                val s = (L'.TFfi ("Basis", "string"), loc)
+            in
+                ((L'.EAbs ("_", outerRec left,
+                           (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
+                           (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
+                                     (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
+                                               (L'.EAbs ("on", s, s,
+                                                         strcat [(L'.EPrim (Prim.String "("), loc),
+                                                                 (L'.ERel 2, loc),
+                                                                 (L'.EPrim (Prim.String " RIGHT JOIN "), loc),
+                                                                 (L'.ERel 1, loc),
+                                                                 (L'.EPrim (Prim.String " ON "), loc),
+                                                                 (L'.ERel 0, loc),
+                                                                 (L'.EPrim (Prim.String ")"), loc)]),
+                                                loc)), loc)), loc)), loc),
+                 fm)
+            end
+          | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_full_join"), _), (L.CRecord (_, left), _)), _),
+                     (L.CRecord (_, right), _)) =>
+            let
+                val s = (L'.TFfi ("Basis", "string"), loc)
+            in
+                ((L'.EAbs ("_", outerRec (left @ right),
+                           (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
+                           (L'.EAbs ("tab1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
+                                     (L'.EAbs ("tab2", s, (L'.TFun (s, s), loc),
+                                               (L'.EAbs ("on", s, s,
+                                                         strcat [(L'.EPrim (Prim.String "("), loc),
+                                                                 (L'.ERel 2, loc),
+                                                                 (L'.EPrim (Prim.String " FULL JOIN "), loc),
+                                                                 (L'.ERel 1, loc),
+                                                                 (L'.EPrim (Prim.String " ON "), loc),
+                                                                 (L'.ERel 0, loc),
+                                                                 (L'.EPrim (Prim.String ")"), loc)]),
+                                                loc)), loc)), loc)), loc),
+                 fm)
+            end
 
           | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) =>
             ((L'.EPrim (Prim.String ""), loc), fm)
diff --git a/src/urweb.grm b/src/urweb.grm
index c1f0b1ca..ce078279 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -213,7 +213,7 @@ datatype attr = Class of exp | Normal of con * exp
  | CURRENT_TIMESTAMP
  | NE | LT | LE | GT | GE
  | CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES
- | JOIN | INNER | CROSS | LEFT
+ | JOIN | INNER | CROSS | OUTER | LEFT | RIGHT | FULL
 
 %nonterm
    file of decl list
@@ -361,7 +361,7 @@ datatype attr = Class of exp | Normal of con * exp
 %nonassoc DCOLON TCOLON
 %left UNION INTERSECT EXCEPT
 %right COMMA
-%right JOIN INNER CROSS LEFT
+%right JOIN INNER CROSS OUTER LEFT RIGHT FULL
 %right OR
 %right CAND
 %nonassoc EQ NE LT LE GT GE IS
@@ -1478,6 +1478,56 @@ fitem  : table'                         ([#1 table'], #2 table')
                                              (#1 fitem1 @ #1 fitem2,
                                               (EApp (e, sqlexp), loc))
                                          end)
+       | fitem LEFT OUTER JOIN fitem ON sqlexp (let
+                                             val loc = s (fitem1left, sqlexpright)
+                                                       
+                                             val e = (EVar (["Basis"], "sql_left_join", Infer), loc)
+                                             val e = (EApp (e, #2 fitem1), loc)
+                                             val e = (EApp (e, #2 fitem2), loc)
+                                         in
+                                             (#1 fitem1 @ #1 fitem2,
+                                              (EApp (e, sqlexp), loc))
+                                         end)
+       | fitem RIGHT JOIN fitem ON sqlexp (let
+                                             val loc = s (fitem1left, sqlexpright)
+                                                       
+                                             val e = (EVar (["Basis"], "sql_right_join", Infer), loc)
+                                             val e = (EApp (e, #2 fitem1), loc)
+                                             val e = (EApp (e, #2 fitem2), loc)
+                                         in
+                                             (#1 fitem1 @ #1 fitem2,
+                                              (EApp (e, sqlexp), loc))
+                                         end)
+       | fitem RIGHT OUTER JOIN fitem ON sqlexp (let
+                                             val loc = s (fitem1left, sqlexpright)
+                                                       
+                                             val e = (EVar (["Basis"], "sql_right_join", Infer), loc)
+                                             val e = (EApp (e, #2 fitem1), loc)
+                                             val e = (EApp (e, #2 fitem2), loc)
+                                         in
+                                             (#1 fitem1 @ #1 fitem2,
+                                              (EApp (e, sqlexp), loc))
+                                         end)
+       | fitem FULL JOIN fitem ON sqlexp (let
+                                             val loc = s (fitem1left, sqlexpright)
+                                                       
+                                             val e = (EVar (["Basis"], "sql_full_join", Infer), loc)
+                                             val e = (EApp (e, #2 fitem1), loc)
+                                             val e = (EApp (e, #2 fitem2), loc)
+                                         in
+                                             (#1 fitem1 @ #1 fitem2,
+                                              (EApp (e, sqlexp), loc))
+                                         end)
+       | fitem FULL OUTER JOIN fitem ON sqlexp (let
+                                             val loc = s (fitem1left, sqlexpright)
+                                                       
+                                             val e = (EVar (["Basis"], "sql_full_join", Infer), loc)
+                                             val e = (EApp (e, #2 fitem1), loc)
+                                             val e = (EApp (e, #2 fitem2), loc)
+                                         in
+                                             (#1 fitem1 @ #1 fitem2,
+                                              (EApp (e, sqlexp), loc))
+                                         end)
 
 tname  : CSYMBOL                        (CName CSYMBOL, s (CSYMBOLleft, CSYMBOLright))
        | LBRACE cexp RBRACE             (cexp)
diff --git a/src/urweb.lex b/src/urweb.lex
index 517054b3..bb9004a6 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -341,7 +341,10 @@ notags = [^<{\n]+;
 <INITIAL> "JOIN"      => (Tokens.JOIN (pos yypos, pos yypos + size yytext));
 <INITIAL> "INNER"     => (Tokens.INNER (pos yypos, pos yypos + size yytext));
 <INITIAL> "CROSS"     => (Tokens.CROSS (pos yypos, pos yypos + size yytext));
+<INITIAL> "OUTER"     => (Tokens.OUTER (pos yypos, pos yypos + size yytext));
 <INITIAL> "LEFT"      => (Tokens.LEFT (pos yypos, pos yypos + size yytext));
+<INITIAL> "RIGHT"     => (Tokens.RIGHT (pos yypos, pos yypos + size yytext));
+<INITIAL> "FULL"      => (Tokens.FULL (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "UNION"     => (Tokens.UNION (pos yypos, pos yypos + size yytext));
 <INITIAL> "INTERSECT" => (Tokens.INTERSECT (pos yypos, pos yypos + size yytext));
diff --git a/tests/join.ur b/tests/join.ur
index 74f49eec..d6647877 100644
--- a/tests/join.ur
+++ b/tests/join.ur
@@ -6,4 +6,6 @@ fun main () =
     r <- oneRow (SELECT * FROM t AS T1 CROSS JOIN t AS T2);
     r <- oneRow (SELECT * FROM t AS T1 JOIN t AS T2 ON T1.A = T2.A);
     r <- oneRow (SELECT * FROM t AS T1 LEFT JOIN t AS T2 ON T1.A = T2.A);
+    r <- oneRow (SELECT * FROM t AS T1 RIGHT OUTER JOIN t AS T2 ON T1.A = T2.A);
+    r <- oneRow (SELECT * FROM t AS T1 FULL JOIN t AS T2 ON T1.A = T2.A);
     return <xml/>
-- 
cgit v1.2.3


From 51f2a80dac5c3cd25a27fb5abfdfa50d813ab0b2 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Tue, 28 Apr 2009 15:04:37 -0400
Subject: A view query works

---
 src/cjr.sml             |  1 +
 src/cjr_env.sml         |  1 +
 src/cjr_print.sml       | 20 ++++++++++++
 src/cjrize.sml          | 28 +++++++++++++++++
 src/core.sml            |  1 +
 src/core_env.sml        |  7 +++++
 src/core_print.sml      |  7 +++++
 src/core_util.sml       | 15 +++++++++
 src/corify.sml          |  8 +++++
 src/elab.sml            |  1 +
 src/elab_env.sml        | 82 ++++++++++++++++++++++++++++++++-----------------
 src/elab_print.sml      |  7 +++++
 src/elab_util.sml       | 14 +++++++++
 src/elaborate.sml       | 47 ++++++++++++++++++++++------
 src/elisp/urweb-mode.el |  2 +-
 src/expl.sml            |  1 +
 src/expl_env.sml        |  7 +++++
 src/expl_print.sml      |  7 +++++
 src/explify.sml         |  2 ++
 src/mono.sml            |  1 +
 src/mono_env.sml        |  1 +
 src/mono_opt.sml        | 25 +++++++++++++++
 src/mono_print.sml      |  7 +++++
 src/mono_shake.sml      |  2 ++
 src/mono_util.sml       |  6 ++++
 src/monoize.sml         | 18 +++++++++++
 src/prepare.sml         |  1 +
 src/reduce.sml          |  1 +
 src/reduce_local.sml    |  1 +
 src/shake.sml           |  5 ++-
 src/source.sml          |  1 +
 src/source_print.sml    |  7 +++++
 src/unnest.sml          |  1 +
 src/urweb.grm           | 13 +++++++-
 src/urweb.lex           |  1 +
 tests/view.ur           | 10 ++++++
 tests/view.urp          |  5 +++
 tests/view.urs          |  1 +
 38 files changed, 325 insertions(+), 40 deletions(-)
 create mode 100644 tests/view.ur
 create mode 100644 tests/view.urp
 create mode 100644 tests/view.urs

(limited to 'src/urweb.lex')

diff --git a/src/cjr.sml b/src/cjr.sml
index 559b7ada..d3fdbc22 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -107,6 +107,7 @@ datatype decl' =
 
        | DTable of string * (string * typ) list * string * (string * string) list
        | DSequence of string
+       | DView of string * (string * typ) list * string
        | DDatabase of {name : string, expunge : int, initialize : int}
        | DPreparedStatements of (string * int) list
 
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index 7f02a4e9..54dbea17 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -164,6 +164,7 @@ fun declBinds env (d, loc) =
                   end) env vis
       | DTable _ => env
       | DSequence _ => env
+      | DView _ => env
       | DDatabase _ => env
       | DPreparedStatements _ => env
       | DJavaScript _ => env
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index c870c3ed..a09dd7f6 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2069,6 +2069,15 @@ fun p_decl env (dAll as (d, _) : decl) =
                             string x,
                             string " */",
                             newline]
+      | DView (x, _, s) => box [string "/* SQL view ",
+                                string x,
+                                space,
+                                string "AS",
+                                space,
+                                string s,
+                                space,
+                                string " */",
+                                newline]
       | DDatabase {name, expunge, initialize} =>
         box [string "static void uw_db_validate(uw_context);",
              newline,
@@ -3089,6 +3098,17 @@ fun p_sql env (ds, _) =
                                                  string ";",
                                                  newline,
                                                  newline]
+                                          | DView (s, xts, q) =>
+                                            box [string "CREATE VIEW",
+                                                 space,
+                                                 string s,
+                                                 space,
+                                                 string "AS",
+                                                 space,
+                                                 string q,
+                                                 string ";",
+                                                 newline,
+                                                 newline]
                                           | _ => box []
                            in
                                (pp, E.declBinds env dAll)
diff --git a/src/cjrize.sml b/src/cjrize.sml
index ee2ecdb6..19aeee4e 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -562,6 +562,34 @@ fun cifyDecl ((d, loc), sm) =
         end
       | L.DSequence s =>
         (SOME (L'.DSequence s, loc), NONE, sm)
+      | L.DView (s, xts, e) =>
+        let
+            val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
+                                                  let
+                                                      val (t, sm) = cifyTyp (t, sm)
+                                                  in
+                                                      ((x, t), sm)
+                                                  end) sm xts
+
+            fun flatten e =
+                case #1 e of
+                    L.ERecord [] => []
+                  | L.ERecord [(x, (L.EPrim (Prim.String v), _), _)] => [(x, v)]
+                  | L.EStrcat (e1, e2) => flatten e1 @ flatten e2
+                  | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined";
+                          Print.prefaces "Undetermined constraint"
+                                         [("e", MonoPrint.p_exp MonoEnv.empty e)];
+                          [])
+
+            val e = case #1 e of
+                        L.EPrim (Prim.String s) => s
+                      | _ => (ErrorMsg.errorAt loc "VIEW query has not been fully determined";
+                              Print.prefaces "Undetermined VIEW query"
+                                             [("e", MonoPrint.p_exp MonoEnv.empty e)];
+                              "")
+        in
+            (SOME (L'.DView (s, xts, e), loc), NONE, sm)
+        end
       | L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm)
       | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm)
       | L.DCookie args => (SOME (L'.DCookie args, loc), NONE, sm)
diff --git a/src/core.sml b/src/core.sml
index 01cf4ec7..131bcc6f 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -130,6 +130,7 @@ datatype decl' =
        | DExport of export_kind * int
        | DTable of string * int * con * string * exp * con * exp * con
        | DSequence of string * int * string
+       | DView of string * int * string * exp * con
        | DDatabase of string
        | DCookie of string * int * con * string
        | DStyle of string * int * string
diff --git a/src/core_env.sml b/src/core_env.sml
index caf30349..0630fef2 100644
--- a/src/core_env.sml
+++ b/src/core_env.sml
@@ -327,6 +327,13 @@ fun declBinds env (d, loc) =
         in
             pushENamed env x n t NONE s
         end
+      | DView (x, n, s, _, c) =>
+        let
+            val ct = (CFfi ("Basis", "sql_view"), loc)
+            val ct = (CApp (ct, c), loc)
+        in
+            pushENamed env x n ct NONE s
+        end
       | DDatabase _ => env
       | DCookie (x, n, c, s) =>
         let
diff --git a/src/core_print.sml b/src/core_print.sml
index 9c1c72cd..f2a42a7b 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -566,6 +566,13 @@ fun p_decl env (dAll as (d, _) : decl) =
                                     string "as",
                                     space,
                                     string s]
+      | DView (x, n, s, e, _) => box [string "view",
+                                      space,
+                                      p_named x n,
+                                      space,
+                                      string "as",
+                                      space,
+                                      p_exp env e]
       | DDatabase s => box [string "database",
                             space,
                             string s]
diff --git a/src/core_util.sml b/src/core_util.sml
index d05aaa72..ae956121 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -946,6 +946,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} =
                                                             fn cc' =>
                                                                (DTable (x, n, c', s, pe', pc', ce', cc'), loc))))))
               | DSequence _ => S.return2 dAll
+              | DView (x, n, s, e, c) =>
+                S.bind2 (mfe ctx e,
+                     fn e' =>
+                        S.map2 (mfc ctx c,
+                             fn c' =>
+                                (DView (x, n, s, e', c'), loc)))
               | DDatabase _ => S.return2 dAll
               | DCookie (x, n, c, s) =>
                 S.map2 (mfc ctx c,
@@ -1082,6 +1088,14 @@ fun mapfoldB (all as {bind, ...}) =
                                         in
                                             bind (ctx, NamedE (x, n, t, NONE, s))
                                         end
+                                      | DView (x, n, s, _, c) =>
+                                        let
+                                            val loc = #2 d'
+                                            val ct = (CFfi ("Basis", "sql_view"), loc)
+                                            val ct = (CApp (ct, c), loc)
+                                        in
+                                            bind (ctx, NamedE (x, n, ct, NONE, s))
+                                        end
                                       | DDatabase _ => ctx
                                       | DCookie (x, n, c, s) =>
                                         let
@@ -1154,6 +1168,7 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
                           | DExport _ => count
                           | DTable (_, n, _, _, _, _, _, _) => Int.max (n, count)
                           | DSequence (_, n, _) => Int.max (n, count)
+                          | DView (_, n, _, _, _) => Int.max (n, count)
                           | DDatabase _ => count
                           | DCookie (_, n, _, _) => Int.max (n, count)
                           | DStyle (_, n, _) => Int.max (n, count)) 0
diff --git a/src/corify.sml b/src/corify.sml
index c1cd940e..f1895e19 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -992,6 +992,13 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
         in
             ([(L'.DSequence (x, n, s), loc)], st)
         end
+      | L.DView (_, x, n, e, c) =>
+        let
+            val (st, n) = St.bindVal st x n
+            val s = relify (doRestify (mods, x))
+        in
+            ([(L'.DView (x, n, s, corifyExp st e, corifyCon st c), loc)], st)
+        end
 
       | L.DDatabase s => ([(L'.DDatabase s, loc)], st)
 
@@ -1063,6 +1070,7 @@ fun maxName ds = foldl (fn ((d, _), n) =>
                              | L.DExport _ => n
                              | L.DTable (_, _, n', _, _, _, _, _) => Int.max (n, n')
                              | L.DSequence (_, _, n') => Int.max (n, n')
+                             | L.DView (_, _, n', _, _) => Int.max (n, n')
                              | L.DDatabase _ => n
                              | L.DCookie (_, _, n', _) => Int.max (n, n')
                              | L.DStyle (_, _, n') => Int.max (n, n'))
diff --git a/src/elab.sml b/src/elab.sml
index f82a947d..555cc25c 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -165,6 +165,7 @@ datatype decl' =
        | DExport of int * sgn * str
        | DTable of int * string * int * con * exp * con * exp * con
        | DSequence of int * string * int
+       | DView of int * string * int * exp * con
        | DClass of string * int * kind * con
        | DDatabase of string
        | DCookie of int * string * int * con
diff --git a/src/elab_env.sml b/src/elab_env.sml
index 0184d0b1..efc2b74e 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -591,6 +591,22 @@ fun unifySubst (rs : con list) =
 
 exception Bad of con * con
 
+val hasUnif = U.Con.exists {kind = fn _ => false,
+                            con = fn CUnif (_, _, _, ref NONE) => true
+                                   | _ => false}
+
+fun startsWithUnif c =
+    let
+        fun firstArg (c, acc) =
+            case #1 c of
+                CApp (f, x) => firstArg (f, SOME x)
+              | _ => acc
+    in
+        case firstArg (c, NONE) of
+            NONE => false
+          | SOME x => hasUnif x
+    end
+
 fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) =
     let
         fun resolve c =
@@ -671,34 +687,37 @@ fun resolveClass (hnorm : con -> con) (consEq : con * con -> bool) (env : env) =
                             tryGrounds (#ground class)
                         end
             in
-                case #1 c of
-                    TRecord c =>
-                    (case #1 (hnorm c) of
-                         CRecord (_, xts) =>
-                         let
-                             fun resolver (xts, acc) =
-                                 case xts of
-                                     [] => SOME (ERecord acc, #2 c)
-                                   | (x, t) :: xts =>
-                                     let
-                                         val t = hnorm t
-
-                                         val t = case t of
-                                                     (CApp (f, x), loc) => (CApp (hnorm f, hnorm x), loc)
-                                                   | _ => t
-                                     in
-                                         case resolve t of
-                                             NONE => NONE
-                                           | SOME e => resolver (xts, (x, e, t) :: acc)
-                                     end
-                         in
-                             resolver (xts, [])
-                         end
-                       | _ => NONE)
-                  | _ =>
-                    case class_head_in c of
-                        SOME f => doHead f
-                      | _ => NONE
+                if startsWithUnif c then
+                    NONE
+                else
+                    case #1 c of
+                        TRecord c =>
+                        (case #1 (hnorm c) of
+                             CRecord (_, xts) =>
+                             let
+                                 fun resolver (xts, acc) =
+                                     case xts of
+                                         [] => SOME (ERecord acc, #2 c)
+                                       | (x, t) :: xts =>
+                                         let
+                                             val t = hnorm t
+
+                                             val t = case t of
+                                                         (CApp (f, x), loc) => (CApp (hnorm f, hnorm x), loc)
+                                                       | _ => t
+                                         in
+                                             case resolve t of
+                                                 NONE => NONE
+                                               | SOME e => resolver (xts, (x, e, t) :: acc)
+                                         end
+                             in
+                                 resolver (xts, [])
+                             end
+                           | _ => NONE)
+                      | _ =>
+                        case class_head_in c of
+                            SOME f => doHead f
+                          | _ => NONE
             end
     in
         resolve
@@ -1482,6 +1501,13 @@ fun declBinds env (d, loc) =
         in
             pushENamedAs env x n t
         end
+      | DView (tn, x, n, _, c) =>
+        let
+            val ct = (CModProj (tn, [], "sql_view"), loc)
+            val ct = (CApp (ct, c), loc)
+        in
+            pushENamedAs env x n ct
+        end
       | DClass (x, n, k, c) =>
         let
             val k = (KArrow (k, (KType, loc)), loc)
diff --git a/src/elab_print.sml b/src/elab_print.sml
index e6a2cccb..bbbd9f8d 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -758,6 +758,13 @@ fun p_decl env (dAll as (d, _) : decl) =
       | DSequence (_, x, n) => box [string "sequence",
                                     space,
                                     p_named x n]
+      | DView (_, x, n, e, _) => box [string "view",
+                                      space,
+                                      p_named x n,
+                                      space,
+                                      string "as",
+                                      space,
+                                      p_exp env e]
       | DClass (x, n, k, c) => box [string "class",
                                     space,
                                     p_named x n,
diff --git a/src/elab_util.sml b/src/elab_util.sml
index 0d78951b..f4cbc951 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -791,6 +791,13 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
                                                    end
                                                  | DSequence (tn, x, n) =>
                                                    bind (ctx, NamedE (x, (CModProj (n, [], "sql_sequence"), loc)))
+                                                 | DView (tn, x, n, _, c) =>
+                                                   let
+                                                       val ct = (CModProj (n, [], "sql_view"), loc)
+                                                       val ct = (CApp (ct, c), loc)
+                                                   in
+                                                       bind (ctx, NamedE (x, ct))
+                                                   end
                                                  | DClass (x, n, k, _) =>
                                                    bind (ctx, NamedC (x, n, (KArrow (k, (KType, loc)), loc)))
                                                  | DDatabase _ => ctx
@@ -899,6 +906,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
                                                               fn cc' =>
                                                                  (DTable (tn, x, n, c', pe', pc', ce', cc'), loc))))))
               | DSequence _ => S.return2 dAll
+              | DView (tn, x, n, e, c) =>
+                S.bind2 (mfe ctx e,
+                        fn e' =>
+                           S.map2 (mfc ctx c,
+                                   fn c' =>
+                                      (DView (tn, x, n, e', c'), loc)))
 
               | DClass (x, n, k, c) =>
                 S.bind2 (mfk ctx k,
@@ -1051,6 +1064,7 @@ and maxNameDecl (d, _) =
       | DExport _ => 0
       | DTable (n1, _, n2, _, _, _, _, _) => Int.max (n1, n2)
       | DSequence (n1, _, n2) => Int.max (n1, n2)
+      | DView (n1, _, n2, _, _) => Int.max (n1, n2)
       | DDatabase _ => 0
       | DCookie (n1, _, n2, _) => Int.max (n1, n2)
       | DStyle (n1, _, n2) => Int.max (n1, n2)
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 81fcbda1..b9378e1b 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -803,19 +803,22 @@
                  handle GuessFailure => false
              end
 
-         val (fs1, fs2, others1, others2) =
+         val (fs1, fs2, others1, others2, unifs1, unifs2) =
              case (fs1, fs2, others1, others2, unifs1, unifs2) of
                  ([], _, [other1], [], [], _) =>
                  if isGuessable (other1, fs2, unifs2) then
-                     ([], [], [], [])
+                     ([], [], [], [], [], [])
                  else
-                     (fs1, fs2, others1, others2)
+                     (fs1, fs2, others1, others2, unifs1, unifs2)
                | (_, [], [], [other2], _, []) =>
                  if isGuessable (other2, fs1, unifs1) then
-                     ([], [], [], [])
+                     ([], [], [], [], [], [])
                  else
-                     (fs1, fs2, others1, others2)
-               | _ => (fs1, fs2, others1, others2)
+                     (prefaces "Not guessable" [("other2", p_con env other2),
+                                                ("fs1", p_con env (L'.CRecord (k, fs1), loc)),
+                                                ("#unifs1", PD.string (Int.toString (length unifs1)))];
+                      (fs1, fs2, others1, others2, unifs1, unifs2))
+               | _ => (fs1, fs2, others1, others2, unifs1, unifs2)
 
          (*val () = eprefaces "Summaries5" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}),
                                           ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*)
@@ -849,7 +852,7 @@
          fun unfold (dom, ran, f, r, c) =
              let
                  fun unfold (r, c) =
-                     case #1 c of
+                     case #1 (hnormCon env c) of
                          L'.CRecord (_, []) => unifyCons env r (L'.CRecord (dom, []), loc)
                        | L'.CRecord (_, [(x, v)]) =>
                          let
@@ -878,8 +881,7 @@
                              unfold (r2, c2');
                              unifyCons env r (L'.CConcat (r1, r2), loc)
                          end
-                       | L'.CUnif (_, _, _, ref (SOME c)) => unfold (r, c)
-                       | L'.CUnif (_, _, _, ur as ref NONE) =>
+                       | L'.CUnif (_, _, _, ur) =>
                          let
                              val ur' = cunif (loc, (L'.KRecord dom, loc))
                          in
@@ -1935,6 +1937,8 @@ val hnormSgn = E.hnormSgn
 
 fun tableOf () = (L'.CModProj (!basis_r, [], "sql_table"), ErrorMsg.dummySpan)
 fun sequenceOf () = (L'.CModProj (!basis_r, [], "sql_sequence"), ErrorMsg.dummySpan)
+fun viewOf () = (L'.CModProj (!basis_r, [], "sql_view"), ErrorMsg.dummySpan)
+fun queryOf () = (L'.CModProj (!basis_r, [], "sql_query"), ErrorMsg.dummySpan)
 fun cookieOf () = (L'.CModProj (!basis_r, [], "http_cookie"), ErrorMsg.dummySpan)
 fun styleOf () = (L'.CModProj (!basis_r, [], "css_class"), ErrorMsg.dummySpan)
 
@@ -2434,6 +2438,8 @@ and sgiOfDecl (d, loc) =
         [(L'.SgiVal (x, n, (L'.CApp ((L'.CApp (tableOf (), c), loc),
                                      (L'.CConcat (pc, cc), loc)), loc)), loc)]
       | L'.DSequence (tn, x, n) => [(L'.SgiVal (x, n, sequenceOf ()), loc)]
+      | L'.DView (tn, x, n, _, c) =>
+        [(L'.SgiVal (x, n, (L'.CApp (viewOf (), c), loc)), loc)]
       | L'.DClass (x, n, k, c) => [(L'.SgiClass (x, n, k, c), loc)]
       | L'.DDatabase _ => []
       | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)]
@@ -3405,6 +3411,29 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
                 in
                     ([(L'.DSequence (!basis_r, x, n), loc)], (env, denv, gs))
                 end
+              | L.DView (x, e) =>
+                let
+                    val (e', t, gs') = elabExp (env, denv) e
+
+                    val k = (L'.KRecord (L'.KType, loc), loc)
+                    val fs = cunif (loc, k)
+                    val ts = cunif (loc, (L'.KRecord k, loc))
+                    val tf = (L'.CApp ((L'.CMap (k, k), loc),
+                                       (L'.CAbs ("_", k, (L'.CRecord ((L'.KType, loc), []), loc)), loc)), loc)
+                    val ts = (L'.CApp (tf, ts), loc)
+
+                    val cv = viewOf ()
+                    val cv = (L'.CApp (cv, fs), loc)
+                    val (env', n) = E.pushENamed env x cv
+
+                    val ct = queryOf ()
+                    val ct = (L'.CApp (ct, ts), loc)
+                    val ct = (L'.CApp (ct, fs), loc)
+                in
+                    checkCon env e' t ct;
+                    ([(L'.DView (!basis_r, x, n, e', fs), loc)],
+                     (env', denv, gs' @ gs))
+                end
 
               | L.DClass (x, k, c) =>
                 let
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index 2cd27fcc..7f4b0dee 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -137,7 +137,7 @@ See doc for the variable `urweb-mode-info'."
 	       "fun" "functor" "if" "include"
 	       "of" "open" "let" "in"
 	       "rec" "sequence" "sig" "signature" "cookie" "style"
-	       "struct" "structure" "table" "then" "type" "val" "where"
+	       "struct" "structure" "table" "view" "then" "type" "val" "where"
 	       "with"
 
                "Name" "Type" "Unit")
diff --git a/src/expl.sml b/src/expl.sml
index e293c36b..cc40e8b4 100644
--- a/src/expl.sml
+++ b/src/expl.sml
@@ -143,6 +143,7 @@ datatype decl' =
        | DExport of int * sgn * str
        | DTable of int * string * int * con * exp * con * exp * con
        | DSequence of int * string * int
+       | DView of int * string * int * exp * con
        | DDatabase of string
        | DCookie of int * string * int * con
        | DStyle of int * string * int
diff --git a/src/expl_env.sml b/src/expl_env.sml
index 1e99b36b..2bb049a3 100644
--- a/src/expl_env.sml
+++ b/src/expl_env.sml
@@ -312,6 +312,13 @@ fun declBinds env (d, loc) =
         in
             pushENamed env x n t
         end
+      | DView (tn, x, n, _, c) =>
+        let
+            val ct = (CModProj (tn, [], "sql_view"), loc)
+            val ct = (CApp (ct, c), loc)
+        in
+            pushENamed env x n ct
+        end
       | DDatabase _ => env
       | DCookie (tn, x, n, c) =>
         let
diff --git a/src/expl_print.sml b/src/expl_print.sml
index 167c6850..e6b28fea 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -681,6 +681,13 @@ fun p_decl env (dAll as (d, _) : decl) =
       | DSequence (_, x, n) => box [string "sequence",
                                     space,
                                     p_named x n]
+      | DView (_, x, n, e, _) => box [string "view",
+                                      space,
+                                      p_named x n,
+                                      space,
+                                      string "as",
+                                      space,
+                                      p_exp env e]
       | DDatabase s => box [string "database",
                             space,
                             string s]
diff --git a/src/explify.sml b/src/explify.sml
index 6a33eabc..2e181771 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -182,6 +182,8 @@ fun explifyDecl (d, loc : EM.span) =
         SOME (L'.DTable (nt, x, n, explifyCon c,
                          explifyExp pe, explifyCon pc,
                          explifyExp ce, explifyCon cc), loc)
+      | L.DView (nt, x, n, e, c) =>
+        SOME (L'.DView (nt, x, n, explifyExp e, explifyCon c), loc)
       | L.DSequence (nt, x, n) => SOME (L'.DSequence (nt, x, n), loc)
       | L.DClass (x, n, k, c) => SOME (L'.DCon (x, n,
                                                 (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), explifyCon c), loc)
diff --git a/src/mono.sml b/src/mono.sml
index e9d30181..7a789e2c 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -127,6 +127,7 @@ datatype decl' =
 
        | DTable of string * (string * typ) list * exp * exp
        | DSequence of string
+       | DView of string * (string * typ) list * exp
        | DDatabase of {name : string, expunge : int, initialize : int}
 
        | DJavaScript of string
diff --git a/src/mono_env.sml b/src/mono_env.sml
index b3572fbe..739f2f89 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.sml
@@ -109,6 +109,7 @@ fun declBinds env (d, loc) =
       | DExport _ => env
       | DTable _ => env
       | DSequence _ => env
+      | DView _ => env
       | DDatabase _ => env
       | DJavaScript _ => env
       | DCookie _ => env
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 19244e60..41724eb0 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -422,6 +422,31 @@ fun exp e =
             EPrim (Prim.String s)
         end
 
+      | EFfiApp ("Basis", "viewify", [(EPrim (Prim.String s), loc)]) => 
+        let
+            fun uwify (cs, acc) =
+                case cs of
+                    [] => String.concat (rev acc)
+                  | #"A" :: #"S" :: #" " :: #"_" :: cs => uwify (cs, "AS uw_" :: acc)
+                  | #"'" :: cs =>
+                    let
+                        fun waitItOut (cs, acc) =
+                            case cs of
+                                [] => raise Fail "MonoOpt: Unterminated SQL string literal"
+                              | #"'" :: cs => uwify (cs, "'" :: acc)
+                              | #"\\" :: #"'" :: cs => waitItOut (cs, "\\'" :: acc)
+                              | #"\\" :: #"\\" :: cs => waitItOut (cs, "\\\\" :: acc)
+                              | c :: cs => waitItOut (cs, str c :: acc)
+                    in
+                        waitItOut (cs, "'" :: acc)
+                    end
+                  | c :: cs => uwify (cs, str c :: acc)
+
+            val s = uwify (String.explode s, [])
+        in
+            EPrim (Prim.String s)
+        end
+
       | _ => e
 
 and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
diff --git a/src/mono_print.sml b/src/mono_print.sml
index ffc1d4fe..a233b400 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -438,6 +438,13 @@ fun p_decl env (dAll as (d, _) : decl) =
       | DSequence s => box [string "(* SQL sequence ",
                             string s,
                             string "*)"]
+      | DView (s, _, e) => box [string "(* SQL view ",
+                                string s,
+                                space,
+                                string "as",
+                                space,
+                                p_exp env e,
+                                string "*)"]
       | DDatabase {name, expunge, initialize} => box [string "database",
                                                       space,
                                                       string name,
diff --git a/src/mono_shake.sml b/src/mono_shake.sml
index 0060d036..4764feb7 100644
--- a/src/mono_shake.sml
+++ b/src/mono_shake.sml
@@ -57,6 +57,7 @@ fun shake file =
                                    | ((DExport _, _), acc) => acc
                                    | ((DTable _, _), acc) => acc
                                    | ((DSequence _, _), acc) => acc
+                                   | ((DView _, _), acc) => acc
                                    | ((DDatabase _, _), acc) => acc
                                    | ((DJavaScript _, _), acc) => acc
                                    | ((DCookie _, _), acc) => acc
@@ -116,6 +117,7 @@ fun shake file =
                       | (DExport _, _) => true
                       | (DTable _, _) => true
                       | (DSequence _, _) => true
+                      | (DView _, _) => true
                       | (DDatabase _, _) => true
                       | (DJavaScript _, _) => true
                       | (DCookie _, _) => true
diff --git a/src/mono_util.sml b/src/mono_util.sml
index dd848ba6..caf96ac7 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -492,6 +492,10 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
                               fn ce' =>
                                  (DTable (s, xts, pe', ce'), loc)))
               | DSequence _ => S.return2 dAll
+              | DView (s, xts, e) =>
+                S.map2 (mfe ctx e,
+                     fn e' =>
+                        (DView (s, xts, e'), loc))
               | DDatabase _ => S.return2 dAll
               | DJavaScript _ => S.return2 dAll
               | DCookie _ => S.return2 dAll
@@ -575,6 +579,7 @@ fun mapfoldB (all as {bind, ...}) =
                                       | DExport _ => ctx
                                       | DTable _ => ctx
                                       | DSequence _ => ctx
+                                      | DView _ => ctx
                                       | DDatabase _ => ctx
                                       | DJavaScript _ => ctx
                                       | DCookie _ => ctx
@@ -626,6 +631,7 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
                           | DExport _ => count
                           | DTable _ => count
                           | DSequence _ => count
+                          | DView _ => count
                           | DDatabase _ => count
                           | DJavaScript _ => count
                           | DCookie _ => count
diff --git a/src/monoize.sml b/src/monoize.sml
index ccc5a851..a2048a7d 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2938,6 +2938,24 @@ fun monoDecl (env, fm) (all as (d, loc)) =
                        (L'.DVal (x, n, t', e_name, s), loc)])
             end
           | L.DTable _ => poly ()
+          | L.DView (x, n, s, e, (L.CRecord (_, xts), _)) =>
+            let
+                val t = (L.CFfi ("Basis", "string"), loc)
+                val t' = (L'.TFfi ("Basis", "string"), loc)
+                val s = "uw_" ^ s
+                val e_name = (L'.EPrim (Prim.String s), loc)
+
+                val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
+
+                val (e, fm) = monoExp (env, St.empty, fm) e
+                val e = (L'.EFfiApp ("Basis", "viewify", [e]), loc)
+            in
+                SOME (Env.pushENamed env x n t NONE s,
+                      fm,
+                      [(L'.DView (s, xts, e), loc),
+                       (L'.DVal (x, n, t', e_name, s), loc)])
+            end
+          | L.DView _ => poly ()
           | L.DSequence (x, n, s) =>
             let
                 val t = (L.CFfi ("Basis", "string"), loc)
diff --git a/src/prepare.sml b/src/prepare.sml
index 25306e89..592b00bc 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -266,6 +266,7 @@ fun prepDecl (d as (_, loc), sns) =
 
       | DTable _ => (d, sns)
       | DSequence _ => (d, sns)
+      | DView _ => (d, sns)
       | DDatabase _ => (d, sns)
       | DPreparedStatements _ => (d, sns)
       | DJavaScript _ => (d, sns)
diff --git a/src/reduce.sml b/src/reduce.sml
index 914f26c0..665c10b4 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -467,6 +467,7 @@ fun reduce file =
                                                                   exp (namedC, namedE) [] ce,
                                                                   con namedC [] cc), loc), st)
               | DSequence _ => (d, st)
+              | DView (s, n, s', e, c) => ((DView (s, n, s', exp (namedC, namedE) [] e, con namedC [] c), loc), st)
               | DDatabase _ => (d, st)
               | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st)
               | DStyle (s, n, s') => ((DStyle (s, n, s'), loc), st)
diff --git a/src/reduce_local.sml b/src/reduce_local.sml
index 265cb2a4..6c25ebf3 100644
--- a/src/reduce_local.sml
+++ b/src/reduce_local.sml
@@ -158,6 +158,7 @@ fun reduce file =
               | DExport _ => d
               | DTable _ => d
               | DSequence _ => d
+              | DView _ => d
               | DDatabase _ => d
               | DCookie _ => d
               | DStyle _ => d
diff --git a/src/shake.sml b/src/shake.sml
index 787bfd2f..35af7436 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -84,6 +84,8 @@ fun shake file =
                                      (cdef, IM.insert (edef, n, ([], c, dummye)))
                                    | ((DSequence (_, n, _), _), (cdef, edef)) =>
                                      (cdef, IM.insert (edef, n, ([], dummyt, dummye)))
+                                   | ((DView (_, n, _, _, c), _), (cdef, edef)) =>
+                                     (cdef, IM.insert (edef, n, ([], c, dummye)))
                                    | ((DDatabase _, _), acc) => acc
                                    | ((DCookie (_, n, c, _), _), (cdef, edef)) =>
                                      (cdef, IM.insert (edef, n, ([], c, dummye)))
@@ -159,8 +161,9 @@ fun shake file =
                       | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n)
                       | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis
                       | (DExport _, _) => true
-                      | (DTable _, _) => true
+                      | (DView _, _) => true
                       | (DSequence _, _) => true
+                      | (DTable _, _) => true
                       | (DDatabase _, _) => true
                       | (DCookie _, _) => true
                       | (DStyle _, _) => true) file
diff --git a/src/source.sml b/src/source.sml
index 6645ae75..9d3eea79 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -161,6 +161,7 @@ datatype decl' =
        | DExport of str
        | DTable of string * con * exp * exp
        | DSequence of string
+       | DView of string * exp
        | DClass of string * kind * con
        | DDatabase of string
        | DCookie of string * con
diff --git a/src/source_print.sml b/src/source_print.sml
index 58867f64..0f8b093b 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -621,6 +621,13 @@ fun p_decl ((d, _) : decl) =
       | DSequence x => box [string "sequence",
                             space,
                             string x]
+      | DView (x, e) => box [string "view",
+                             space,
+                             string x,
+                             space,
+                             string "=",
+                             space,
+                             p_exp e]
       | DClass (x, k, c) => box [string "class",
                                  space,
                                  string x,
diff --git a/src/unnest.sml b/src/unnest.sml
index c321b34d..51b66aa4 100644
--- a/src/unnest.sml
+++ b/src/unnest.sml
@@ -404,6 +404,7 @@ fun unnest file =
                   | DExport _ => default ()
                   | DTable _ => default ()
                   | DSequence _ => default ()
+                  | DView _ => default ()
                   | DClass _ => default ()
                   | DDatabase _ => default ()
                   | DCookie _ => default ()
diff --git a/src/urweb.grm b/src/urweb.grm
index ce078279..da817ab3 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -195,7 +195,7 @@ datatype attr = Class of exp | Normal of con * exp
  | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE | CARET
  | LET | IN
  | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL
- | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE
+ | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW
  | COOKIE | STYLE
  | CASE | IF | THEN | ELSE
 
@@ -438,6 +438,10 @@ decl   : CON SYMBOL cargl2 kopt EQ cexp (let
        | TABLE SYMBOL COLON cterm pkopt commaOpt cstopt([(DTable (SYMBOL, entable cterm, pkopt, cstopt),
                                                  s (TABLEleft, cstoptright))])
        | SEQUENCE SYMBOL                ([(DSequence SYMBOL, s (SEQUENCEleft, SYMBOLright))])
+       | VIEW SYMBOL EQ query           ([(DView (SYMBOL, query),
+                                           s (VIEWleft, queryright))])
+       | VIEW SYMBOL EQ LBRACE eexp RBRACE ([(DView (SYMBOL, eexp),
+                                           s (VIEWleft, RBRACEright))])
        | CLASS SYMBOL EQ cexp           (let
                                              val loc = s (CLASSleft, cexpright)
                                          in
@@ -674,6 +678,13 @@ sgi    : CON SYMBOL DCOLON kind         ((SgiConAbs (SYMBOL, kind), s (CONleft,
                                          in
                                              (SgiVal (SYMBOL, t), loc)
                                          end)
+       | VIEW SYMBOL COLON cexp         (let
+                                             val loc = s (VIEWleft, cexpright)
+                                             val t = (CVar (["Basis"], "sql_view"), loc)
+                                             val t = (CApp (t, cexp), loc)
+                                         in
+                                             (SgiVal (SYMBOL, t), loc)
+                                         end)
        | CLASS SYMBOL                   (let
                                              val loc = s (CLASSleft, SYMBOLright)
                                              val k = (KArrow ((KType, loc), (KType, loc)), loc)
diff --git a/src/urweb.lex b/src/urweb.lex
index bb9004a6..85cf3bcf 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -317,6 +317,7 @@ notags = [^<{\n]+;
 <INITIAL> "export"    => (Tokens.EXPORT (pos yypos, pos yypos + size yytext));
 <INITIAL> "table"     => (Tokens.TABLE (pos yypos, pos yypos + size yytext));
 <INITIAL> "sequence"  => (Tokens.SEQUENCE (pos yypos, pos yypos + size yytext));
+<INITIAL> "view"      => (Tokens.VIEW (pos yypos, pos yypos + size yytext));
 <INITIAL> "class"     => (Tokens.CLASS (pos yypos, pos yypos + size yytext));
 <INITIAL> "cookie"    => (Tokens.COOKIE (pos yypos, pos yypos + size yytext));
 <INITIAL> "style"     => (Tokens.STYLE (pos yypos, pos yypos + size yytext));
diff --git a/tests/view.ur b/tests/view.ur
new file mode 100644
index 00000000..36d77deb
--- /dev/null
+++ b/tests/view.ur
@@ -0,0 +1,10 @@
+table t : { A : int, B : string }
+
+view v = SELECT t.A AS X FROM t
+
+fun main () =
+    rows <- queryX (SELECT * FROM v)
+            (fn r => <xml><li>{[r.V.X]}</li></xml>);
+    return <xml><body>
+      {rows}
+    </body></xml>
diff --git a/tests/view.urp b/tests/view.urp
new file mode 100644
index 00000000..3528ec9d
--- /dev/null
+++ b/tests/view.urp
@@ -0,0 +1,5 @@
+debug
+database dbname=view
+sql view.sql
+
+view
diff --git a/tests/view.urs b/tests/view.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/view.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page
-- 
cgit v1.2.3


From db2f1f208afef9110d8a5796a2325928a92b62cc Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Thu, 30 Apr 2009 16:25:27 -0400
Subject: Lexing character entities

---
 src/urweb.lex | 55 +++++++++++++++++++++++++++++++++++++++++++++++++++++--
 tests/ent.ur  |  3 +++
 tests/ent.urp |  3 +++
 tests/ent.urs |  1 +
 4 files changed, 60 insertions(+), 2 deletions(-)
 create mode 100644 tests/ent.ur
 create mode 100644 tests/ent.urp
 create mode 100644 tests/ent.urs

(limited to 'src/urweb.lex')

diff --git a/src/urweb.lex b/src/urweb.lex
index 85cf3bcf..46835fa2 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -1,4 +1,6 @@
-(* Copyright (c) 2008, Adam Chlipala
+(* -*- mode: sml-lex -*- *)
+
+(* Copyright (c) 2008-2009, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
@@ -106,6 +108,55 @@ fun initialize () = (xmlTag := [];
 		     xmlString := false)
 
 
+fun unescape loc s =
+    let
+        fun process (s, acc) =
+            let
+                val (befor, after) = Substring.splitl (fn ch => ch <> #"&") s
+            in
+                if Substring.size after = 0 then
+                    Substring.concat (rev (s :: acc))
+                else
+                    let
+                        val after = Substring.slice (after, 1, NONE)
+                        val (befor', after') = Substring.splitl (fn ch => ch <> #";") after
+                    in
+                        if Substring.size after' = 0 then
+                            (ErrorMsg.errorAt' loc "Missing ';' after '&'";
+                             "")
+                        else
+                            let
+                                val pre = befor
+                                val code = befor'
+                                val s = Substring.slice (after', 1, NONE)
+
+                                val special =
+                                    if Substring.size code > 0 andalso Substring.sub (code, 0) = #"#"
+                                       andalso CharVectorSlice.all Char.isDigit (Substring.slice (code, 1, NONE)) then
+                                        let
+                                            val code = Substring.string (Substring.slice (code, 1, NONE))
+                                        in
+                                            Option.map chr (Int.fromString code)
+                                        end
+                                    else case Substring.string code of
+                                             "amp" => SOME #"&"
+                                           | "lt" => SOME #"<"
+                                           | "gt" => SOME #">"
+                                           | "quot" => SOME #"\""
+                                           | _ => NONE
+                            in
+                                case special of
+                                    NONE => (ErrorMsg.errorAt' loc ("Unsupported XML character entity "
+                                                                        ^ Substring.string code);
+                                             "")
+                                  | SOME ch => process (s, Substring.full (String.str ch) :: pre :: acc)
+                            end
+                    end
+            end
+    in
+        process (Substring.full s, [])
+    end
+
 %%
 %header (functor UrwebLexFn(structure Tokens : Urweb_TOKENS));
 %full
@@ -231,7 +282,7 @@ notags = [^<{\n]+;
 			  pushLevel (fn () => YYBEGIN XML);
 			  Tokens.LBRACE (yypos, yypos + 1));
 
-<XML> {notags}        => (Tokens.NOTAGS (yytext, yypos, yypos + size yytext));
+<XML> {notags}        => (Tokens.NOTAGS (unescape (yypos, yypos + size yytext) yytext, yypos, yypos + size yytext));
 
 <XML> .               => (ErrorMsg.errorAt' (yypos, yypos)
                           ("illegal XML character: \"" ^ yytext ^ "\"");
diff --git a/tests/ent.ur b/tests/ent.ur
new file mode 100644
index 00000000..fa01e8cf
--- /dev/null
+++ b/tests/ent.ur
@@ -0,0 +1,3 @@
+fun main () = return <xml><body>
+  &lt;Whoa-hoa!&gt;  A&#66;CD!
+</body></xml>
diff --git a/tests/ent.urp b/tests/ent.urp
new file mode 100644
index 00000000..f63d1159
--- /dev/null
+++ b/tests/ent.urp
@@ -0,0 +1,3 @@
+debug
+
+ent
diff --git a/tests/ent.urs b/tests/ent.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/ent.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page
-- 
cgit v1.2.3


From d8801e05ef2f81f21eb27555b626ee2e52c3365f Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Tue, 26 May 2009 12:25:06 -0400
Subject: Chars and more string operations

---
 include/types.h   |  1 +
 include/urweb.h   |  5 +++++
 lib/js/urweb.js   |  3 +++
 lib/ur/basis.urs  |  7 +++++++
 lib/ur/list.ur    | 34 ++++++++++++++++++++++++++++++++++
 lib/ur/list.urs   |  8 ++++++++
 lib/ur/string.ur  |  4 ++++
 lib/ur/string.urs |  4 ++++
 src/c/urweb.c     | 44 ++++++++++++++++++++++++++++++++++++++++++++
 src/elaborate.sml |  3 +++
 src/jscomp.sml    |  1 +
 src/monoize.sml   | 31 +++++++++++++++++++++++++++++++
 src/prim.sig      |  1 +
 src/prim.sml      | 11 ++++++++++-
 src/settings.sml  |  5 ++++-
 src/urweb.grm     |  4 +++-
 src/urweb.lex     | 27 ++++++++++++++++++++++++++-
 tests/char.ur     |  4 ++++
 tests/char.urp    |  3 +++
 tests/char.urs    |  1 +
 20 files changed, 197 insertions(+), 4 deletions(-)
 create mode 100644 lib/ur/string.ur
 create mode 100644 lib/ur/string.urs
 create mode 100644 tests/char.ur
 create mode 100644 tests/char.urp
 create mode 100644 tests/char.urs

(limited to 'src/urweb.lex')

diff --git a/include/types.h b/include/types.h
index 89e88b88..ca9ef152 100644
--- a/include/types.h
+++ b/include/types.h
@@ -6,6 +6,7 @@
 typedef long long uw_Basis_int;
 typedef double uw_Basis_float;
 typedef char* uw_Basis_string;
+typedef char uw_Basis_char;
 typedef time_t uw_Basis_time;
 typedef struct {
   size_t size;
diff --git a/include/urweb.h b/include/urweb.h
index 974d3c01..1b4a5558 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -111,6 +111,8 @@ uw_Basis_string uw_Basis_unurlifyString(uw_context, char **);
 uw_Basis_bool uw_Basis_unurlifyBool(uw_context, char **);
 uw_Basis_time uw_Basis_unurlifyTime(uw_context, char **);
 
+uw_Basis_char uw_Basis_strsub(uw_context, const char *, uw_Basis_int);
+uw_Basis_string uw_Basis_strsuffix(uw_context, const char *, uw_Basis_int);
 uw_Basis_string uw_Basis_strcat(uw_context, const char *, const char *);
 uw_Basis_string uw_strdup(uw_context, const char *);
 uw_Basis_string uw_maybe_strdup(uw_context, const char *);
@@ -138,16 +140,19 @@ char *uw_Basis_jsifyChannel(uw_context, uw_Basis_channel);
 
 uw_Basis_string uw_Basis_intToString(uw_context, uw_Basis_int);
 uw_Basis_string uw_Basis_floatToString(uw_context, uw_Basis_float);
+uw_Basis_string uw_Basis_charToString(uw_context, uw_Basis_char);
 uw_Basis_string uw_Basis_boolToString(uw_context, uw_Basis_bool);
 uw_Basis_string uw_Basis_timeToString(uw_context, uw_Basis_time);
 
 uw_Basis_int *uw_Basis_stringToInt(uw_context, uw_Basis_string);
 uw_Basis_float *uw_Basis_stringToFloat(uw_context, uw_Basis_string);
+uw_Basis_char *uw_Basis_stringToChar(uw_context, uw_Basis_string);
 uw_Basis_bool *uw_Basis_stringToBool(uw_context, uw_Basis_string);
 uw_Basis_time *uw_Basis_stringToTime(uw_context, uw_Basis_string);
 
 uw_Basis_int uw_Basis_stringToInt_error(uw_context, uw_Basis_string);
 uw_Basis_float uw_Basis_stringToFloat_error(uw_context, uw_Basis_string);
+uw_Basis_char uw_Basis_stringToChar_error(uw_context, uw_Basis_string);
 uw_Basis_bool uw_Basis_stringToBool_error(uw_context, uw_Basis_string);
 uw_Basis_time uw_Basis_stringToTime_error(uw_context, uw_Basis_string);
 uw_Basis_blob uw_Basis_stringToBlob_error(uw_context, uw_Basis_string, size_t);
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index c031678a..2b4d2643 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -351,6 +351,9 @@ function eh(x) {
 function ts(x) { return x.toString() }
 function bs(b) { return (b ? "True" : "False") }
 
+function sub(x, i) { return x[i]; }
+function suf(x, i) { return x.substring(i); }
+
 function pi(s) {
   var r = parseInt(s);
   if (r.toString() == s)
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index c5251bb8..1209d265 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -1,6 +1,7 @@
 type int
 type float
 type string
+type char
 type time
 type blob
 
@@ -21,6 +22,7 @@ val ne : t ::: Type -> eq t -> t -> t -> bool
 val eq_int : eq int
 val eq_float : eq float
 val eq_string : eq string
+val eq_char : eq char
 val eq_bool : eq bool
 val eq_time : eq time
 val mkEq : t ::: Type -> (t -> t -> bool) -> eq t
@@ -44,6 +46,7 @@ val ge : t ::: Type -> ord t -> t -> t -> bool
 val ord_int : ord int
 val ord_float : ord float
 val ord_string : ord string
+val ord_char : ord char
 val ord_bool : ord bool
 val ord_time : ord time
 
@@ -51,12 +54,15 @@ val ord_time : ord time
 (** String operations *)
 
 val strcat : string -> string -> string
+val strsub : string -> int -> char
+val strsuffix : string -> int -> string
 
 class show
 val show : t ::: Type -> show t -> t -> string
 val show_int : show int
 val show_float : show float
 val show_string : show string
+val show_char : show char
 val show_bool : show bool
 val show_time : show time
 val mkShow : t ::: Type -> (t -> string) -> show t
@@ -68,6 +74,7 @@ val readError : t ::: Type -> read t -> string -> t
 val read_int : read int
 val read_float : read float
 val read_string : read string
+val read_char : read char
 val read_bool : read bool
 val read_time : read time
 val mkRead : t ::: Type -> (string -> t) -> (string -> option t) -> read t
diff --git a/lib/ur/list.ur b/lib/ur/list.ur
index 7079f6bc..7527362d 100644
--- a/lib/ur/list.ur
+++ b/lib/ur/list.ur
@@ -20,6 +20,18 @@ val rev (a ::: Type) =
         rev' []
     end
 
+val revAppend (a ::: Type) =
+    let
+        fun ra (ls : list a) acc =
+            case ls of
+                [] => acc
+              | x :: ls => ra ls (x :: acc)
+    in
+        ra
+    end
+
+fun append (a ::: Type) (ls1 : t a) (ls2 : t a) = revAppend (rev ls1) ls2                
+
 fun mp (a ::: Type) (b ::: Type) f =
     let
         fun mp' acc ls =
@@ -30,6 +42,18 @@ fun mp (a ::: Type) (b ::: Type) f =
         mp' []
     end
 
+fun mapPartial (a ::: Type) (b ::: Type) f =
+    let
+        fun mp' acc ls =
+            case ls of
+                [] => rev acc
+              | x :: ls => mp' (case f x of
+                                    None => acc
+                                  | Some y => y :: acc) ls
+    in
+        mp' []
+    end
+
 fun mapX (a ::: Type) (ctx ::: {Unit}) f =
     let
         fun mapX' ls =
@@ -49,3 +73,13 @@ fun mapM (m ::: (Type -> Type)) (_ : monad m) (a ::: Type) (b ::: Type) f =
     in
         mapM' []
     end
+
+fun filter (a ::: Type) f =
+    let
+        fun fil acc ls =
+            case ls of
+                [] => rev acc
+              | x :: ls => fil (if f x then x :: acc else acc) ls
+    in
+        fil []
+    end
diff --git a/lib/ur/list.urs b/lib/ur/list.urs
index d27ad997..fb3407ae 100644
--- a/lib/ur/list.urs
+++ b/lib/ur/list.urs
@@ -4,9 +4,17 @@ val show : a ::: Type -> show a -> show (list a)
 
 val rev : a ::: Type -> t a -> t a
 
+val revAppend : a ::: Type -> t a -> t a -> t a
+
+val append : a ::: Type -> t a -> t a -> t a
+
 val mp : a ::: Type -> b ::: Type -> (a -> b) -> t a -> t b
 
+val mapPartial : a ::: Type -> b ::: Type -> (a -> option b) -> t a -> t b
+
 val mapX : a ::: Type -> ctx ::: {Unit} -> (a -> xml ctx [] []) -> t a -> xml ctx [] []
 
 val mapM : m ::: (Type -> Type) -> monad m -> a ::: Type -> b ::: Type
            -> (a -> m b) -> list a -> m (list b)
+
+val filter : a ::: Type -> (a -> bool) -> t a -> t a
diff --git a/lib/ur/string.ur b/lib/ur/string.ur
new file mode 100644
index 00000000..5362805b
--- /dev/null
+++ b/lib/ur/string.ur
@@ -0,0 +1,4 @@
+type t = Basis.string
+
+val sub = Basis.strsub
+val suffix = Basis.strsuffix
diff --git a/lib/ur/string.urs b/lib/ur/string.urs
new file mode 100644
index 00000000..524e002d
--- /dev/null
+++ b/lib/ur/string.urs
@@ -0,0 +1,4 @@
+type t = string
+
+val sub : t -> int -> char
+val suffix : t -> int -> string
diff --git a/src/c/urweb.c b/src/c/urweb.c
index a75ccf56..d399b3bd 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -1793,6 +1793,20 @@ uw_unit uw_Basis_htmlifyTime_w(uw_context ctx, uw_Basis_time t) {
   return uw_unit_v;
 }
 
+uw_Basis_char uw_Basis_strsub(uw_context ctx, uw_Basis_string s, uw_Basis_int n) {
+  if (n >= 0 && n < strlen(s))
+    return s[n];
+  else
+    uw_error(ctx, FATAL, "Out-of-bounds strsub");
+}
+
+uw_Basis_string uw_Basis_strsuffix(uw_context ctx, uw_Basis_string s, uw_Basis_int n) {
+  if (n >= 0 && n < strlen(s))
+    return &s[n];
+  else
+    uw_error(ctx, FATAL, "Out-of-bounds strsuffix");
+}
+
 uw_Basis_string uw_Basis_strcat(uw_context ctx, uw_Basis_string s1, uw_Basis_string s2) {
   int len = strlen(s1) + strlen(s2) + 1;
   char *s;
@@ -2081,6 +2095,13 @@ uw_Basis_string uw_Basis_floatToString(uw_context ctx, uw_Basis_float n) {
   return r;
 }
 
+uw_Basis_string uw_Basis_charToString(uw_context ctx, uw_Basis_char ch) {
+  char *r = uw_malloc(ctx, 2);
+  r[0] = ch;
+  r[1] = 0;
+  return r;
+}
+
 uw_Basis_string uw_Basis_boolToString(uw_context ctx, uw_Basis_bool b) {
   if (b == uw_Basis_False)
     return "False";
@@ -2127,6 +2148,20 @@ uw_Basis_float *uw_Basis_stringToFloat(uw_context ctx, uw_Basis_string s) {
     return NULL;
 }
 
+uw_Basis_char *uw_Basis_stringToChar(uw_context ctx, uw_Basis_string s) {
+  if (s[0] == 0) {
+    uw_Basis_char *r = uw_malloc(ctx, 1);
+    r[0] = 0;
+    return r;
+  } else if (s[1] != 0)
+    return NULL;
+  else {
+    uw_Basis_char *r = uw_malloc(ctx, 1);
+    r[0] = s[0];
+    return r;
+  }
+}
+
 uw_Basis_bool *uw_Basis_stringToBool(uw_context ctx, uw_Basis_string s) {
   static uw_Basis_bool true = uw_Basis_True;
   static uw_Basis_bool false = uw_Basis_False;
@@ -2215,6 +2250,15 @@ uw_Basis_float uw_Basis_stringToFloat_error(uw_context ctx, uw_Basis_string s) {
     uw_error(ctx, FATAL, "Can't parse float: %s", s);
 }
 
+uw_Basis_char uw_Basis_stringToChar_error(uw_context ctx, uw_Basis_string s) {
+  if (s[0] == 0)
+    return 0;
+  else if (s[1] != 0)
+    uw_error(ctx, FATAL, "Can't parse char: %s", s);
+  else
+    return s[0];
+}
+
 uw_Basis_bool uw_Basis_stringToBool_error(uw_context ctx, uw_Basis_string s) {
   if (!strcasecmp(s, "T") || !strcasecmp (s, "True"))
     return uw_Basis_True;
diff --git a/src/elaborate.sml b/src/elaborate.sml
index fb376df2..49b826eb 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -140,6 +140,7 @@
  val int = ref cerror
  val float = ref cerror
  val string = ref cerror
+ val char = ref cerror
  val table = ref cerror
 
  local
@@ -1096,6 +1097,7 @@
          P.Int _ => !int
        | P.Float _ => !float
        | P.String _ => !string
+       | P.Char _ => !char
                            
  datatype constraint =
           Disjoint of D.goal
@@ -3974,6 +3976,7 @@ fun elabFile basis topStr topSgn env file =
         val () = discoverC int "int"
         val () = discoverC float "float"
         val () = discoverC string "string"
+        val () = discoverC char "char"
         val () = discoverC table "sql_table"
 
         val (topSgn, gs) = elabSgn (env', D.empty) (L.SgnConst topSgn, ErrorMsg.dummySpan)
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 4352693f..0e5c70de 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -541,6 +541,7 @@ fun process file =
                                                                                 Int.fmt StringCvt.OCT (ord ch),
                                                                                 3)) s
                                      ^ "\"")
+                              | Prim.Char ch => str ("'" ^ String.str ch ^ "'")
                               | _ => str (Prim.toString p)
 
                         fun jsPat depth inner (p, _) succ fail =
diff --git a/src/monoize.sml b/src/monoize.sml
index 19bb1a11..87c4d86c 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -762,6 +762,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                  (L'.TFfi ("Basis", "bool"), loc),
                                  (L'.EBinop ("!strcmp", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
              fm)
+          | L.EFfi ("Basis", "eq_char") =>
+            ((L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc),
+                       (L'.TFun ((L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
+                       (L'.EAbs ("y", (L'.TFfi ("Basis", "char"), loc),
+                                 (L'.TFfi ("Basis", "bool"), loc),
+                                 (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
+             fm)
           | L.EFfi ("Basis", "eq_time") =>
             ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc),
                        (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
@@ -971,6 +978,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                        boolBin "<",
                        boolBin "<=")
             end
+          | L.EFfi ("Basis", "ord_char") =>
+            let
+                fun charBin s =
+                    (L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc),
+                              (L'.TFun ((L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
+                              (L'.EAbs ("y", (L'.TFfi ("Basis", "char"), loc),
+                                        (L'.TFfi ("Basis", "bool"), loc),
+                                        (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc)
+            in
+                ordEx ((L'.TFfi ("Basis", "char"), loc),
+                       charBin "<",
+                       charBin "<=")
+            end
           | L.EFfi ("Basis", "ord_time") =>
             let
                 fun boolBin s =
@@ -1003,6 +1023,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             in
                 ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm)
             end
+          | L.EFfi ("Basis", "show_char") =>
+            ((L'.EFfi ("Basis", "charToString"), loc), fm)
           | L.EFfi ("Basis", "show_bool") =>
             ((L'.EFfi ("Basis", "boolToString"), loc), fm)
           | L.EFfi ("Basis", "show_time") =>
@@ -1080,6 +1102,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                               ("ReadError", (L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), readErrType (s, loc))], loc),
                  fm)
             end
+          | L.EFfi ("Basis", "read_char") =>
+            let
+                val t = (L'.TFfi ("Basis", "char"), loc)
+            in
+                ((L'.ERecord [("Read", (L'.EFfi ("Basis", "stringToChar"), loc), readType' (t, loc)),
+                               ("ReadError", (L'.EFfi ("Basis", "stringToChar_error"), loc), readErrType (t, loc))],
+                  loc),
+                 fm)
+            end
           | L.EFfi ("Basis", "read_bool") =>
             let
                 val t = (L'.TFfi ("Basis", "bool"), loc)
diff --git a/src/prim.sig b/src/prim.sig
index 54625379..fb067b3a 100644
--- a/src/prim.sig
+++ b/src/prim.sig
@@ -31,6 +31,7 @@ signature PRIM = sig
              Int of Int64.int
            | Float of Real64.real
            | String of string
+           | Char of char
 
     val p_t : t Print.printer
     val p_t_GCC : t Print.printer
diff --git a/src/prim.sml b/src/prim.sml
index 95df6e02..597b3fba 100644
--- a/src/prim.sml
+++ b/src/prim.sml
@@ -31,6 +31,7 @@ datatype t =
          Int of Int64.int
        | Float of Real64.real
        | String of string
+       | Char of char
 
 open Print.PD
 open Print
@@ -40,6 +41,7 @@ fun p_t t =
         Int n => string (Int64.toString n)
       | Float n => string (Real64.toString n)
       | String s => box [string "\"", string (String.toString s), string "\""]
+      | Char ch => box [string "#\"", string (String.str ch), string "\""]
 
 fun int2s n =
     if Int64.compare (n, Int64.fromInt 0) = LESS then
@@ -64,18 +66,21 @@ fun toString t =
         Int n => int2s' n
       | Float n => float2s n
       | String s => s
+      | Char ch => str ch
 
 fun p_t_GCC t =
     case t of
         Int n => string (int2s n)
       | Float n => string (float2s n)
       | String s => box [string "\"", string (String.toString s), string "\""]
+      | Char ch => box [string "'", string (str ch), string "'"]
 
 fun equal x =
     case x of
         (Int n1, Int n2) => n1 = n2
       | (Float n1, Float n2) => Real64.== (n1, n2)
       | (String s1, String s2) => s1 = s2
+      | (Char ch1, Char ch2) => ch1 = ch2
 
       | _ => false
 
@@ -87,8 +92,12 @@ fun compare (p1, p2) =
 
       | (Float n1, Float n2) => Real64.compare (n1, n2)
       | (Float _, _) => LESS
-      | (_, Float _) => GREATER
+      | (_, Float _) => GREATER 
 
       | (String n1, String n2) => String.compare (n1, n2)
+      | (String _, _) => LESS
+      | (_, String _) => GREATER
+
+      | (Char ch1, Char ch2) => Char.compare (ch1, ch2)
 
 end
diff --git a/src/settings.sml b/src/settings.sml
index 9dc6e414..4b2092d2 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -140,6 +140,7 @@ val jsFuncsBase = basisM [("alert", "alert"),
                           ("strcat", "cat"),
                           ("intToString", "ts"),
                           ("floatToString", "ts"),
+                          ("charToString", "ts"),
                           ("onError", "onError"),
                           ("onFail", "onFail"),
                           ("onConnectFail", "onConnectFail"),
@@ -149,7 +150,9 @@ val jsFuncsBase = basisM [("alert", "alert"),
                           ("attrifyInt", "ts"),
                           ("attrifyFloat", "ts"),
                           ("attrifyBool", "bs"),
-                          ("boolToString", "ts")]
+                          ("boolToString", "ts"),
+                          ("strsub", "sub"),
+                          ("strsuffix", "suf")]
 val jsFuncs = ref jsFuncsBase
 fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
 fun jsFunc x = M.find (!jsFuncs, x)
diff --git a/src/urweb.grm b/src/urweb.grm
index bd834b47..bfb230a6 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -183,7 +183,7 @@ datatype attr = Class of exp | Normal of con * exp
 
 %term 
    EOF
- | STRING of string | INT of Int64.int | FLOAT of Real64.real
+ | STRING of string | INT of Int64.int | FLOAT of Real64.real | CHAR of char
  | SYMBOL of string | CSYMBOL of string
  | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
  | EQ | COMMA | COLON | DCOLON | TCOLON | DOT | HASH | UNDER | UNDERUNDER | BAR
@@ -1080,6 +1080,7 @@ eterm  : LPAREN eexp RPAREN             (#1 eexp, s (LPARENleft, RPARENright))
        | INT                            (EPrim (Prim.Int INT), s (INTleft, INTright))
        | FLOAT                          (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
        | STRING                         (EPrim (Prim.String STRING), s (STRINGleft, STRINGright))
+       | CHAR                           (EPrim (Prim.Char CHAR), s (CHARleft, CHARright))
 
        | path DOT idents                (let
                                              val loc = s (pathleft, identsright)
@@ -1228,6 +1229,7 @@ pterm  : SYMBOL                         (PVar SYMBOL, s (SYMBOLleft, SYMBOLright
        | UNDER                          (PWild, s (UNDERleft, UNDERright))
        | INT                            (PPrim (Prim.Int INT), s (INTleft, INTright))
        | STRING                         (PPrim (Prim.String STRING), s (STRINGleft, STRINGright))
+       | CHAR                           (PPrim (Prim.Char CHAR), s (CHARleft, CHARright))
        | LPAREN pat RPAREN              (pat)
        | LBRACE RBRACE                  (PRecord ([], false), s (LBRACEleft, RBRACEright))
        | UNIT                           (PRecord ([], false), s (UNITleft, UNITright))
diff --git a/src/urweb.lex b/src/urweb.lex
index 46835fa2..b2f715d5 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -160,7 +160,7 @@ fun unescape loc s =
 %%
 %header (functor UrwebLexFn(structure Tokens : Urweb_TOKENS));
 %full
-%s COMMENT STRING XML XMLTAG;
+%s COMMENT STRING CHAR XML XMLTAG;
 
 id = [a-z_][A-Za-z0-9_']*;
 cid = [A-Z][A-Za-z0-9_]*;
@@ -193,6 +193,31 @@ notags = [^<{\n]+;
 <COMMENT> "*)"        => (if exitComment () then YYBEGIN INITIAL else ();
 			  continue ());
 
+<INITIAL> "#\""       => (YYBEGIN CHAR; strEnder := #"\""; strStart := pos yypos; str := []; continue());
+<CHAR> "\\\""         => (str := #"\"" :: !str; continue());
+<CHAR> "\\'"          => (str := #"'" :: !str; continue());
+<CHAR> "\n"           => (newline yypos;
+			  str := #"\n" :: !str; continue());
+<CHAR> .              => (let
+                              val ch = String.sub (yytext, 0)
+                          in
+                              if ch = !strEnder then
+                                  let
+                                      val s = String.implode (List.rev (!str))
+                                  in
+			              YYBEGIN INITIAL;
+                                      if size s = 1 then
+			                  Tokens.CHAR (String.sub (s, 0), !strStart, pos yypos + 1)
+                                      else
+                                          (ErrorMsg.errorAt' (yypos, yypos)
+                                                             "Character constant is zero or multiple characters";
+                                           continue ())
+                                  end
+                              else
+                                  (str := ch :: !str;
+                                   continue ())
+                          end);
+
 <INITIAL> "\""        => (YYBEGIN STRING; strEnder := #"\""; strStart := pos yypos; str := []; continue());
 <INITIAL> "'"         => (YYBEGIN STRING; strEnder := #"'"; strStart := pos yypos; str := []; continue());
 <STRING> "\\\""       => (str := #"\"" :: !str; continue());
diff --git a/tests/char.ur b/tests/char.ur
new file mode 100644
index 00000000..08621eba
--- /dev/null
+++ b/tests/char.ur
@@ -0,0 +1,4 @@
+fun main () =
+  case #"A" of
+      #"B" => return <xml/>
+    | _ => return <xml>A!</xml>
diff --git a/tests/char.urp b/tests/char.urp
new file mode 100644
index 00000000..840c4478
--- /dev/null
+++ b/tests/char.urp
@@ -0,0 +1,3 @@
+debug
+
+char
diff --git a/tests/char.urs b/tests/char.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/char.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page
-- 
cgit v1.2.3


From a144d74a7fb416108f643daaa3a734e416683737 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Tue, 2 Jun 2009 19:28:25 -0400
Subject: Lexing some more string escape sequences; JS versions of number read;
 fix problem with signature unification; escape < more often in Jscomp

---
 lib/js/urweb.js   | 16 ++++++++++++++
 src/elaborate.sml | 66 +++++++++++++++++++++++++++++++++++++++----------------
 src/jscomp.sml    |  4 ++--
 src/settings.sml  |  2 ++
 src/urweb.grm     |  5 -----
 src/urweb.lex     | 17 +++++++-------
 6 files changed, 76 insertions(+), 34 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index 581ee4d7..6c974948 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -397,6 +397,22 @@ function pfl(s) {
     er("Can't parse float: " + s);
 }
 
+function pio(s) {
+  var r = parseInt(s);
+  if (r.toString() == s)
+    return r;
+  else
+    return null;
+}
+
+function pflo(s) {
+  var r = parseFloat(s);
+  if (r.toString() == s)
+    return r;
+  else
+    return null;
+}
+
 function uf(s) {
   return escape(s).replace(new RegExp ("/", "g"), "%2F");
 }
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 64b690ef..d60f19f7 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -158,7 +158,7 @@
                      "U" ^ Int.toString (n - 26)
      in
          count := n + 1;
-         (L'.KUnif (loc, s, ref NONE), dummy)
+         (L'.KUnif (loc, s, ref NONE), loc)
      end
 
  end
@@ -178,7 +178,7 @@
                      "U" ^ Int.toString (n - 26)
      in
          count := n + 1;
-         (L'.CUnif (loc, k, s, ref NONE), dummy)
+         (L'.CUnif (loc, k, s, ref NONE), loc)
      end
 
  end
@@ -776,7 +776,7 @@
                | orig as ([(_, r1 as ref NONE)], _, [], [(_, r2 as ref NONE)], _, []) =>
                  if List.all (fn (x1, _) => List.all (fn (x2, _) => consNeq env (x1, x2)) fs2) fs1 then
                      let
-                         val kr = (L'.KRecord k, dummy)
+                         val kr = (L'.KRecord k, loc)
                          val u = cunif (loc, kr)
                      in
                          r1 := SOME (L'.CConcat ((L'.CRecord (k, fs2), loc), u), loc);
@@ -817,7 +817,7 @@
          (*val () = eprefaces "Summaries5" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}),
                                           ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*)
 
-         val empty = (L'.CRecord (k, []), dummy)
+         val empty = (L'.CRecord (k, []), loc)
          fun failure () = raise CUnify' (CRecordFailure (unsummarize s1, unsummarize s2))
      in
          (case (unifs1, fs1, others1, unifs2, fs2, others2) of
@@ -1652,7 +1652,7 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
 
                 val dom = cunif (loc, ktype)
                 val ran = cunif (loc, ktype)
-                val t = (L'.TFun (dom, ran), dummy)
+                val t = (L'.TFun (dom, ran), loc)
             in
                 checkCon env e1' t1 t;
                 checkCon env e2' t2 dom;
@@ -2507,7 +2507,7 @@ and sgiOfDecl (d, loc) =
       | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)]
       | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)]
 
-and subSgn env sgn1 (sgn2 as (_, loc2)) =
+and subSgn' counterparts env sgn1 (sgn2 as (_, loc2)) =
     ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1),
                         ("sgn2", p_sgn env sgn2)];*)
     case (#1 (hnormSgn env sgn1), #1 (hnormSgn env sgn2)) of
@@ -2521,6 +2521,18 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) =
                                         ("sgis1", p_sgn env (L'.SgnConst sgis1, loc2)),
                                         ("sgis2", p_sgn env (L'.SgnConst sgis2, loc2))]*)
 
+            fun cpart n = IM.find (!counterparts, n)
+            fun cparts (n2, n1) = counterparts := IM.insert (!counterparts, n2, n1)
+
+            val sub2 = U.Con.map {kind = fn k => k,
+                                  con = fn c =>
+                                           case c of
+                                               L'.CNamed n2 =>
+                                               (case cpart n2 of
+                                                    NONE => c
+                                                  | SOME n1 => L'.CNamed n1)
+                                             | _ => c}
+
             fun folder (sgi2All as (sgi, loc), env) =
                 let
                     (*val () = prefaces "folder" [("sgis1", p_sgn env (L'.SgnConst sgis1, loc2))]*)
@@ -2572,7 +2584,8 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) =
                                                  SOME (if n1 = n2 then
                                                            env
                                                        else
-                                                           E.pushCNamedAs env x n2 k2 (SOME (L'.CNamed n1, loc2)))
+                                                           (cparts (n2, n1);
+                                                            E.pushCNamedAs env x n2 k2 (SOME (L'.CNamed n1, loc2))))
                                              end
                                          else
                                              NONE
@@ -2616,6 +2629,8 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) =
                                      fun found (x', n1, k1, c1) =
                                          if x = x' then
                                              let
+                                                 val c2 = sub2 c2
+
                                                  fun good () =
                                                      let
                                                          val env = E.pushCNamedAs env x n2 k2 (SOME c2)
@@ -2662,8 +2677,9 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) =
                                                 val env = if n1 = n2 then
                                                               env
                                                           else
-                                                              E.pushCNamedAs env x1 n2 k'
-                                                                             (SOME (L'.CNamed n1, loc))
+                                                              (cparts (n2, n1);
+                                                               E.pushCNamedAs env x1 n2 k'
+                                                                              (SOME (L'.CNamed n1, loc)))
                                             in
                                                 SOME env
                                             end
@@ -2672,14 +2688,15 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) =
                                         val env = if n1 = n2 then
                                                       env
                                                   else
-                                                      E.pushCNamedAs env x1 n2 k' (SOME (L'.CNamed n1, loc))
+                                                      (cparts (n2, n1);
+                                                       E.pushCNamedAs env x1 n2 k' (SOME (L'.CNamed n1, loc)))
                                         val env = foldl (fn (x, env) => E.pushCRel env x k) env xs1
                                         fun xncBad ((x1, _, t1), (x2, _, t2)) =
                                             String.compare (x1, x2) <> EQUAL
                                             orelse case (t1, t2) of
                                                        (NONE, NONE) => false
                                                      | (SOME t1, SOME t2) =>
-                                                       (unifyCons env t1 t2; false)
+                                                       (unifyCons env t1 (sub2 t2); false)
                                                      | _ => true
                                     in
                                         (if xs1 <> xs2
@@ -2746,6 +2763,7 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) =
                                                      val env = E.pushCNamedAs env x n1 k' (SOME t1)
                                                      val env = E.pushCNamedAs env x n2 k' (SOME t2)
                                                  in
+                                                     cparts (n2, n1);
                                                      SOME env
                                                  end
                                          in
@@ -2765,7 +2783,12 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) =
                                  case sgi1 of
                                      L'.SgiVal (x', n1, c1) =>
                                      if x = x' then
-                                         (unifyCons env c1 c2;
+                                         ((*prefaces "val" [("x", PD.string x),
+                                                          ("n1", PD.string (Int.toString n1)),
+                                                          ("c1", p_con env c1),
+                                                          ("c2", p_con env c2),
+                                                          ("c2'", p_con env (sub2 c2))];*)
+                                          unifyCons env c1 (sub2 c2);
                                           SOME env)
                                          handle CUnify (c1, c2, err) =>
                                                 (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err));
@@ -2780,7 +2803,7 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) =
                                      L'.SgiStr (x', n1, sgn1) =>
                                      if x = x' then
                                          let
-                                             val () = subSgn env sgn1 sgn2
+                                             val () = subSgn' counterparts env sgn1 sgn2
                                              val env = E.pushStrNamedAs env x n1 sgn1
                                              val env = if n1 = n2 then
                                                            env
@@ -2801,14 +2824,15 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) =
                                      L'.SgiSgn (x', n1, sgn1) =>
                                      if x = x' then
                                          let
-                                             val () = subSgn env sgn1 sgn2
-                                             val () = subSgn env sgn2 sgn1
+                                             val () = subSgn' counterparts env sgn1 sgn2
+                                             val () = subSgn' counterparts env sgn2 sgn1
 
                                              val env = E.pushSgnNamedAs env x n2 sgn2
                                              val env = if n1 = n2 then
                                                            env
                                                        else
-                                                           E.pushSgnNamedAs env x n1 sgn2
+                                                           (cparts (n2, n1);
+                                                            E.pushSgnNamedAs env x n1 sgn2)
                                          in
                                              SOME env
                                          end
@@ -2841,7 +2865,8 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) =
                                                  SOME (if n1 = n2 then
                                                            env
                                                        else
-                                                           E.pushCNamedAs env x n2 k1 (SOME (L'.CNamed n1, loc2)))
+                                                           (cparts (n2, n1);
+                                                            E.pushCNamedAs env x n2 k1 (SOME (L'.CNamed n1, loc2))))
                                              end
                                          else
                                              NONE
@@ -2861,6 +2886,8 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) =
                                                      handle KUnify (k1, k2, err) =>
                                                             sgnError env (SgiWrongKind (sgi1All, k1, sgi2All, k2, err))
 
+                                                 val c2 = sub2 c2
+
                                                  fun good () =
                                                      let
                                                          val env = E.pushCNamedAs env x n2 k2 (SOME c2)
@@ -2898,12 +2925,13 @@ and subSgn env sgn1 (sgn2 as (_, loc2)) =
                 else
                     subStrInSgn (n2, n1) ran2
         in
-            subSgn env dom2 dom1;
-            subSgn (E.pushStrNamedAs env m1 n1 dom2) ran1 ran2
+            subSgn' counterparts env dom2 dom1;
+            subSgn' counterparts (E.pushStrNamedAs env m1 n1 dom2) ran1 ran2
         end
 
       | _ => sgnError env (SgnWrongForm (sgn1, sgn2)))
 
+and subSgn env = subSgn' (ref IM.empty) env
 
 and positive self =
     let
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 91ac0acb..0178888a 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -523,9 +523,9 @@ fun process file =
                                                                 "'"
                                                           | #"\"" => "\\\""
                                                           | #"<" =>
-                                                            if mode = Script then
+                                                            (*if mode = Script then
                                                                 "<"
-                                                            else
+                                                            else*)
                                                                 "\\074"
                                                           | #"\\" => "\\\\"
                                                           | #"\n" => "\\n"
diff --git a/src/settings.sml b/src/settings.sml
index a71ab872..e5b42abc 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -131,6 +131,8 @@ val jsFuncsBase = basisM [("alert", "alert"),
                           ("htmlifyString", "eh"),
                           ("new_client_source", "sc"),
                           ("set_client_source", "sv"),
+                          ("stringToFloat", "pflo"),
+                          ("stringToInt", "pio"),
                           ("stringToFloat_error", "pfl"),
                           ("stringToInt_error", "pi"),
                           ("urlifyInt", "ts"),
diff --git a/src/urweb.grm b/src/urweb.grm
index 1bb5da58..0232a3f3 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -959,11 +959,6 @@ eexp   : eapps                          (eapps)
                                          end)
 
 bind   : SYMBOL LARROW eapps            (SYMBOL, NONE, eapps)
-       | UNIT LARROW eapps              (let
-                                             val loc = s (UNITleft, eappsright)
-                                         in
-                                             ("_", SOME (TRecord (CRecord [], loc), loc), eapps)
-                                         end)
        | eapps                          (let
                                              val loc = s (eappsleft, eappsright)
                                          in
diff --git a/src/urweb.lex b/src/urweb.lex
index b2f715d5..c23dfe62 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -193,11 +193,15 @@ notags = [^<{\n]+;
 <COMMENT> "*)"        => (if exitComment () then YYBEGIN INITIAL else ();
 			  continue ());
 
-<INITIAL> "#\""       => (YYBEGIN CHAR; strEnder := #"\""; strStart := pos yypos; str := []; continue());
-<CHAR> "\\\""         => (str := #"\"" :: !str; continue());
-<CHAR> "\\'"          => (str := #"'" :: !str; continue());
-<CHAR> "\n"           => (newline yypos;
+<STRING,CHAR> "\\\""  => (str := #"\"" :: !str; continue());
+<STRING,CHAR> "\\'"   => (str := #"'" :: !str; continue());
+<STRING,CHAR> "\\n"   => (str := #"\n" :: !str; continue());
+<STRING,CHAR> "\\t"   => (str := #"\t" :: !str; continue());
+<STRING,CHAR> "\n"    => (newline yypos;
 			  str := #"\n" :: !str; continue());
+
+<INITIAL> "#\""       => (YYBEGIN CHAR; strEnder := #"\""; strStart := pos yypos; str := []; continue());
+
 <CHAR> .              => (let
                               val ch = String.sub (yytext, 0)
                           in
@@ -220,10 +224,7 @@ notags = [^<{\n]+;
 
 <INITIAL> "\""        => (YYBEGIN STRING; strEnder := #"\""; strStart := pos yypos; str := []; continue());
 <INITIAL> "'"         => (YYBEGIN STRING; strEnder := #"'"; strStart := pos yypos; str := []; continue());
-<STRING> "\\\""       => (str := #"\"" :: !str; continue());
-<STRING> "\\'"        => (str := #"'" :: !str; continue());
-<STRING> "\n"         => (newline yypos;
-			  str := #"\n" :: !str; continue());
+
 <STRING> .            => (let
                               val ch = String.sub (yytext, 0)
                           in
-- 
cgit v1.2.3


From 2b3788462fada38dab4a72d036aff5e66b8d9240 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sun, 7 Jun 2009 12:01:55 -0400
Subject: && and ||

---
 src/urweb.grm | 21 ++++++++++++++++++++-
 src/urweb.lex |  4 ++++
 2 files changed, 24 insertions(+), 1 deletion(-)

(limited to 'src/urweb.lex')

diff --git a/src/urweb.grm b/src/urweb.grm
index 0232a3f3..5a2da601 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -202,7 +202,7 @@ fun patType loc (p : pat) =
  | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL
  | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW
  | COOKIE | STYLE
- | CASE | IF | THEN | ELSE
+ | CASE | IF | THEN | ELSE | ANDALSO | ORELSE
 
  | XML_BEGIN of string | XML_END | XML_BEGIN_END of string
  | NOTAGS of string 
@@ -365,6 +365,8 @@ fun patType loc (p : pat) =
 %right SEMI
 %nonassoc LARROW
 %nonassoc IF THEN ELSE
+%left ANDALSO
+%left ORELSE
 %nonassoc DARROW
 %nonassoc COLON
 %nonassoc DCOLON TCOLON
@@ -944,6 +946,23 @@ eexp   : eapps                          (eapps)
        | eexp GT eexp                   (native_op ("gt", eexp1, eexp2, s (eexp1left, eexp2right)))
        | eexp GE eexp                   (native_op ("ge", eexp1, eexp2, s (eexp1left, eexp2right)))
 
+       | eexp ANDALSO eexp              (let
+                                             val loc = s (eexp1left, eexp2right)
+                                         in
+                                             (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc),
+                                                              eexp2),
+                                                             ((PCon (["Basis"], "False", NONE), loc),
+                                                              (EVar (["Basis"], "False", Infer), loc))]), loc)
+                                         end)
+       | eexp ORELSE eexp               (let
+                                             val loc = s (eexp1left, eexp2right)
+                                         in
+                                             (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc),
+                                                              (EVar (["Basis"], "True", Infer), loc)),
+                                                             ((PCon (["Basis"], "False", NONE), loc),
+                                                              eexp2)]), loc)
+                                         end)
+
        | eexp PLUSPLUS eexp             (EConcat (eexp1, eexp2), s (eexp1left, eexp2right))
 
        | eexp CARET eexp                (native_op ("strcat", eexp1, eexp2, s (eexp1left, eexp2right)))
diff --git a/src/urweb.lex b/src/urweb.lex
index c23dfe62..38816a3c 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -333,6 +333,9 @@ notags = [^<{\n]+;
 <INITIAL> "---"       => (Tokens.MINUSMINUSMINUS (pos yypos, pos yypos + size yytext));
 <INITIAL> "^"         => (Tokens.CARET (pos yypos, pos yypos + size yytext));
 
+<INITIAL> "&&"        => (Tokens.ANDALSO (pos yypos, pos yypos + size yytext));
+<INITIAL> "||"        => (Tokens.ORELSE (pos yypos, pos yypos + size yytext));
+
 <INITIAL> "="         => (Tokens.EQ (pos yypos, pos yypos + size yytext));
 <INITIAL> "<>"        => (Tokens.NE (pos yypos, pos yypos + size yytext));
 <INITIAL> "<"         => (Tokens.LT (pos yypos, pos yypos + size yytext));
@@ -377,6 +380,7 @@ notags = [^<{\n]+;
 <INITIAL> "then"      => (Tokens.THEN (pos yypos, pos yypos + size yytext));
 <INITIAL> "else"      => (Tokens.ELSE (pos yypos, pos yypos + size yytext));
 
+
 <INITIAL> "structure" => (Tokens.STRUCTURE (pos yypos, pos yypos + size yytext));
 <INITIAL> "signature" => (Tokens.SIGNATURE (pos yypos, pos yypos + size yytext));
 <INITIAL> "struct"    => (Tokens.STRUCT (pos yypos, pos yypos + size yytext));
-- 
cgit v1.2.3


From 5765efc372a628ede62d8b27c799708f530a3456 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Tue, 6 Oct 2009 15:39:27 -0400
Subject: SELECT DISTINCT; eta expansion during Cjrization

---
 demo/more/versioned.ur   | 114 +++++++++++++++++++++++++++++++++++++++++++++++
 demo/more/versioned.urp  |   4 ++
 demo/more/versioned.urs  |  19 ++++++++
 demo/more/versioned1.ur  |  62 ++++++++++++++++++++++++++
 demo/more/versioned1.urp |   6 +++
 demo/more/versioned1.urs |   1 +
 lib/ur/basis.urs         |   3 +-
 lib/ur/top.ur            |   6 +++
 lib/ur/top.urs           |   3 ++
 src/cjrize.sml           |  11 +++--
 src/elisp/urweb-mode.el  |   2 +-
 src/mono_env.sig         |   2 +
 src/monoize.sml          |  20 ++++++++-
 src/urweb.grm            |  17 ++++---
 src/urweb.lex            |   1 +
 15 files changed, 260 insertions(+), 11 deletions(-)
 create mode 100644 demo/more/versioned.ur
 create mode 100644 demo/more/versioned.urp
 create mode 100644 demo/more/versioned.urs
 create mode 100644 demo/more/versioned1.ur
 create mode 100644 demo/more/versioned1.urp
 create mode 100644 demo/more/versioned1.urs

(limited to 'src/urweb.lex')

diff --git a/demo/more/versioned.ur b/demo/more/versioned.ur
new file mode 100644
index 00000000..cb93ef6c
--- /dev/null
+++ b/demo/more/versioned.ur
@@ -0,0 +1,114 @@
+functor Make(M : sig
+                 con key :: {Type}
+                 con data :: {Type}
+                 constraint key ~ data
+                 constraint [When] ~ (key ++ data)
+
+                 val key : $(map sql_injectable key)
+                 val data : $(map (fn t => {Inj : sql_injectable_prim t,
+                                            Eq : eq t}) data)
+
+                 val keyFolder : folder key
+                 val dataFolder : folder data
+             end) = struct
+    con all = [When = time] ++ M.key ++ map option M.data
+    table t : all
+
+    val keys = List.mapQuery (SELECT DISTINCT t.{{M.key}} FROM t) (fn r => r.T)
+
+    con dmeta = fn t => {Inj : sql_injectable_prim t,
+                         Eq : eq t}
+
+    fun keyRecd (r : $(M.key ++ M.data)) =
+        map2 [sql_injectable] [id] [sql_exp [] [] []]
+             (fn [t] => @sql_inject)
+             [_] M.keyFolder M.key (r --- M.data)
+
+    fun insert r = dml (Basis.insert t
+                                     ({When = (SQL CURRENT_TIMESTAMP)}
+                                          ++ keyRecd r
+                                          ++ map2 [dmeta] [id]
+                                          [fn t => sql_exp [] [] [] (option t)]
+                                          (fn [t] x v => @sql_inject (@sql_option_prim x.Inj)
+                                                          (Some v))
+                                          [_] M.dataFolder M.data (r --- M.key)))
+
+    fun keyExp (r : $M.key) : sql_exp [T = all] [] [] bool =
+        foldR2 [sql_injectable] [id] [fn before => after :: {Type} -> [before ~ after]
+                                         => sql_exp [T = before ++ after] [] [] bool]
+               (fn [nm :: Name] [t :: Type] [before :: {Type}] [[nm] ~ before]
+                                (inj : sql_injectable t) (v : t)
+                   (e : after :: {Type} -> [before ~ after]
+                    => sql_exp [T = before ++ after] [] [] bool)
+                   [after :: {Type}] [[nm = t] ++ before ~ after] =>
+                   (SQL t.{nm} = {[v]} AND {e [[nm = t] ++ after] !}))
+               (fn [after :: {Type}] [[] ~ after] => (SQL TRUE))
+               [_] M.keyFolder M.key r
+               [_] !
+
+    fun current k =
+        let
+            fun current' timeOpt r =
+                let
+                    val complete = foldR [option] [fn ts => option $ts]
+                                   (fn [nm :: Name] [v :: Type] [r :: {Type}] [[nm] ~ r]
+                                                    v r =>
+                                       case (v, r) of
+                                           (Some v, Some r) => Some ({nm = v} ++ r)
+                                         | _ => None)
+                                   (Some {}) [_] M.dataFolder r
+                in
+                    case complete of
+                        Some r => return (Some r)
+                      | None =>
+                        let
+                            val filter = case timeOpt of
+                                             None => (WHERE TRUE)
+                                           | Some time => (WHERE t.When < {[time]})
+                        in
+                            ro <- oneOrNoRows (SELECT t.When, t.{{map option M.data}}
+                                               FROM t
+                                               WHERE {filter}
+                                                 AND {keyExp k}
+                                               ORDER BY t.When DESC
+                                               LIMIT 1);
+                            case ro of
+                                None => return None
+                              | Some r' =>
+                                let
+                                    val r = map2 [option] [option] [option]
+                                            (fn [t ::: Type] old new =>
+                                                case old of
+                                                    None => new
+                                                  | Some _ => old)
+                                            [_] M.dataFolder r (r'.T -- #When)
+                                in
+                                    current' (Some r'.T.When) r
+                                end
+                        end
+                end
+        in
+            current' None (map0 [option] (fn [t :: Type] => None : option t) [_] M.dataFolder)
+        end
+
+    fun update r =
+        cur <- current (r --- M.data);
+        case cur of
+            None => error <xml>Tried to update nonexistent key</xml>
+          | Some cur =>
+            let
+                val r' = map3 [dmeta] [id] [id] [fn t => sql_exp [] [] [] (option t)]
+                              (fn [t] (meta : dmeta t) old new =>
+                                  @sql_inject (@sql_option_prim meta.Inj)
+                                   (if @@eq [_] meta.Eq old new then
+                                        None
+                                    else
+                                        Some new))
+                              [_] M.dataFolder M.data cur (r --- M.key)
+                val r' = {When = (SQL CURRENT_TIMESTAMP)}
+                             ++ keyRecd r
+                             ++ r'
+            in
+                dml (Basis.insert t r')
+            end
+end
diff --git a/demo/more/versioned.urp b/demo/more/versioned.urp
new file mode 100644
index 00000000..a75d6c6a
--- /dev/null
+++ b/demo/more/versioned.urp
@@ -0,0 +1,4 @@
+
+$/option
+$/list
+versioned
diff --git a/demo/more/versioned.urs b/demo/more/versioned.urs
new file mode 100644
index 00000000..eb0a485e
--- /dev/null
+++ b/demo/more/versioned.urs
@@ -0,0 +1,19 @@
+functor Make(M : sig
+                 con key :: {Type}
+                 con data :: {Type}
+                 constraint key ~ data
+                 constraint [When] ~ (key ++ data)
+
+                 val key : $(map sql_injectable key)
+                 val data : $(map (fn t => {Inj : sql_injectable_prim t,
+                                            Eq : eq t}) data)
+
+                 val keyFolder : folder key
+                 val dataFolder : folder data
+             end) : sig
+    val insert : $(M.key ++ M.data) -> transaction unit
+    val update : $(M.key ++ M.data) -> transaction unit
+
+    val keys : transaction (list $M.key)
+    val current : $M.key -> transaction (option $M.data)
+end
diff --git a/demo/more/versioned1.ur b/demo/more/versioned1.ur
new file mode 100644
index 00000000..506d2778
--- /dev/null
+++ b/demo/more/versioned1.ur
@@ -0,0 +1,62 @@
+open Versioned.Make(struct
+                        con key = [Id = int]
+                        con data = [Nam = string, ShoeSize = int]
+
+                        val key = {Id = _}
+                        val data = {Nam = {Inj = _,
+                                           Eq = _},
+                                    ShoeSize = {Inj = _,
+                                                Eq = _}}
+                    end)
+
+fun expandKey k =
+    name <- source "";
+    shoeSize <- source "";
+    return {Key = k, Nam = name, ShoeSize = shoeSize}
+
+fun main () =
+    ks0 <- keys;
+    ks0 <- List.mapM (fn r => expandKey r.Id) ks0;
+    ks <- source ks0;
+
+    id <- source "";
+    name <- source "";
+    shoeSize <- source "";
+
+    return <xml><body>
+      <dyn signal={ks <- signal ks;
+                   return (List.mapX (fn kr => <xml><div>
+                     {[kr.Key]}:
+                     <ctextbox source={kr.Nam}/>
+                     <ctextbox size={5} source={kr.ShoeSize}/>
+                     <button value="Latest" onclick={ro <- rpc (current {Id = kr.Key});
+                                                     case ro of
+                                                         None => alert "Can't get it!"
+                                                       | Some r =>
+                                                         set kr.Nam r.Nam;
+                                                         set kr.ShoeSize (show r.ShoeSize)}/>
+                     <button value="Update" onclick={name <- get kr.Nam;
+                                                     shoeSize <- get kr.ShoeSize;
+                                                     rpc (update {Id = kr.Key,
+                                                                  Nam = name,
+                                                                  ShoeSize = readError shoeSize})
+                                                    }/>
+                   </div></xml>) ks)}/>
+
+      <h2>Add one:</h2>
+
+      <table>
+        <tr><th>Id:</th> <td><ctextbox size={5} source={id}/></td></tr>
+        <tr><th>Name:</th> <td><ctextbox source={name}/></td></tr>
+        <tr><th>Shoe size:</th> <td><ctextbox size={5} source={shoeSize}/></td></tr>
+        <tr><th><button value="Add" onclick={id <- get id;
+                                             name <- get name;
+                                             shoeSize <- get shoeSize;
+                                             rpc (insert {Id = readError id, Nam = name,
+                                                          ShoeSize = readError shoeSize});
+
+                                             cur <- get ks;
+                                             kr <- expandKey (readError id);
+                                             set ks (kr :: cur)}/></th></tr>
+      </table>
+    </body></xml>
diff --git a/demo/more/versioned1.urp b/demo/more/versioned1.urp
new file mode 100644
index 00000000..c24b3531
--- /dev/null
+++ b/demo/more/versioned1.urp
@@ -0,0 +1,6 @@
+debug
+library versioned
+database dbname=test
+sql versioned1.sql
+
+versioned1
diff --git a/demo/more/versioned1.urs b/demo/more/versioned1.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/demo/more/versioned1.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index b7468d2f..9ddae8fe 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -291,7 +291,8 @@ val sql_query1 : tables ::: {{Type}}
                  -> grouped ::: {{Type}}
                  -> selectedFields ::: {{Type}}
                  -> selectedExps ::: {Type}
-                 -> {From : sql_from_items tables,
+                 -> {Distinct : bool,
+                     From : sql_from_items tables,
                      Where : sql_exp tables [] [] bool,
                      GroupBy : sql_subset tables grouped,
                      Having : sql_exp grouped tables [] bool,
diff --git a/lib/ur/top.ur b/lib/ur/top.ur
index 67e75573..a2395d4f 100644
--- a/lib/ur/top.ur
+++ b/lib/ur/top.ur
@@ -92,6 +92,12 @@ fun read_option [t ::: Type] (_ : read t) =
 fun txt [t] [ctx ::: {Unit}] [use ::: {Type}] (_ : show t) (v : t) =
     cdata (show v)
 
+fun map0 [K] [tf :: K -> Type] (f : t :: K -> tf t) [r :: {K}] (fl : folder r) =
+    fl [fn r :: {K} => $(map tf r)]
+    (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] acc =>
+        acc ++ {nm = f [t]})
+    {}
+
 fun mp [K] [tf1 :: K -> Type] [tf2 :: K -> Type] (f : t ::: K -> tf1 t -> tf2 t) [r :: {K}] (fl : folder r) =
     fl [fn r :: {K} => $(map tf1 r) -> $(map tf2 r)]
     (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] acc r =>
diff --git a/lib/ur/top.urs b/lib/ur/top.urs
index 637c4e5d..ef907760 100644
--- a/lib/ur/top.urs
+++ b/lib/ur/top.urs
@@ -45,6 +45,9 @@ val read_option : t ::: Type -> read t -> read (option t)
 val txt : t ::: Type -> ctx ::: {Unit} -> use ::: {Type} -> show t -> t
           -> xml ctx use []
 
+val map0 : K --> tf :: (K -> Type)
+           -> (t :: K -> tf t)
+           -> r :: {K} -> folder r -> $(map tf r)
 val mp : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type)
          -> (t ::: K -> tf1 t -> tf2 t)
          -> r :: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r)
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 6a79b4e6..bf814266 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -520,9 +520,14 @@ fun cifyDecl ((d, loc), sm) =
                                           in
                                               ((ax, dom) :: args, t, e)
                                           end
-                                        | (L'.TFun _, _) =>
-                                          (ErrorMsg.errorAt loc "Function isn't explicit at code generation";
-                                           ([], tAll, eAll))
+                                        | (L'.TFun (dom, ran), _) =>
+                                          let
+                                              val e = MonoEnv.liftExpInExp 0 eAll
+                                              val e = (L.EApp (e, (L.ERel 0, loc)), loc)
+                                              val (args, t, e) = unravel (ran, e)
+                                          in
+                                              (("x", dom) :: args, t, e)
+                                          end
                                         | _ => ([], tAll, eAll)
 
                                   val (args, ran, e) = unravel (t, e)
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index 7f4b0dee..42846e6c 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -144,7 +144,7 @@ See doc for the variable `urweb-mode-info'."
   "A regexp that matches any non-SQL keywords of Ur/Web.")
 
 (defconst urweb-sql-keywords-regexp
-  (urweb-syms-re "SELECT" "FROM" "AS" "WHERE" "SQL" "GROUP" "ORDER" "BY"
+  (urweb-syms-re "SELECT" "DISTINCT" "FROM" "AS" "WHERE" "SQL" "GROUP" "ORDER" "BY"
                  "HAVING" "LIMIT" "OFFSET" "ALL" "UNION" "INTERSECT" "EXCEPT"
                  "TRUE" "FALSE" "AND" "OR" "NOT" "COUNT" "AVG" "SUM" "MIN" "MAX"
                  "ASC" "DESC" "INSERT" "INTO" "VALUES" "UPDATE" "SET" "DELETE"
diff --git a/src/mono_env.sig b/src/mono_env.sig
index c59596ae..c5ca7c0b 100644
--- a/src/mono_env.sig
+++ b/src/mono_env.sig
@@ -48,5 +48,7 @@ signature MONO_ENV = sig
     val declBinds : env -> Mono.decl -> env
     val patBinds : env -> Mono.pat -> env
     val patBindsN : Mono.pat -> int
+
+    val liftExpInExp : int -> Mono.exp -> Mono.exp
                                                  
 end
diff --git a/src/monoize.sml b/src/monoize.sml
index b80b4a65..a01f953f 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1771,6 +1771,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             let
                 fun sc s = (L'.EPrim (Prim.String s), loc)
                 val s = (L'.TFfi ("Basis", "string"), loc)
+                val b = (L'.TFfi ("Basis", "bool"), loc)
                 val un = (L'.TRecord [], loc)
                 fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
 
@@ -1806,7 +1807,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                         (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) sexps
                     in
                         ((L'.EAbs ("r",
-                                   (L'.TRecord [("From", s),
+                                   (L'.TRecord [("Distinct", b),
+                                                ("From", s),
                                                 ("Where", s),
                                                 ("GroupBy", un),
                                                 ("Having", s),
@@ -1815,6 +1817,22 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                     loc),
                                    s,
                                    strcat [sc "SELECT ",
+                                           (L'.ECase (gf "Distinct",
+                                                      [((L'.PCon (L'.Enum,
+                                                                  L'.PConFfi {mod = "Basis",
+                                                                              datatyp = "bool",
+                                                                              con = "True",
+                                                                              arg = NONE},
+                                                                  NONE), loc),
+                                                        (L'.EPrim (Prim.String "DISTINCT "), loc)),
+                                                       ((L'.PCon (L'.Enum,
+                                                                  L'.PConFfi {mod = "Basis",
+                                                                              datatyp = "bool",
+                                                                              con = "False",
+                                                                              arg = NONE},
+                                                                  NONE), loc),
+                                                        (L'.EPrim (Prim.String ""), loc))],
+                                                      {disc = b, result = s}), loc),
                                            strcatComma (map (fn (x, t) =>
                                                                 strcat [
                                                                 (L'.EField (gf "SelectExps", x), loc),
diff --git a/src/urweb.grm b/src/urweb.grm
index 111b1854..edd93d96 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -208,7 +208,7 @@ fun patType loc (p : pat) =
  | NOTAGS of string 
  | BEGIN_TAG of string | END_TAG of string
 
- | SELECT | FROM | AS | CWHERE | GROUP | ORDER | BY | HAVING
+ | SELECT | DISTINCT | FROM | AS | CWHERE | GROUP | ORDER | BY | HAVING
  | UNION | INTERSECT | EXCEPT
  | LIMIT | OFFSET | ALL
  | TRUE | FALSE | CAND | OR | NOT
@@ -314,6 +314,7 @@ fun patType loc (p : pat) =
 
  | query of exp
  | query1 of exp
+ | dopt of exp
  | tables of con list * exp
  | fitem of con list * exp
  | tname of con
@@ -625,7 +626,7 @@ pmodes :                                ([])
 commaOpt:                               ()
         | COMMA                         ()
 
-pkopt  :                                (EVar (["Basis"], "no_primary_key", Infer), ErrorMsg.dummySpan)
+pkopt  :                                (EVar (["Basis"], "no_primary_key", Infer), dummy)
        | PRIMARY KEY tnames             (let
                                              val loc = s (PRIMARYleft, tnamesright)
 
@@ -1410,8 +1411,12 @@ query  : query1 obopt lopt ofopt        (let
                                          in
                                              (EApp ((EVar (["Basis"], "sql_query", Infer), loc), re), loc)
                                          end)
-                
-query1 : SELECT select FROM tables wopt gopt hopt
+
+dopt   :                                (EVar (["Basis"], "False", Infer), dummy)
+       | DISTINCT                       (EVar (["Basis"], "True", Infer),
+                                         s (DISTINCTleft, DISTINCTright))
+
+query1 : SELECT dopt select FROM tables wopt gopt hopt
                                         (let
                                              val loc = s (SELECTleft, tablesright)
 
@@ -1460,7 +1465,9 @@ query1 : SELECT select FROM tables wopt gopt hopt
                                                            end
 
                                              val e = (EVar (["Basis"], "sql_query1", Infer), loc)
-                                             val re = (ERecord [((CName "From", loc),
+                                             val re = (ERecord [((CName "Distinct", loc),
+                                                                 dopt),
+                                                                ((CName "From", loc),
                                                                  #2 tables),
                                                                 ((CName "Where", loc),
                                                                  wopt),
diff --git a/src/urweb.lex b/src/urweb.lex
index 38816a3c..4e572009 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -408,6 +408,7 @@ notags = [^<{\n]+;
 <INITIAL> "Unit"      => (Tokens.KUNIT (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "SELECT"    => (Tokens.SELECT (pos yypos, pos yypos + size yytext));
+<INITIAL> "DISTINCT"  => (Tokens.DISTINCT (pos yypos, pos yypos + size yytext));
 <INITIAL> "FROM"      => (Tokens.FROM (pos yypos, pos yypos + size yytext));
 <INITIAL> "AS"        => (Tokens.AS (pos yypos, pos yypos + size yytext));
 <INITIAL> "WHERE"     => (Tokens.CWHERE (pos yypos, pos yypos + size yytext));
-- 
cgit v1.2.3


From 0a168e5f39165bd9e462813866c9a25dc2d6b688 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sat, 12 Dec 2009 14:51:10 -0500
Subject: Fix lexing of string literals in XML; treat EError as impure in
 MonoReduce

---
 src/mono_reduce.sml | 3 ++-
 src/urweb.lex       | 2 +-
 2 files changed, 3 insertions(+), 2 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index a15ce34b..f29117cf 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -56,6 +56,7 @@ fun simpleImpure (tsyms, syms) =
                               | ERecv _ => true
                               | ESleep _ => true
                               | ENamed n => IS.member (syms, n)
+                              | EError _ => true
                               | ERel n =>
                                 let
                                     val (_, t, _) = E.lookupERel env n
@@ -96,7 +97,7 @@ fun impure (e, _) =
 
       | ECase (e, pes, _) => impure e orelse List.exists (fn (_, e) => impure e) pes
 
-      | EError (e, _) => impure e
+      | EError _ => true
       | EReturnBlob {blob = e1, mimeType = e2, ...} => impure e1 orelse impure e2
       | ERedirect (e, _) => impure e
 
diff --git a/src/urweb.lex b/src/urweb.lex
index 4e572009..b6916cb9 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -290,7 +290,7 @@ notags = [^<{\n]+;
                                        ("Expected float, received: " ^ yytext);
                                        continue ()));
 <XMLTAG> "\""         => (YYBEGIN STRING;
-			  xmlString := true;
+			  xmlString := true; strEnder := #"\"";
 			  strStart := yypos; str := []; continue ());
 
 <XMLTAG> "{"          => (YYBEGIN INITIAL;
-- 
cgit v1.2.3


From 46d562fc3d06a5ef8b17e90c7a4dfd0547757294 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sun, 13 Dec 2009 11:28:47 -0500
Subject: Better record summary error messages; more tweaking SQL usability

---
 lib/ur/basis.urs        |  3 +++
 src/elab_err.sig        |  2 +-
 src/elab_err.sml        | 14 ++++++++++----
 src/elaborate.sml       | 19 ++++++++++++++++++-
 src/elisp/urweb-mode.el |  4 ++--
 src/monoize.sml         | 14 ++++++++++++++
 src/urweb.grm           |  4 +++-
 src/urweb.lex           |  1 +
 8 files changed, 52 insertions(+), 9 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 4b53659d..9bba1ee1 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -344,6 +344,9 @@ val sql_relop : tables1 ::: {{Type}}
                 -> sql_query1 tables1 selectedFields selectedExps
                 -> sql_query1 tables2 selectedFields selectedExps
                 -> sql_query1 selectedFields selectedFields selectedExps
+val sql_forget_tables : tables ::: {{Type}} -> selectedFields ::: {{Type}} -> selectedExps ::: {Type}
+                        -> sql_query1 tables selectedFields selectedExps
+                        -> sql_query1 selectedFields selectedFields selectedExps
 
 type sql_direction
 val sql_asc : sql_direction
diff --git a/src/elab_err.sig b/src/elab_err.sig
index 18596d04..f6277488 100644
--- a/src/elab_err.sig
+++ b/src/elab_err.sig
@@ -55,7 +55,7 @@ signature ELAB_ERR = sig
            | CIncompatible of Elab.con * Elab.con
            | CExplicitness of Elab.con * Elab.con
            | CKindof of Elab.kind * Elab.con * string
-           | CRecordFailure of Elab.con * Elab.con
+           | CRecordFailure of Elab.con * Elab.con * (Elab.con * Elab.con * Elab.con) option
 
     val cunifyError : ElabEnv.env -> cunify_error -> unit
 
diff --git a/src/elab_err.sml b/src/elab_err.sml
index 6d9bd2e6..80de9497 100644
--- a/src/elab_err.sml
+++ b/src/elab_err.sml
@@ -119,7 +119,7 @@ datatype cunify_error =
        | CIncompatible of con * con
        | CExplicitness of con * con
        | CKindof of kind * con * string
-       | CRecordFailure of con * con
+       | CRecordFailure of con * con * (con * con * con) option
 
 fun cunifyError env err =
     case err of
@@ -144,10 +144,16 @@ fun cunifyError env err =
         eprefaces ("Unexpected kind for kindof calculation (expecting " ^ expected ^ ")")
                   [("Kind", p_kind env k),
                    ("Con", p_con env c)]
-      | CRecordFailure (c1, c2) =>
+      | CRecordFailure (c1, c2, fo) =>
         eprefaces "Can't unify record constructors"
-                  [("Summary 1", p_con env c1),
-                   ("Summary 2", p_con env c2)]
+                  (("Summary 1", p_con env c1)
+                   :: ("Summary 2", p_con env c2)
+                   :: (case fo of
+                           NONE => []
+                         | SOME (nm, t1, t2) =>
+                           [("Field", p_con env nm),
+                            ("Value 1", p_con env t1),
+                            ("Value 2", p_con env t2)]))
 
 datatype exp_error =
        UnboundExp of ErrorMsg.span * string
diff --git a/src/elaborate.sml b/src/elaborate.sml
index eccc4840..71842ec2 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -817,7 +817,24 @@
                                           ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*)
 
          val empty = (L'.CRecord (k, []), loc)
-         fun failure () = raise CUnify' (CRecordFailure (unsummarize s1, unsummarize s2))
+         fun failure () =
+             let
+                 val fs2 = #fields s2
+
+                 fun findPointwise fs1 =
+                     case fs1 of
+                         [] => NONE
+                       | (nm1, c1) :: fs1 =>
+                         case List.find (fn (nm2, _) => consEq env loc (nm1, nm2)) fs2 of
+                             NONE => findPointwise fs1
+                           | SOME (_, c2) =>
+                             if consEq env loc (c1, c2) then
+                                 findPointwise fs1
+                             else
+                                 SOME (nm1, c1, c2)
+             in
+                 raise CUnify' (CRecordFailure (unsummarize s1, unsummarize s2, findPointwise (#fields s1)))
+             end
      in
          (case (unifs1, fs1, others1, unifs2, fs2, others2) of
               (_, [], [], [], [], []) =>
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index 42846e6c..72005af9 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -150,7 +150,7 @@ See doc for the variable `urweb-mode-info'."
                  "ASC" "DESC" "INSERT" "INTO" "VALUES" "UPDATE" "SET" "DELETE"
                  "PRIMARY" "KEY" "CONSTRAINT" "UNIQUE" "CHECK"
                  "FOREIGN" "REFERENCES" "ON" "NO" "ACTION" "CASCADE" "RESTRICT" "NULL"
-                 "JOIN" "INNER" "OUTER" "LEFT" "RIGHT" "FULL" "CROSS")
+                 "JOIN" "INNER" "OUTER" "LEFT" "RIGHT" "FULL" "CROSS" "SELECT1")
   "A regexp that matches SQL keywords.")
 
 (defconst urweb-lident-regexp "\\<[a-z_][A-Za-z0-9_']*\\>"
@@ -530,7 +530,7 @@ If anyone has a good algorithm for this..."
     (current-indentation)))
 
 (defconst urweb-sql-main-starters
-  '("SQL" "SELECT" "INSERT" "UPDATE" "DELETE"))
+  '("SQL" "SELECT" "INSERT" "UPDATE" "DELETE" "FROM" "SELECT1" "WHERE"))
 
 (defconst urweb-sql-starters
   (append urweb-sql-main-starters
diff --git a/src/monoize.sml b/src/monoize.sml
index f3c8b5f6..3998a49f 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2292,6 +2292,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                        sc "))"]), loc)), loc)), loc),
                  fm)
             end
+          | L.ECApp (
+            (L.ECApp (
+             (L.ECApp (
+              (L.EFfi ("Basis", "sql_forget_tables"), _),
+              _), _),
+             _), _),
+            _) =>
+            let
+                val s = (L'.TFfi ("Basis", "string"), loc)
+                fun sc s = (L'.EPrim (Prim.String s), loc)
+            in
+                ((L'.EAbs ("x", s, s, (L'.ERel 0, loc)), loc),
+                 fm)
+            end
 
           | L.EFfi ("Basis", "sql_union") => ((L'.EPrim (Prim.String "UNION"), loc), fm)
           | L.EFfi ("Basis", "sql_intersect") => ((L'.EPrim (Prim.String "INTERSECT"), loc), fm)
diff --git a/src/urweb.grm b/src/urweb.grm
index da40945a..87a8547d 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -199,7 +199,7 @@ fun patType loc (p : pat) =
  | ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW | BANG
  | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE | CARET
  | LET | IN
- | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL
+ | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | SELECT1
  | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW
  | COOKIE | STYLE
  | CASE | IF | THEN | ELSE | ANDALSO | ORELSE
@@ -1170,6 +1170,7 @@ eterm  : LPAREN eexp RPAREN             (#1 eexp, s (LPARENleft, RPARENright))
        | LPAREN CWHERE sqlexp RPAREN    (sqlexp)
        | LPAREN SQL sqlexp RPAREN       (sqlexp)
        | LPAREN FROM tables RPAREN      (#2 tables)
+       | LPAREN SELECT1 query1 RPAREN   (query1)
 
        | LPAREN INSERT INTO texp LPAREN fields RPAREN VALUES LPAREN sqlexps RPAREN RPAREN
                                         (let
@@ -1540,6 +1541,7 @@ tables : fitem                          (fitem)
                                          end)
 
 fitem  : table'                         ([#1 table'], #2 table')
+       | LBRACE LBRACE eexp RBRACE RBRACE ([], eexp)
        | fitem JOIN fitem ON sqlexp     (let
                                              val loc = s (fitem1left, sqlexpright)
                                                        
diff --git a/src/urweb.lex b/src/urweb.lex
index b6916cb9..ed6e310b 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -420,6 +420,7 @@ notags = [^<{\n]+;
 <INITIAL> "LIMIT"     => (Tokens.LIMIT (pos yypos, pos yypos + size yytext));
 <INITIAL> "OFFSET"    => (Tokens.OFFSET (pos yypos, pos yypos + size yytext));
 <INITIAL> "ALL"       => (Tokens.ALL (pos yypos, pos yypos + size yytext));
+<INITIAL> "SELECT1"   => (Tokens.SELECT1 (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "JOIN"      => (Tokens.JOIN (pos yypos, pos yypos + size yytext));
 <INITIAL> "INNER"     => (Tokens.INNER (pos yypos, pos yypos + size yytext));
-- 
cgit v1.2.3


From b225596addee1a3cfd6c3189cff923e7f0e8f7c9 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sun, 13 Dec 2009 14:20:41 -0500
Subject: Initializers and setval

---
 CHANGELOG               |  1 +
 lib/ur/basis.urs        |  1 +
 src/checknest.sml       |  4 ++++
 src/cjr.sml             |  3 +++
 src/cjr_env.sml         |  1 +
 src/cjr_print.sml       | 23 ++++++++++++++++++++++-
 src/cjrize.sml          | 17 +++++++++++++++++
 src/core.sml            |  1 +
 src/core_env.sml        |  1 +
 src/core_print.sml      |  3 +++
 src/core_util.sml       |  8 +++++++-
 src/corify.sml          |  6 +++++-
 src/elab.sml            |  1 +
 src/elab_env.sml        |  1 +
 src/elab_print.sml      |  3 +++
 src/elab_util.sml       |  8 +++++++-
 src/elaborate.sml       | 10 ++++++++++
 src/elisp/urweb-defs.el |  8 +++++---
 src/elisp/urweb-mode.el |  4 ++--
 src/expl.sml            |  1 +
 src/expl_env.sml        |  1 +
 src/expl_print.sml      |  3 +++
 src/explify.sml         |  1 +
 src/jscomp.sml          |  8 ++++++++
 src/mono.sml            |  3 +++
 src/mono_env.sml        |  1 +
 src/mono_print.sml      |  9 +++++++++
 src/mono_reduce.sml     |  3 +++
 src/mono_shake.sml      | 42 +++++++++++++++++++++++++++++++-----------
 src/mono_util.sml       | 14 +++++++++++++-
 src/monoize.sml         | 15 +++++++++++++++
 src/mysql.sml           |  3 +++
 src/postgres.sml        | 43 +++++++++++++++++++++++++++++++++++++++++++
 src/prepare.sml         | 14 ++++++++++++++
 src/reduce.sml          |  9 +++++++++
 src/reduce_local.sml    |  1 +
 src/scriptcheck.sml     |  1 +
 src/settings.sig        |  1 +
 src/settings.sml        |  4 ++++
 src/shake.sml           |  7 +++++--
 src/source.sml          |  1 +
 src/source_print.sml    |  3 +++
 src/sqlite.sml          |  2 ++
 src/unnest.sml          |  1 +
 src/urweb.grm           |  3 ++-
 src/urweb.lex           |  1 +
 tests/init.ur           |  6 ++++++
 tests/init.urp          |  5 +++++
 48 files changed, 286 insertions(+), 24 deletions(-)
 create mode 100644 tests/init.ur
 create mode 100644 tests/init.urp

(limited to 'src/urweb.lex')

diff --git a/CHANGELOG b/CHANGELOG
index 15e92fd5..e1e14aea 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -6,6 +6,7 @@ Next
 - More syntactic sugar for SQL
 - Typing of SQL queries no longer exposes which tables were used in joins but
   had none of their fields projected
+- Module-level initializers
 
 ========
 20091203
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index b9d1f55f..f7e098d4 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -523,6 +523,7 @@ val delete : fields ::: {Type} -> uniques ::: {{Unit}}
 
 type sql_sequence
 val nextval : sql_sequence -> transaction int
+val setval : sql_sequence -> int -> transaction unit
 
 
 (** XML *)
diff --git a/src/checknest.sml b/src/checknest.sml
index 49519705..c0f843d6 100644
--- a/src/checknest.sml
+++ b/src/checknest.sml
@@ -87,6 +87,7 @@ fun expUses globals =
                         SOME {id, ...} => IS.add (s, id)
                       | _ => s
                 end
+              | ESetval {seq, count} => IS.union (eu seq, eu count)
 
               | EUnurlify (e, _) => eu e
     in
@@ -144,6 +145,9 @@ fun annotateExp globals =
               | ENextval {seq, prepared} =>
                 (ENextval {seq = ae seq,
                            prepared = prepared}, loc)
+              | ESetval {seq, count} =>
+                (ESetval {seq = ae seq,
+                          count = ae count}, loc)
 
               | EUnurlify (e, t) => (EUnurlify (ae e, t), loc)
     in
diff --git a/src/cjr.sml b/src/cjr.sml
index 2b8ce6fe..9be54670 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -95,6 +95,7 @@ datatype exp' =
                    prepared : {id : int, dml : string} option }
        | ENextval of { seq : exp,
                        prepared : {id : int, query : string} option }
+       | ESetval of { seq : exp, count : exp }
        | EUnurlify of exp * typ
 
 withtype exp = exp' located
@@ -117,6 +118,8 @@ datatype decl' =
        | DCookie of string
        | DStyle of string
 
+       | DInitializer of exp
+
 withtype decl = decl' located
 
 datatype sidedness =
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index 217efb3a..e4d978d5 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -171,5 +171,6 @@ fun declBinds env (d, loc) =
       | DJavaScript _ => env
       | DCookie _ => env
       | DStyle _ => env
+      | DInitializer _ => env
 
 end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index a1d5ed2c..6a5116ce 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1849,6 +1849,20 @@ fun p_exp' par env (e, loc) =
              newline,
              string "})"]
 
+      | ESetval {seq, count} =>
+        box [string "({",
+             newline,
+
+             #setval (Settings.currentDbms ()) {loc = loc,
+                                                seqE = p_exp env seq,
+                                                count = p_exp env count},
+             newline,
+             newline,
+
+             string "uw_unit_v;",
+             newline,
+             string "})"]
+
       | EUnurlify (e, t) =>
         let
             fun getIt () =
@@ -2085,6 +2099,8 @@ fun p_decl env (dAll as (d, _) : decl) =
                          space,
                          string "*/"]
 
+      | DInitializer _ => box []
+
 datatype 'a search =
          Found of 'a
        | NotFound
@@ -2716,6 +2732,8 @@ fun p_file env (ds, ps) =
                       newline],
                  string "}",
                  newline]
+
+        val initializers = List.mapPartial (fn (DInitializer e, _) => SOME e | _ => NONE) ds
     in
         box [string "#include <stdio.h>",
              newline,
@@ -2849,7 +2867,10 @@ fun p_file env (ds, ps) =
 
                       string "void uw_initializer(uw_context ctx) {",
                       newline,
-                      box [p_enamed env (!initialize),
+                      box [p_list_sep (box []) (fn e => box [p_exp env e,
+                                                             string ";",
+                                                             newline]) initializers,
+                           p_enamed env (!initialize),
                            string "(ctx, uw_unit_v);",
                            newline],
                       string "}",
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 703b9477..3936f6a5 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -468,6 +468,13 @@ fun cifyExp (eAll as (e, loc), sm) =
         in
             ((L'.ENextval {seq = e, prepared = NONE}, loc), sm)
         end
+      | L.ESetval (e1, e2) =>
+        let
+            val (e1, sm) = cifyExp (e1, sm)
+            val (e2, sm) = cifyExp (e2, sm)
+        in
+            ((L'.ESetval {seq = e1, count = e2}, loc), sm)
+        end
 
       | L.EUnurlify (e, t) =>
         let
@@ -653,6 +660,16 @@ fun cifyDecl ((d, loc), sm) =
       | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm)
       | L.DCookie args => (SOME (L'.DCookie args, loc), NONE, sm)
       | L.DStyle args => (SOME (L'.DStyle args, loc), NONE, sm)
+      | L.DInitializer e =>
+        (case #1 e of
+             L.EAbs (_, _, _, e) =>
+             let
+                 val (e, sm) = cifyExp (e, sm)
+             in
+                 (SOME (L'.DInitializer e, loc), NONE, sm)
+             end
+           | _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined";
+                   (NONE, NONE, sm)))
 
 fun cjrize ds =
     let
diff --git a/src/core.sml b/src/core.sml
index 6bead3dc..a60bfd3b 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -134,6 +134,7 @@ datatype decl' =
        | DDatabase of string
        | DCookie of string * int * con * string
        | DStyle of string * int * string
+       | DInitializer of exp
 
 withtype decl = decl' located
 
diff --git a/src/core_env.sml b/src/core_env.sml
index e8cd139f..5e0af98c 100644
--- a/src/core_env.sml
+++ b/src/core_env.sml
@@ -348,6 +348,7 @@ fun declBinds env (d, loc) =
         in
             pushENamed env x n t NONE s
         end
+      | DInitializer _ => env
 
 fun patBinds env (p, loc) =
     case p of
diff --git a/src/core_print.sml b/src/core_print.sml
index 02407f01..7dd43d56 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -611,6 +611,9 @@ fun p_decl env (dAll as (d, _) : decl) =
                                  string "as",
                                  space,
                                  string s]
+      | DInitializer e => box [string "initializer",
+                               space,
+                               p_exp env e]
 
 fun p_file env file =
     let
diff --git a/src/core_util.sml b/src/core_util.sml
index cedde841..7ead1157 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -971,6 +971,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} =
                      fn c' =>
                         (DCookie (x, n, c', s), loc))
               | DStyle _ => S.return2 dAll
+              | DInitializer e =>
+                S.map2 (mfe ctx e,
+                     fn e' =>
+                        (DInitializer e', loc))
 
         and mfvi ctx (x, n, t, e, s) =
             S.bind2 (mfc ctx t,
@@ -1125,6 +1129,7 @@ fun mapfoldB (all as {bind, ...}) =
                                         in
                                             bind (ctx, NamedE (x, n, t, NONE, s))
                                         end
+                                      | DInitializer _ => ctx
                             in
                                 S.map2 (mff ctx' ds',
                                      fn ds' =>
@@ -1187,7 +1192,8 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
                           | DView (_, n, _, _, _) => Int.max (n, count)
                           | DDatabase _ => count
                           | DCookie (_, n, _, _) => Int.max (n, count)
-                          | DStyle (_, n, _) => Int.max (n, count)) 0
+                          | DStyle (_, n, _) => Int.max (n, count)
+                          | DInitializer _ => count) 0
               
 end
 
diff --git a/src/corify.sml b/src/corify.sml
index 9bf322f3..cc0500af 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -1064,6 +1064,9 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
             ([(L'.DStyle (x, n, s), loc)], st)
         end
 
+      | L.DInitializer e =>
+        ([(L'.DInitializer (corifyExp st e), loc)], st)
+
 and corifyStr mods ((str, _), st) =
     case str of
         L.StrConst ds =>
@@ -1120,7 +1123,8 @@ fun maxName ds = foldl (fn ((d, _), n) =>
                              | L.DView (_, _, n', _, _) => Int.max (n, n')
                              | L.DDatabase _ => n
                              | L.DCookie (_, _, n', _) => Int.max (n, n')
-                             | L.DStyle (_, _, n') => Int.max (n, n'))
+                             | L.DStyle (_, _, n') => Int.max (n, n')
+                             | L.DInitializer _ => n)
                        0 ds
 
 and maxNameStr (str, _) =
diff --git a/src/elab.sml b/src/elab.sml
index 76ea6725..1cd7aefa 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -170,6 +170,7 @@ datatype decl' =
        | DDatabase of string
        | DCookie of int * string * int * con
        | DStyle of int * string * int
+       | DInitializer of exp
 
      and str' =
          StrConst of decl list
diff --git a/src/elab_env.sml b/src/elab_env.sml
index 4636fda8..763cf801 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -1622,5 +1622,6 @@ fun declBinds env (d, loc) =
         in
             pushENamedAs env x n t
         end
+      | DInitializer _ => env
 
 end
diff --git a/src/elab_print.sml b/src/elab_print.sml
index 3e4ea659..906c836d 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -799,6 +799,9 @@ fun p_decl env (dAll as (d, _) : decl) =
       | DStyle (_, x, n) => box [string "style",
                                  space,
                                  p_named x n]
+      | DInitializer e => box [string "initializer",
+                               space,
+                               p_exp env e]
 
 and p_str env (str, _) =
     case str of
diff --git a/src/elab_util.sml b/src/elab_util.sml
index e7985026..2a044e71 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -853,7 +853,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
                                                    bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "cookie"), loc),
                                                                                 c), loc)))
                                                  | DStyle (tn, x, n) =>
-                                                   bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc))),
+                                                   bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc)))
+                                                 | DInitializer _ => ctx,
                                                mfd ctx d)) ctx ds,
                      fn ds' => (StrConst ds', loc))
               | StrVar _ => S.return2 strAll
@@ -978,6 +979,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
                         fn c' =>
                            (DCookie (tn, x, n, c'), loc))
               | DStyle _ => S.return2 dAll
+              | DInitializer e =>
+                S.map2 (mfe ctx e,
+                        fn e' =>
+                           (DInitializer e', loc))
 
         and mfvi ctx (x, n, c, e) =
             S.bind2 (mfc ctx c,
@@ -1120,6 +1125,7 @@ and maxNameDecl (d, _) =
       | DDatabase _ => 0
       | DCookie (n1, _, n2, _) => Int.max (n1, n2)
       | DStyle (n1, _, n2) => Int.max (n1, n2)
+      | DInitializer _ => 0
 and maxNameStr (str, _) =
     case str of
         StrConst ds => maxName ds
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 71842ec2..327004e2 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -2548,6 +2548,7 @@ and sgiOfDecl (d, loc) =
       | L'.DDatabase _ => []
       | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)]
       | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)]
+      | L'.DInitializer _ => []
 
 and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) =
     ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1),
@@ -3668,6 +3669,15 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
                 in
                     ([(L'.DStyle (!basis_r, x, n), loc)], (env, denv, gs))
                 end
+              | L.DInitializer e =>
+                let
+                    val (e', t, gs) = elabExp (env, denv) e
+                    val t' = (L'.CApp ((L'.CModProj (!basis_r, [], "transaction"), loc),
+                                       (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc)), loc)
+                in
+                    checkCon env e' t t';
+                    ([(L'.DInitializer e', loc)], (env, denv, gs))
+                end
 
         (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*)
     in
diff --git a/src/elisp/urweb-defs.el b/src/elisp/urweb-defs.el
index e1382692..bb0e257d 100644
--- a/src/elisp/urweb-defs.el
+++ b/src/elisp/urweb-defs.el
@@ -108,7 +108,7 @@ notion of \"the end of an outline\".")
                  "datatype" "type" "open" "include"
                  urweb-module-head-syms
                  "con" "map" "where" "extern" "constraint" "constraints"
-                 "table" "sequence" "class" "cookie")
+                 "table" "sequence" "class" "cookie" "initializer")
   "Symbols starting an sexp.")
 
 ;; (defconst urweb-not-arg-start-re
@@ -134,7 +134,8 @@ notion of \"the end of an outline\".")
      (,urweb-=-starter-syms nil)
      (("case" "datatype" "if" "then" "else"
        "let" "open" "sig" "struct" "type" "val"
-       "con" "constraint" "table" "sequence" "class" "cookie")))))
+       "con" "constraint" "table" "sequence" "class" "cookie"
+       "initializer")))))
 
 (defconst urweb-starters-indent-after
   (urweb-syms-re "let" "in" "struct" "sig")
@@ -188,7 +189,8 @@ for all symbols and in all lines starting with the given symbol."
   (append urweb-module-head-syms
 	  '("datatype" "fun"
 	    "open" "type" "val" "and"
-	    "con" "constraint" "table" "sequence" "class" "cookie"))
+	    "con" "constraint" "table" "sequence" "class" "cookie"
+            "initializer"))
   "The starters of new expressions.")
 
 (defconst urweb-exptrail-syms
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index 72005af9..ab274f22 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -136,7 +136,7 @@ See doc for the variable `urweb-mode-info'."
 	       "datatype" "else" "end" "extern" "fn" "map"
 	       "fun" "functor" "if" "include"
 	       "of" "open" "let" "in"
-	       "rec" "sequence" "sig" "signature" "cookie" "style"
+	       "rec" "sequence" "sig" "signature" "cookie" "style" "initializer"
 	       "struct" "structure" "table" "view" "then" "type" "val" "where"
 	       "with"
 
@@ -226,7 +226,7 @@ See doc for the variable `urweb-mode-info'."
     ("\\<\\(\\(data\\)?type\\|con\\|class\\)\\s-+\\(\\sw+\\)"
      (1 font-lock-keyword-face)
      (3 (amAttribute font-lock-type-def-face)))
-    ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
+    ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\|initializer\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
      (1 font-lock-keyword-face)
      (3 (amAttribute font-lock-variable-name-face)))
     ("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)"
diff --git a/src/expl.sml b/src/expl.sml
index 4a9acd8a..eb79e2b0 100644
--- a/src/expl.sml
+++ b/src/expl.sml
@@ -147,6 +147,7 @@ datatype decl' =
        | DDatabase of string
        | DCookie of int * string * int * con
        | DStyle of int * string * int
+       | DInitializer of exp
 
      and str' =
          StrConst of decl list
diff --git a/src/expl_env.sml b/src/expl_env.sml
index 836af42c..f16eeb8e 100644
--- a/src/expl_env.sml
+++ b/src/expl_env.sml
@@ -343,6 +343,7 @@ fun declBinds env (d, loc) =
         in
             pushENamed env x n t
         end
+      | DInitializer _ => env
 
 fun sgiBinds env (sgi, loc) =
     case sgi of
diff --git a/src/expl_print.sml b/src/expl_print.sml
index 0783facc..624afa63 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -713,6 +713,9 @@ fun p_decl env (dAll as (d, _) : decl) =
       | DStyle (_, x, n) => box [string "style",
                                  space,
                                  p_named x n]
+      | DInitializer e => box [string "initializer",
+                               space,
+                               p_exp env e]
 
 and p_str env (str, _) =
     case str of
diff --git a/src/explify.sml b/src/explify.sml
index 3ec588fa..d66b3530 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -195,6 +195,7 @@ fun explifyDecl (d, loc : EM.span) =
       | L.DDatabase s => SOME (L'.DDatabase s, loc)
       | L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc)
       | L.DStyle (nt, x, n) => SOME (L'.DStyle (nt, x, n), loc)
+      | L.DInitializer e => SOME (L'.DInitializer (explifyExp e), loc)
 
 and explifyStr (str, loc) =
     case str of
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 471711d2..ca20e71d 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -868,6 +868,7 @@ fun process file =
                           | EQuery _ => unsupported "Query"
                           | EDml _ => unsupported "DML"
                           | ENextval _ => unsupported "Nextval"
+                          | ESetval _ => unsupported "Nextval"
                           | EUnurlify _ => unsupported "EUnurlify"
                           | EReturnBlob _ => unsupported "EUnurlify"
                           | ERedirect _ => unsupported "ERedirect"
@@ -1142,6 +1143,13 @@ fun process file =
                  in
                      ((ENextval e, loc), st)
                  end
+               | ESetval (e1, e2) =>
+                 let
+                     val (e1, st) = exp outer (e1, st)
+                     val (e2, st) = exp outer (e2, st)
+                 in
+                     ((ESetval (e1, e2), loc), st)
+                 end
 
                | EUnurlify (e, t) =>
                  let
diff --git a/src/mono.sml b/src/mono.sml
index 92424ee3..1962c6c5 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -106,6 +106,7 @@ datatype exp' =
                      initial : exp }
        | EDml of exp
        | ENextval of exp
+       | ESetval of exp * exp
 
        | EUnurlify of exp * typ
 
@@ -138,6 +139,8 @@ datatype decl' =
        | DCookie of string
        | DStyle of string
 
+       | DInitializer of exp
+
 withtype decl = decl' located
 
 type file = decl list
diff --git a/src/mono_env.sml b/src/mono_env.sml
index 3114176d..6ffab153 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.sml
@@ -129,6 +129,7 @@ fun declBinds env (d, loc) =
       | DJavaScript _ => env
       | DCookie _ => env
       | DStyle _ => env
+      | DInitializer _ => env
 
 fun patBinds env (p, loc) =
     case p of
diff --git a/src/mono_print.sml b/src/mono_print.sml
index cfaa410b..13c45329 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -320,6 +320,12 @@ fun p_exp' par env (e, _) =
       | ENextval e => box [string "nextval(",
                            p_exp env e,
                            string ")"]
+      | ESetval (e1, e2) => box [string "setval(",
+                                 p_exp env e1,
+                                 string ",",
+                                 space,
+                                 p_exp env e2,
+                                 string ")"]
       | EUnurlify (e, _) => box [string "unurlify(",
                                  p_exp env e,
                                  string ")"]
@@ -485,6 +491,9 @@ fun p_decl env (dAll as (d, _) : decl) =
       | DStyle s => box [string "style",
                          space,
                          string s]
+      | DInitializer e => box [string "initializer",
+                               space,
+                               p_exp env e]
 
                           
 fun p_file env file =
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index f29117cf..aa6b7051 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -51,6 +51,7 @@ fun simpleImpure (tsyms, syms) =
                               | EQuery _ => true
                               | EDml _ => true
                               | ENextval _ => true
+                              | ESetval _ => true
                               | EFfiApp (m, x, _) => Settings.isEffectful (m, x)
                               | EServerCall _ => true
                               | ERecv _ => true
@@ -75,6 +76,7 @@ fun impure (e, _) =
       | EQuery _ => true
       | EDml _ => true
       | ENextval _ => true
+      | ESetval _ => true
       | EUnurlify _ => true
       | EAbs _ => false
 
@@ -448,6 +450,7 @@ fun reduce file =
 
                       | EDml e => summarize d e @ [WriteDb]
                       | ENextval e => summarize d e @ [WriteDb]
+                      | ESetval (e1, e2) => summarize d e1 @ summarize d e2 @ [WriteDb]
                       | EUnurlify (e, _) => summarize d e
                       | EJavaScript (_, e) => summarize d e
                       | ESignalReturn e => summarize d e
diff --git a/src/mono_shake.sml b/src/mono_shake.sml
index 40b83934..fc46cf96 100644
--- a/src/mono_shake.sml
+++ b/src/mono_shake.sml
@@ -43,10 +43,22 @@ type free = {
 
 fun shake file =
     let
-        val page_es = List.foldl
-                          (fn ((DExport (_, _, n, _, _), _), page_es) => n :: page_es
-                            | ((DDatabase {expunge = n1, initialize = n2, ...}, _), page_es) => n1 :: n2 :: page_es
-                            | (_, page_es) => page_es) [] file
+        val usedVars = U.Exp.fold {typ = fn (c, st as (cs, es)) =>
+                                            case c of
+                                                TDatatype (n, _) => (IS.add (cs, n), es)
+                                              | _ => st,
+                                   exp = fn (e, st as (cs, es)) =>
+                                            case e of
+                                                ENamed n => (cs, IS.add (es, n))
+                                              | _ => st}
+
+        val (page_cs, page_es) =
+            List.foldl
+                (fn ((DExport (_, _, n, _, _), _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n))
+                  | ((DDatabase {expunge = n1, initialize = n2, ...}, _), (page_cs, page_es)) =>
+                    (page_cs, IS.addList (page_es, [n1, n2]))
+                  | ((DInitializer e, _), st) => usedVars st e
+                  | (_, st) => st) (IS.empty, IS.empty) file
 
         val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) =>
                                      (foldl (fn ((_, n, xncs), cdef) => IM.insert (cdef, n, xncs)) cdef dts, edef)
@@ -61,7 +73,8 @@ fun shake file =
                                    | ((DDatabase _, _), acc) => acc
                                    | ((DJavaScript _, _), acc) => acc
                                    | ((DCookie _, _), acc) => acc
-                                   | ((DStyle _, _), acc) => acc)
+                                   | ((DStyle _, _), acc) => acc
+                                   | ((DInitializer _, _), acc) => acc)
                                  (IM.empty, IM.empty) file
 
         fun typ (c, s) =
@@ -104,12 +117,18 @@ fun shake file =
 
         and shakeExp s = U.Exp.fold {typ = typ, exp = exp} s
 
-        val s = {con = IS.empty, exp = IS.addList (IS.empty, page_es)}
+        val s = {con = page_cs, exp = page_es}
+
+        val s = IS.foldl (fn (n, s) =>
+                             case IM.find (cdef, n) of
+                                 NONE => raise Fail "MonoShake: Couldn't find 'datatype'"
+                               | SOME xncs => foldl (fn ((_, _, SOME c), s) => shakeTyp s c
+                                                      | _ => s) s xncs) s page_cs
 
-        val s = foldl (fn (n, s) =>
-                          case IM.find (edef, n) of
-                              NONE => raise Fail "Shake: Couldn't find 'val'"
-                            | SOME (t, e) => shakeExp s e) s page_es
+        val s = IS.foldl (fn (n, s) =>
+                             case IM.find (edef, n) of
+                                 NONE => raise Fail "MonoShake: Couldn't find 'val'"
+                               | SOME (t, e) => shakeExp s e) s page_es
     in
         List.filter (fn (DDatatype dts, _) => List.exists (fn (_, n, _) => IS.member (#con s, n)) dts
                       | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n)
@@ -121,7 +140,8 @@ fun shake file =
                       | (DDatabase _, _) => true
                       | (DJavaScript _, _) => true
                       | (DCookie _, _) => true
-                      | (DStyle _, _) => true) file
+                      | (DStyle _, _) => true
+                      | (DInitializer _, _) => true) file
     end
 
 end
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 91b4412e..184ce168 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -340,6 +340,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
                 S.map2 (mfe ctx e,
                      fn e' =>
                         (ENextval e', loc))
+              | ESetval (e1, e2) =>
+                S.bind2 (mfe ctx e1,
+                     fn e1' =>
+                        S.map2 (mfe ctx e2,
+                             fn e2' =>
+                                (ESetval (e1', e2'), loc)))
               | EUnurlify (e, t) =>
                 S.bind2 (mfe ctx e,
                      fn e' =>
@@ -522,6 +528,10 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
               | DJavaScript _ => S.return2 dAll
               | DCookie _ => S.return2 dAll
               | DStyle _ => S.return2 dAll
+              | DInitializer e =>
+                S.map2 (mfe ctx e,
+                     fn e' =>
+                        (DInitializer e', loc))
 
         and mfvi ctx (x, n, t, e, s) =
             S.bind2 (mft t,
@@ -608,6 +618,7 @@ fun mapfoldB (all as {bind, ...}) =
                                       | DJavaScript _ => ctx
                                       | DCookie _ => ctx
                                       | DStyle _ => ctx
+                                      | DInitializer _ => ctx
                             in
                                 S.map2 (mff ctx' ds',
                                      fn ds' =>
@@ -660,7 +671,8 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
                           | DDatabase _ => count
                           | DJavaScript _ => count
                           | DCookie _ => count
-                          | DStyle _ => count) 0
+                          | DStyle _ => count
+                          | DInitializer _ => count) 0
 
 end
 
diff --git a/src/monoize.sml b/src/monoize.sml
index b92b9c70..503fd6b3 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2475,6 +2475,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             in
                 ((L'.ENextval e, loc), fm)
             end
+          | L.EFfiApp ("Basis", "setval", [e1, e2]) =>
+            let
+                val (e1, fm) = monoExp (env, st, fm) e1
+                val (e2, fm) = monoExp (env, st, fm) e2
+            in
+                ((L'.ESetval (e1, e2), loc), fm)
+            end
 
           | L.EApp (
             (L.ECApp (
@@ -3471,6 +3478,14 @@ fun monoDecl (env, fm) (all as (d, loc)) =
                       [(L'.DStyle s, loc),
                        (L'.DVal (x, n, t', e, s), loc)])
             end
+          | L.DInitializer e =>
+            let
+                val (e, fm) = monoExp (env, St.empty, fm) e
+            in
+                SOME (env,
+                      fm,
+                      [(L'.DInitializer e, loc)])
+            end
     end
 
 datatype expungable = Client | Channel
diff --git a/src/mysql.sml b/src/mysql.sml
index 514a9257..40409ff0 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -1503,6 +1503,8 @@ fun nextval {loc, seqE, seqName} =
 
 fun nextvalPrepared _ = raise Fail "MySQL.nextvalPrepared called"
 
+fun setval _ = raise Fail "MySQL.setval called"
+
 fun sqlifyString s = "'" ^ String.translate (fn #"'" => "\\'"
                                               | #"\\" => "\\\\"
                                               | ch =>
@@ -1529,6 +1531,7 @@ val () = addDbms {name = "mysql",
                   dmlPrepared = dmlPrepared,
                   nextval = nextval,
                   nextvalPrepared = nextvalPrepared,
+                  setval = setval,
                   sqlifyString = sqlifyString,
                   p_cast = p_cast,
                   p_blank = p_blank,
diff --git a/src/postgres.sml b/src/postgres.sml
index 51e856db..c4bbb067 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -867,6 +867,48 @@ fun nextvalPrepared {loc, id, query} =
                                                 string (String.toString query),
                                                 string "\""]}]
 
+fun setvalCommon {loc, query} =
+    box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating setval result.\");",
+         newline,
+         newline,
+
+         string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
+         newline,
+         box [string "PQclear(res);",
+              newline,
+              string "uw_error(ctx, FATAL, \"",
+              string (ErrorMsg.spanToString loc),
+              string ": Query failed:\\n%s\\n%s\", ",
+              query,
+              string ", PQerrorMessage(conn));",
+              newline],
+         string "}",
+         newline,
+         newline,
+
+         string "PQclear(res);",
+         newline]
+
+fun setval {loc, seqE, count} =
+    let
+        val query = box [string "uw_Basis_strcat(ctx, \"SELECT SETVAL('\", uw_Basis_strcat(ctx, ",
+                         seqE,
+                         string ", uw_Basis_strcat(ctx, \"', \", uw_Basis_strcat(ctx, uw_Basis_sqlifyInt(ctx, ",
+                         count,
+                         string "), \")\"))))"]
+    in
+        box [string "char *query = ",
+             query,
+             string ";",
+             newline,
+             string "PGconn *conn = uw_get_db(ctx);",
+             newline,
+             string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);",
+             newline,
+             newline,
+             setvalCommon {loc = loc, query = string "query"}]
+    end
+
 fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'"
                                                | #"\\" => "\\\\"
                                                | ch =>
@@ -892,6 +934,7 @@ val () = addDbms {name = "postgres",
                   dmlPrepared = dmlPrepared,
                   nextval = nextval,
                   nextvalPrepared = nextvalPrepared,
+                  setval = setval,
                   sqlifyString = sqlifyString,
                   p_cast = p_cast,
                   p_blank = p_blank,
diff --git a/src/prepare.sml b/src/prepare.sml
index 58344a1f..7cbd7d76 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -273,6 +273,14 @@ fun prepExp (e as (_, loc), st) =
         else
             (e, st)
 
+      | ESetval {seq = e1, count = e2} =>
+        let
+            val (e1, st) = prepExp (e1, st)
+            val (e2, st) = prepExp (e2, st)
+        in
+            ((ESetval {seq = e1, count = e2}, loc), st)
+        end
+
       | EUnurlify (e, t) =>
         let
             val (e, st) = prepExp (e, st)
@@ -317,6 +325,12 @@ fun prepDecl (d as (_, loc), st) =
       | DJavaScript _ => (d, st)
       | DCookie _ => (d, st)
       | DStyle _ => (d, st)
+      | DInitializer e =>
+        let
+            val (e, st) = prepExp (e, st)
+        in
+            ((DInitializer e, loc), st)
+        end
 
 fun prepare (ds, ps) =
     let
diff --git a/src/reduce.sml b/src/reduce.sml
index 1310c7d0..cedb79fa 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -804,6 +804,15 @@ fun reduce file =
               | DDatabase _ => (d, st)
               | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st)
               | DStyle (s, n, s') => ((DStyle (s, n, s'), loc), st)
+              | DInitializer e =>
+                let
+                    val e = exp (namedC, namedE) [] e
+                in
+                    ((DInitializer e, loc),
+                     (polyC,
+                      namedC,
+                      namedE))
+                end
 
         val (file, _) = ListUtil.foldlMap doDecl (IS.empty, IM.empty, IM.empty) file
     in
diff --git a/src/reduce_local.sml b/src/reduce_local.sml
index 4ddddfbf..82490118 100644
--- a/src/reduce_local.sml
+++ b/src/reduce_local.sml
@@ -251,6 +251,7 @@ fun reduce file =
               | DDatabase _ => d
               | DCookie _ => d
               | DStyle _ => d
+              | DInitializer e => (DInitializer (exp [] e), loc)
     in
         map doDecl file
     end
diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml
index 6dc11c65..5cd056d5 100644
--- a/src/scriptcheck.sml
+++ b/src/scriptcheck.sml
@@ -114,6 +114,7 @@ fun classify (ds, ps) =
                                                               orelse hasClient initial
                       | EDml {dml, ...} => hasClient dml
                       | ENextval {seq, ...} => hasClient seq
+                      | ESetval {seq, count, ...} => hasClient seq orelse hasClient count
                       | EUnurlify (e, _) => hasClient e
             in
                 hasClient
diff --git a/src/settings.sig b/src/settings.sig
index 61095ff8..574832a2 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -147,6 +147,7 @@ signature SETTINGS = sig
                         inputs : sql_type list} -> Print.PD.pp_desc,
          nextval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, seqName : string option} -> Print.PD.pp_desc,
          nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc,
+         setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc,
          sqlifyString : string -> string,
          p_cast : string * sql_type -> string,
          p_blank : int * sql_type -> string (* Prepared statement input *),
diff --git a/src/settings.sml b/src/settings.sml
index f5d5a3ab..a7f2cc9f 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -79,6 +79,7 @@ fun mayClientToServer x = S.member (!clientToServer, x)
 
 val effectfulBase = basis ["dml",
                            "nextval",
+                           "setval",
                            "set_cookie",
                            "clear_cookie",
                            "new_client_source",
@@ -120,6 +121,7 @@ val serverBase = basis ["requestHeader",
                         "query",
                         "dml",
                         "nextval",
+                        "setval",
                         "channel",
                         "send"]
 val server = ref serverBase
@@ -355,6 +357,7 @@ type dbms = {
                     inputs : sql_type list} -> Print.PD.pp_desc,
      nextval : {loc : ErrorMsg.span, seqName : string option, seqE : Print.PD.pp_desc} -> Print.PD.pp_desc,
      nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc,
+     setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc,
      sqlifyString : string -> string,
      p_cast : string * sql_type -> string,
      p_blank : int * sql_type -> string,
@@ -382,6 +385,7 @@ val curDb = ref ({name = "",
                   dmlPrepared = fn _ => Print.box [],
                   nextval = fn _ => Print.box [],
                   nextvalPrepared = fn _ => Print.box [],
+                  setval = fn _ => Print.box [],
                   sqlifyString = fn s => s,
                   p_cast = fn _ => "",
                   p_blank = fn _ => "",
diff --git a/src/shake.sml b/src/shake.sml
index dde131fc..787500ea 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -79,6 +79,7 @@ fun shake file =
                     in
                         (usedE, usedC)
                     end
+                  | ((DInitializer e, _), st) => usedVars st e
                   | (_, acc) => acc) (IS.empty, IS.empty) file
 
         val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef)
@@ -104,7 +105,8 @@ fun shake file =
                                    | ((DCookie (_, n, c, _), _), (cdef, edef)) =>
                                      (cdef, IM.insert (edef, n, ([], c, dummye)))
                                    | ((DStyle (_, n, _), _), (cdef, edef)) =>
-                                     (cdef, IM.insert (edef, n, ([], dummyt, dummye))))
+                                     (cdef, IM.insert (edef, n, ([], dummyt, dummye)))
+                                   | ((DInitializer _, _), acc) => acc)
                                  (IM.empty, IM.empty) file
 
         fun kind (_, s) = s
@@ -183,7 +185,8 @@ fun shake file =
                       | (DTable _, _) => true
                       | (DDatabase _, _) => true
                       | (DCookie _, _) => true
-                      | (DStyle _, _) => true) file
+                      | (DStyle _, _) => true
+                      | (DInitializer _, _) => true) file
     end
 
 end
diff --git a/src/source.sml b/src/source.sml
index c5950b36..e52872f0 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -167,6 +167,7 @@ datatype decl' =
        | DDatabase of string
        | DCookie of string * con
        | DStyle of string
+       | DInitializer of exp
 
      and str' =
          StrConst of decl list
diff --git a/src/source_print.sml b/src/source_print.sml
index 7ec584d7..31fc2500 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -662,6 +662,9 @@ fun p_decl ((d, _) : decl) =
       | DStyle x => box [string "style",
                          space,
                          string x]
+      | DInitializer e => box [string "initializer",
+                               space,
+                               p_exp e]
 
 and p_str (str, _) =
     case str of
diff --git a/src/sqlite.sml b/src/sqlite.sml
index 8a61c25e..440c7c28 100644
--- a/src/sqlite.sml
+++ b/src/sqlite.sml
@@ -757,6 +757,7 @@ fun nextval {loc, seqE, seqName} =
          newline]
 
 fun nextvalPrepared _ = raise Fail "SQLite.nextvalPrepared called"
+fun setval _ = raise Fail "SQLite.setval called"
 
 fun sqlifyString s = "'" ^ String.translate (fn #"'" => "''"
                                               | ch =>
@@ -783,6 +784,7 @@ val () = addDbms {name = "sqlite",
                   dmlPrepared = dmlPrepared,
                   nextval = nextval,
                   nextvalPrepared = nextvalPrepared,
+                  setval = setval,
                   sqlifyString = sqlifyString,
                   p_cast = p_cast,
                   p_blank = p_blank,
diff --git a/src/unnest.sml b/src/unnest.sml
index a4bdb7a9..c4d9a8b5 100644
--- a/src/unnest.sml
+++ b/src/unnest.sml
@@ -422,6 +422,7 @@ fun unnest file =
                   | DDatabase _ => default ()
                   | DCookie _ => default ()
                   | DStyle _ => default ()
+                  | DInitializer _ => explore ()
             end
 
         and doStr (all as (str, loc), st) =
diff --git a/src/urweb.grm b/src/urweb.grm
index 87a8547d..8780d9f6 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -201,7 +201,7 @@ fun patType loc (p : pat) =
  | LET | IN
  | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | SELECT1
  | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW
- | COOKIE | STYLE
+ | COOKIE | STYLE | INITIALIZER
  | CASE | IF | THEN | ELSE | ANDALSO | ORELSE
 
  | XML_BEGIN of string | XML_END | XML_BEGIN_END of string
@@ -479,6 +479,7 @@ decl   : CON SYMBOL cargl2 kopt EQ cexp (let
                                          end)
        | COOKIE SYMBOL COLON cexp       ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))])
        | STYLE SYMBOL                   ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))])
+       | INITIALIZER eexp               ([(DInitializer eexp, s (INITIALIZERleft, eexpright))])
 
 dtype  : SYMBOL dargs EQ barOpt dcons   (SYMBOL, dargs, dcons)
 
diff --git a/src/urweb.lex b/src/urweb.lex
index ed6e310b..d04822f7 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -402,6 +402,7 @@ notags = [^<{\n]+;
 <INITIAL> "class"     => (Tokens.CLASS (pos yypos, pos yypos + size yytext));
 <INITIAL> "cookie"    => (Tokens.COOKIE (pos yypos, pos yypos + size yytext));
 <INITIAL> "style"     => (Tokens.STYLE (pos yypos, pos yypos + size yytext));
+<INITIAL> "initializer" => (Tokens.INITIALIZER (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "Type"      => (Tokens.TYPE (pos yypos, pos yypos + size yytext));
 <INITIAL> "Name"      => (Tokens.NAME (pos yypos, pos yypos + size yytext));
diff --git a/tests/init.ur b/tests/init.ur
new file mode 100644
index 00000000..0a44a9e4
--- /dev/null
+++ b/tests/init.ur
@@ -0,0 +1,6 @@
+sequence seq
+table fred : {A : int, B : int}
+
+initializer
+    setval seq 1;
+    dml (INSERT INTO fred (A, B) VALUES (0, 1))
diff --git a/tests/init.urp b/tests/init.urp
new file mode 100644
index 00000000..a2166e44
--- /dev/null
+++ b/tests/init.urp
@@ -0,0 +1,5 @@
+debug
+database dbname=init
+sql init.sql
+
+init
-- 
cgit v1.2.3


From 6179a09d47c5af4db1ac41d00b8cb7ec36741c3e Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Tue, 15 Dec 2009 10:19:05 -0500
Subject: Convert to task syntax

---
 CHANGELOG               |  2 +-
 lib/ur/basis.urs        |  6 ++++++
 src/cjr.sml             |  4 +++-
 src/cjr_env.sml         |  2 +-
 src/cjr_print.sml       |  4 ++--
 src/cjrize.sml          | 10 +++++++---
 src/core.sml            |  2 +-
 src/core_env.sml        |  2 +-
 src/core_print.sml      |  8 ++++++--
 src/core_util.sml       | 14 ++++++++------
 src/corify.sml          |  6 +++---
 src/elab.sml            |  2 +-
 src/elab_env.sml        |  2 +-
 src/elab_print.sml      |  8 ++++++--
 src/elab_util.sml       | 14 ++++++++------
 src/elaborate.sml       | 18 +++++++++++-------
 src/elisp/urweb-defs.el |  6 +++---
 src/elisp/urweb-mode.el |  4 ++--
 src/expl.sml            |  2 +-
 src/expl_env.sml        |  2 +-
 src/expl_print.sml      |  8 ++++++--
 src/explify.sml         |  2 +-
 src/mono.sml            |  2 +-
 src/mono_env.sml        |  2 +-
 src/mono_print.sml      |  8 ++++++--
 src/mono_shake.sml      |  6 +++---
 src/mono_util.sml       | 14 ++++++++------
 src/monoize.sml         |  7 ++++---
 src/prepare.sml         |  4 ++--
 src/reduce.sml          |  7 ++++---
 src/reduce_local.sml    |  2 +-
 src/shake.sml           |  6 +++---
 src/source.sml          |  2 +-
 src/source_print.sml    |  8 ++++++--
 src/unnest.sml          |  2 +-
 src/urweb.grm           |  4 ++--
 src/urweb.lex           |  2 +-
 tests/init.ur           |  2 +-
 38 files changed, 125 insertions(+), 81 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/CHANGELOG b/CHANGELOG
index e1e14aea..ec2eda90 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -6,7 +6,7 @@ Next
 - More syntactic sugar for SQL
 - Typing of SQL queries no longer exposes which tables were used in joins but
   had none of their fields projected
-- Module-level initializers
+- Tasks
 
 ========
 20091203
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index f7e098d4..f550ce67 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -757,3 +757,9 @@ val onDisconnect : transaction unit -> transaction unit
 val onServerError : (string -> transaction unit) -> transaction unit
 
 val show_xml : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> show (xml ctx use bind)
+
+
+(** Tasks *)
+
+type task_kind
+val initialize : task_kind
diff --git a/src/cjr.sml b/src/cjr.sml
index 9be54670..f5392d49 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -100,6 +100,8 @@ datatype exp' =
 
 withtype exp = exp' located
 
+datatype task = Initialize
+
 datatype decl' =
          DStruct of int * (string * typ) list
        | DDatatype of (datatype_kind * string * int * (string * int * typ option) list) list
@@ -118,7 +120,7 @@ datatype decl' =
        | DCookie of string
        | DStyle of string
 
-       | DInitializer of exp
+       | DTask of task * exp
 
 withtype decl = decl' located
 
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index e4d978d5..ac83f263 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -171,6 +171,6 @@ fun declBinds env (d, loc) =
       | DJavaScript _ => env
       | DCookie _ => env
       | DStyle _ => env
-      | DInitializer _ => env
+      | DTask _ => env
 
 end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 6a5116ce..2d547519 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2099,7 +2099,7 @@ fun p_decl env (dAll as (d, _) : decl) =
                          space,
                          string "*/"]
 
-      | DInitializer _ => box []
+      | DTask _ => box []
 
 datatype 'a search =
          Found of 'a
@@ -2733,7 +2733,7 @@ fun p_file env (ds, ps) =
                  string "}",
                  newline]
 
-        val initializers = List.mapPartial (fn (DInitializer e, _) => SOME e | _ => NONE) ds
+        val initializers = List.mapPartial (fn (DTask (Initialize, e), _) => SOME e | _ => NONE) ds
     in
         box [string "#include <stdio.h>",
              newline,
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 3936f6a5..0136bdf6 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -660,13 +660,17 @@ fun cifyDecl ((d, loc), sm) =
       | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm)
       | L.DCookie args => (SOME (L'.DCookie args, loc), NONE, sm)
       | L.DStyle args => (SOME (L'.DStyle args, loc), NONE, sm)
-      | L.DInitializer e =>
-        (case #1 e of
+      | L.DTask (e1, e2) =>
+        (case #1 e2 of
              L.EAbs (_, _, _, e) =>
              let
+                 val tk = case #1 e1 of
+                              L.EFfi ("Basis", "initialize") => L'.Initialize
+                            | _ => (ErrorMsg.errorAt loc "Task kind not fully determined";
+                                    L'.Initialize)
                  val (e, sm) = cifyExp (e, sm)
              in
-                 (SOME (L'.DInitializer e, loc), NONE, sm)
+                 (SOME (L'.DTask (tk, e), loc), NONE, sm)
              end
            | _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined";
                    (NONE, NONE, sm)))
diff --git a/src/core.sml b/src/core.sml
index a60bfd3b..78a1eded 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -134,7 +134,7 @@ datatype decl' =
        | DDatabase of string
        | DCookie of string * int * con * string
        | DStyle of string * int * string
-       | DInitializer of exp
+       | DTask of exp * exp
 
 withtype decl = decl' located
 
diff --git a/src/core_env.sml b/src/core_env.sml
index 5e0af98c..4c50bdd7 100644
--- a/src/core_env.sml
+++ b/src/core_env.sml
@@ -348,7 +348,7 @@ fun declBinds env (d, loc) =
         in
             pushENamed env x n t NONE s
         end
-      | DInitializer _ => env
+      | DTask _ => env
 
 fun patBinds env (p, loc) =
     case p of
diff --git a/src/core_print.sml b/src/core_print.sml
index 7dd43d56..c1f93587 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -611,9 +611,13 @@ fun p_decl env (dAll as (d, _) : decl) =
                                  string "as",
                                  space,
                                  string s]
-      | DInitializer e => box [string "initializer",
+      | DTask (e1, e2) => box [string "task",
                                space,
-                               p_exp env e]
+                               p_exp env e1,
+                               space,
+                               string "=",
+                               space,
+                               p_exp env e2]
 
 fun p_file env file =
     let
diff --git a/src/core_util.sml b/src/core_util.sml
index 7ead1157..599e1abc 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -971,10 +971,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} =
                      fn c' =>
                         (DCookie (x, n, c', s), loc))
               | DStyle _ => S.return2 dAll
-              | DInitializer e =>
-                S.map2 (mfe ctx e,
-                     fn e' =>
-                        (DInitializer e', loc))
+              | DTask (e1, e2) =>
+                S.bind2 (mfe ctx e1,
+                     fn e1' =>
+                        S.map2 (mfe ctx e2,
+                             fn e2' =>
+                                (DTask (e1', e2'), loc)))
 
         and mfvi ctx (x, n, t, e, s) =
             S.bind2 (mfc ctx t,
@@ -1129,7 +1131,7 @@ fun mapfoldB (all as {bind, ...}) =
                                         in
                                             bind (ctx, NamedE (x, n, t, NONE, s))
                                         end
-                                      | DInitializer _ => ctx
+                                      | DTask _ => ctx
                             in
                                 S.map2 (mff ctx' ds',
                                      fn ds' =>
@@ -1193,7 +1195,7 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
                           | DDatabase _ => count
                           | DCookie (_, n, _, _) => Int.max (n, count)
                           | DStyle (_, n, _) => Int.max (n, count)
-                          | DInitializer _ => count) 0
+                          | DTask _ => count) 0
               
 end
 
diff --git a/src/corify.sml b/src/corify.sml
index cc0500af..9259b4f2 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -1064,8 +1064,8 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
             ([(L'.DStyle (x, n, s), loc)], st)
         end
 
-      | L.DInitializer e =>
-        ([(L'.DInitializer (corifyExp st e), loc)], st)
+      | L.DTask (e1, e2) =>
+        ([(L'.DTask (corifyExp st e1, corifyExp st e2), loc)], st)
 
 and corifyStr mods ((str, _), st) =
     case str of
@@ -1124,7 +1124,7 @@ fun maxName ds = foldl (fn ((d, _), n) =>
                              | L.DDatabase _ => n
                              | L.DCookie (_, _, n', _) => Int.max (n, n')
                              | L.DStyle (_, _, n') => Int.max (n, n')
-                             | L.DInitializer _ => n)
+                             | L.DTask _ => n)
                        0 ds
 
 and maxNameStr (str, _) =
diff --git a/src/elab.sml b/src/elab.sml
index 1cd7aefa..a0f9a4e8 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -170,7 +170,7 @@ datatype decl' =
        | DDatabase of string
        | DCookie of int * string * int * con
        | DStyle of int * string * int
-       | DInitializer of exp
+       | DTask of exp * exp
 
      and str' =
          StrConst of decl list
diff --git a/src/elab_env.sml b/src/elab_env.sml
index 763cf801..5092c6fb 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -1622,6 +1622,6 @@ fun declBinds env (d, loc) =
         in
             pushENamedAs env x n t
         end
-      | DInitializer _ => env
+      | DTask _ => env
 
 end
diff --git a/src/elab_print.sml b/src/elab_print.sml
index 906c836d..62b5262f 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -799,9 +799,13 @@ fun p_decl env (dAll as (d, _) : decl) =
       | DStyle (_, x, n) => box [string "style",
                                  space,
                                  p_named x n]
-      | DInitializer e => box [string "initializer",
+      | DTask (e1, e2) => box [string "task",
                                space,
-                               p_exp env e]
+                               p_exp env e1,
+                               space,
+                               string "=",
+                               space,
+                               p_exp env e2]
 
 and p_str env (str, _) =
     case str of
diff --git a/src/elab_util.sml b/src/elab_util.sml
index 2a044e71..d0e140c5 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -854,7 +854,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
                                                                                 c), loc)))
                                                  | DStyle (tn, x, n) =>
                                                    bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc)))
-                                                 | DInitializer _ => ctx,
+                                                 | DTask _ => ctx,
                                                mfd ctx d)) ctx ds,
                      fn ds' => (StrConst ds', loc))
               | StrVar _ => S.return2 strAll
@@ -979,10 +979,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
                         fn c' =>
                            (DCookie (tn, x, n, c'), loc))
               | DStyle _ => S.return2 dAll
-              | DInitializer e =>
-                S.map2 (mfe ctx e,
-                        fn e' =>
-                           (DInitializer e', loc))
+              | DTask (e1, e2) =>
+                S.bind2 (mfe ctx e1,
+                        fn e1' =>
+                           S.map2 (mfe ctx e2,
+                                fn e2' =>
+                                   (DTask (e1', e2'), loc)))
 
         and mfvi ctx (x, n, c, e) =
             S.bind2 (mfc ctx c,
@@ -1125,7 +1127,7 @@ and maxNameDecl (d, _) =
       | DDatabase _ => 0
       | DCookie (n1, _, n2, _) => Int.max (n1, n2)
       | DStyle (n1, _, n2) => Int.max (n1, n2)
-      | DInitializer _ => 0
+      | DTask _ => 0
 and maxNameStr (str, _) =
     case str of
         StrConst ds => maxName ds
diff --git a/src/elaborate.sml b/src/elaborate.sml
index d1b9648a..2a237c50 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -2548,7 +2548,7 @@ and sgiOfDecl (d, loc) =
       | L'.DDatabase _ => []
       | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)]
       | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)]
-      | L'.DInitializer _ => []
+      | L'.DTask _ => []
 
 and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) =
     ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1),
@@ -3669,14 +3669,18 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
                 in
                     ([(L'.DStyle (!basis_r, x, n), loc)], (env, denv, gs))
                 end
-              | L.DInitializer e =>
+              | L.DTask (e1, e2) =>
                 let
-                    val (e', t, gs') = elabExp (env, denv) e
-                    val t' = (L'.CApp ((L'.CModProj (!basis_r, [], "transaction"), loc),
-                                       (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc)), loc)
+                    val (e1', t1, gs1) = elabExp (env, denv) e1
+                    val (e2', t2, gs2) = elabExp (env, denv) e2
+
+                    val t1' = (L'.CModProj (!basis_r, [], "task_kind"), loc)
+                    val t2' = (L'.CApp ((L'.CModProj (!basis_r, [], "transaction"), loc),
+                                        (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc)), loc)
                 in
-                    checkCon env e' t t';
-                    ([(L'.DInitializer e', loc)], (env, denv, gs' @ gs))
+                    checkCon env e1' t1 t1';
+                    checkCon env e2' t2 t2';
+                    ([(L'.DTask (e1', e2'), loc)], (env, denv, gs2 @ gs1 @ gs))
                 end
 
         (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*)
diff --git a/src/elisp/urweb-defs.el b/src/elisp/urweb-defs.el
index bb0e257d..c697a274 100644
--- a/src/elisp/urweb-defs.el
+++ b/src/elisp/urweb-defs.el
@@ -108,7 +108,7 @@ notion of \"the end of an outline\".")
                  "datatype" "type" "open" "include"
                  urweb-module-head-syms
                  "con" "map" "where" "extern" "constraint" "constraints"
-                 "table" "sequence" "class" "cookie" "initializer")
+                 "table" "sequence" "class" "cookie" "task")
   "Symbols starting an sexp.")
 
 ;; (defconst urweb-not-arg-start-re
@@ -135,7 +135,7 @@ notion of \"the end of an outline\".")
      (("case" "datatype" "if" "then" "else"
        "let" "open" "sig" "struct" "type" "val"
        "con" "constraint" "table" "sequence" "class" "cookie"
-       "initializer")))))
+       "task")))))
 
 (defconst urweb-starters-indent-after
   (urweb-syms-re "let" "in" "struct" "sig")
@@ -190,7 +190,7 @@ for all symbols and in all lines starting with the given symbol."
 	  '("datatype" "fun"
 	    "open" "type" "val" "and"
 	    "con" "constraint" "table" "sequence" "class" "cookie"
-            "initializer"))
+            "task"))
   "The starters of new expressions.")
 
 (defconst urweb-exptrail-syms
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index ab274f22..107ea3bc 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -136,7 +136,7 @@ See doc for the variable `urweb-mode-info'."
 	       "datatype" "else" "end" "extern" "fn" "map"
 	       "fun" "functor" "if" "include"
 	       "of" "open" "let" "in"
-	       "rec" "sequence" "sig" "signature" "cookie" "style" "initializer"
+	       "rec" "sequence" "sig" "signature" "cookie" "style" "task"
 	       "struct" "structure" "table" "view" "then" "type" "val" "where"
 	       "with"
 
@@ -226,7 +226,7 @@ See doc for the variable `urweb-mode-info'."
     ("\\<\\(\\(data\\)?type\\|con\\|class\\)\\s-+\\(\\sw+\\)"
      (1 font-lock-keyword-face)
      (3 (amAttribute font-lock-type-def-face)))
-    ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\|initializer\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
+    ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\|task\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
      (1 font-lock-keyword-face)
      (3 (amAttribute font-lock-variable-name-face)))
     ("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)"
diff --git a/src/expl.sml b/src/expl.sml
index eb79e2b0..17797626 100644
--- a/src/expl.sml
+++ b/src/expl.sml
@@ -147,7 +147,7 @@ datatype decl' =
        | DDatabase of string
        | DCookie of int * string * int * con
        | DStyle of int * string * int
-       | DInitializer of exp
+       | DTask of exp * exp
 
      and str' =
          StrConst of decl list
diff --git a/src/expl_env.sml b/src/expl_env.sml
index f16eeb8e..0bf7323f 100644
--- a/src/expl_env.sml
+++ b/src/expl_env.sml
@@ -343,7 +343,7 @@ fun declBinds env (d, loc) =
         in
             pushENamed env x n t
         end
-      | DInitializer _ => env
+      | DTask _ => env
 
 fun sgiBinds env (sgi, loc) =
     case sgi of
diff --git a/src/expl_print.sml b/src/expl_print.sml
index 624afa63..5284eecb 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -713,9 +713,13 @@ fun p_decl env (dAll as (d, _) : decl) =
       | DStyle (_, x, n) => box [string "style",
                                  space,
                                  p_named x n]
-      | DInitializer e => box [string "initializer",
+      | DTask (e1, e2) => box [string "task",
                                space,
-                               p_exp env e]
+                               p_exp env e1,
+                               space,
+                               string "=",
+                               space,
+                               p_exp env e2]
 
 and p_str env (str, _) =
     case str of
diff --git a/src/explify.sml b/src/explify.sml
index d66b3530..aff91a34 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -195,7 +195,7 @@ fun explifyDecl (d, loc : EM.span) =
       | L.DDatabase s => SOME (L'.DDatabase s, loc)
       | L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc)
       | L.DStyle (nt, x, n) => SOME (L'.DStyle (nt, x, n), loc)
-      | L.DInitializer e => SOME (L'.DInitializer (explifyExp e), loc)
+      | L.DTask (e1, e2) => SOME (L'.DTask (explifyExp e1, explifyExp e2), loc)
 
 and explifyStr (str, loc) =
     case str of
diff --git a/src/mono.sml b/src/mono.sml
index 1962c6c5..e5e68bfa 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -139,7 +139,7 @@ datatype decl' =
        | DCookie of string
        | DStyle of string
 
-       | DInitializer of exp
+       | DTask of exp * exp
 
 withtype decl = decl' located
 
diff --git a/src/mono_env.sml b/src/mono_env.sml
index 6ffab153..c2e6cf02 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.sml
@@ -129,7 +129,7 @@ fun declBinds env (d, loc) =
       | DJavaScript _ => env
       | DCookie _ => env
       | DStyle _ => env
-      | DInitializer _ => env
+      | DTask _ => env
 
 fun patBinds env (p, loc) =
     case p of
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 13c45329..da34c220 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -491,9 +491,13 @@ fun p_decl env (dAll as (d, _) : decl) =
       | DStyle s => box [string "style",
                          space,
                          string s]
-      | DInitializer e => box [string "initializer",
+      | DTask (e1, e2) => box [string "task",
                                space,
-                               p_exp env e]
+                               p_exp env e1,
+                               space,
+                               string "=",
+                               space,
+                               p_exp env e2]
 
                           
 fun p_file env file =
diff --git a/src/mono_shake.sml b/src/mono_shake.sml
index fc46cf96..048cc190 100644
--- a/src/mono_shake.sml
+++ b/src/mono_shake.sml
@@ -57,7 +57,7 @@ fun shake file =
                 (fn ((DExport (_, _, n, _, _), _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n))
                   | ((DDatabase {expunge = n1, initialize = n2, ...}, _), (page_cs, page_es)) =>
                     (page_cs, IS.addList (page_es, [n1, n2]))
-                  | ((DInitializer e, _), st) => usedVars st e
+                  | ((DTask (e1, e2), _), st) => usedVars (usedVars st e2) e1
                   | (_, st) => st) (IS.empty, IS.empty) file
 
         val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) =>
@@ -74,7 +74,7 @@ fun shake file =
                                    | ((DJavaScript _, _), acc) => acc
                                    | ((DCookie _, _), acc) => acc
                                    | ((DStyle _, _), acc) => acc
-                                   | ((DInitializer _, _), acc) => acc)
+                                   | ((DTask _, _), acc) => acc)
                                  (IM.empty, IM.empty) file
 
         fun typ (c, s) =
@@ -141,7 +141,7 @@ fun shake file =
                       | (DJavaScript _, _) => true
                       | (DCookie _, _) => true
                       | (DStyle _, _) => true
-                      | (DInitializer _, _) => true) file
+                      | (DTask _, _) => true) file
     end
 
 end
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 184ce168..894e35d0 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -528,10 +528,12 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
               | DJavaScript _ => S.return2 dAll
               | DCookie _ => S.return2 dAll
               | DStyle _ => S.return2 dAll
-              | DInitializer e =>
-                S.map2 (mfe ctx e,
-                     fn e' =>
-                        (DInitializer e', loc))
+              | DTask (e1, e2) =>
+                S.bind2 (mfe ctx e1,
+                     fn e1' =>
+                        S.map2 (mfe ctx e2,
+                             fn e2' =>
+                                (DTask (e1', e2'), loc)))
 
         and mfvi ctx (x, n, t, e, s) =
             S.bind2 (mft t,
@@ -618,7 +620,7 @@ fun mapfoldB (all as {bind, ...}) =
                                       | DJavaScript _ => ctx
                                       | DCookie _ => ctx
                                       | DStyle _ => ctx
-                                      | DInitializer _ => ctx
+                                      | DTask _ => ctx
                             in
                                 S.map2 (mff ctx' ds',
                                      fn ds' =>
@@ -672,7 +674,7 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
                           | DJavaScript _ => count
                           | DCookie _ => count
                           | DStyle _ => count
-                          | DInitializer _ => count) 0
+                          | DTask _ => count) 0
 
 end
 
diff --git a/src/monoize.sml b/src/monoize.sml
index 503fd6b3..f6a56c33 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3478,13 +3478,14 @@ fun monoDecl (env, fm) (all as (d, loc)) =
                       [(L'.DStyle s, loc),
                        (L'.DVal (x, n, t', e, s), loc)])
             end
-          | L.DInitializer e =>
+          | L.DTask (e1, e2) =>
             let
-                val (e, fm) = monoExp (env, St.empty, fm) e
+                val (e1, fm) = monoExp (env, St.empty, fm) e1
+                val (e2, fm) = monoExp (env, St.empty, fm) e2
             in
                 SOME (env,
                       fm,
-                      [(L'.DInitializer e, loc)])
+                      [(L'.DTask (e1, e2), loc)])
             end
     end
 
diff --git a/src/prepare.sml b/src/prepare.sml
index 7cbd7d76..2d144c67 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -325,11 +325,11 @@ fun prepDecl (d as (_, loc), st) =
       | DJavaScript _ => (d, st)
       | DCookie _ => (d, st)
       | DStyle _ => (d, st)
-      | DInitializer e =>
+      | DTask (tk, e) =>
         let
             val (e, st) = prepExp (e, st)
         in
-            ((DInitializer e, loc), st)
+            ((DTask (tk, e), loc), st)
         end
 
 fun prepare (ds, ps) =
diff --git a/src/reduce.sml b/src/reduce.sml
index cedb79fa..95b26da8 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -804,11 +804,12 @@ fun reduce file =
               | DDatabase _ => (d, st)
               | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st)
               | DStyle (s, n, s') => ((DStyle (s, n, s'), loc), st)
-              | DInitializer e =>
+              | DTask (e1, e2) =>
                 let
-                    val e = exp (namedC, namedE) [] e
+                    val e1 = exp (namedC, namedE) [] e1
+                    val e2 = exp (namedC, namedE) [] e2
                 in
-                    ((DInitializer e, loc),
+                    ((DTask (e1, e2), loc),
                      (polyC,
                       namedC,
                       namedE))
diff --git a/src/reduce_local.sml b/src/reduce_local.sml
index 82490118..b040a1ec 100644
--- a/src/reduce_local.sml
+++ b/src/reduce_local.sml
@@ -251,7 +251,7 @@ fun reduce file =
               | DDatabase _ => d
               | DCookie _ => d
               | DStyle _ => d
-              | DInitializer e => (DInitializer (exp [] e), loc)
+              | DTask (e1, e2) => (DTask (exp [] e1, exp [] e2), loc)
     in
         map doDecl file
     end
diff --git a/src/shake.sml b/src/shake.sml
index 787500ea..d1810bea 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -79,7 +79,7 @@ fun shake file =
                     in
                         (usedE, usedC)
                     end
-                  | ((DInitializer e, _), st) => usedVars st e
+                  | ((DTask (e1, e2), _), st) => usedVars (usedVars st e1) e2
                   | (_, acc) => acc) (IS.empty, IS.empty) file
 
         val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef)
@@ -106,7 +106,7 @@ fun shake file =
                                      (cdef, IM.insert (edef, n, ([], c, dummye)))
                                    | ((DStyle (_, n, _), _), (cdef, edef)) =>
                                      (cdef, IM.insert (edef, n, ([], dummyt, dummye)))
-                                   | ((DInitializer _, _), acc) => acc)
+                                   | ((DTask _, _), acc) => acc)
                                  (IM.empty, IM.empty) file
 
         fun kind (_, s) = s
@@ -186,7 +186,7 @@ fun shake file =
                       | (DDatabase _, _) => true
                       | (DCookie _, _) => true
                       | (DStyle _, _) => true
-                      | (DInitializer _, _) => true) file
+                      | (DTask _, _) => true) file
     end
 
 end
diff --git a/src/source.sml b/src/source.sml
index e52872f0..dc867026 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -167,7 +167,7 @@ datatype decl' =
        | DDatabase of string
        | DCookie of string * con
        | DStyle of string
-       | DInitializer of exp
+       | DTask of exp * exp
 
      and str' =
          StrConst of decl list
diff --git a/src/source_print.sml b/src/source_print.sml
index 31fc2500..e3b4fe94 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -662,9 +662,13 @@ fun p_decl ((d, _) : decl) =
       | DStyle x => box [string "style",
                          space,
                          string x]
-      | DInitializer e => box [string "initializer",
+      | DTask (e1, e2) => box [string "task",
                                space,
-                               p_exp e]
+                               p_exp e1,
+                               space,
+                               string "=",
+                               space,
+                               p_exp e2]
 
 and p_str (str, _) =
     case str of
diff --git a/src/unnest.sml b/src/unnest.sml
index c4d9a8b5..e030bbc6 100644
--- a/src/unnest.sml
+++ b/src/unnest.sml
@@ -422,7 +422,7 @@ fun unnest file =
                   | DDatabase _ => default ()
                   | DCookie _ => default ()
                   | DStyle _ => default ()
-                  | DInitializer _ => explore ()
+                  | DTask _ => explore ()
             end
 
         and doStr (all as (str, loc), st) =
diff --git a/src/urweb.grm b/src/urweb.grm
index 8780d9f6..afe7be07 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -201,7 +201,7 @@ fun patType loc (p : pat) =
  | LET | IN
  | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | SELECT1
  | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW
- | COOKIE | STYLE | INITIALIZER
+ | COOKIE | STYLE | TASK
  | CASE | IF | THEN | ELSE | ANDALSO | ORELSE
 
  | XML_BEGIN of string | XML_END | XML_BEGIN_END of string
@@ -479,7 +479,7 @@ decl   : CON SYMBOL cargl2 kopt EQ cexp (let
                                          end)
        | COOKIE SYMBOL COLON cexp       ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))])
        | STYLE SYMBOL                   ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))])
-       | INITIALIZER eexp               ([(DInitializer eexp, s (INITIALIZERleft, eexpright))])
+       | TASK eapps EQ eexp             ([(DTask (eapps, eexp), s (TASKleft, eexpright))])
 
 dtype  : SYMBOL dargs EQ barOpt dcons   (SYMBOL, dargs, dcons)
 
diff --git a/src/urweb.lex b/src/urweb.lex
index d04822f7..5fb767b1 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -402,7 +402,7 @@ notags = [^<{\n]+;
 <INITIAL> "class"     => (Tokens.CLASS (pos yypos, pos yypos + size yytext));
 <INITIAL> "cookie"    => (Tokens.COOKIE (pos yypos, pos yypos + size yytext));
 <INITIAL> "style"     => (Tokens.STYLE (pos yypos, pos yypos + size yytext));
-<INITIAL> "initializer" => (Tokens.INITIALIZER (pos yypos, pos yypos + size yytext));
+<INITIAL> "task"      => (Tokens.TASK (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "Type"      => (Tokens.TYPE (pos yypos, pos yypos + size yytext));
 <INITIAL> "Name"      => (Tokens.NAME (pos yypos, pos yypos + size yytext));
diff --git a/tests/init.ur b/tests/init.ur
index 0a44a9e4..aafbb55f 100644
--- a/tests/init.ur
+++ b/tests/init.ur
@@ -1,6 +1,6 @@
 sequence seq
 table fred : {A : int, B : int}
 
-initializer
+task initialize =
     setval seq 1;
     dml (INSERT INTO fred (A, B) VALUES (0, 1))
-- 
cgit v1.2.3


From addaa90f75a4901481fb0f0f5890fff7e85e94db Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Tue, 29 Dec 2009 12:55:26 -0500
Subject: Octal and hexidecimal string escapes

---
 src/urweb.lex | 12 ++++++++++++
 1 file changed, 12 insertions(+)

(limited to 'src/urweb.lex')

diff --git a/src/urweb.lex b/src/urweb.lex
index 5fb767b1..d2227d16 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -168,6 +168,8 @@ ws = [\ \t\012];
 intconst = [0-9]+;
 realconst = [0-9]+\.[0-9]*;
 notags = [^<{\n]+;
+oint = [0-9][0-9][0-9];
+xint = x[0-9a-fA-F][0-9a-fA-F];
 
 %%
 
@@ -199,6 +201,16 @@ notags = [^<{\n]+;
 <STRING,CHAR> "\\t"   => (str := #"\t" :: !str; continue());
 <STRING,CHAR> "\n"    => (newline yypos;
 			  str := #"\n" :: !str; continue());
+<STRING,CHAR> "\\" {oint} => (case StringCvt.scanString (Int.scan StringCvt.OCT)
+                                                        (String.extract (yytext, 1, NONE)) of
+                                  NONE => ErrorMsg.errorAt' (pos yypos, pos yypos) "Illegal string escape"
+                                | SOME n => str := chr n :: !str;
+                              continue());
+<STRING,CHAR> "\\" {xint} => (case StringCvt.scanString (Int.scan StringCvt.HEX)
+                                                        (String.extract (yytext, 2, NONE)) of
+                                  NONE => ErrorMsg.errorAt' (pos yypos, pos yypos) "Illegal string escape"
+                                | SOME n => str := chr n :: !str;
+                              continue());
 
 <INITIAL> "#\""       => (YYBEGIN CHAR; strEnder := #"\""; strStart := pos yypos; str := []; continue());
 
-- 
cgit v1.2.3


From 227c87323603dc0b338e89997d2fce7ffc755fb0 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Tue, 12 Jan 2010 16:09:13 -0500
Subject: Allow escaped backslashes in literals; conversion betwixt int and
 char

---
 include/urweb.h  | 3 +++
 lib/ur/basis.urs | 3 ++-
 lib/ur/char.ur   | 3 +++
 lib/ur/char.urs  | 3 +++
 src/c/urweb.c    | 8 ++++++++
 src/urweb.lex    | 1 +
 6 files changed, 20 insertions(+), 1 deletion(-)

(limited to 'src/urweb.lex')

diff --git a/include/urweb.h b/include/urweb.h
index 84da7694..b62adce1 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -258,6 +258,9 @@ uw_Basis_bool uw_Basis_isxdigit(uw_context, uw_Basis_char);
 uw_Basis_char uw_Basis_tolower(uw_context, uw_Basis_char);
 uw_Basis_char uw_Basis_toupper(uw_context, uw_Basis_char);
 
+uw_Basis_int uw_Basis_ord(uw_context, uw_Basis_char);
+uw_Basis_char uw_Basis_chr(uw_context, uw_Basis_int);
+
 uw_Basis_string uw_Basis_currentUrl(uw_context);
 void uw_set_currentUrl(uw_context, char *);
 
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index d61763af..ea50b0b3 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -68,7 +68,8 @@ val isupper : char -> bool
 val isxdigit : char -> bool
 val tolower : char -> char
 val toupper : char -> char
-
+val ord : char -> int
+val chr : int -> char
 
 (** String operations *)
 
diff --git a/lib/ur/char.ur b/lib/ur/char.ur
index 29e181e6..d2890bea 100644
--- a/lib/ur/char.ur
+++ b/lib/ur/char.ur
@@ -14,3 +14,6 @@ val isUpper = Basis.isupper
 val isXdigit = Basis.isxdigit
 val toLower = Basis.tolower
 val toUpper = Basis.toupper
+
+val toInt = Basis.ord
+val fromInt = Basis.chr
diff --git a/lib/ur/char.urs b/lib/ur/char.urs
index 02e55632..c185af92 100644
--- a/lib/ur/char.urs
+++ b/lib/ur/char.urs
@@ -14,3 +14,6 @@ val isUpper : t -> bool
 val isXdigit : t -> bool
 val toLower : t -> t
 val toUpper : t -> t
+
+val toInt : t -> int
+val fromInt : int -> t
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 006e2e28..8ccecdaa 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -3375,6 +3375,14 @@ uw_Basis_char uw_Basis_toupper(uw_context ctx, uw_Basis_char c) {
   return toupper(c);
 }
 
+uw_Basis_int uw_Basis_ord(uw_context ctx, uw_Basis_char c) {
+  return (unsigned char)c;
+}
+
+uw_Basis_char uw_Basis_chr(uw_context ctx, uw_Basis_int n) {
+  return n;
+}
+
 uw_Basis_string uw_Basis_currentUrl(uw_context ctx) {
   return ctx->current_url;
 }
diff --git a/src/urweb.lex b/src/urweb.lex
index d2227d16..45f555dd 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -198,6 +198,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 <STRING,CHAR> "\\\""  => (str := #"\"" :: !str; continue());
 <STRING,CHAR> "\\'"   => (str := #"'" :: !str; continue());
 <STRING,CHAR> "\\n"   => (str := #"\n" :: !str; continue());
+<STRING,CHAR> "\\\\"  => (str := #"\\" :: !str; continue());
 <STRING,CHAR> "\\t"   => (str := #"\t" :: !str; continue());
 <STRING,CHAR> "\n"    => (newline yypos;
 			  str := #"\n" :: !str; continue());
-- 
cgit v1.2.3


From 6a326e3bb3eb16e04f3cca082f0dd67278e85785 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@hcoop.net>
Date: Sun, 4 Apr 2010 12:29:34 -0400
Subject: Pushing policies through

---
 lib/ur/basis.urs        |  9 +++++++++
 src/cjrize.sml          |  1 +
 src/core.sml            |  1 +
 src/core_env.sml        |  1 +
 src/core_print.sml      |  3 +++
 src/core_util.sml       |  8 +++++++-
 src/corify.sml          |  6 +++++-
 src/css.sml             |  1 +
 src/elab.sml            |  1 +
 src/elab_env.sml        |  1 +
 src/elab_print.sml      |  3 +++
 src/elab_util.sml       |  8 +++++++-
 src/elaborate.sml       | 10 ++++++++++
 src/elisp/urweb-defs.el |  6 +++---
 src/elisp/urweb-mode.el |  4 ++--
 src/expl.sml            |  1 +
 src/expl_env.sml        |  1 +
 src/expl_print.sml      |  3 +++
 src/explify.sml         |  1 +
 src/mono.sml            |  6 +++++-
 src/mono_env.sml        |  1 +
 src/mono_print.sml      |  9 +++++++++
 src/mono_shake.sml      | 13 +++++++++++--
 src/mono_util.sml       | 14 +++++++++++++-
 src/monoize.sml         | 14 ++++++++++++++
 src/reduce.sml          |  9 +++++++++
 src/reduce_local.sml    |  1 +
 src/shake.sml           | 11 +++++++++--
 src/source.sml          |  1 +
 src/source_print.sml    |  3 +++
 src/unnest.sml          |  1 +
 src/urweb.grm           |  3 ++-
 src/urweb.lex           |  1 +
 tests/policy.ur         |  3 +++
 tests/policy.urp        |  1 +
 35 files changed, 145 insertions(+), 15 deletions(-)
 create mode 100644 tests/policy.ur
 create mode 100644 tests/policy.urp

(limited to 'src/urweb.lex')

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 8388e107..aad04b5f 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -795,4 +795,13 @@ type task_kind
 val initialize : task_kind
 
 
+(** Information flow security *)
+
+type sql_policy
+
+val query_policy : tables ::: {{Type}} -> exps ::: {Type}
+                   -> [tables ~ exps] => sql_query [] tables exps
+                   -> sql_policy
+
+
 val debug : string -> transaction unit
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 6e41a69b..b98b3c25 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -674,6 +674,7 @@ fun cifyDecl ((d, loc), sm) =
              end
            | _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined";
                    (NONE, NONE, sm)))
+      | L.DPolicy _ => (NONE, NONE, sm)
 
 fun cjrize ds =
     let
diff --git a/src/core.sml b/src/core.sml
index 90005f16..e5358f48 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -135,6 +135,7 @@ datatype decl' =
        | DCookie of string * int * con * string
        | DStyle of string * int * string
        | DTask of exp * exp
+       | DPolicy of exp
 
 withtype decl = decl' located
 
diff --git a/src/core_env.sml b/src/core_env.sml
index 9001e29c..478ef495 100644
--- a/src/core_env.sml
+++ b/src/core_env.sml
@@ -349,6 +349,7 @@ fun declBinds env (d, loc) =
             pushENamed env x n t NONE s
         end
       | DTask _ => env
+      | DPolicy _ => env
 
 fun patBinds env (p, loc) =
     case p of
diff --git a/src/core_print.sml b/src/core_print.sml
index d6be76a3..fd0556e6 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -618,6 +618,9 @@ fun p_decl env (dAll as (d, _) : decl) =
                                string "=",
                                space,
                                p_exp env e2]
+      | DPolicy e1 => box [string "policy",
+                           space,
+                           p_exp env e1]
 
 fun p_file env file =
     let
diff --git a/src/core_util.sml b/src/core_util.sml
index 247dd32e..eedcd2bb 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -992,6 +992,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} =
                         S.map2 (mfe ctx e2,
                              fn e2' =>
                                 (DTask (e1', e2'), loc)))
+              | DPolicy e =>
+                S.map2 (mfe ctx e,
+                     fn e' =>
+                        (DPolicy e', loc))
 
         and mfvi ctx (x, n, t, e, s) =
             S.bind2 (mfc ctx t,
@@ -1147,6 +1151,7 @@ fun mapfoldB (all as {bind, ...}) =
                                             bind (ctx, NamedE (x, n, t, NONE, s))
                                         end
                                       | DTask _ => ctx
+                                      | DPolicy _ => ctx
                             in
                                 S.map2 (mff ctx' ds',
                                      fn ds' =>
@@ -1210,7 +1215,8 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
                           | DDatabase _ => count
                           | DCookie (_, n, _, _) => Int.max (n, count)
                           | DStyle (_, n, _) => Int.max (n, count)
-                          | DTask _ => count) 0
+                          | DTask _ => count
+                          | DPolicy _ => count) 0
               
 end
 
diff --git a/src/corify.sml b/src/corify.sml
index 6931600e..88473455 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -1080,6 +1080,9 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
       | L.DTask (e1, e2) =>
         ([(L'.DTask (corifyExp st e1, corifyExp st e2), loc)], st)
 
+      | L.DPolicy e1 =>
+        ([(L'.DPolicy (corifyExp st e1), loc)], st)
+
 and corifyStr mods ((str, _), st) =
     case str of
         L.StrConst ds =>
@@ -1137,7 +1140,8 @@ fun maxName ds = foldl (fn ((d, _), n) =>
                              | L.DDatabase _ => n
                              | L.DCookie (_, _, n', _) => Int.max (n, n')
                              | L.DStyle (_, _, n') => Int.max (n, n')
-                             | L.DTask _ => n)
+                             | L.DTask _ => n
+                             | L.DPolicy _ => n)
                        0 ds
 
 and maxNameStr (str, _) =
diff --git a/src/css.sml b/src/css.sml
index 7189904f..3df35ed1 100644
--- a/src/css.sml
+++ b/src/css.sml
@@ -287,6 +287,7 @@ fun summarize file =
                   | DCookie _ => st
                   | DStyle (_, n, s) => (IM.insert (globals, n, (SOME s, [])), classes)
                   | DTask _ => st
+                  | DPolicy _ => st
             end
 
         val (globals, classes) = foldl decl (IM.empty, IM.empty) file
diff --git a/src/elab.sml b/src/elab.sml
index a0f9a4e8..e040a059 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -171,6 +171,7 @@ datatype decl' =
        | DCookie of int * string * int * con
        | DStyle of int * string * int
        | DTask of exp * exp
+       | DPolicy of exp
 
      and str' =
          StrConst of decl list
diff --git a/src/elab_env.sml b/src/elab_env.sml
index 5092c6fb..dd050c9e 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -1623,5 +1623,6 @@ fun declBinds env (d, loc) =
             pushENamedAs env x n t
         end
       | DTask _ => env
+      | DPolicy _ => env
 
 end
diff --git a/src/elab_print.sml b/src/elab_print.sml
index 62b5262f..86448659 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -806,6 +806,9 @@ fun p_decl env (dAll as (d, _) : decl) =
                                string "=",
                                space,
                                p_exp env e2]
+      | DPolicy e1 => box [string "policy",
+                           space,
+                           p_exp env e1]
 
 and p_str env (str, _) =
     case str of
diff --git a/src/elab_util.sml b/src/elab_util.sml
index d0e140c5..8345e3f3 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -854,7 +854,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
                                                                                 c), loc)))
                                                  | DStyle (tn, x, n) =>
                                                    bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc)))
-                                                 | DTask _ => ctx,
+                                                 | DTask _ => ctx
+                                                 | DPolicy _ => ctx,
                                                mfd ctx d)) ctx ds,
                      fn ds' => (StrConst ds', loc))
               | StrVar _ => S.return2 strAll
@@ -985,6 +986,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
                            S.map2 (mfe ctx e2,
                                 fn e2' =>
                                    (DTask (e1', e2'), loc)))
+              | DPolicy e1 =>
+                S.map2 (mfe ctx e1,
+                     fn e1' =>
+                        (DPolicy e1', loc))
 
         and mfvi ctx (x, n, c, e) =
             S.bind2 (mfc ctx c,
@@ -1128,6 +1133,7 @@ and maxNameDecl (d, _) =
       | DCookie (n1, _, n2, _) => Int.max (n1, n2)
       | DStyle (n1, _, n2) => Int.max (n1, n2)
       | DTask _ => 0
+      | DPolicy _ => 0
 and maxNameStr (str, _) =
     case str of
         StrConst ds => maxName ds
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 1651f344..07818a57 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -2595,6 +2595,7 @@ and sgiOfDecl (d, loc) =
       | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)]
       | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)]
       | L'.DTask _ => []
+      | L'.DPolicy _ => []
 
 and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) =
     ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1),
@@ -3729,6 +3730,15 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
                     checkCon env e2' t2 t2';
                     ([(L'.DTask (e1', e2'), loc)], (env, denv, gs2 @ gs1 @ gs))
                 end
+              | L.DPolicy e1 =>
+                let
+                    val (e1', t1, gs1) = elabExp (env, denv) e1
+
+                    val t1' = (L'.CModProj (!basis_r, [], "sql_policy"), loc)
+                in
+                    checkCon env e1' t1 t1';
+                    ([(L'.DPolicy e1', loc)], (env, denv, gs1 @ gs))
+                end
 
         (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*)
     in
diff --git a/src/elisp/urweb-defs.el b/src/elisp/urweb-defs.el
index c697a274..8054d829 100644
--- a/src/elisp/urweb-defs.el
+++ b/src/elisp/urweb-defs.el
@@ -108,7 +108,7 @@ notion of \"the end of an outline\".")
                  "datatype" "type" "open" "include"
                  urweb-module-head-syms
                  "con" "map" "where" "extern" "constraint" "constraints"
-                 "table" "sequence" "class" "cookie" "task")
+                 "table" "sequence" "class" "cookie" "task" "policy")
   "Symbols starting an sexp.")
 
 ;; (defconst urweb-not-arg-start-re
@@ -135,7 +135,7 @@ notion of \"the end of an outline\".")
      (("case" "datatype" "if" "then" "else"
        "let" "open" "sig" "struct" "type" "val"
        "con" "constraint" "table" "sequence" "class" "cookie"
-       "task")))))
+       "task" "policy")))))
 
 (defconst urweb-starters-indent-after
   (urweb-syms-re "let" "in" "struct" "sig")
@@ -190,7 +190,7 @@ for all symbols and in all lines starting with the given symbol."
 	  '("datatype" "fun"
 	    "open" "type" "val" "and"
 	    "con" "constraint" "table" "sequence" "class" "cookie"
-            "task"))
+            "task" "policy"))
   "The starters of new expressions.")
 
 (defconst urweb-exptrail-syms
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index 107ea3bc..c9fe5f19 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -136,7 +136,7 @@ See doc for the variable `urweb-mode-info'."
 	       "datatype" "else" "end" "extern" "fn" "map"
 	       "fun" "functor" "if" "include"
 	       "of" "open" "let" "in"
-	       "rec" "sequence" "sig" "signature" "cookie" "style" "task"
+	       "rec" "sequence" "sig" "signature" "cookie" "style" "task" "policy"
 	       "struct" "structure" "table" "view" "then" "type" "val" "where"
 	       "with"
 
@@ -226,7 +226,7 @@ See doc for the variable `urweb-mode-info'."
     ("\\<\\(\\(data\\)?type\\|con\\|class\\)\\s-+\\(\\sw+\\)"
      (1 font-lock-keyword-face)
      (3 (amAttribute font-lock-type-def-face)))
-    ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\|task\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
+    ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\|task\\|policy\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]"
      (1 font-lock-keyword-face)
      (3 (amAttribute font-lock-variable-name-face)))
     ("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)"
diff --git a/src/expl.sml b/src/expl.sml
index 17797626..1212383f 100644
--- a/src/expl.sml
+++ b/src/expl.sml
@@ -148,6 +148,7 @@ datatype decl' =
        | DCookie of int * string * int * con
        | DStyle of int * string * int
        | DTask of exp * exp
+       | DPolicy of exp
 
      and str' =
          StrConst of decl list
diff --git a/src/expl_env.sml b/src/expl_env.sml
index 0bf7323f..583e4881 100644
--- a/src/expl_env.sml
+++ b/src/expl_env.sml
@@ -344,6 +344,7 @@ fun declBinds env (d, loc) =
             pushENamed env x n t
         end
       | DTask _ => env
+      | DPolicy _ => env
 
 fun sgiBinds env (sgi, loc) =
     case sgi of
diff --git a/src/expl_print.sml b/src/expl_print.sml
index 5284eecb..15838729 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -720,6 +720,9 @@ fun p_decl env (dAll as (d, _) : decl) =
                                string "=",
                                space,
                                p_exp env e2]
+      | DPolicy e1 => box [string "policy",
+                           space,
+                           p_exp env e1]
 
 and p_str env (str, _) =
     case str of
diff --git a/src/explify.sml b/src/explify.sml
index aff91a34..0013906f 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -196,6 +196,7 @@ fun explifyDecl (d, loc : EM.span) =
       | L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc)
       | L.DStyle (nt, x, n) => SOME (L'.DStyle (nt, x, n), loc)
       | L.DTask (e1, e2) => SOME (L'.DTask (explifyExp e1, explifyExp e2), loc)
+      | L.DPolicy e1 => SOME (L'.DPolicy (explifyExp e1), loc)
 
 and explifyStr (str, loc) =
     case str of
diff --git a/src/mono.sml b/src/mono.sml
index 898feb9b..33ab5bd4 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008, Adam Chlipala
+(* Copyright (c) 2008-2010, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
@@ -123,6 +123,8 @@ datatype exp' =
 
 withtype exp = exp' located
 
+datatype policy = PolQuery of exp
+
 datatype decl' =
          DDatatype of (string * int * (string * int * typ option) list) list
        | DVal of string * int * typ * exp * string
@@ -141,6 +143,8 @@ datatype decl' =
 
        | DTask of exp * exp
 
+       | DPolicy of policy
+
 withtype decl = decl' located
 
 type file = decl list
diff --git a/src/mono_env.sml b/src/mono_env.sml
index c2e6cf02..87f96488 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.sml
@@ -130,6 +130,7 @@ fun declBinds env (d, loc) =
       | DCookie _ => env
       | DStyle _ => env
       | DTask _ => env
+      | DPolicy _ => env
 
 fun patBinds env (p, loc) =
     case p of
diff --git a/src/mono_print.sml b/src/mono_print.sml
index d1f5fc27..50c4717a 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -412,6 +412,12 @@ fun p_datatype env (x, n, cons) =
                         cons]
     end
 
+fun p_policy env pol =
+    case pol of
+        PolQuery e => box [string "query",
+                           space,
+                           p_exp env e]
+
 fun p_decl env (dAll as (d, _) : decl) =
     case d of
         DDatatype x => box [string "datatype",
@@ -506,6 +512,9 @@ fun p_decl env (dAll as (d, _) : decl) =
                                string "=",
                                space,
                                p_exp env e2]
+      | DPolicy p => box [string "policy",
+                          space,
+                          p_policy env p]
 
                           
 fun p_file env file =
diff --git a/src/mono_shake.sml b/src/mono_shake.sml
index e53b6930..358b31d2 100644
--- a/src/mono_shake.sml
+++ b/src/mono_shake.sml
@@ -58,6 +58,13 @@ fun shake file =
                   | ((DDatabase {expunge = n1, initialize = n2, ...}, _), (page_cs, page_es)) =>
                     (page_cs, IS.addList (page_es, [n1, n2]))
                   | ((DTask (e1, e2), _), st) => usedVars (usedVars st e2) e1
+                  | ((DPolicy pol, _), st) =>
+                    let
+                        val e1 = case pol of
+                                     PolQuery e1 => e1
+                    in
+                        usedVars st e1
+                    end
                   | (_, st) => st) (IS.empty, IS.empty) file
 
         val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) =>
@@ -74,7 +81,8 @@ fun shake file =
                                    | ((DJavaScript _, _), acc) => acc
                                    | ((DCookie _, _), acc) => acc
                                    | ((DStyle _, _), acc) => acc
-                                   | ((DTask _, _), acc) => acc)
+                                   | ((DTask _, _), acc) => acc
+                                   | ((DPolicy _, _), acc) => acc)
                                  (IM.empty, IM.empty) file
 
         fun typ (c, s) =
@@ -141,7 +149,8 @@ fun shake file =
                       | (DJavaScript _, _) => true
                       | (DCookie _, _) => true
                       | (DStyle _, _) => true
-                      | (DTask _, _) => true) file
+                      | (DTask _, _) => true
+                      | (DPolicy _, _) => true) file
     end
 
 end
diff --git a/src/mono_util.sml b/src/mono_util.sml
index a75843c4..094f216b 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -534,6 +534,16 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
                         S.map2 (mfe ctx e2,
                              fn e2' =>
                                 (DTask (e1', e2'), loc)))
+              | DPolicy pol =>
+                S.map2 (mfpol ctx pol,
+                     fn p' =>
+                        (DPolicy p', loc))
+
+        and mfpol ctx pol =
+            case pol of
+                PolQuery e =>
+                S.map2 (mfe ctx e,
+                        PolQuery)
 
         and mfvi ctx (x, n, t, e, s) =
             S.bind2 (mft t,
@@ -621,6 +631,7 @@ fun mapfoldB (all as {bind, ...}) =
                                       | DCookie _ => ctx
                                       | DStyle _ => ctx
                                       | DTask _ => ctx
+                                      | DPolicy _ => ctx
                             in
                                 S.map2 (mff ctx' ds',
                                      fn ds' =>
@@ -674,7 +685,8 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
                           | DJavaScript _ => count
                           | DCookie _ => count
                           | DStyle _ => count
-                          | DTask _ => count) 0
+                          | DTask _ => count
+                          | DPolicy _ => count) 0
 
 end
 
diff --git a/src/monoize.sml b/src/monoize.sml
index 25ea87f5..6f229766 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3738,6 +3738,20 @@ fun monoDecl (env, fm) (all as (d, loc)) =
                       fm,
                       [(L'.DTask (e1, e2), loc)])
             end
+          | L.DPolicy e =>
+            let
+                val (e, make) =
+                    case #1 e of
+                        L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "query_policy"), _), _), _), _), _), e) =>
+                        (e, L'.PolQuery)
+                      | _ => (poly (); (e, L'.PolQuery))
+
+                val (e, fm) = monoExp (env, St.empty, fm) e
+            in
+                SOME (env,
+                      fm,
+                      [(L'.DPolicy (make e), loc)])
+            end
     end
 
 datatype expungable = Client | Channel
diff --git a/src/reduce.sml b/src/reduce.sml
index b7ad567a..cefe1955 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -746,6 +746,15 @@ fun reduce file =
                       namedC,
                       namedE))
                 end
+              | DPolicy e1 =>
+                let
+                    val e1 = exp (namedC, namedE) [] e1
+                in
+                    ((DPolicy e1, loc),
+                     (polyC,
+                      namedC,
+                      namedE))
+                end
 
         val (file, _) = ListUtil.foldlMap doDecl (IS.empty, IM.empty, IM.empty) file
     in
diff --git a/src/reduce_local.sml b/src/reduce_local.sml
index b040a1ec..4c5ab52e 100644
--- a/src/reduce_local.sml
+++ b/src/reduce_local.sml
@@ -252,6 +252,7 @@ fun reduce file =
               | DCookie _ => d
               | DStyle _ => d
               | DTask (e1, e2) => (DTask (exp [] e1, exp [] e2), loc)
+              | DPolicy e1 => (DPolicy (exp [] e1), loc)
     in
         map doDecl file
     end
diff --git a/src/shake.sml b/src/shake.sml
index 686a043c..f679c6e8 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -90,6 +90,11 @@ fun shake file =
                         st
                     else
                         usedVars (usedVars st e1) e2
+                  | ((DPolicy e1, _), st) =>
+                    if !sliceDb then
+                        st
+                    else
+                        usedVars st e1
                   | (_, acc) => acc) (IS.empty, IS.empty) file
 
         val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef)
@@ -116,7 +121,8 @@ fun shake file =
                                      (cdef, IM.insert (edef, n, ([], c, dummye)))
                                    | ((DStyle (_, n, _), _), (cdef, edef)) =>
                                      (cdef, IM.insert (edef, n, ([], dummyt, dummye)))
-                                   | ((DTask _, _), acc) => acc)
+                                   | ((DTask _, _), acc) => acc
+                                   | ((DPolicy _, _), acc) => acc)
                                  (IM.empty, IM.empty) file
 
         fun kind (_, s) = s
@@ -203,7 +209,8 @@ fun shake file =
                       | (DDatabase _, _) => not (!sliceDb)
                       | (DCookie _, _) => not (!sliceDb)
                       | (DStyle _, _) => not (!sliceDb)
-                      | (DTask _, _) => not (!sliceDb)) file
+                      | (DTask _, _) => not (!sliceDb)
+                      | (DPolicy _, _) => not (!sliceDb)) file
     end
 
 end
diff --git a/src/source.sml b/src/source.sml
index dc867026..9768cfc0 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -168,6 +168,7 @@ datatype decl' =
        | DCookie of string * con
        | DStyle of string
        | DTask of exp * exp
+       | DPolicy of exp
 
      and str' =
          StrConst of decl list
diff --git a/src/source_print.sml b/src/source_print.sml
index e3b4fe94..590d15d5 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -669,6 +669,9 @@ fun p_decl ((d, _) : decl) =
                                string "=",
                                space,
                                p_exp e2]
+      | DPolicy e1 => box [string "policy",
+                           space,
+                           p_exp e1]
 
 and p_str (str, _) =
     case str of
diff --git a/src/unnest.sml b/src/unnest.sml
index e030bbc6..77589bfb 100644
--- a/src/unnest.sml
+++ b/src/unnest.sml
@@ -423,6 +423,7 @@ fun unnest file =
                   | DCookie _ => default ()
                   | DStyle _ => default ()
                   | DTask _ => explore ()
+                  | DPolicy _ => explore ()
             end
 
         and doStr (all as (str, loc), st) =
diff --git a/src/urweb.grm b/src/urweb.grm
index ad3de6b2..3df9554f 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -202,7 +202,7 @@ fun patType loc (p : pat) =
  | LET | IN
  | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | SELECT1
  | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW
- | COOKIE | STYLE | TASK
+ | COOKIE | STYLE | TASK | POLICY
  | CASE | IF | THEN | ELSE | ANDALSO | ORELSE
 
  | XML_BEGIN of string | XML_END | XML_BEGIN_END of string
@@ -481,6 +481,7 @@ decl   : CON SYMBOL cargl2 kopt EQ cexp (let
        | COOKIE SYMBOL COLON cexp       ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))])
        | STYLE SYMBOL                   ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))])
        | TASK eapps EQ eexp             ([(DTask (eapps, eexp), s (TASKleft, eexpright))])
+       | POLICY eexp                    ([(DPolicy eexp, s (POLICYleft, eexpright))])
 
 dtype  : SYMBOL dargs EQ barOpt dcons   (SYMBOL, dargs, dcons)
 
diff --git a/src/urweb.lex b/src/urweb.lex
index 45f555dd..8930c463 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -416,6 +416,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 <INITIAL> "cookie"    => (Tokens.COOKIE (pos yypos, pos yypos + size yytext));
 <INITIAL> "style"     => (Tokens.STYLE (pos yypos, pos yypos + size yytext));
 <INITIAL> "task"      => (Tokens.TASK (pos yypos, pos yypos + size yytext));
+<INITIAL> "policy"    => (Tokens.POLICY (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "Type"      => (Tokens.TYPE (pos yypos, pos yypos + size yytext));
 <INITIAL> "Name"      => (Tokens.NAME (pos yypos, pos yypos + size yytext));
diff --git a/tests/policy.ur b/tests/policy.ur
new file mode 100644
index 00000000..db87b582
--- /dev/null
+++ b/tests/policy.ur
@@ -0,0 +1,3 @@
+table fruit : { Id : int, Nam : string, Weight : float }
+
+policy query_policy (SELECT * FROM fruit)
diff --git a/tests/policy.urp b/tests/policy.urp
new file mode 100644
index 00000000..b26ebd4a
--- /dev/null
+++ b/tests/policy.urp
@@ -0,0 +1 @@
+policy
-- 
cgit v1.2.3


From 4bc2b6c4388096c65e2b45b186722e32267948d8 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Tue, 10 Aug 2010 14:44:26 -0400
Subject: ML-style comments inside XML

---
 src/urweb.lex       | 30 +++++++++++++++++++++---------
 tests/xcomments.ur  |  8 ++++++++
 tests/xcomments.urp |  1 +
 tests/xcomments.urs |  1 +
 4 files changed, 31 insertions(+), 9 deletions(-)
 create mode 100644 tests/xcomments.ur
 create mode 100644 tests/xcomments.urp
 create mode 100644 tests/xcomments.urs

(limited to 'src/urweb.lex')

diff --git a/src/urweb.lex b/src/urweb.lex
index 8930c463..8a989884 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -34,6 +34,8 @@ type svalue = Tokens.svalue
 type ('a,'b) token = ('a,'b) Tokens.token
 type lexresult = (svalue,pos) Tokens.token
 
+val commentOut = ref (fn () => ())
+
 local
   val commentLevel = ref 0
   val commentPos = ref 0
@@ -47,7 +49,10 @@ in
     
   fun exitComment () =
       (ignore (commentLevel := !commentLevel - 1);
-       !commentLevel = 0)
+       if !commentLevel = 0 then
+           !commentOut ()
+       else
+           ())
 
   fun eof () = 
     let 
@@ -167,17 +172,14 @@ cid = [A-Z][A-Za-z0-9_]*;
 ws = [\ \t\012];
 intconst = [0-9]+;
 realconst = [0-9]+\.[0-9]*;
-notags = [^<{\n]+;
+notags = [^<{\n(]+;
 oint = [0-9][0-9][0-9];
 xint = x[0-9a-fA-F][0-9a-fA-F];
 
 %%
 
-<INITIAL> \n          => (newline yypos;
-                          continue ());
-<COMMENT> \n          => (newline yypos;
-                          continue ());
-<XMLTAG> \n           => (newline yypos;
+<INITIAL,COMMENT,XMLTAG>
+      \n              => (newline yypos;
                           continue ());
 <XML> \n              => (newline yypos;
                           Tokens.NOTAGS (yytext, yypos, yypos + size yytext));
@@ -185,14 +187,24 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 <INITIAL> {ws}+       => (lex ());
 
 <INITIAL> "(*"        => (YYBEGIN COMMENT;
+                          commentOut := (fn () => YYBEGIN INITIAL);
+                          enterComment (pos yypos);
+                          continue ());
+<XML> "(*"            => (YYBEGIN COMMENT;
+                          commentOut := (fn () => YYBEGIN XML);
+                          enterComment (pos yypos);
+                          continue ());
+<XMLTAG> "(*"         => (YYBEGIN COMMENT;
+                          commentOut := (fn () => YYBEGIN XMLTAG);
                           enterComment (pos yypos);
                           continue ());
-<INITIAL> "*)"        => (ErrorMsg.errorAt' (pos yypos, pos yypos) "Unbalanced comments";
+<INITIAL,XML,XMLTAG>
+             "*)"     => (ErrorMsg.errorAt' (pos yypos, pos yypos) "Unbalanced comments";
 			  continue ());
 
 <COMMENT> "(*"        => (enterComment (pos yypos);
                           continue ());
-<COMMENT> "*)"        => (if exitComment () then YYBEGIN INITIAL else ();
+<COMMENT> "*)"        => (exitComment ();
 			  continue ());
 
 <STRING,CHAR> "\\\""  => (str := #"\"" :: !str; continue());
diff --git a/tests/xcomments.ur b/tests/xcomments.ur
new file mode 100644
index 00000000..61a0b34b
--- /dev/null
+++ b/tests/xcomments.ur
@@ -0,0 +1,8 @@
+fun foo () = <xml>Hi!</xml>
+
+(* fun bar () = return (* No *)<xml>Yes!</xml> *)
+
+fun main () = return <xml><body>
+  A (* B *) C (* D (* E *) F *) D<br/>
+  <b>A</b> <i>(* B *) C <b>D (* E *) F {foo ()}</b></i>
+</body></xml>
diff --git a/tests/xcomments.urp b/tests/xcomments.urp
new file mode 100644
index 00000000..1a0c34f8
--- /dev/null
+++ b/tests/xcomments.urp
@@ -0,0 +1 @@
+xcomments
diff --git a/tests/xcomments.urs b/tests/xcomments.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/xcomments.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page
-- 
cgit v1.2.3


From 55a669bc95cb2831f5a4fc084d2aa828863a1f07 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Tue, 10 Aug 2010 14:52:33 -0400
Subject: HTML comments

---
 src/urweb.lex      | 3 +++
 tests/xcomments.ur | 4 +++-
 2 files changed, 6 insertions(+), 1 deletion(-)

(limited to 'src/urweb.lex')

diff --git a/src/urweb.lex b/src/urweb.lex
index 8a989884..88b7d857 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -173,6 +173,7 @@ ws = [\ \t\012];
 intconst = [0-9]+;
 realconst = [0-9]+\.[0-9]*;
 notags = [^<{\n(]+;
+xcom = ([^-]|(-[^-]))+;
 oint = [0-9][0-9][0-9];
 xint = x[0-9a-fA-F][0-9a-fA-F];
 
@@ -207,6 +208,8 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 <COMMENT> "*)"        => (exitComment ();
 			  continue ());
 
+<XML> "<!--" {xcom} "-->" => (continue ());
+
 <STRING,CHAR> "\\\""  => (str := #"\"" :: !str; continue());
 <STRING,CHAR> "\\'"   => (str := #"'" :: !str; continue());
 <STRING,CHAR> "\\n"   => (str := #"\n" :: !str; continue());
diff --git a/tests/xcomments.ur b/tests/xcomments.ur
index 61a0b34b..83608ff9 100644
--- a/tests/xcomments.ur
+++ b/tests/xcomments.ur
@@ -4,5 +4,7 @@ fun foo () = <xml>Hi!</xml>
 
 fun main () = return <xml><body>
   A (* B *) C (* D (* E *) F *) D<br/>
-  <b>A</b> <i>(* B *) C <b>D (* E *) F {foo ()}</b></i>
+  <b>A</b> <i>(* B *) C <b>D (* E <!-- 7 --> *) F {foo ()}</b></i>
+  A <!-- B --> C <!-- D (* E *) F --> D<br/>
+  <b>A</b> <i><!-- B --> C <b>D <!-- E --> F {foo ()}</b></i>
 </body></xml>
-- 
cgit v1.2.3


From 06f9a1fcbb40856fae744e49be3bf0e166246293 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Tue, 10 Aug 2010 15:55:43 -0400
Subject: Better UTF-8 escaping for JavaScript and SQL literals

---
 src/cjr_print.sml |  8 ++++----
 src/jscomp.sml    |  2 +-
 src/mysql.sml     | 14 +++++++-------
 src/postgres.sml  | 20 ++++++++++----------
 src/sqlite.sml    | 27 +++++++++++----------------
 src/urweb.lex     |  2 +-
 6 files changed, 34 insertions(+), 39 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 34936aac..412531a6 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2128,7 +2128,7 @@ fun p_decl env (dAll as (d, _) : decl) =
       | DPreparedStatements _ => box []
 
       | DJavaScript s => box [string "static char jslib[] = \"",
-                              string (String.toString s),
+                              string (String.toCString s),
                               string "\";"]
       | DCookie s => box [string "/*",
                           space,
@@ -2585,7 +2585,7 @@ fun p_file env (ds, ps) =
                             prefix ^ s
             in
                 box [string "if (!strncmp(request, \"",
-                     string (String.toString s),
+                     string (String.toCString s),
                      string "\", ",
                      string (Int.toString (size s)),
                      string ") && (request[",
@@ -2761,10 +2761,10 @@ fun p_file env (ds, ps) =
                           box [string "if (!str",
                                case #kind rule of
                                    Settings.Exact => box [string "cmp(s, \"",
-                                                          string (String.toString (#pattern rule)),
+                                                          string (String.toCString (#pattern rule)),
                                                           string "\"))"]
                                  | Settings.Prefix => box [string "ncmp(s, \"",
-                                                           string (String.toString (#pattern rule)),
+                                                           string (String.toCString (#pattern rule)),
                                                            string "\", ",
                                                            string (Int.toString (size (#pattern rule))),
                                                            string "))"],
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 4b04194c..f97725eb 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -435,7 +435,7 @@ fun process file =
                                       | #"\r" => "\\r"
                                       | #"\t" => "\\t"
                                       | ch =>
-                                        if Char.isPrint ch then
+                                        if Char.isPrint ch orelse ord ch >= 128 then
                                             String.str ch
                                         else
                                             "\\" ^ padWith (#"0",
diff --git a/src/mysql.sml b/src/mysql.sml
index fa49ced3..12d52255 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -344,7 +344,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
         fun stringOf r = case !r of
                              NONE => string "NULL"
                            | SOME s => box [string "\"",
-                                            string (String.toString s),
+                                            string (String.toCString s),
                                             string "\""]
     in
         app (fn s =>
@@ -477,7 +477,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
                                                                newline,
 
                                                                string "if (mysql_stmt_prepare(stmt, \"",
-                                                               string (String.toString s),
+                                                               string (String.toCString s),
                                                                string "\", ",
                                                                string (Int.toString (size s)),
                                                                string ")) {",
@@ -974,7 +974,7 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} =
               else
                   box [],
               string "if (mysql_stmt_prepare(stmt, \"",
-              string (String.toString query),
+              string (String.toCString query),
               string "\", ",
               string (Int.toString (size query)),
               string ")) {",
@@ -1185,7 +1185,7 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} =
          newline,
 
          queryCommon {loc = loc, cols = cols, doCols = doCols, query = box [string "\"",
-                                                                            string (String.toString query),
+                                                                            string (String.toCString query),
                                                                             string "\""]},
 
          if nested then
@@ -1276,7 +1276,7 @@ fun dmlPrepared {loc, id, dml, inputs} =
               string "if (stmt == NULL) uw_error(ctx, FATAL, \"Out of memory allocating prepared statement\");",
               newline,
               string "if (mysql_stmt_prepare(stmt, \"",
-              string (String.toString dml),
+              string (String.toCString dml),
               string "\", ",
               string (Int.toString (size dml)),
               string ")) {",
@@ -1470,7 +1470,7 @@ fun dmlPrepared {loc, id, dml, inputs} =
          newline,
 
          dmlCommon {loc = loc, dml = box [string "\"",
-                                          string (String.toString dml),
+                                          string (String.toCString dml),
                                           string "\""]}]
 
 fun nextval {loc, seqE, seqName} =
@@ -1514,7 +1514,7 @@ fun sqlifyString s = "'" ^ String.translate (fn #"'" => "\\'"
                                                     (ErrorMsg.error
                                                          "Non-printing character found in SQL string literal";
                                                      ""))
-                                            (String.toString s) ^ "'"
+                                            (String.toCString s) ^ "'"
 
 fun p_cast (s, _) = s
 
diff --git a/src/postgres.sml b/src/postgres.sml
index 8541ca4a..12e928c5 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -331,7 +331,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
                                                   box [string "res = PQprepare(conn, \"uw",
                                                        string (Int.toString i),
                                                        string "\", \"",
-                                                       string (String.toString s),
+                                                       string (String.toCString s),
                                                        string "\", ",
                                                        string (Int.toString n),
                                                        string ", NULL);",
@@ -349,7 +349,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
                                                             string "PQfinish(conn);",
                                                             newline,
                                                             string "uw_error(ctx, FATAL, \"Unable to create prepared statement:\\n",
-                                                            string (String.toString s),
+                                                            string (String.toCString s),
                                                             string "\\n%s\", msg);",
                                                             newline],
                                                        string "}",
@@ -473,7 +473,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
          string "static void uw_db_init(uw_context ctx) {",
          newline,
          string "PGconn *conn = PQconnectdb(\"",
-         string (String.toString dbstring),
+         string (String.toCString dbstring),
          string "\");",
          newline,
          string "if (conn == NULL) uw_error(ctx, FATAL, ",
@@ -698,14 +698,14 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols, nested = _} =
                   string ", paramValues, paramLengths, paramFormats, 0);"]
          else
              box [string "PQexecParams(conn, \"",
-                  string (String.toString query),
+                  string (String.toCString query),
                   string "\", ",
                   string (Int.toString (length inputs)),
                   string ", NULL, paramValues, paramLengths, paramFormats, 0);"],
          newline,
          newline,
          queryCommon {loc = loc, cols = cols, doCols = doCols, query = box [string "\"",
-                                                                            string (String.toString query),
+                                                                            string (String.toCString query),
                                                                             string "\""]}]
 
 fun dmlCommon {loc, dml} =
@@ -779,14 +779,14 @@ fun dmlPrepared {loc, id, dml, inputs} =
                   string ", paramValues, paramLengths, paramFormats, 0);"]
          else
              box [string "PQexecParams(conn, \"",
-                  string (String.toString dml),
+                  string (String.toCString dml),
                   string "\", ",
                   string (Int.toString (length inputs)),
                   string ", NULL, paramValues, paramLengths, paramFormats, 0);"],
          newline,
          newline,
          dmlCommon {loc = loc, dml = box [string "\"",
-                                          string (String.toString dml),
+                                          string (String.toCString dml),
                                           string "\""]}]
 
 fun nextvalCommon {loc, query} =
@@ -863,12 +863,12 @@ fun nextvalPrepared {loc, id, query} =
                   string "\", 0, NULL, NULL, NULL, 0);"]
          else
              box [string "PQexecParams(conn, \"",
-                  string (String.toString query),
+                  string (String.toCString query),
                   string "\", 0, NULL, NULL, NULL, NULL, 0);"],
          newline,
          newline,
          nextvalCommon {loc = loc, query = box [string "\"",
-                                                string (String.toString query),
+                                                string (String.toCString query),
                                                 string "\""]}]
 
 fun setvalCommon {loc, query} =
@@ -921,7 +921,7 @@ fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'"
                                                  else
                                                      "\\" ^ StringCvt.padLeft #"0" 3
                                                                               (Int.fmt StringCvt.OCT (ord ch)))
-                                             (String.toString s) ^ "'::text"
+                                             (String.toCString s) ^ "'::text"
 
 fun p_cast (s, t) = s ^ "::" ^ p_sql_type t
 
diff --git a/src/sqlite.sml b/src/sqlite.sml
index d628da16..74093f21 100644
--- a/src/sqlite.sml
+++ b/src/sqlite.sml
@@ -230,7 +230,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
                                                                    newline]
                                                       in
                                                           box [string "if (sqlite3_prepare_v2(conn->conn, \"",
-                                                               string (String.toString s),
+                                                               string (String.toCString s),
                                                                string "\", -1, &conn->p",
                                                                string (Int.toString i),
                                                                string ", NULL) != SQLITE_OK) {",
@@ -242,7 +242,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
                                                                     string "msg[1023] = 0;",
                                                                     newline,
                                                                     uhoh false ("Error preparing statement: "
-                                                                                ^ String.toString s ^ "<br />%s") ["msg"]],
+                                                                                ^ String.toCString s ^ "<br />%s") ["msg"]],
                                                                string "}",
                                                                newline]
                                                       end)
@@ -651,9 +651,9 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} =
                   newline],
 
          string "if (sqlite3_prepare_v2(conn->conn, \"",
-         string (String.toString query),
+         string (String.toCString query),
          string "\", -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: ",
-         string (String.toString query),
+         string (String.toCString query),
          string "<br />%s\", sqlite3_errmsg(conn->conn));",
          newline,
          if nested then
@@ -677,7 +677,7 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} =
          newline,
 
          queryCommon {loc = loc, cols = cols, doCols = doCols, query = box [string "\"",
-                                                                            string (String.toString query),
+                                                                            string (String.toCString query),
                                                                             string "\""]},
 
          string "uw_pop_cleanup(ctx);",
@@ -739,9 +739,9 @@ fun dmlPrepared {loc, id, dml, inputs} =
          string "if (stmt == NULL) {",
          newline,
          box [string "if (sqlite3_prepare_v2(conn->conn, \"",
-              string (String.toString dml),
+              string (String.toCString dml),
               string "\", -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: ",
-              string (String.toString dml),
+              string (String.toCString dml),
               string "<br />%s\", sqlite3_errmsg(conn->conn));",
               newline,
               string "conn->p",
@@ -760,7 +760,7 @@ fun dmlPrepared {loc, id, dml, inputs} =
          newline,
 
          dmlCommon {loc = loc, dml = box [string "\"",
-                                          string (String.toString dml),
+                                          string (String.toCString dml),
                                           string "\""]},
 
          string "uw_pop_cleanup(ctx);",
@@ -800,14 +800,9 @@ fun nextvalPrepared _ = raise Fail "SQLite.nextvalPrepared called"
 fun setval _ = raise Fail "SQLite.setval called"
 
 fun sqlifyString s = "'" ^ String.translate (fn #"'" => "''"
-                                              | ch =>
-                                                if Char.isPrint ch then
-                                                    str ch
-                                                else
-                                                    (ErrorMsg.error
-                                                         "Non-printing character found in SQL string literal";
-                                                     ""))
-                                            (String.toString s) ^ "'"
+                                              | #"\000" => ""
+                                              | ch => str ch)
+                                            s ^ "'"
 
 fun p_cast (s, _) = s
 
diff --git a/src/urweb.lex b/src/urweb.lex
index 88b7d857..27af5bdd 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -173,7 +173,7 @@ ws = [\ \t\012];
 intconst = [0-9]+;
 realconst = [0-9]+\.[0-9]*;
 notags = [^<{\n(]+;
-xcom = ([^-]|(-[^-]))+;
+xcom = ([^\-]|(-[^\-]))+;
 oint = [0-9][0-9][0-9];
 xint = x[0-9a-fA-F][0-9a-fA-F];
 
-- 
cgit v1.2.3


From 10abf930df47a214ef2d66a6727c9e159093bc57 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Thu, 16 Sep 2010 15:34:50 -0400
Subject: Fix typing of cut operators; fix lexing of XML comments

---
 src/elaborate.sml | 2 ++
 src/urweb.lex     | 2 +-
 2 files changed, 3 insertions(+), 1 deletion(-)

(limited to 'src/urweb.lex')

diff --git a/src/elaborate.sml b/src/elaborate.sml
index e7848f21..e3f42c19 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1998,6 +1998,7 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
                             
                 val gs3 = D.prove env denv (first, rest, loc)
             in
+                checkKind env c' ck kname;
                 ((L'.ECut (e', c', {field = ft, rest = rest}), loc), (L'.TRecord rest, loc),
                  gs1 @ enD gs2 @ enD gs3)
             end
@@ -2013,6 +2014,7 @@ fun elabExp (env, denv) (eAll as (e, loc)) =
                             
                 val gs3 = D.prove env denv (c', rest, loc)
             in
+                checkKind env c' ck (L'.KRecord ktype, loc);
                 ((L'.ECutMulti (e', c', {rest = rest}), loc), (L'.TRecord rest, loc),
                  gs1 @ enD gs2 @ enD gs3)
             end
diff --git a/src/urweb.lex b/src/urweb.lex
index 27af5bdd..0ee09cad 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -172,7 +172,7 @@ cid = [A-Z][A-Za-z0-9_]*;
 ws = [\ \t\012];
 intconst = [0-9]+;
 realconst = [0-9]+\.[0-9]*;
-notags = [^<{\n(]+;
+notags = ([^<{\n(]|(\([^\*]))+;
 xcom = ([^\-]|(-[^\-]))+;
 oint = [0-9][0-9][0-9];
 xint = x[0-9a-fA-F][0-9a-fA-F];
-- 
cgit v1.2.3


From bfeac162a328dba937a28e747e4fc4006fac500c Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Sun, 10 Oct 2010 13:07:38 -0400
Subject: Flex kinds for type-level tuples; ::_ notation

---
 demo/batchFun.ur   | 22 ++++++++--------------
 demo/crud.ur       | 46 ++++++++++++++++++----------------------------
 demo/metaform.ur   |  6 +++---
 doc/manual.tex     |  2 ++
 src/elab.sml       |  1 +
 src/elab_print.sml | 10 ++++++++++
 src/elab_util.sml  | 12 +++++++++++-
 src/elaborate.sml  | 49 ++++++++++++++++++++++++++++++++++++++++---------
 src/explify.sml    |  2 ++
 src/urweb.grm      | 27 ++++++++++++++++++++++++++-
 src/urweb.lex      |  1 +
 tests/ktuple.ur    |  2 ++
 tests/ktuple.urp   |  1 +
 13 files changed, 125 insertions(+), 56 deletions(-)
 create mode 100644 tests/ktuple.ur
 create mode 100644 tests/ktuple.urp

(limited to 'src/urweb.lex')

diff --git a/demo/batchFun.ur b/demo/batchFun.ur
index f665b132..ca48c7dc 100644
--- a/demo/batchFun.ur
+++ b/demo/batchFun.ur
@@ -6,7 +6,7 @@ con colMeta = fn (db :: Type, state :: Type) =>
                   NewState : transaction state,
                   Widget : state -> xbody,
                   ReadState : state -> transaction db}
-con colsMeta = fn cols :: {(Type * Type)} => $(map colMeta cols)
+con colsMeta = fn cols => $(map colMeta cols)
 
 fun default [t] (sh : show t) (rd : read t) (inj : sql_injectable t)
             name : colMeta (t, source string) =
@@ -46,10 +46,8 @@ functor Make(M : sig
     fun add r =
         dml (insert t
                     (@foldR2 [fst] [colMeta]
-                      [fn cols => $(map (fn t :: (Type * Type) =>
-                                            sql_exp [] [] [] t.1) cols)]
-                      (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
-                                       [[nm] ~ rest] input col acc =>
+                      [fn cols => $(map (fn t => sql_exp [] [] [] t.1) cols)]
+                      (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] input col acc =>
                           acc ++ {nm = @sql_inject col.Inject input})
                       {} M.fl (r -- #Id) M.cols
                       ++ {Id = (SQL {[r.Id]})}))
@@ -73,8 +71,7 @@ functor Make(M : sig
                     <tr>
                       <td>{[r.Id]}</td>
                       {@mapX2 [colMeta] [fst] [_]
-                        (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}]
-                                         [[nm] ~ rest] m v =>
+                        (fn [nm :: Name] [p ::_] [rest ::_] [[nm] ~ rest] m v =>
                             <xml><td>{m.Show v}</td></xml>)
                         M.fl M.cols (r -- #Id)}
                       {if withDel then
@@ -89,8 +86,7 @@ functor Make(M : sig
               <tr>
                 <th>Id</th>
                 {@mapX [colMeta] [_]
-                  (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}]
-                                   [[nm] ~ rest] m =>
+                  (fn [nm :: Name] [p ::_] [rest ::_] [[nm] ~ rest] m =>
                       <xml><th>{[m.Nam]}</th></xml>)
                   M.fl M.cols}
               </tr>
@@ -104,7 +100,7 @@ functor Make(M : sig
 
         id <- source "";
         inps <- @foldR [colMeta] [fn r => transaction ($(map snd r))]
-                 (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}] [[nm] ~ rest] m acc =>
+                 (fn [nm :: Name] [p ::_] [rest ::_] [[nm] ~ rest] m acc =>
                      s <- m.NewState;
                      r <- acc;
                      return ({nm = s} ++ r))
@@ -115,8 +111,7 @@ functor Make(M : sig
             fun add () =
                 id <- get id;
                 vs <- @foldR2 [colMeta] [snd] [fn r => transaction ($(map fst r))]
-                       (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}]
-                                        [[nm] ~ rest] m s acc =>
+                       (fn [nm :: Name] [p ::_] [rest ::_] [[nm] ~ rest] m s acc =>
                            v <- m.ReadState s;
                            r <- acc;
                            return ({nm = v} ++ r))
@@ -145,8 +140,7 @@ functor Make(M : sig
               <table>
                 <tr> <th>Id:</th> <td><ctextbox source={id}/></td> </tr>
                 {@mapX2 [colMeta] [snd] [_]
-                  (fn [nm :: Name] [p :: (Type * Type)] [rest :: {(Type * Type)}]
-                                   [[nm] ~ rest] m s =>
+                  (fn [nm :: Name] [p ::_] [rest ::_] [[nm] ~ rest] m s =>
                       <xml><tr> <th>{[m.Nam]}:</th> <td>{m.Widget s}</td> </tr></xml>)
                   M.fl M.cols inps}
                 <tr> <th/> <td><button value="Batch it" onclick={add ()}/></td> </tr>
diff --git a/demo/crud.ur b/demo/crud.ur
index 82739772..2fc82c1b 100644
--- a/demo/crud.ur
+++ b/demo/crud.ur
@@ -5,7 +5,7 @@ con colMeta = fn (db :: Type, widget :: Type) =>
                   WidgetPopulated : nm :: Name -> db -> xml form [] [nm = widget],
                   Parse : widget -> db,
                   Inject : sql_injectable db}
-con colsMeta = fn cols :: {(Type * Type)} => $(map colMeta cols)
+con colsMeta = fn cols => $(map colMeta cols)
 
 fun default [t] (sh : show t) (rd : read t) (inj : sql_injectable t)
             name : colMeta (t, string) =
@@ -51,10 +51,9 @@ functor Make(M : sig
                          <tr>
                            <td>{[fs.T.Id]}</td>
                            {@mapX2 [fst] [colMeta] [tr]
-                             (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
-                                              [[nm] ~ rest] v col => <xml>
-                                                <td>{col.Show v}</td>
-                                              </xml>)
+                             (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] v col => <xml>
+                               <td>{col.Show v}</td>
+                             </xml>)
                              M.fl (fs.T -- #Id) M.cols}
                            <td>
                              <a link={upd fs.T.Id}>[Update]</a>
@@ -67,10 +66,9 @@ functor Make(M : sig
             <tr>
               <th>ID</th>
               {@mapX [colMeta] [tr]
-                (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
-                                 [[nm] ~ rest] col => <xml>
-                                   <th>{cdata col.Nam}</th>
-                                 </xml>)
+                (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] col => <xml>
+                  <th>{cdata col.Nam}</th>
+                </xml>)
                 M.fl M.cols}
             </tr>
             {rows}
@@ -79,12 +77,11 @@ functor Make(M : sig
           <br/><hr/><br/>
 
           <form>
-            {@foldR [colMeta] [fn cols :: {(Type * Type)} => xml form [] (map snd cols)]
-              (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
-                               [[nm] ~ rest] (col : colMeta t) (acc : xml form [] (map snd rest)) => <xml>
-                                 <li> {cdata col.Nam}: {col.Widget [nm]}</li>
-                                 {useMore acc}
-                               </xml>)
+            {@foldR [colMeta] [fn cols => xml form [] (map snd cols)]
+              (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] (col : colMeta t) (acc : xml form [] (map snd rest)) => <xml>
+                <li> {cdata col.Nam}: {col.Widget [nm]}</li>
+                {useMore acc}
+              </xml>)
               <xml/>
               M.fl M.cols}
             
@@ -96,10 +93,8 @@ functor Make(M : sig
         id <- nextval seq;
         dml (insert tab
                     (@foldR2 [snd] [colMeta]
-                      [fn cols => $(map (fn t :: (Type * Type) =>
-                                            sql_exp [] [] [] t.1) cols)]
-                      (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
-                                       [[nm] ~ rest] =>
+                      [fn cols => $(map (fn t => sql_exp [] [] [] t.1) cols)]
+                      (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] =>
                        fn input col acc => acc ++ {nm = @sql_inject col.Inject (col.Parse input)})
                       {} M.fl inputs M.cols
                      ++ {Id = (SQL {[id]})}));
@@ -115,12 +110,8 @@ functor Make(M : sig
             fun save (inputs : $(map snd M.cols)) =
                 dml (update [map fst M.cols]
                             (@foldR2 [snd] [colMeta]
-                              [fn cols => $(map (fn t :: (Type * Type) =>
-                                                    sql_exp [T = [Id = int]
-                                                                     ++ map fst M.cols]
-                                                            [] [] t.1) cols)]
-                              (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
-                                               [[nm] ~ rest] =>
+                              [fn cols => $(map (fn t => sql_exp [T = [Id = int] ++ map fst M.cols] [] [] t.1) cols)]
+                              (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] =>
                                fn input col acc => acc ++ {nm =
                                                            @sql_inject col.Inject (col.Parse input)})
                               {} M.fl inputs M.cols)
@@ -136,9 +127,8 @@ functor Make(M : sig
             case fso : (Basis.option {Tab : $(map fst M.cols)}) of
                 None => return <xml><body>Not found!</body></xml>
               | Some fs => return <xml><body><form>
-                {@foldR2 [fst] [colMeta] [fn cols :: {(Type * Type)} => xml form [] (map snd cols)]
-                  (fn [nm :: Name] [t :: (Type * Type)] [rest :: {(Type * Type)}]
-                                   [[nm] ~ rest] (v : t.1) (col : colMeta t)
+                {@foldR2 [fst] [colMeta] [fn cols => xml form [] (map snd cols)]
+                  (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] (v : t.1) (col : colMeta t)
                                    (acc : xml form [] (map snd rest)) =>
                       <xml>
                         <li> {cdata col.Nam}: {col.WidgetPopulated [nm] v}</li>
diff --git a/demo/metaform.ur b/demo/metaform.ur
index 0a664005..729b7d08 100644
--- a/demo/metaform.ur
+++ b/demo/metaform.ur
@@ -6,7 +6,7 @@ functor Make (M : sig
 
     fun handler values = return <xml><body>
       {@mapUX2 [string] [string] [body]
-        (fn [nm :: Name] [rest :: {Unit}] [[nm] ~ rest] name value => <xml>
+        (fn [nm :: Name] [rest ::_] [[nm] ~ rest] name value => <xml>
           <li> {[name]} = {[value]}</li>
         </xml>)
         M.fl M.names values}
@@ -14,8 +14,8 @@ functor Make (M : sig
 
     fun main () = return <xml><body>
       <form>
-        {@foldUR [string] [fn cols :: {Unit} => xml form [] (mapU string cols)]
-          (fn [nm :: Name] [rest :: {Unit}] [[nm] ~ rest] name
+        {@foldUR [string] [fn cols => xml form [] (mapU string cols)]
+          (fn [nm :: Name] [rest ::_] [[nm] ~ rest] name
                            (acc : xml form [] (mapU string rest)) => <xml>
                              <li> {[name]}: <textbox{nm}/></li>
                              {useMore acc}
diff --git a/doc/manual.tex b/doc/manual.tex
index 98b3b63c..9dbdb505 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -495,6 +495,8 @@ A tuple type $(\tau_1, \ldots, \tau_n)$ expands to a record type $\{1 = \tau_1,
 
 In general, several adjacent $\lambda$ forms may be combined into one, and kind and type annotations may be omitted, in which case they are implicitly included as wildcards.  More formally, for constructor-level abstractions, we can define a new non-terminal $b ::= x \mid (x :: \kappa) \mid X$ and allow composite abstractions of the form $\lambda b^+ \Rightarrow c$, elaborating into the obvious sequence of one core $\lambda$ per element of $b^+$.
 
+In some contexts, the parser isn't happy with token sequences like $x :: \_$, to indicate a constructor variable of wildcard kind.  In such cases, write the second two tokens as $::\hspace{-.05in}\_$, with no intervening spaces.
+
 For any signature item or declaration that defines some entity to be equal to $A$ with classification annotation $B$ (e.g., $\mt{val} \; x : B = A$), $B$ and the preceding colon (or similar punctuation) may be omitted, in which case it is filled in as a wildcard.
 
 A signature item or declaration $\mt{type} \; x$ or $\mt{type} \; x = \tau$ is elaborated into $\mt{con} \; x :: \mt{Type}$ or $\mt{con} \; x :: \mt{Type} = \tau$, respectively.
diff --git a/src/elab.sml b/src/elab.sml
index 6d405af6..dcb15502 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -39,6 +39,7 @@ datatype kind' =
 
        | KError
        | KUnif of ErrorMsg.span * string * kind option ref
+       | KTupleUnif of ErrorMsg.span * (int * kind) list * kind option ref
 
        | KRel of int
        | KFun of string * kind
diff --git a/src/elab_print.sml b/src/elab_print.sml
index 4fb7ee73..279c7231 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -56,6 +56,16 @@ fun p_kind' par env (k, _) =
       | KError => string "<ERROR>"
       | KUnif (_, _, ref (SOME k)) => p_kind' par env k
       | KUnif (_, s, _) => string ("<UNIF:" ^ s ^ ">")
+      | KTupleUnif (_, _, ref (SOME k)) => p_kind' par env k
+      | KTupleUnif (_, nks, _) => box [string "(",
+                                       p_list_sep (box [space, string "*", space])
+                                                  (fn (n, k) => box [string (Int.toString n ^ ":"),
+                                                                     space,
+                                                                     p_kind env k]) nks,
+                                       space,
+                                       string "*",
+                                       space,
+                                       string "...)"]
 
       | KRel n => ((if !debug then
                          string (E.lookupKRel env n ^ "_" ^ Int.toString n)
diff --git a/src/elab_util.sml b/src/elab_util.sml
index ccfb86a3..33ed599c 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -78,6 +78,16 @@ fun mapfoldB {kind, bind} =
               | KUnif (_, _, ref (SOME k)) => mfk' ctx k
               | KUnif _ => S.return2 kAll
 
+              | KTupleUnif (_, _, ref (SOME k)) => mfk' ctx k
+              | KTupleUnif (loc, nks, r) =>
+                S.map2 (ListUtil.mapfold (fn (n, k) =>
+                                             S.map2 (mfk ctx k,
+                                                  fn k' =>
+                                                     (n, k'))) nks,
+                     fn nks' =>
+                        (KTupleUnif (loc, nks', r), loc))
+
+
               | KRel _ => S.return2 kAll
               | KFun (x, k) =>
                 S.map2 (mfk (bind (ctx, x)) k,
@@ -207,7 +217,7 @@ fun mapfoldB {kind = fk, con = fc, bind} =
               | CError => S.return2 cAll
               | CUnif (_, _, _, ref (SOME c)) => mfc' ctx c
               | CUnif _ => S.return2 cAll
-
+                        
               | CKAbs (x, c) =>
                 S.map2 (mfc (bind (ctx, RelK x)) c,
                         fn c' =>
diff --git a/src/elaborate.sml b/src/elaborate.sml
index e3f42c19..2cc01eda 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -94,6 +94,9 @@
            | (L'.KUnif (_, _, ref (SOME k1All)), _) => unifyKinds' env k1All k2All
            | (_, L'.KUnif (_, _, ref (SOME k2All))) => unifyKinds' env k1All k2All
 
+           | (L'.KTupleUnif (_, _, ref (SOME k)), _) => unifyKinds' env k k2All
+           | (_, L'.KTupleUnif (_, _, ref (SOME k))) => unifyKinds' env k1All k
+
            | (L'.KUnif (_, _, r1), L'.KUnif (_, _, r2)) =>
              if r1 = r2 then
                  ()
@@ -111,6 +114,32 @@
              else
                  r := SOME k1All
 
+           | (L'.KTupleUnif (_, nks, r), L'.KTuple ks) =>
+             ((app (fn (n, k) => unifyKinds' env k (List.nth (ks, n-1))) nks;
+               r := SOME k2All)
+              handle Subscript => err KIncompatible)
+           | (L'.KTuple ks, L'.KTupleUnif (_, nks, r)) =>
+             ((app (fn (n, k) => unifyKinds' env (List.nth (ks, n-1)) k) nks;
+               r := SOME k1All)
+              handle Subscript => err KIncompatible)
+           | (L'.KTupleUnif (loc, nks1, r1), L'.KTupleUnif (_, nks2, r2)) =>
+             let
+                 val nks = foldl (fn (p as (n, k1), nks) =>
+                                     case ListUtil.search (fn (n', k2) =>
+                                                              if n' = n then
+                                                                  SOME k2
+                                                              else
+                                                                  NONE) nks2 of
+                                         NONE => p :: nks
+                                       | SOME k2 => (unifyKinds' env k1 k2;
+                                                     nks)) nks2 nks1
+
+                 val k = (L'.KTupleUnif (loc, nks, ref NONE), loc)
+             in
+                 r1 := SOME k;
+                 r2 := SOME k
+             end
+
            | _ => err KIncompatible
      end
 
@@ -441,16 +470,15 @@
        | L.CProj (c, n) =>
          let
              val (c', k, gs) = elabCon (env, denv) c
+
+             val k' = kunif loc
          in
-             case hnormKind k of
-                 (L'.KTuple ks, _) =>
-                 if n <= 0 orelse n > length ks then
-                     (conError env (ProjBounds (c', n));
-                      (cerror, kerror, []))
-                 else
-                     ((L'.CProj (c', n), loc), List.nth (ks, n - 1), gs)
-               | k => (conError env (ProjMismatch (c', k));
-                       (cerror, kerror, []))
+             if n <= 0 then
+                 (conError env (ProjBounds (c', n));
+                  (cerror, kerror, []))
+             else
+                 (checkKind env c' k (L'.KTupleUnif (loc, [(n, k')], ref NONE), loc);
+                  ((L'.CProj (c', n), loc), k', gs))
          end
 
        | L.CWild k =>
@@ -463,6 +491,7 @@
  fun kunifsRemain k =
      case k of
          L'.KUnif (_, _, ref NONE) => true
+       | L'.KTupleUnif (_, _, ref NONE) => true
        | _ => false
  fun cunifsRemain c =
      case c of
@@ -3229,6 +3258,8 @@ and wildifyStr env (str, sgn) =
                        | L'.KError => NONE
                        | L'.KUnif (_, _, ref (SOME k)) => decompileKind k
                        | L'.KUnif _ => NONE
+                       | L'.KTupleUnif (_, _, ref (SOME k)) => decompileKind k
+                       | L'.KTupleUnif _ => NONE
 
                        | L'.KRel _ => NONE
                        | L'.KFun _ => NONE
diff --git a/src/explify.sml b/src/explify.sml
index 4f4f83e1..cf6c491c 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -44,6 +44,8 @@ fun explifyKind (k, loc) =
       | L.KError => raise Fail ("explifyKind: KError at " ^ EM.spanToString loc)
       | L.KUnif (_, _, ref (SOME k)) => explifyKind k
       | L.KUnif _ => raise Fail ("explifyKind: KUnif at " ^ EM.spanToString loc)
+      | L.KTupleUnif (loc, _, ref (SOME k)) => explifyKind k
+      | L.KTupleUnif _ => raise Fail ("explifyKind: KTupleUnif at " ^ EM.spanToString loc)
 
       | L.KRel n => (L'.KRel n, loc)
       | L.KFun (x, k) => (L'.KFun (x, explifyKind k), loc)
diff --git a/src/urweb.grm b/src/urweb.grm
index dfc22112..0c85ad7f 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -212,7 +212,7 @@ fun tnamesOf (e, _) =
  | STRING of string | INT of Int64.int | FLOAT of Real64.real | CHAR of char
  | SYMBOL of string | CSYMBOL of string
  | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
- | EQ | COMMA | COLON | DCOLON | TCOLON | DOT | HASH | UNDER | UNDERUNDER | BAR
+ | EQ | COMMA | COLON | DCOLON | DCOLONWILD | TCOLON | DOT | HASH | UNDER | UNDERUNDER | BAR
  | PLUS | MINUS | DIVIDE | DOTDOTDOT | MOD | AT
  | CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS
  | DATATYPE | OF
@@ -510,6 +510,7 @@ dtypes : dtype                          ([dtype])
 
 kopt   :                                (NONE)
        | DCOLON kind                    (SOME kind)
+       | DCOLONWILD                     (SOME (KWild, s (DCOLONWILDleft, DCOLONWILDright)))
 
 dargs  :                                ([])
        | SYMBOL dargs                   (SYMBOL :: dargs)
@@ -853,6 +854,22 @@ carg   : SYMBOL DCOLON kind             (fn (c, k) =>
                                                 ((CAbs ("_", SOME kind, c), loc),
                                                  (KArrow (kind, k), loc))
                                             end)
+       | SYMBOL DCOLONWILD              (fn (c, k) =>
+                                            let
+                                                val loc = s (SYMBOLleft, DCOLONWILDright)
+                                                val kind = (KWild, loc)
+                                            in
+                                                ((CAbs (SYMBOL, NONE, c), loc),
+                                                 (KArrow (kind, k), loc))
+                                            end)
+       | UNDER DCOLONWILD               (fn (c, k) =>
+                                            let
+                                                val loc = s (UNDERleft, DCOLONWILDright)
+                                                val kind = (KWild, loc)
+                                            in
+                                                ((CAbs ("_", NONE, c), loc),
+                                                 (KArrow (kind, k), loc))
+                                            end)
        | cargp                          (cargp)
 
 cargp  : SYMBOL                         (fn (c, k) =>
@@ -1079,6 +1096,14 @@ earga  : LBRACK SYMBOL RBRACK            (fn (e, t) =>
                                                  ((ECAbs (Implicit, SYMBOL, kind, e), loc),
                                                   (TCFun (Implicit, SYMBOL, kind, t), loc))
                                              end)
+       | LBRACK SYMBOL DCOLONWILD RBRACK (fn (e, t) =>
+                                             let
+                                                 val loc = s (LBRACKleft, RBRACKright)
+                                                 val kind = (KWild, loc)
+                                             in
+                                                 ((ECAbs (Explicit, SYMBOL, kind, e), loc),
+                                                  (TCFun (Explicit, SYMBOL, kind, t), loc))
+                                             end)
        | LBRACK SYMBOL kcolon kind RBRACK(fn (e, t) =>
                                              let
                                                  val loc = s (LBRACKleft, RBRACKright)
diff --git a/src/urweb.lex b/src/urweb.lex
index 0ee09cad..a6df5f1b 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -372,6 +372,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 <INITIAL> ">="        => (Tokens.GE (pos yypos, pos yypos + size yytext));
 <INITIAL> ","         => (Tokens.COMMA (pos yypos, pos yypos + size yytext));
 <INITIAL> ":::"       => (Tokens.TCOLON (pos yypos, pos yypos + size yytext));
+<INITIAL> "::_"       => (Tokens.DCOLONWILD (pos yypos, pos yypos + size yytext));
 <INITIAL> "::"        => (Tokens.DCOLON (pos yypos, pos yypos + size yytext));
 <INITIAL> ":"         => (Tokens.COLON (pos yypos, pos yypos + size yytext));
 <INITIAL> "..."       => (Tokens.DOTDOTDOT (pos yypos, pos yypos + size yytext));
diff --git a/tests/ktuple.ur b/tests/ktuple.ur
new file mode 100644
index 00000000..040578e0
--- /dev/null
+++ b/tests/ktuple.ur
@@ -0,0 +1,2 @@
+type q = (fn p => p.1) (int, float)
+type q = (fn p => p.1 * $p.3) (int, float, [])
diff --git a/tests/ktuple.urp b/tests/ktuple.urp
new file mode 100644
index 00000000..c466588c
--- /dev/null
+++ b/tests/ktuple.urp
@@ -0,0 +1 @@
+ktuple
-- 
cgit v1.2.3


From 4e608544ebe87dd991d53ded5267f14f5df93b8b Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Sun, 10 Oct 2010 20:33:10 -0400
Subject: :::_ notation; switch to TooDeep error message

---
 doc/manual.tex    |  2 +-
 src/elab_err.sig  |  1 +
 src/elab_err.sml  |  2 ++
 src/elaborate.sml |  4 ++--
 src/urweb.grm     | 12 ++++++++++--
 src/urweb.lex     |  1 +
 6 files changed, 17 insertions(+), 5 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/doc/manual.tex b/doc/manual.tex
index 9dbdb505..ebeb2d55 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -495,7 +495,7 @@ A tuple type $(\tau_1, \ldots, \tau_n)$ expands to a record type $\{1 = \tau_1,
 
 In general, several adjacent $\lambda$ forms may be combined into one, and kind and type annotations may be omitted, in which case they are implicitly included as wildcards.  More formally, for constructor-level abstractions, we can define a new non-terminal $b ::= x \mid (x :: \kappa) \mid X$ and allow composite abstractions of the form $\lambda b^+ \Rightarrow c$, elaborating into the obvious sequence of one core $\lambda$ per element of $b^+$.
 
-In some contexts, the parser isn't happy with token sequences like $x :: \_$, to indicate a constructor variable of wildcard kind.  In such cases, write the second two tokens as $::\hspace{-.05in}\_$, with no intervening spaces.
+In some contexts, the parser isn't happy with token sequences like $x :: \_$, to indicate a constructor variable of wildcard kind.  In such cases, write the second two tokens as $::\hspace{-.05in}\_$, with no intervening spaces.  Analogous syntax $:::\hspace{-.05in}\_$ is available for implicit constructor arguments.
 
 For any signature item or declaration that defines some entity to be equal to $A$ with classification annotation $B$ (e.g., $\mt{val} \; x : B = A$), $B$ and the preceding colon (or similar punctuation) may be omitted, in which case it is filled in as a wildcard.
 
diff --git a/src/elab_err.sig b/src/elab_err.sig
index fbe55a5b..3dfd5d4e 100644
--- a/src/elab_err.sig
+++ b/src/elab_err.sig
@@ -58,6 +58,7 @@ signature ELAB_ERR = sig
            | CRecordFailure of Elab.con * Elab.con * (Elab.con * Elab.con * Elab.con) option
            | TooLifty of ErrorMsg.span * ErrorMsg.span
            | TooUnify of Elab.con * Elab.con
+           | TooDeep
 
     val cunifyError : ElabEnv.env -> cunify_error -> unit
 
diff --git a/src/elab_err.sml b/src/elab_err.sml
index f8a16294..7d5e6be8 100644
--- a/src/elab_err.sml
+++ b/src/elab_err.sml
@@ -121,6 +121,7 @@ datatype cunify_error =
        | CRecordFailure of con * con * (con * con * con) option
        | TooLifty of ErrorMsg.span * ErrorMsg.span
        | TooUnify of con * con
+       | TooDeep
 
 fun cunifyError env err =
     case err of
@@ -162,6 +163,7 @@ fun cunifyError env err =
         (ErrorMsg.errorAt (#2 c1) "Substitution in constructor is blocked by a too-deep unification variable";
          eprefaces' [("Replacement", p_con env c1),
                      ("Body", p_con env c2)])
+      | TooDeep => ErrorMsg.error "Can't reverse-engineer unification variable lifting"
 
 datatype exp_error =
        UnboundExp of ErrorMsg.span * string
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 7bf687e2..dcae4650 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1079,13 +1079,13 @@
                  err COccursCheckFailed
              else
                  (r := SOME (squish nl c2All)
-                  handle CantSquish => err CIncompatible)
+                  handle CantSquish => err (fn _ => TooDeep))
            | (_, L'.CUnif (nl, _, _, _, r)) =>
              if occursCon r c1All then
                  err COccursCheckFailed
              else
                  (r := SOME (squish nl c1All)
-                  handle CantSquish => err CIncompatible)
+                  handle CantSquish => err (fn _ => TooDeep))
 
            | (L'.CUnit, L'.CUnit) => ()
 
diff --git a/src/urweb.grm b/src/urweb.grm
index 0c85ad7f..21c4a50c 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -212,7 +212,7 @@ fun tnamesOf (e, _) =
  | STRING of string | INT of Int64.int | FLOAT of Real64.real | CHAR of char
  | SYMBOL of string | CSYMBOL of string
  | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
- | EQ | COMMA | COLON | DCOLON | DCOLONWILD | TCOLON | DOT | HASH | UNDER | UNDERUNDER | BAR
+ | EQ | COMMA | COLON | DCOLON | DCOLONWILD | TCOLON | TCOLONWILD | DOT | HASH | UNDER | UNDERUNDER | BAR
  | PLUS | MINUS | DIVIDE | DOTDOTDOT | MOD | AT
  | CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS
  | DATATYPE | OF
@@ -394,7 +394,7 @@ fun tnamesOf (e, _) =
 %left ANDALSO
 %left ORELSE
 %nonassoc COLON
-%nonassoc DCOLON TCOLON
+%nonassoc DCOLON TCOLON DCOLONWILD TCOLONWILD
 %left UNION INTERSECT EXCEPT
 %right COMMA
 %right JOIN INNER CROSS OUTER LEFT RIGHT FULL
@@ -1111,6 +1111,14 @@ earga  : LBRACK SYMBOL RBRACK            (fn (e, t) =>
                                                  ((ECAbs (kcolon, SYMBOL, kind, e), loc),
                                                   (TCFun (kcolon, SYMBOL, kind, t), loc))
                                              end)
+       | LBRACK SYMBOL TCOLONWILD RBRACK (fn (e, t) =>
+                                             let
+                                                 val loc = s (LBRACKleft, RBRACKright)
+                                                 val kind = (KWild, loc)
+                                             in
+                                                 ((ECAbs (Implicit, SYMBOL, kind, e), loc),
+                                                  (TCFun (Implicit, SYMBOL, kind, t), loc))
+                                             end)
        | LBRACK cexp TWIDDLE cexp RBRACK(fn (e, t) =>
                                             let
                                                 val loc = s (LBRACKleft, RBRACKright)
diff --git a/src/urweb.lex b/src/urweb.lex
index a6df5f1b..fa8c5dde 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -371,6 +371,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 <INITIAL> "<="        => (Tokens.LE (pos yypos, pos yypos + size yytext));
 <INITIAL> ">="        => (Tokens.GE (pos yypos, pos yypos + size yytext));
 <INITIAL> ","         => (Tokens.COMMA (pos yypos, pos yypos + size yytext));
+<INITIAL> ":::_"      => (Tokens.TCOLONWILD (pos yypos, pos yypos + size yytext));
 <INITIAL> ":::"       => (Tokens.TCOLON (pos yypos, pos yypos + size yytext));
 <INITIAL> "::_"       => (Tokens.DCOLONWILD (pos yypos, pos yypos + size yytext));
 <INITIAL> "::"        => (Tokens.DCOLON (pos yypos, pos yypos + size yytext));
-- 
cgit v1.2.3


From 928db0bf3aa8a149d0e1632f07eb7672ec65add3 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Fri, 24 Dec 2010 18:55:13 -0500
Subject: JavaScript compilation of time comparison; fix lexing of XML that
 includes open parens

---
 src/settings.sml | 6 +++++-
 src/urweb.lex    | 4 +++-
 2 files changed, 8 insertions(+), 2 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/src/settings.sml b/src/settings.sml
index 97c39abf..5b4bbe2c 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -211,7 +211,11 @@ val jsFuncsBase = basisM [("alert", "alert"),
                           ("toupper", "toUpper"),
 
                           ("checkUrl", "checkUrl"),
-                          ("bless", "bless")]
+                          ("bless", "bless"),
+
+                          ("eq_time", "eq"),
+                          ("lt_time", "lt"),
+                          ("le_time", "le")]
 val jsFuncs = ref jsFuncsBase
 fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
 fun jsFunc x = M.find (!jsFuncs, x)
diff --git a/src/urweb.lex b/src/urweb.lex
index fa8c5dde..371d69a7 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -172,7 +172,7 @@ cid = [A-Z][A-Za-z0-9_]*;
 ws = [\ \t\012];
 intconst = [0-9]+;
 realconst = [0-9]+\.[0-9]*;
-notags = ([^<{\n(]|(\([^\*]))+;
+notags = ([^<{\n(]|(\([^\*<{\n]))+;
 xcom = ([^\-]|(-[^\-]))+;
 oint = [0-9][0-9][0-9];
 xint = x[0-9a-fA-F][0-9a-fA-F];
@@ -338,6 +338,8 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 
 <XML> {notags}        => (Tokens.NOTAGS (unescape (yypos, yypos + size yytext) yytext, yypos, yypos + size yytext));
 
+<XML> "("             => (Tokens.NOTAGS ("(", yypos, yypos + size yytext));
+
 <XML> .               => (ErrorMsg.errorAt' (yypos, yypos)
                           ("illegal XML character: \"" ^ yytext ^ "\"");
                           continue ());
-- 
cgit v1.2.3


From c824364cb48385480667ce646425d37ec0ad87b0 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Thu, 10 Mar 2011 19:26:35 -0500
Subject: Cope with DOS-format line breaks in source code

---
 src/urweb.lex | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'src/urweb.lex')

diff --git a/src/urweb.lex b/src/urweb.lex
index 371d69a7..74b91432 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -169,7 +169,7 @@ fun unescape loc s =
 
 id = [a-z_][A-Za-z0-9_']*;
 cid = [A-Z][A-Za-z0-9_]*;
-ws = [\ \t\012];
+ws = [\ \t\012\r];
 intconst = [0-9]+;
 realconst = [0-9]+\.[0-9]*;
 notags = ([^<{\n(]|(\([^\*<{\n]))+;
-- 
cgit v1.2.3


From 8a167261f4de68926907c3cc97f8252957274bff Mon Sep 17 00:00:00 2001
From: Karn Kallio <kkallio@eka>
Date: Fri, 14 Oct 2011 01:33:03 -0530
Subject: IF THEN ELSE conditional for SQL.

---
 lib/ur/basis.urs        |  7 +++++++
 src/elisp/urweb-mode.el |  3 ++-
 src/monoize.sml         | 25 +++++++++++++++++++++++++
 src/urweb.grm           |  8 ++++++++
 src/urweb.lex           |  4 ++++
 5 files changed, 46 insertions(+), 1 deletion(-)

(limited to 'src/urweb.lex')

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 70c1ef55..73ee8e2b 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -474,6 +474,13 @@ val sql_is_null : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
                   -> sql_exp tables agg exps (option t)
                   -> sql_exp tables agg exps bool
 
+val sql_if_then_else : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+                       -> t ::: Type
+                       -> sql_exp tables agg exps bool
+                       -> sql_exp tables agg exps t
+                       -> sql_exp tables agg exps t
+                       -> sql_exp tables agg exps t
+
 class sql_arith
 val sql_arith_int : sql_arith int
 val sql_arith_float : sql_arith float
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index b9ffaf10..f56834b2 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -150,7 +150,8 @@ See doc for the variable `urweb-mode-info'."
                  "ASC" "DESC" "INSERT" "INTO" "VALUES" "UPDATE" "SET" "DELETE"
                  "PRIMARY" "KEY" "CONSTRAINT" "UNIQUE" "CHECK"
                  "FOREIGN" "REFERENCES" "ON" "NO" "ACTION" "CASCADE" "RESTRICT" "NULL"
-                 "JOIN" "INNER" "OUTER" "LEFT" "RIGHT" "FULL" "CROSS" "SELECT1")
+                 "JOIN" "INNER" "OUTER" "LEFT" "RIGHT" "FULL" "CROSS" "SELECT1"
+                 "IF" "THEN" "ELSE")
   "A regexp that matches SQL keywords.")
 
 (defconst urweb-lident-regexp "\\<[a-z_][A-Za-z0-9_']*\\>"
diff --git a/src/monoize.sml b/src/monoize.sml
index 417bf044..e33513f8 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2804,6 +2804,31 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                  fm)
             end
 
+          | (L.ECApp (
+             (L.ECApp (
+              (L.ECApp (
+               (L.ECApp (
+                (L.EFfi ("Basis", "sql_if_then_else"), _), _),
+                _), _),
+               _), _),
+              _), _)) =>
+            let
+                val s = (L'.TFfi ("Basis", "string"), loc)
+                fun sc s = (L'.EPrim (Prim.String s), loc)
+            in
+                ((L'.EAbs ("if", s, (L'.TFun (s, s), loc),
+                           (L'.EAbs ("then", s, (L'.TFun (s, s), loc),
+                                     (L'.EAbs ("else", s, (L'.TFun (s, s), loc),
+                                               strcat [sc "(CASE WHEN (",
+                                                       (L'.ERel 2, loc),
+                                                       sc ") THEN (",
+                                                       (L'.ERel 1, loc),
+                                                       sc ") ELSE (",
+                                                       (L'.ERel 0, loc),
+                                                       sc ") END)"]), loc)), loc)), loc),
+                 fm)
+            end
+
           | L.ECApp (
             (L.ECApp (
              (L.ECApp (
diff --git a/src/urweb.grm b/src/urweb.grm
index db99d3b5..d39fbe55 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -249,6 +249,7 @@ fun tnamesOf (e, _) =
  | NE | LT | LE | GT | GE
  | CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES
  | JOIN | INNER | CROSS | OUTER | LEFT | RIGHT | FULL
+ | CIF | CTHEN | CELSE
 
 %nonterm
    file of decl list
@@ -1828,6 +1829,13 @@ sqlexp : TRUE                           (sql_inject (EVar (["Basis"], "True", In
                                                     sqlexp), loc)
                                          end)
 
+       | CIF sqlexp CTHEN sqlexp CELSE sqlexp (let
+                                                   val loc = s (CIFleft, sqlexp3right)
+                                                   val e = (EVar (["Basis"], "sql_if_then_else", Infer), loc) 
+                                               in
+                                                   (EApp ((EApp ((EApp (e, sqlexp1), loc), sqlexp2), loc), sqlexp3), loc)
+                                               end)
+
        | LBRACE LBRACK eexp RBRACK RBRACE  (sql_inject (#1 eexp,
                                                         s (LBRACEleft, RBRACEright)))
        | LPAREN sqlexp RPAREN           (sqlexp)
diff --git a/src/urweb.lex b/src/urweb.lex
index 74b91432..21e3d603 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -480,6 +480,10 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 <INITIAL> "MIN"       => (Tokens.MIN (pos yypos, pos yypos + size yytext));
 <INITIAL> "MAX"       => (Tokens.MAX (pos yypos, pos yypos + size yytext));
 
+<INITIAL> "IF"        => (Tokens.CIF (pos yypos, pos yypos + size yytext));
+<INITIAL> "THEN"      => (Tokens.CTHEN (pos yypos, pos yypos + size yytext));
+<INITIAL> "ELSE"      => (Tokens.CELSE (pos yypos, pos yypos + size yytext));
+
 <INITIAL> "ASC"       => (Tokens.ASC (pos yypos, pos yypos + size yytext));
 <INITIAL> "DESC"      => (Tokens.DESC (pos yypos, pos yypos + size yytext));
 
-- 
cgit v1.2.3


From 99adfa83d473370a0bc0d085279a5406404a7f5a Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Sat, 5 Nov 2011 12:32:20 -0400
Subject: Adjust for different ml-lex behavior between SML/NJ and MLton

---
 src/urweb.lex    | 2 +-
 tests/sigbug.ur  | 3 +++
 tests/sigbug.urs | 3 +++
 3 files changed, 7 insertions(+), 1 deletion(-)
 create mode 100644 tests/sigbug.ur
 create mode 100644 tests/sigbug.urs

(limited to 'src/urweb.lex')

diff --git a/src/urweb.lex b/src/urweb.lex
index 21e3d603..19f28738 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -416,7 +416,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 <INITIAL> "structure" => (Tokens.STRUCTURE (pos yypos, pos yypos + size yytext));
 <INITIAL> "signature" => (Tokens.SIGNATURE (pos yypos, pos yypos + size yytext));
 <INITIAL> "struct"    => (Tokens.STRUCT (pos yypos, pos yypos + size yytext));
-<INITIAL> "sig"       => (if yypos = 2 then initialSig () else (); Tokens.SIG (pos yypos, pos yypos + size yytext));
+<INITIAL> "sig"       => (if yypos <= 2 then initialSig () else (); Tokens.SIG (pos yypos, pos yypos + size yytext));
 <INITIAL> "let"       => (Tokens.LET (pos yypos, pos yypos + size yytext));
 <INITIAL> "in"        => (Tokens.IN (pos yypos, pos yypos + size yytext));
 <INITIAL> "end"       => (Tokens.END (pos yypos, pos yypos + size yytext));
diff --git a/tests/sigbug.ur b/tests/sigbug.ur
new file mode 100644
index 00000000..ec00343c
--- /dev/null
+++ b/tests/sigbug.ur
@@ -0,0 +1,3 @@
+val z = 3
+val x = 1
+val y = 2
diff --git a/tests/sigbug.urs b/tests/sigbug.urs
new file mode 100644
index 00000000..81693932
--- /dev/null
+++ b/tests/sigbug.urs
@@ -0,0 +1,3 @@
+val x : inta
+val y : into
+val z : introx
-- 
cgit v1.2.3


From 954936dd180e34b79baca71e43d55a204dda9594 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Sat, 5 Nov 2011 15:05:13 -0400
Subject: Support the full set of XHTML character entities

---
 .hgignore             |   3 +
 Makefile.am           |  11 ++-
 Makefile.in           |  11 ++-
 src/sources           |   5 ++
 src/urweb.lex         |  20 +++--
 src/utf8.sig          |  32 +++++++
 src/utf8.sml          |  59 +++++++++++++
 tests/entities.ur     |   5 ++
 xml/parse.sml         |  77 ++++++++++++++++
 xml/xhtml-lat1.ent    | 196 +++++++++++++++++++++++++++++++++++++++++
 xml/xhtml-special.ent |  80 +++++++++++++++++
 xml/xhtml-symbol.ent  | 237 ++++++++++++++++++++++++++++++++++++++++++++++++++
 12 files changed, 724 insertions(+), 12 deletions(-)
 create mode 100644 src/utf8.sig
 create mode 100644 src/utf8.sml
 create mode 100644 tests/entities.ur
 create mode 100644 xml/parse.sml
 create mode 100644 xml/xhtml-lat1.ent
 create mode 100644 xml/xhtml-special.ent
 create mode 100644 xml/xhtml-symbol.ent

(limited to 'src/urweb.lex')

diff --git a/.hgignore b/.hgignore
index cfb45564..401353b3 100644
--- a/.hgignore
+++ b/.hgignore
@@ -48,6 +48,9 @@ doc/*.html
 Makefile.coq
 *.vo
 
+xml/parse
+xml/entities.sml
+
 syntax: regexp
 
 ^Makefile$
diff --git a/Makefile.am b/Makefile.am
index 45e7d7e0..42e5d4d7 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -21,7 +21,7 @@ mlton: bin/urweb
 
 clean-local:
 	rm -f src/*.mlton.grm.* src/*.mlton.lex.* \
-		src/urweb.cm src/urweb.mlb
+		src/urweb.cm src/urweb.mlb xml/parse xml/entities.sml
 	rm -rf .cm src/.cm
 
 src/urweb.cm: src/prefix.cm src/sources
@@ -55,11 +55,18 @@ MLTON := mlton
 #	MLTON += -profile $(PROFILE)
 #endif
 
-bin/urweb: src/compiler.mlb src/urweb.mlb src/*.sig src/*.sml \
+bin/urweb: xml/entities.sml \
+		src/compiler.mlb src/urweb.mlb src/*.sig src/*.sml \
 		src/urweb.mlton.lex.sml \
 		src/urweb.mlton.grm.sig src/urweb.mlton.grm.sml
 	$(MLTON) -output $@ src/compiler.mlb
 
+xml/entities.sml: xml/parse xml/xhtml-lat1.ent xml/xhtml-special.ent xml/xhtml-symbol.ent
+	xml/parse >xml/entities.sml
+
+xml/parse: xml/parse.sml
+	$(MLTON) xml/parse.sml
+
 install-exec-emacs:
 if USE_EMACS
 	mkdir -p $(DESTDIR)$(SITELISP)
diff --git a/Makefile.in b/Makefile.in
index f8a7dfd9..c758310d 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -750,7 +750,7 @@ mlton: bin/urweb
 
 clean-local:
 	rm -f src/*.mlton.grm.* src/*.mlton.lex.* \
-		src/urweb.cm src/urweb.mlb
+		src/urweb.cm src/urweb.mlb xml/parse xml/entities.sml
 	rm -rf .cm src/.cm
 
 src/urweb.cm: src/prefix.cm src/sources
@@ -782,11 +782,18 @@ src/urweb.mlton.grm.sig src/urweb.mlton.grm.sml: src/urweb.mlton.grm
 #	MLTON += -profile $(PROFILE)
 #endif
 
-bin/urweb: src/compiler.mlb src/urweb.mlb src/*.sig src/*.sml \
+bin/urweb: xml/entities.sml \
+		src/compiler.mlb src/urweb.mlb src/*.sig src/*.sml \
 		src/urweb.mlton.lex.sml \
 		src/urweb.mlton.grm.sig src/urweb.mlton.grm.sml
 	$(MLTON) -output $@ src/compiler.mlb
 
+xml/entities.sml: xml/parse xml/xhtml-lat1.ent xml/xhtml-special.ent xml/xhtml-symbol.ent
+	xml/parse >xml/entities.sml
+
+xml/parse: xml/parse.sml
+	$(MLTON) xml/parse.sml
+
 install-exec-emacs:
 @USE_EMACS_TRUE@	mkdir -p $(DESTDIR)$(SITELISP)
 @USE_EMACS_TRUE@	cp src/elisp/*.el $(DESTDIR)$(SITELISP)/
diff --git a/src/sources b/src/sources
index ebc2ab13..862845d5 100644
--- a/src/sources
+++ b/src/sources
@@ -47,6 +47,11 @@ export.sml
 
 source.sml
 
+utf8.sig
+utf8.sml
+
+../xml/entities.sml
+
 urweb.grm
 urweb.lex
 
diff --git a/src/urweb.lex b/src/urweb.lex
index 19f28738..a989d933 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -113,6 +113,14 @@ fun initialize () = (xmlTag := [];
 		     xmlString := false)
 
 
+structure StringMap = BinaryMapFn(struct
+                                  type ord_key = string
+                                  val compare = String.compare
+                                  end)
+
+val entities = foldl (fn ((key, value), entities) => StringMap.insert (entities, key, value))
+                     StringMap.empty Entities.all
+
 fun unescape loc s =
     let
         fun process (s, acc) =
@@ -141,20 +149,16 @@ fun unescape loc s =
                                         let
                                             val code = Substring.string (Substring.slice (code, 1, NONE))
                                         in
-                                            Option.map chr (Int.fromString code)
+                                            Option.map Utf8.encode (Int.fromString code)
                                         end
-                                    else case Substring.string code of
-                                             "amp" => SOME #"&"
-                                           | "lt" => SOME #"<"
-                                           | "gt" => SOME #">"
-                                           | "quot" => SOME #"\""
-                                           | _ => NONE
+                                    else
+                                        Option.map Utf8.encode (StringMap.find (entities, Substring.string code))
                             in
                                 case special of
                                     NONE => (ErrorMsg.errorAt' loc ("Unsupported XML character entity "
                                                                         ^ Substring.string code);
                                              "")
-                                  | SOME ch => process (s, Substring.full (String.str ch) :: pre :: acc)
+                                  | SOME sp => process (s, Substring.full sp :: pre :: acc)
                             end
                     end
             end
diff --git a/src/utf8.sig b/src/utf8.sig
new file mode 100644
index 00000000..4198f604
--- /dev/null
+++ b/src/utf8.sig
@@ -0,0 +1,32 @@
+(* Copyright (c) 2011, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+(* UTF-8 conversion *)
+
+signature UTF8 = sig
+    val encode : int -> string
+end
diff --git a/src/utf8.sml b/src/utf8.sml
new file mode 100644
index 00000000..cbd2fa5c
--- /dev/null
+++ b/src/utf8.sml
@@ -0,0 +1,59 @@
+(* Copyright (c) 2011, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+(* UTF-8 conversion *)
+
+structure Utf8 :> UTF8 = struct
+
+fun byte n = str (chr (Word.toInt n))
+
+fun encode n =
+    if n <= 0 then
+        raise Fail "Invalid character to UTF-8-encode"
+    else if n <= 0x7F then
+        str (chr n)
+    else if n <= 0x7FF then
+        let
+            val w = Word.fromInt n
+            val b1 = Word.orb (Word.fromInt (128 + 64), Word.>> (w, Word.fromInt 6))
+            val b2 = Word.orb (Word.fromInt 128, Word.andb (w, Word.fromInt 63))
+        in
+            byte b1 ^ byte b2
+        end
+    else if n <= 0xFFFF then
+        let
+            val w = Word.fromInt n
+            val b1 = Word.orb (Word.fromInt (128 + 64 + 32), Word.>> (w, Word.fromInt 12))
+            val b2 = Word.orb (Word.fromInt 128, Word.andb (Word.>> (w, Word.fromInt 6), Word.fromInt 63))
+            val b3 = Word.orb (Word.fromInt 128, Word.andb (w, Word.fromInt 63))
+        in
+            byte b1 ^ byte b2 ^ byte b3
+        end
+    else
+        raise Fail "Exceeded supported range for UTF-8 characters"
+
+end
diff --git a/tests/entities.ur b/tests/entities.ur
new file mode 100644
index 00000000..8b78edbc
--- /dev/null
+++ b/tests/entities.ur
@@ -0,0 +1,5 @@
+fun main () : transaction page = return <xml><body>
+  Hello world! &amp; so on, &copy; me today (8 &euro;)<br/>
+  &spades; &clubs; &hearts; &diams;<br/>
+  &dagger; DANGER &dagger;
+</body></xml>
diff --git a/xml/parse.sml b/xml/parse.sml
new file mode 100644
index 00000000..86ff3682
--- /dev/null
+++ b/xml/parse.sml
@@ -0,0 +1,77 @@
+(* Copyright (c) 2011, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+(* Building SML code from XML entity tables *)
+
+fun main () =
+    let
+        fun doFile fname =
+            let
+                val inf = TextIO.openIn fname
+
+                fun loop () =
+                    case TextIO.inputLine inf of
+                        NONE => TextIO.closeIn inf
+                      | SOME line =>
+                        if String.isPrefix "<!ENTITY " line then
+                            case String.tokens (fn ch => Char.isSpace ch orelse ch = #">") line of
+                                "<!ENTITY" :: ent :: exp :: _ =>
+                                let
+                                    val exp = if String.isPrefix "\"&#" exp andalso String.isSuffix ";\"" exp then
+                                                  let
+                                                      val middle = String.substring (exp, 3, size exp - 5)
+                                                  in
+                                                      if CharVector.all Char.isDigit middle then
+                                                          middle
+                                                      else if String.isPrefix "38;#" middle then
+                                                          String.extract (middle, 4, NONE)
+                                                      else
+                                                          raise Fail "Bad entity expression [1]"
+                                                  end
+                                              else
+                                                  raise Fail "Bad entity expansion [2]"
+                                in
+                                    print ("\t\t(\"" ^ ent ^ "\", " ^ exp ^ "),\n");
+                                    loop ()
+                                end
+                              | _ => raise Fail "Bad ENTITY line"
+                        else
+                            loop ()
+            in
+                loop ()
+            end
+    in
+        print "structure Entities = struct\n";
+        print "\tval all = [\n";
+        doFile "xml/xhtml-lat1.ent";
+        doFile "xml/xhtml-special.ent";
+        doFile "xml/xhtml-symbol.ent";
+        print "\t(\"\", 0)]\n";
+        print "end\n"
+    end
+
+val () = main ()
diff --git a/xml/xhtml-lat1.ent b/xml/xhtml-lat1.ent
new file mode 100644
index 00000000..ffee223e
--- /dev/null
+++ b/xml/xhtml-lat1.ent
@@ -0,0 +1,196 @@
+<!-- Portions (C) International Organization for Standardization 1986
+     Permission to copy in any form is granted for use with
+     conforming SGML systems and applications as defined in
+     ISO 8879, provided this notice is included in all copies.
+-->
+<!-- Character entity set. Typical invocation:
+    <!ENTITY % HTMLlat1 PUBLIC
+       "-//W3C//ENTITIES Latin 1 for XHTML//EN"
+       "http://www.w3.org/TR/xhtml1/DTD/xhtml-lat1.ent">
+    %HTMLlat1;
+-->
+
+<!ENTITY nbsp   "&#160;"> <!-- no-break space = non-breaking space,
+                                  U+00A0 ISOnum -->
+<!ENTITY iexcl  "&#161;"> <!-- inverted exclamation mark, U+00A1 ISOnum -->
+<!ENTITY cent   "&#162;"> <!-- cent sign, U+00A2 ISOnum -->
+<!ENTITY pound  "&#163;"> <!-- pound sign, U+00A3 ISOnum -->
+<!ENTITY curren "&#164;"> <!-- currency sign, U+00A4 ISOnum -->
+<!ENTITY yen    "&#165;"> <!-- yen sign = yuan sign, U+00A5 ISOnum -->
+<!ENTITY brvbar "&#166;"> <!-- broken bar = broken vertical bar,
+                                  U+00A6 ISOnum -->
+<!ENTITY sect   "&#167;"> <!-- section sign, U+00A7 ISOnum -->
+<!ENTITY uml    "&#168;"> <!-- diaeresis = spacing diaeresis,
+                                  U+00A8 ISOdia -->
+<!ENTITY copy   "&#169;"> <!-- copyright sign, U+00A9 ISOnum -->
+<!ENTITY ordf   "&#170;"> <!-- feminine ordinal indicator, U+00AA ISOnum -->
+<!ENTITY laquo  "&#171;"> <!-- left-pointing double angle quotation mark
+                                  = left pointing guillemet, U+00AB ISOnum -->
+<!ENTITY not    "&#172;"> <!-- not sign = angled dash,
+                                  U+00AC ISOnum -->
+<!ENTITY shy    "&#173;"> <!-- soft hyphen = discretionary hyphen,
+                                  U+00AD ISOnum -->
+<!ENTITY reg    "&#174;"> <!-- registered sign = registered trade mark sign,
+                                  U+00AE ISOnum -->
+<!ENTITY macr   "&#175;"> <!-- macron = spacing macron = overline
+                                  = APL overbar, U+00AF ISOdia -->
+<!ENTITY deg    "&#176;"> <!-- degree sign, U+00B0 ISOnum -->
+<!ENTITY plusmn "&#177;"> <!-- plus-minus sign = plus-or-minus sign,
+                                  U+00B1 ISOnum -->
+<!ENTITY sup2   "&#178;"> <!-- superscript two = superscript digit two
+                                  = squared, U+00B2 ISOnum -->
+<!ENTITY sup3   "&#179;"> <!-- superscript three = superscript digit three
+                                  = cubed, U+00B3 ISOnum -->
+<!ENTITY acute  "&#180;"> <!-- acute accent = spacing acute,
+                                  U+00B4 ISOdia -->
+<!ENTITY micro  "&#181;"> <!-- micro sign, U+00B5 ISOnum -->
+<!ENTITY para   "&#182;"> <!-- pilcrow sign = paragraph sign,
+                                  U+00B6 ISOnum -->
+<!ENTITY middot "&#183;"> <!-- middle dot = Georgian comma
+                                  = Greek middle dot, U+00B7 ISOnum -->
+<!ENTITY cedil  "&#184;"> <!-- cedilla = spacing cedilla, U+00B8 ISOdia -->
+<!ENTITY sup1   "&#185;"> <!-- superscript one = superscript digit one,
+                                  U+00B9 ISOnum -->
+<!ENTITY ordm   "&#186;"> <!-- masculine ordinal indicator,
+                                  U+00BA ISOnum -->
+<!ENTITY raquo  "&#187;"> <!-- right-pointing double angle quotation mark
+                                  = right pointing guillemet, U+00BB ISOnum -->
+<!ENTITY frac14 "&#188;"> <!-- vulgar fraction one quarter
+                                  = fraction one quarter, U+00BC ISOnum -->
+<!ENTITY frac12 "&#189;"> <!-- vulgar fraction one half
+                                  = fraction one half, U+00BD ISOnum -->
+<!ENTITY frac34 "&#190;"> <!-- vulgar fraction three quarters
+                                  = fraction three quarters, U+00BE ISOnum -->
+<!ENTITY iquest "&#191;"> <!-- inverted question mark
+                                  = turned question mark, U+00BF ISOnum -->
+<!ENTITY Agrave "&#192;"> <!-- latin capital letter A with grave
+                                  = latin capital letter A grave,
+                                  U+00C0 ISOlat1 -->
+<!ENTITY Aacute "&#193;"> <!-- latin capital letter A with acute,
+                                  U+00C1 ISOlat1 -->
+<!ENTITY Acirc  "&#194;"> <!-- latin capital letter A with circumflex,
+                                  U+00C2 ISOlat1 -->
+<!ENTITY Atilde "&#195;"> <!-- latin capital letter A with tilde,
+                                  U+00C3 ISOlat1 -->
+<!ENTITY Auml   "&#196;"> <!-- latin capital letter A with diaeresis,
+                                  U+00C4 ISOlat1 -->
+<!ENTITY Aring  "&#197;"> <!-- latin capital letter A with ring above
+                                  = latin capital letter A ring,
+                                  U+00C5 ISOlat1 -->
+<!ENTITY AElig  "&#198;"> <!-- latin capital letter AE
+                                  = latin capital ligature AE,
+                                  U+00C6 ISOlat1 -->
+<!ENTITY Ccedil "&#199;"> <!-- latin capital letter C with cedilla,
+                                  U+00C7 ISOlat1 -->
+<!ENTITY Egrave "&#200;"> <!-- latin capital letter E with grave,
+                                  U+00C8 ISOlat1 -->
+<!ENTITY Eacute "&#201;"> <!-- latin capital letter E with acute,
+                                  U+00C9 ISOlat1 -->
+<!ENTITY Ecirc  "&#202;"> <!-- latin capital letter E with circumflex,
+                                  U+00CA ISOlat1 -->
+<!ENTITY Euml   "&#203;"> <!-- latin capital letter E with diaeresis,
+                                  U+00CB ISOlat1 -->
+<!ENTITY Igrave "&#204;"> <!-- latin capital letter I with grave,
+                                  U+00CC ISOlat1 -->
+<!ENTITY Iacute "&#205;"> <!-- latin capital letter I with acute,
+                                  U+00CD ISOlat1 -->
+<!ENTITY Icirc  "&#206;"> <!-- latin capital letter I with circumflex,
+                                  U+00CE ISOlat1 -->
+<!ENTITY Iuml   "&#207;"> <!-- latin capital letter I with diaeresis,
+                                  U+00CF ISOlat1 -->
+<!ENTITY ETH    "&#208;"> <!-- latin capital letter ETH, U+00D0 ISOlat1 -->
+<!ENTITY Ntilde "&#209;"> <!-- latin capital letter N with tilde,
+                                  U+00D1 ISOlat1 -->
+<!ENTITY Ograve "&#210;"> <!-- latin capital letter O with grave,
+                                  U+00D2 ISOlat1 -->
+<!ENTITY Oacute "&#211;"> <!-- latin capital letter O with acute,
+                                  U+00D3 ISOlat1 -->
+<!ENTITY Ocirc  "&#212;"> <!-- latin capital letter O with circumflex,
+                                  U+00D4 ISOlat1 -->
+<!ENTITY Otilde "&#213;"> <!-- latin capital letter O with tilde,
+                                  U+00D5 ISOlat1 -->
+<!ENTITY Ouml   "&#214;"> <!-- latin capital letter O with diaeresis,
+                                  U+00D6 ISOlat1 -->
+<!ENTITY times  "&#215;"> <!-- multiplication sign, U+00D7 ISOnum -->
+<!ENTITY Oslash "&#216;"> <!-- latin capital letter O with stroke
+                                  = latin capital letter O slash,
+                                  U+00D8 ISOlat1 -->
+<!ENTITY Ugrave "&#217;"> <!-- latin capital letter U with grave,
+                                  U+00D9 ISOlat1 -->
+<!ENTITY Uacute "&#218;"> <!-- latin capital letter U with acute,
+                                  U+00DA ISOlat1 -->
+<!ENTITY Ucirc  "&#219;"> <!-- latin capital letter U with circumflex,
+                                  U+00DB ISOlat1 -->
+<!ENTITY Uuml   "&#220;"> <!-- latin capital letter U with diaeresis,
+                                  U+00DC ISOlat1 -->
+<!ENTITY Yacute "&#221;"> <!-- latin capital letter Y with acute,
+                                  U+00DD ISOlat1 -->
+<!ENTITY THORN  "&#222;"> <!-- latin capital letter THORN,
+                                  U+00DE ISOlat1 -->
+<!ENTITY szlig  "&#223;"> <!-- latin small letter sharp s = ess-zed,
+                                  U+00DF ISOlat1 -->
+<!ENTITY agrave "&#224;"> <!-- latin small letter a with grave
+                                  = latin small letter a grave,
+                                  U+00E0 ISOlat1 -->
+<!ENTITY aacute "&#225;"> <!-- latin small letter a with acute,
+                                  U+00E1 ISOlat1 -->
+<!ENTITY acirc  "&#226;"> <!-- latin small letter a with circumflex,
+                                  U+00E2 ISOlat1 -->
+<!ENTITY atilde "&#227;"> <!-- latin small letter a with tilde,
+                                  U+00E3 ISOlat1 -->
+<!ENTITY auml   "&#228;"> <!-- latin small letter a with diaeresis,
+                                  U+00E4 ISOlat1 -->
+<!ENTITY aring  "&#229;"> <!-- latin small letter a with ring above
+                                  = latin small letter a ring,
+                                  U+00E5 ISOlat1 -->
+<!ENTITY aelig  "&#230;"> <!-- latin small letter ae
+                                  = latin small ligature ae, U+00E6 ISOlat1 -->
+<!ENTITY ccedil "&#231;"> <!-- latin small letter c with cedilla,
+                                  U+00E7 ISOlat1 -->
+<!ENTITY egrave "&#232;"> <!-- latin small letter e with grave,
+                                  U+00E8 ISOlat1 -->
+<!ENTITY eacute "&#233;"> <!-- latin small letter e with acute,
+                                  U+00E9 ISOlat1 -->
+<!ENTITY ecirc  "&#234;"> <!-- latin small letter e with circumflex,
+                                  U+00EA ISOlat1 -->
+<!ENTITY euml   "&#235;"> <!-- latin small letter e with diaeresis,
+                                  U+00EB ISOlat1 -->
+<!ENTITY igrave "&#236;"> <!-- latin small letter i with grave,
+                                  U+00EC ISOlat1 -->
+<!ENTITY iacute "&#237;"> <!-- latin small letter i with acute,
+                                  U+00ED ISOlat1 -->
+<!ENTITY icirc  "&#238;"> <!-- latin small letter i with circumflex,
+                                  U+00EE ISOlat1 -->
+<!ENTITY iuml   "&#239;"> <!-- latin small letter i with diaeresis,
+                                  U+00EF ISOlat1 -->
+<!ENTITY eth    "&#240;"> <!-- latin small letter eth, U+00F0 ISOlat1 -->
+<!ENTITY ntilde "&#241;"> <!-- latin small letter n with tilde,
+                                  U+00F1 ISOlat1 -->
+<!ENTITY ograve "&#242;"> <!-- latin small letter o with grave,
+                                  U+00F2 ISOlat1 -->
+<!ENTITY oacute "&#243;"> <!-- latin small letter o with acute,
+                                  U+00F3 ISOlat1 -->
+<!ENTITY ocirc  "&#244;"> <!-- latin small letter o with circumflex,
+                                  U+00F4 ISOlat1 -->
+<!ENTITY otilde "&#245;"> <!-- latin small letter o with tilde,
+                                  U+00F5 ISOlat1 -->
+<!ENTITY ouml   "&#246;"> <!-- latin small letter o with diaeresis,
+                                  U+00F6 ISOlat1 -->
+<!ENTITY divide "&#247;"> <!-- division sign, U+00F7 ISOnum -->
+<!ENTITY oslash "&#248;"> <!-- latin small letter o with stroke,
+                                  = latin small letter o slash,
+                                  U+00F8 ISOlat1 -->
+<!ENTITY ugrave "&#249;"> <!-- latin small letter u with grave,
+                                  U+00F9 ISOlat1 -->
+<!ENTITY uacute "&#250;"> <!-- latin small letter u with acute,
+                                  U+00FA ISOlat1 -->
+<!ENTITY ucirc  "&#251;"> <!-- latin small letter u with circumflex,
+                                  U+00FB ISOlat1 -->
+<!ENTITY uuml   "&#252;"> <!-- latin small letter u with diaeresis,
+                                  U+00FC ISOlat1 -->
+<!ENTITY yacute "&#253;"> <!-- latin small letter y with acute,
+                                  U+00FD ISOlat1 -->
+<!ENTITY thorn  "&#254;"> <!-- latin small letter thorn,
+                                  U+00FE ISOlat1 -->
+<!ENTITY yuml   "&#255;"> <!-- latin small letter y with diaeresis,
+                                  U+00FF ISOlat1 -->
diff --git a/xml/xhtml-special.ent b/xml/xhtml-special.ent
new file mode 100644
index 00000000..ca358b2f
--- /dev/null
+++ b/xml/xhtml-special.ent
@@ -0,0 +1,80 @@
+<!-- Special characters for XHTML -->
+
+<!-- Character entity set. Typical invocation:
+     <!ENTITY % HTMLspecial PUBLIC
+        "-//W3C//ENTITIES Special for XHTML//EN"
+        "http://www.w3.org/TR/xhtml1/DTD/xhtml-special.ent">
+     %HTMLspecial;
+-->
+
+<!-- Portions (C) International Organization for Standardization 1986:
+     Permission to copy in any form is granted for use with
+     conforming SGML systems and applications as defined in
+     ISO 8879, provided this notice is included in all copies.
+-->
+
+<!-- Relevant ISO entity set is given unless names are newly introduced.
+     New names (i.e., not in ISO 8879 list) do not clash with any
+     existing ISO 8879 entity names. ISO 10646 character numbers
+     are given for each character, in hex. values are decimal
+     conversions of the ISO 10646 values and refer to the document
+     character set. Names are Unicode names. 
+-->
+
+<!-- C0 Controls and Basic Latin -->
+<!ENTITY quot    "&#34;"> <!--  quotation mark, U+0022 ISOnum -->
+<!ENTITY amp     "&#38;#38;"> <!--  ampersand, U+0026 ISOnum -->
+<!ENTITY lt      "&#38;#60;"> <!--  less-than sign, U+003C ISOnum -->
+<!ENTITY gt      "&#62;"> <!--  greater-than sign, U+003E ISOnum -->
+<!ENTITY apos	 "&#39;"> <!--  apostrophe = APL quote, U+0027 ISOnum -->
+
+<!-- Latin Extended-A -->
+<!ENTITY OElig   "&#338;"> <!--  latin capital ligature OE,
+                                    U+0152 ISOlat2 -->
+<!ENTITY oelig   "&#339;"> <!--  latin small ligature oe, U+0153 ISOlat2 -->
+<!-- ligature is a misnomer, this is a separate character in some languages -->
+<!ENTITY Scaron  "&#352;"> <!--  latin capital letter S with caron,
+                                    U+0160 ISOlat2 -->
+<!ENTITY scaron  "&#353;"> <!--  latin small letter s with caron,
+                                    U+0161 ISOlat2 -->
+<!ENTITY Yuml    "&#376;"> <!--  latin capital letter Y with diaeresis,
+                                    U+0178 ISOlat2 -->
+
+<!-- Spacing Modifier Letters -->
+<!ENTITY circ    "&#710;"> <!--  modifier letter circumflex accent,
+                                    U+02C6 ISOpub -->
+<!ENTITY tilde   "&#732;"> <!--  small tilde, U+02DC ISOdia -->
+
+<!-- General Punctuation -->
+<!ENTITY ensp    "&#8194;"> <!-- en space, U+2002 ISOpub -->
+<!ENTITY emsp    "&#8195;"> <!-- em space, U+2003 ISOpub -->
+<!ENTITY thinsp  "&#8201;"> <!-- thin space, U+2009 ISOpub -->
+<!ENTITY zwnj    "&#8204;"> <!-- zero width non-joiner,
+                                    U+200C NEW RFC 2070 -->
+<!ENTITY zwj     "&#8205;"> <!-- zero width joiner, U+200D NEW RFC 2070 -->
+<!ENTITY lrm     "&#8206;"> <!-- left-to-right mark, U+200E NEW RFC 2070 -->
+<!ENTITY rlm     "&#8207;"> <!-- right-to-left mark, U+200F NEW RFC 2070 -->
+<!ENTITY ndash   "&#8211;"> <!-- en dash, U+2013 ISOpub -->
+<!ENTITY mdash   "&#8212;"> <!-- em dash, U+2014 ISOpub -->
+<!ENTITY lsquo   "&#8216;"> <!-- left single quotation mark,
+                                    U+2018 ISOnum -->
+<!ENTITY rsquo   "&#8217;"> <!-- right single quotation mark,
+                                    U+2019 ISOnum -->
+<!ENTITY sbquo   "&#8218;"> <!-- single low-9 quotation mark, U+201A NEW -->
+<!ENTITY ldquo   "&#8220;"> <!-- left double quotation mark,
+                                    U+201C ISOnum -->
+<!ENTITY rdquo   "&#8221;"> <!-- right double quotation mark,
+                                    U+201D ISOnum -->
+<!ENTITY bdquo   "&#8222;"> <!-- double low-9 quotation mark, U+201E NEW -->
+<!ENTITY dagger  "&#8224;"> <!-- dagger, U+2020 ISOpub -->
+<!ENTITY Dagger  "&#8225;"> <!-- double dagger, U+2021 ISOpub -->
+<!ENTITY permil  "&#8240;"> <!-- per mille sign, U+2030 ISOtech -->
+<!ENTITY lsaquo  "&#8249;"> <!-- single left-pointing angle quotation mark,
+                                    U+2039 ISO proposed -->
+<!-- lsaquo is proposed but not yet ISO standardized -->
+<!ENTITY rsaquo  "&#8250;"> <!-- single right-pointing angle quotation mark,
+                                    U+203A ISO proposed -->
+<!-- rsaquo is proposed but not yet ISO standardized -->
+
+<!-- Currency Symbols -->
+<!ENTITY euro   "&#8364;"> <!--  euro sign, U+20AC NEW -->
diff --git a/xml/xhtml-symbol.ent b/xml/xhtml-symbol.ent
new file mode 100644
index 00000000..63c2abfa
--- /dev/null
+++ b/xml/xhtml-symbol.ent
@@ -0,0 +1,237 @@
+<!-- Mathematical, Greek and Symbolic characters for XHTML -->
+
+<!-- Character entity set. Typical invocation:
+     <!ENTITY % HTMLsymbol PUBLIC
+        "-//W3C//ENTITIES Symbols for XHTML//EN"
+        "http://www.w3.org/TR/xhtml1/DTD/xhtml-symbol.ent">
+     %HTMLsymbol;
+-->
+
+<!-- Portions (C) International Organization for Standardization 1986:
+     Permission to copy in any form is granted for use with
+     conforming SGML systems and applications as defined in
+     ISO 8879, provided this notice is included in all copies.
+-->
+
+<!-- Relevant ISO entity set is given unless names are newly introduced.
+     New names (i.e., not in ISO 8879 list) do not clash with any
+     existing ISO 8879 entity names. ISO 10646 character numbers
+     are given for each character, in hex. values are decimal
+     conversions of the ISO 10646 values and refer to the document
+     character set. Names are Unicode names. 
+-->
+
+<!-- Latin Extended-B -->
+<!ENTITY fnof     "&#402;"> <!-- latin small letter f with hook = function
+                                    = florin, U+0192 ISOtech -->
+
+<!-- Greek -->
+<!ENTITY Alpha    "&#913;"> <!-- greek capital letter alpha, U+0391 -->
+<!ENTITY Beta     "&#914;"> <!-- greek capital letter beta, U+0392 -->
+<!ENTITY Gamma    "&#915;"> <!-- greek capital letter gamma,
+                                    U+0393 ISOgrk3 -->
+<!ENTITY Delta    "&#916;"> <!-- greek capital letter delta,
+                                    U+0394 ISOgrk3 -->
+<!ENTITY Epsilon  "&#917;"> <!-- greek capital letter epsilon, U+0395 -->
+<!ENTITY Zeta     "&#918;"> <!-- greek capital letter zeta, U+0396 -->
+<!ENTITY Eta      "&#919;"> <!-- greek capital letter eta, U+0397 -->
+<!ENTITY Theta    "&#920;"> <!-- greek capital letter theta,
+                                    U+0398 ISOgrk3 -->
+<!ENTITY Iota     "&#921;"> <!-- greek capital letter iota, U+0399 -->
+<!ENTITY Kappa    "&#922;"> <!-- greek capital letter kappa, U+039A -->
+<!ENTITY Lambda   "&#923;"> <!-- greek capital letter lamda,
+                                    U+039B ISOgrk3 -->
+<!ENTITY Mu       "&#924;"> <!-- greek capital letter mu, U+039C -->
+<!ENTITY Nu       "&#925;"> <!-- greek capital letter nu, U+039D -->
+<!ENTITY Xi       "&#926;"> <!-- greek capital letter xi, U+039E ISOgrk3 -->
+<!ENTITY Omicron  "&#927;"> <!-- greek capital letter omicron, U+039F -->
+<!ENTITY Pi       "&#928;"> <!-- greek capital letter pi, U+03A0 ISOgrk3 -->
+<!ENTITY Rho      "&#929;"> <!-- greek capital letter rho, U+03A1 -->
+<!-- there is no Sigmaf, and no U+03A2 character either -->
+<!ENTITY Sigma    "&#931;"> <!-- greek capital letter sigma,
+                                    U+03A3 ISOgrk3 -->
+<!ENTITY Tau      "&#932;"> <!-- greek capital letter tau, U+03A4 -->
+<!ENTITY Upsilon  "&#933;"> <!-- greek capital letter upsilon,
+                                    U+03A5 ISOgrk3 -->
+<!ENTITY Phi      "&#934;"> <!-- greek capital letter phi,
+                                    U+03A6 ISOgrk3 -->
+<!ENTITY Chi      "&#935;"> <!-- greek capital letter chi, U+03A7 -->
+<!ENTITY Psi      "&#936;"> <!-- greek capital letter psi,
+                                    U+03A8 ISOgrk3 -->
+<!ENTITY Omega    "&#937;"> <!-- greek capital letter omega,
+                                    U+03A9 ISOgrk3 -->
+
+<!ENTITY alpha    "&#945;"> <!-- greek small letter alpha,
+                                    U+03B1 ISOgrk3 -->
+<!ENTITY beta     "&#946;"> <!-- greek small letter beta, U+03B2 ISOgrk3 -->
+<!ENTITY gamma    "&#947;"> <!-- greek small letter gamma,
+                                    U+03B3 ISOgrk3 -->
+<!ENTITY delta    "&#948;"> <!-- greek small letter delta,
+                                    U+03B4 ISOgrk3 -->
+<!ENTITY epsilon  "&#949;"> <!-- greek small letter epsilon,
+                                    U+03B5 ISOgrk3 -->
+<!ENTITY zeta     "&#950;"> <!-- greek small letter zeta, U+03B6 ISOgrk3 -->
+<!ENTITY eta      "&#951;"> <!-- greek small letter eta, U+03B7 ISOgrk3 -->
+<!ENTITY theta    "&#952;"> <!-- greek small letter theta,
+                                    U+03B8 ISOgrk3 -->
+<!ENTITY iota     "&#953;"> <!-- greek small letter iota, U+03B9 ISOgrk3 -->
+<!ENTITY kappa    "&#954;"> <!-- greek small letter kappa,
+                                    U+03BA ISOgrk3 -->
+<!ENTITY lambda   "&#955;"> <!-- greek small letter lamda,
+                                    U+03BB ISOgrk3 -->
+<!ENTITY mu       "&#956;"> <!-- greek small letter mu, U+03BC ISOgrk3 -->
+<!ENTITY nu       "&#957;"> <!-- greek small letter nu, U+03BD ISOgrk3 -->
+<!ENTITY xi       "&#958;"> <!-- greek small letter xi, U+03BE ISOgrk3 -->
+<!ENTITY omicron  "&#959;"> <!-- greek small letter omicron, U+03BF NEW -->
+<!ENTITY pi       "&#960;"> <!-- greek small letter pi, U+03C0 ISOgrk3 -->
+<!ENTITY rho      "&#961;"> <!-- greek small letter rho, U+03C1 ISOgrk3 -->
+<!ENTITY sigmaf   "&#962;"> <!-- greek small letter final sigma,
+                                    U+03C2 ISOgrk3 -->
+<!ENTITY sigma    "&#963;"> <!-- greek small letter sigma,
+                                    U+03C3 ISOgrk3 -->
+<!ENTITY tau      "&#964;"> <!-- greek small letter tau, U+03C4 ISOgrk3 -->
+<!ENTITY upsilon  "&#965;"> <!-- greek small letter upsilon,
+                                    U+03C5 ISOgrk3 -->
+<!ENTITY phi      "&#966;"> <!-- greek small letter phi, U+03C6 ISOgrk3 -->
+<!ENTITY chi      "&#967;"> <!-- greek small letter chi, U+03C7 ISOgrk3 -->
+<!ENTITY psi      "&#968;"> <!-- greek small letter psi, U+03C8 ISOgrk3 -->
+<!ENTITY omega    "&#969;"> <!-- greek small letter omega,
+                                    U+03C9 ISOgrk3 -->
+<!ENTITY thetasym "&#977;"> <!-- greek theta symbol,
+                                    U+03D1 NEW -->
+<!ENTITY upsih    "&#978;"> <!-- greek upsilon with hook symbol,
+                                    U+03D2 NEW -->
+<!ENTITY piv      "&#982;"> <!-- greek pi symbol, U+03D6 ISOgrk3 -->
+
+<!-- General Punctuation -->
+<!ENTITY bull     "&#8226;"> <!-- bullet = black small circle,
+                                     U+2022 ISOpub  -->
+<!-- bullet is NOT the same as bullet operator, U+2219 -->
+<!ENTITY hellip   "&#8230;"> <!-- horizontal ellipsis = three dot leader,
+                                     U+2026 ISOpub  -->
+<!ENTITY prime    "&#8242;"> <!-- prime = minutes = feet, U+2032 ISOtech -->
+<!ENTITY Prime    "&#8243;"> <!-- double prime = seconds = inches,
+                                     U+2033 ISOtech -->
+<!ENTITY oline    "&#8254;"> <!-- overline = spacing overscore,
+                                     U+203E NEW -->
+<!ENTITY frasl    "&#8260;"> <!-- fraction slash, U+2044 NEW -->
+
+<!-- Letterlike Symbols -->
+<!ENTITY weierp   "&#8472;"> <!-- script capital P = power set
+                                     = Weierstrass p, U+2118 ISOamso -->
+<!ENTITY image    "&#8465;"> <!-- black-letter capital I = imaginary part,
+                                     U+2111 ISOamso -->
+<!ENTITY real     "&#8476;"> <!-- black-letter capital R = real part symbol,
+                                     U+211C ISOamso -->
+<!ENTITY trade    "&#8482;"> <!-- trade mark sign, U+2122 ISOnum -->
+<!ENTITY alefsym  "&#8501;"> <!-- alef symbol = first transfinite cardinal,
+                                     U+2135 NEW -->
+<!-- alef symbol is NOT the same as hebrew letter alef,
+     U+05D0 although the same glyph could be used to depict both characters -->
+
+<!-- Arrows -->
+<!ENTITY larr     "&#8592;"> <!-- leftwards arrow, U+2190 ISOnum -->
+<!ENTITY uarr     "&#8593;"> <!-- upwards arrow, U+2191 ISOnum-->
+<!ENTITY rarr     "&#8594;"> <!-- rightwards arrow, U+2192 ISOnum -->
+<!ENTITY darr     "&#8595;"> <!-- downwards arrow, U+2193 ISOnum -->
+<!ENTITY harr     "&#8596;"> <!-- left right arrow, U+2194 ISOamsa -->
+<!ENTITY crarr    "&#8629;"> <!-- downwards arrow with corner leftwards
+                                     = carriage return, U+21B5 NEW -->
+<!ENTITY lArr     "&#8656;"> <!-- leftwards double arrow, U+21D0 ISOtech -->
+<!-- Unicode does not say that lArr is the same as the 'is implied by' arrow
+    but also does not have any other character for that function. So lArr can
+    be used for 'is implied by' as ISOtech suggests -->
+<!ENTITY uArr     "&#8657;"> <!-- upwards double arrow, U+21D1 ISOamsa -->
+<!ENTITY rArr     "&#8658;"> <!-- rightwards double arrow,
+                                     U+21D2 ISOtech -->
+<!-- Unicode does not say this is the 'implies' character but does not have 
+     another character with this function so rArr can be used for 'implies'
+     as ISOtech suggests -->
+<!ENTITY dArr     "&#8659;"> <!-- downwards double arrow, U+21D3 ISOamsa -->
+<!ENTITY hArr     "&#8660;"> <!-- left right double arrow,
+                                     U+21D4 ISOamsa -->
+
+<!-- Mathematical Operators -->
+<!ENTITY forall   "&#8704;"> <!-- for all, U+2200 ISOtech -->
+<!ENTITY part     "&#8706;"> <!-- partial differential, U+2202 ISOtech  -->
+<!ENTITY exist    "&#8707;"> <!-- there exists, U+2203 ISOtech -->
+<!ENTITY empty    "&#8709;"> <!-- empty set = null set, U+2205 ISOamso -->
+<!ENTITY nabla    "&#8711;"> <!-- nabla = backward difference,
+                                     U+2207 ISOtech -->
+<!ENTITY isin     "&#8712;"> <!-- element of, U+2208 ISOtech -->
+<!ENTITY notin    "&#8713;"> <!-- not an element of, U+2209 ISOtech -->
+<!ENTITY ni       "&#8715;"> <!-- contains as member, U+220B ISOtech -->
+<!ENTITY prod     "&#8719;"> <!-- n-ary product = product sign,
+                                     U+220F ISOamsb -->
+<!-- prod is NOT the same character as U+03A0 'greek capital letter pi' though
+     the same glyph might be used for both -->
+<!ENTITY sum      "&#8721;"> <!-- n-ary summation, U+2211 ISOamsb -->
+<!-- sum is NOT the same character as U+03A3 'greek capital letter sigma'
+     though the same glyph might be used for both -->
+<!ENTITY minus    "&#8722;"> <!-- minus sign, U+2212 ISOtech -->
+<!ENTITY lowast   "&#8727;"> <!-- asterisk operator, U+2217 ISOtech -->
+<!ENTITY radic    "&#8730;"> <!-- square root = radical sign,
+                                     U+221A ISOtech -->
+<!ENTITY prop     "&#8733;"> <!-- proportional to, U+221D ISOtech -->
+<!ENTITY infin    "&#8734;"> <!-- infinity, U+221E ISOtech -->
+<!ENTITY ang      "&#8736;"> <!-- angle, U+2220 ISOamso -->
+<!ENTITY and      "&#8743;"> <!-- logical and = wedge, U+2227 ISOtech -->
+<!ENTITY or       "&#8744;"> <!-- logical or = vee, U+2228 ISOtech -->
+<!ENTITY cap      "&#8745;"> <!-- intersection = cap, U+2229 ISOtech -->
+<!ENTITY cup      "&#8746;"> <!-- union = cup, U+222A ISOtech -->
+<!ENTITY int      "&#8747;"> <!-- integral, U+222B ISOtech -->
+<!ENTITY there4   "&#8756;"> <!-- therefore, U+2234 ISOtech -->
+<!ENTITY sim      "&#8764;"> <!-- tilde operator = varies with = similar to,
+                                     U+223C ISOtech -->
+<!-- tilde operator is NOT the same character as the tilde, U+007E,
+     although the same glyph might be used to represent both  -->
+<!ENTITY cong     "&#8773;"> <!-- approximately equal to, U+2245 ISOtech -->
+<!ENTITY asymp    "&#8776;"> <!-- almost equal to = asymptotic to,
+                                     U+2248 ISOamsr -->
+<!ENTITY ne       "&#8800;"> <!-- not equal to, U+2260 ISOtech -->
+<!ENTITY equiv    "&#8801;"> <!-- identical to, U+2261 ISOtech -->
+<!ENTITY le       "&#8804;"> <!-- less-than or equal to, U+2264 ISOtech -->
+<!ENTITY ge       "&#8805;"> <!-- greater-than or equal to,
+                                     U+2265 ISOtech -->
+<!ENTITY sub      "&#8834;"> <!-- subset of, U+2282 ISOtech -->
+<!ENTITY sup      "&#8835;"> <!-- superset of, U+2283 ISOtech -->
+<!ENTITY nsub     "&#8836;"> <!-- not a subset of, U+2284 ISOamsn -->
+<!ENTITY sube     "&#8838;"> <!-- subset of or equal to, U+2286 ISOtech -->
+<!ENTITY supe     "&#8839;"> <!-- superset of or equal to,
+                                     U+2287 ISOtech -->
+<!ENTITY oplus    "&#8853;"> <!-- circled plus = direct sum,
+                                     U+2295 ISOamsb -->
+<!ENTITY otimes   "&#8855;"> <!-- circled times = vector product,
+                                     U+2297 ISOamsb -->
+<!ENTITY perp     "&#8869;"> <!-- up tack = orthogonal to = perpendicular,
+                                     U+22A5 ISOtech -->
+<!ENTITY sdot     "&#8901;"> <!-- dot operator, U+22C5 ISOamsb -->
+<!-- dot operator is NOT the same character as U+00B7 middle dot -->
+
+<!-- Miscellaneous Technical -->
+<!ENTITY lceil    "&#8968;"> <!-- left ceiling = APL upstile,
+                                     U+2308 ISOamsc  -->
+<!ENTITY rceil    "&#8969;"> <!-- right ceiling, U+2309 ISOamsc  -->
+<!ENTITY lfloor   "&#8970;"> <!-- left floor = APL downstile,
+                                     U+230A ISOamsc  -->
+<!ENTITY rfloor   "&#8971;"> <!-- right floor, U+230B ISOamsc  -->
+<!ENTITY lang     "&#9001;"> <!-- left-pointing angle bracket = bra,
+                                     U+2329 ISOtech -->
+<!-- lang is NOT the same character as U+003C 'less than sign' 
+     or U+2039 'single left-pointing angle quotation mark' -->
+<!ENTITY rang     "&#9002;"> <!-- right-pointing angle bracket = ket,
+                                     U+232A ISOtech -->
+<!-- rang is NOT the same character as U+003E 'greater than sign' 
+     or U+203A 'single right-pointing angle quotation mark' -->
+
+<!-- Geometric Shapes -->
+<!ENTITY loz      "&#9674;"> <!-- lozenge, U+25CA ISOpub -->
+
+<!-- Miscellaneous Symbols -->
+<!ENTITY spades   "&#9824;"> <!-- black spade suit, U+2660 ISOpub -->
+<!-- black here seems to mean filled as opposed to hollow -->
+<!ENTITY clubs    "&#9827;"> <!-- black club suit = shamrock,
+                                     U+2663 ISOpub -->
+<!ENTITY hearts   "&#9829;"> <!-- black heart suit = valentine,
+                                     U+2665 ISOpub -->
+<!ENTITY diams    "&#9830;"> <!-- black diamond suit, U+2666 ISOpub -->
-- 
cgit v1.2.3


From e43dd849a122a59fa2c22278ddf9c9a09d1550bd Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Sat, 19 Nov 2011 10:43:57 -0500
Subject: COALESCE

---
 doc/manual.tex     | 10 ++++++++++
 lib/ur/basis.urs   |  6 ++++++
 src/monoize.sml    | 22 ++++++++++++++++++++++
 src/urweb.grm      | 10 +++++++++-
 src/urweb.lex      |  1 +
 tests/coalesce.ur  |  6 ++++++
 tests/coalesce.urp |  4 ++++
 7 files changed, 58 insertions(+), 1 deletion(-)
 create mode 100644 tests/coalesce.ur
 create mode 100644 tests/coalesce.urp

(limited to 'src/urweb.lex')

diff --git a/doc/manual.tex b/doc/manual.tex
index 84b300e7..03d29701 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -1709,6 +1709,15 @@ $$\begin{array}{l}
   \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; (\mt{option} \; \mt{t}) \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{bool}
 \end{array}$$
 
+As another way of dealing with null values, there is also a restricted form of the standard \cd{COALESCE} function.
+$$\begin{array}{l}
+  \mt{val} \; \mt{sql\_coalesce} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \\
+  \hspace{.1in} \to \mt{t} ::: \mt{Type} \\
+  \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; (\mt{option} \; \mt{t}) \\
+  \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t} \\
+  \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t}
+\end{array}$$
+
 We have generic nullary, unary, and binary operators.
 $$\begin{array}{l}
   \mt{con} \; \mt{sql\_nfunc} :: \mt{Type} \to \mt{Type} \\
@@ -2140,6 +2149,7 @@ $$\begin{array}{rrcll}
   &&& \ell & \textrm{primitive type literals} \\
   &&& \mt{NULL} & \textrm{null value (injection of $\mt{None}$)} \\
   &&& E \; \mt{IS} \; \mt{NULL} & \textrm{nullness test} \\
+  &&& \mt{COALESCE}(E, E) & \textrm{take first non-null value} \\
   &&& n & \textrm{nullary operators} \\
   &&& u \; E & \textrm{unary operators} \\
   &&& E \; b \; E & \textrm{binary operators} \\
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 73ee8e2b..f21faf38 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -474,6 +474,12 @@ val sql_is_null : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
                   -> sql_exp tables agg exps (option t)
                   -> sql_exp tables agg exps bool
 
+val sql_coalesce : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+                  -> t ::: Type
+                  -> sql_exp tables agg exps (option t)
+                  -> sql_exp tables agg exps t
+                  -> sql_exp tables agg exps t
+
 val sql_if_then_else : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
                        -> t ::: Type
                        -> sql_exp tables agg exps bool
diff --git a/src/monoize.sml b/src/monoize.sml
index e570b4cb..d18b4d2a 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2804,6 +2804,28 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                  fm)
             end
 
+          | (L.ECApp (
+             (L.ECApp (
+              (L.ECApp (
+               (L.ECApp (
+                (L.EFfi ("Basis", "sql_coalesce"), _), _),
+                _), _),
+               _), _),
+              _), _)) =>
+            let
+                val s = (L'.TFfi ("Basis", "string"), loc)
+                fun sc s = (L'.EPrim (Prim.String s), loc)
+            in
+                ((L'.EAbs ("x1", s, (L'.TFun (s, s), loc),
+                           (L'.EAbs ("x1", s, s,
+                                     strcat [sc "COALESCE(",
+                                             (L'.ERel 1, loc),
+                                             sc ",",
+                                             (L'.ERel 0, loc),
+                                             sc ")"]), loc)), loc),
+                 fm)
+            end
+
           | (L.ECApp (
              (L.ECApp (
               (L.ECApp (
diff --git a/src/urweb.grm b/src/urweb.grm
index db8b6294..8e3fad90 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -244,7 +244,7 @@ fun tnamesOf (e, _) =
  | TRUE | FALSE | CAND | OR | NOT
  | COUNT | AVG | SUM | MIN | MAX
  | ASC | DESC
- | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS
+ | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS | COALESCE
  | CURRENT_TIMESTAMP
  | NE | LT | LE | GT | GE
  | CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES
@@ -1881,6 +1881,14 @@ sqlexp : TRUE                           (sql_inject (EVar (["Basis"], "True", In
                                          in
                                              (EApp (e, sqlexp), loc)
                                          end)
+       | COALESCE LPAREN sqlexp COMMA sqlexp RPAREN
+                                        (let
+                                             val loc = s (COALESCEright, sqlexp2right)
+                                             val e = (EVar (["Basis"], "sql_coalesce", Infer), loc)
+                                             val e = (EApp (e, sqlexp1), loc)
+                                         in
+                                             (EApp (e, sqlexp2), loc)
+                                         end)
        | fname LPAREN sqlexp RPAREN     (let
                                              val loc = s (fnameleft, RPARENright)
 
diff --git a/src/urweb.lex b/src/urweb.lex
index a989d933..8e8b0a12 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -499,6 +499,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 <INITIAL> "DELETE"    => (Tokens.DELETE (pos yypos, pos yypos + size yytext));
 <INITIAL> "NULL"      => (Tokens.NULL (pos yypos, pos yypos + size yytext));
 <INITIAL> "IS"        => (Tokens.IS (pos yypos, pos yypos + size yytext));
+<INITIAL> "COALESCE"  => (Tokens.COALESCE (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "CONSTRAINT"=> (Tokens.CCONSTRAINT (pos yypos, pos yypos + size yytext));
 <INITIAL> "UNIQUE"    => (Tokens.UNIQUE (pos yypos, pos yypos + size yytext));
diff --git a/tests/coalesce.ur b/tests/coalesce.ur
new file mode 100644
index 00000000..5ee8cf19
--- /dev/null
+++ b/tests/coalesce.ur
@@ -0,0 +1,6 @@
+table t : { A : option int }
+
+fun main () : transaction page =
+    queryX (SELECT COALESCE(t.A, 13)
+            FROM t)
+    (fn r => <xml>{[r.1]},</xml>)
diff --git a/tests/coalesce.urp b/tests/coalesce.urp
new file mode 100644
index 00000000..7d7decee
--- /dev/null
+++ b/tests/coalesce.urp
@@ -0,0 +1,4 @@
+database dbname=test
+sql coalesce.sql
+
+coalesce
-- 
cgit v1.2.3


From bce3a31c8040f437fcb1d0a3e0440259ed851a9d Mon Sep 17 00:00:00 2001
From: Karn Kallio <kkallio@eka>
Date: Wed, 23 Nov 2011 12:17:40 -0530
Subject: Add LIKE operator to SQL sublanguage.

---
 lib/ur/basis.urs        | 2 ++
 src/elisp/urweb-mode.el | 2 +-
 src/monoize.sml         | 3 +++
 src/urweb.grm           | 4 +++-
 src/urweb.lex           | 1 +
 5 files changed, 10 insertions(+), 2 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index f21faf38..fcce3a01 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -523,6 +523,8 @@ val sql_le : t ::: Type -> sql_binary t t bool
 val sql_gt : t ::: Type -> sql_binary t t bool
 val sql_ge : t ::: Type -> sql_binary t t bool
 
+val sql_like : sql_binary string string bool
+
 val sql_count : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
                 -> sql_exp tables agg exps int
 
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index f56834b2..b5c42cbe 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -151,7 +151,7 @@ See doc for the variable `urweb-mode-info'."
                  "PRIMARY" "KEY" "CONSTRAINT" "UNIQUE" "CHECK"
                  "FOREIGN" "REFERENCES" "ON" "NO" "ACTION" "CASCADE" "RESTRICT" "NULL"
                  "JOIN" "INNER" "OUTER" "LEFT" "RIGHT" "FULL" "CROSS" "SELECT1"
-                 "IF" "THEN" "ELSE")
+                 "IF" "THEN" "ELSE" "COALESCE" "LIKE")
   "A regexp that matches SQL keywords.")
 
 (defconst urweb-lident-regexp "\\<[a-z_][A-Za-z0-9_']*\\>"
diff --git a/src/monoize.sml b/src/monoize.sml
index d18b4d2a..4a70c012 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2470,6 +2470,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
           | L.EFfi ("Basis", "sql_mod") =>
             ((L'.EPrim (Prim.String "%"), loc), fm)
 
+          | L.EFfi ("Basis", "sql_like") =>
+            ((L'.EPrim (Prim.String "LIKE"), loc), fm)
+
           | L.ECApp (
             (L.ECApp (
              (L.ECApp (
diff --git a/src/urweb.grm b/src/urweb.grm
index 8e3fad90..bb9ea18b 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -244,7 +244,7 @@ fun tnamesOf (e, _) =
  | TRUE | FALSE | CAND | OR | NOT
  | COUNT | AVG | SUM | MIN | MAX
  | ASC | DESC
- | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS | COALESCE
+ | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS | COALESCE | LIKE
  | CURRENT_TIMESTAMP
  | NE | LT | LE | GT | GE
  | CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES
@@ -1834,6 +1834,8 @@ sqlexp : TRUE                           (sql_inject (EVar (["Basis"], "True", In
        | sqlexp CAND sqlexp             (sql_binary ("and", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
        | sqlexp OR sqlexp               (sql_binary ("or", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
 
+       | sqlexp LIKE sqlexp             (sql_binary ("like", sqlexp1, sqlexp2, s (sqlexp1left, sqlexp2right)))
+
        | NOT sqlexp                     (sql_unary ("not", sqlexp, s (NOTleft, sqlexpright)))
        | MINUS sqlexp                   (sql_unary ("neg", sqlexp, s (MINUSleft, sqlexpright)))
 
diff --git a/src/urweb.lex b/src/urweb.lex
index 8e8b0a12..b3b590f2 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -500,6 +500,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 <INITIAL> "NULL"      => (Tokens.NULL (pos yypos, pos yypos + size yytext));
 <INITIAL> "IS"        => (Tokens.IS (pos yypos, pos yypos + size yytext));
 <INITIAL> "COALESCE"  => (Tokens.COALESCE (pos yypos, pos yypos + size yytext));
+<INITIAL> "LIKE"      => (Tokens.LIKE (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "CONSTRAINT"=> (Tokens.CCONSTRAINT (pos yypos, pos yypos + size yytext));
 <INITIAL> "UNIQUE"    => (Tokens.UNIQUE (pos yypos, pos yypos + size yytext));
-- 
cgit v1.2.3


From 1a92bdc65a47614912b4bfd0cf6f442d7134ce23 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Thu, 2 Feb 2012 11:40:10 -0500
Subject: 'ORDER BY RANDOM' (based on a patch from Ron de Bruijn)

---
 lib/ur/basis.urs        | 12 +++++++-----
 src/elisp/urweb-mode.el |  2 +-
 src/monoize.sml         | 33 +++++++++++++++++----------------
 src/mysql.sml           | 21 +++++++++++----------
 src/postgres.sml        |  5 +++--
 src/settings.sig        |  8 +++++---
 src/settings.sml        |  2 ++
 src/sqlite.sml          |  7 ++++---
 src/urweb.grm           |  7 ++++++-
 src/urweb.lex           |  1 +
 tests/random.ur         |  8 ++++++++
 tests/random.urp        |  4 ++++
 12 files changed, 69 insertions(+), 41 deletions(-)
 create mode 100644 tests/random.ur
 create mode 100644 tests/random.urp

(limited to 'src/urweb.lex')

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 08585546..3afb4985 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -399,7 +399,7 @@ val sql_query1 : free ::: {{Type}}
                                             selectedExps) }
                  -> sql_query1 free afree tables selectedFields selectedExps
 
-type sql_relop 
+type sql_relop
 val sql_union : sql_relop
 val sql_intersect : sql_relop
 val sql_except : sql_relop
@@ -428,11 +428,13 @@ val sql_order_by_Cons : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type
                         -> sql_exp tables [] exps t -> sql_direction
                         -> sql_order_by tables exps
                         -> sql_order_by tables exps
+val sql_order_by_random : tables ::: {{Type}} -> exps ::: {Type}
+                          -> sql_order_by tables exps
 
 type sql_limit
 val sql_no_limit : sql_limit
 val sql_limit : int -> sql_limit
-                       
+
 type sql_offset
 val sql_no_offset : sql_offset
 val sql_offset : int -> sql_offset
@@ -651,7 +653,7 @@ val tag : attrsGiven ::: {Type} -> attrsAbsent ::: {Type}
                   ctxOuter ctxInner useOuter bindOuter
            -> xml ctxInner useInner bindInner
            -> xml ctxOuter (useOuter ++ useInner) (bindOuter ++ bindInner)
-val join : ctx ::: {Unit} 
+val join : ctx ::: {Unit}
         -> use1 ::: {Type} -> bind1 ::: {Type} -> bind2 ::: {Type}
         -> [use1 ~ bind1] => [bind1 ~ bind2] =>
               xml ctx use1 bind1
@@ -769,13 +771,13 @@ val a : bodyTag ([Link = transaction page, Href = url, Target = string] ++ boxAt
 val img : bodyTag ([Alt = string, Src = url, Width = int, Height = int,
                     Onabort = transaction unit, Onerror = transaction unit,
                     Onload = transaction unit] ++ boxAttrs)
-          
+
 val form : ctx ::: {Unit} -> bind ::: {Type}
            -> [[MakeForm, Form] ~ ctx] =>
     option css_class
     -> xml ([Form] ++ ctx) [] bind
     -> xml ([MakeForm] ++ ctx) [] []
-       
+
 val subform : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type}
               -> [[Form] ~ ctx] =>
     nm :: Name -> [[nm] ~ use] =>
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index b5c42cbe..480ba1f6 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -151,7 +151,7 @@ See doc for the variable `urweb-mode-info'."
                  "PRIMARY" "KEY" "CONSTRAINT" "UNIQUE" "CHECK"
                  "FOREIGN" "REFERENCES" "ON" "NO" "ACTION" "CASCADE" "RESTRICT" "NULL"
                  "JOIN" "INNER" "OUTER" "LEFT" "RIGHT" "FULL" "CROSS" "SELECT1"
-                 "IF" "THEN" "ELSE" "COALESCE" "LIKE")
+                 "IF" "THEN" "ELSE" "COALESCE" "LIKE" "RANDOM")
   "A regexp that matches SQL keywords.")
 
 (defconst urweb-lident-regexp "\\<[a-z_][A-Za-z0-9_']*\\>"
diff --git a/src/monoize.sml b/src/monoize.sml
index ccadf936..1331d065 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -16,7 +16,7 @@
  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
@@ -74,7 +74,7 @@ fun pvar (r, r', loc) =
                                                SM.insert (fs', x, n))) ([], SM.empty) (r, fs)
         in
             pvars := RM.insert (!pvars, r', (n, fs));
-            pvarDefs := (L'.DDatatype [("$poly" ^ Int.toString n, n, map (fn (x, n, t) => (x, n, SOME t)) fs)], loc) 
+            pvarDefs := (L'.DDatatype [("$poly" ^ Int.toString n, n, map (fn (x, n, t) => (x, n, SOME t)) fs)], loc)
                         :: !pvarDefs;
             pvarOldDefs := (n, r) :: !pvarOldDefs;
             (n, fs)
@@ -312,9 +312,9 @@ fun monoType env =
                          let
                              val r = ref (L'.Default, [])
                              val (_, xs, xncs) = Env.lookupDatatype env n
-                                                 
+
                              val dtmap' = IM.insert (dtmap, n, r)
-                                          
+
                              val xncs = map (fn (x, n, to) => (x, n, Option.map (mt env dtmap') to)) xncs
                          in
                              case xs of
@@ -580,7 +580,7 @@ fun fooifyExp fk env =
                                                                      result = ran}), loc)), loc),
                                                "")], loc),
                                  fm)
-                            end       
+                            end
 
                         val (fm, n) = Fm.lookup fm fk i makeDecl
                     in
@@ -594,7 +594,7 @@ fun fooifyExp fk env =
                         ((L'.ECase (e,
                                     [((L'.PNone t, loc),
                                       (L'.EPrim (Prim.String "None"), loc)),
-                                     
+
                                      ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc),
                                       (L'.EStrcat ((L'.EPrim (Prim.String "Some/"), loc),
                                                    body), loc))],
@@ -1186,7 +1186,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                 ((L'.EAbs ("f", dom, dom,
                            (L'.ERel 0, loc)), loc), fm)
             end
-                       
+
           | L.ECApp ((L.EFfi ("Basis", "show"), _), t) =>
             let
                 val t = monoType env t
@@ -2059,7 +2059,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                         strcat [sc " WHERE ", gf "Where"])],
                                                       {disc = s,
                                                        result = s}), loc),
-                                           
+
                                            if List.all (fn (x, xts) =>
                                                            case List.find (fn (x', _) => x' = x) grouped of
                                                                NONE => List.null xts
@@ -2194,7 +2194,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
           | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_subset_concat"),
                                                     _), _), _), _), _), _), _), _) =>
             let
-                val un = (L'.TRecord [], loc) 
+                val un = (L'.TRecord [], loc)
             in
                 ((L'.EAbs ("_", un, (L'.TFun (un, un), loc),
                            (L'.EAbs ("_", un, un,
@@ -2406,6 +2406,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
 
           | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) =>
             ((L'.EPrim (Prim.String ""), loc), fm)
+          | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_random"), _), _), _), _) =>
+            ((L'.EPrim (Prim.String (#randomFunction (Settings.currentDbms ()) ^ "()")), loc), fm)
           | L.ECApp (
             (L.ECApp (
              (L.ECApp (
@@ -2755,7 +2757,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
 
           | L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm)
           | L.EFfi ("Basis", "sql_desc") => ((L'.EPrim (Prim.String " DESC"), loc), fm)
-
           | L.ECApp (
             (L.ECApp (
              (L.ECApp (
@@ -2763,7 +2764,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                (L.EFfi ("Basis", "sql_nfunc"), _),
                _), _),
               _), _),
-             _), _), 
+             _), _),
            _) =>
             let
                 val s = (L'.TFfi ("Basis", "string"), loc)
@@ -2893,7 +2894,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                      (L'.ERel 0, loc)), loc)), loc),
                  fm)
             end
- 
+
           | L.ECApp (
             (L.ECApp (
              (L.ECApp (
@@ -3045,7 +3046,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                       | ("Onload", e, _) :: rest => findOnload (rest, SOME e, onunload, acc)
                       | ("Onunload", e, _) :: rest => findOnload (rest, onload, SOME e, acc)
                       | x :: rest => findOnload (rest, onload, onunload, x :: acc)
-                                     
+
                 val (onload, onunload, attrs) = findOnload (attrs, NONE, NONE, [])
 
                 val (class, fm) = monoExp (env, st, fm) class
@@ -3325,7 +3326,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
 						List.exists (fn ((L.CName tag', _), _) => tag' = tag
                                                               | _ => false) ctx
                                               | _ => false
-                                                     
+
                             val tag = if inTag "Tr" then
 					  "tr"
                                       else if inTag "Table" then
@@ -3343,7 +3344,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
 				 fm)
                               | _ => raise Fail "Monoize: Bad dyn attributes"
 			end
-			
+
                       | "submit" => normal ("input type=\"submit\"", NONE, NONE)
                       | "image" => normal ("input type=\"image\"", NONE, NONE)
                       | "button" => normal ("input type=\"submit\"", NONE, NONE)
@@ -4312,7 +4313,7 @@ fun monoize env file =
                                             let
                                                 val (nExp, fm) = Fm.freshName fm
                                                 val (nIni, fm) = Fm.freshName fm
-                                                                 
+
                                                 val dExp = L'.DVal ("expunger",
                                                                     nExp,
                                                                     (L'.TFun (client, unit), loc),
diff --git a/src/mysql.sml b/src/mysql.sml
index 686f430f..780f5148 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -16,7 +16,7 @@
  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
@@ -258,7 +258,7 @@ fun checkRel (table, checkNullable) (s, xts) =
              string "mysql_free_result(res);",
              newline,
              newline,
-             
+
              string "if (mysql_query(conn->conn, \"",
              string q'',
              string "\")) {",
@@ -503,7 +503,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
                       string "static void uw_db_validate(uw_context ctx) { }"],
              newline,
              newline,
-             
+
              string "static void uw_db_init(uw_context ctx) {",
              newline,
              string "MYSQL *mysql = mysql_init(NULL);",
@@ -829,7 +829,7 @@ fun queryCommon {loc, query, cols, doCols} =
                                                    string (Int.toString i),
                                                    string ";",
                                                    newline,
-                                                               
+
                                                    case t of
                                                        Nullable t => buffers t
                                                      | _ => buffers t,
@@ -1123,7 +1123,7 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} =
                                                                       string (Int.toString i),
                                                                       string ";",
                                                                       newline]
-                                                                   
+
                                                     | _ => box [string "in[",
                                                                 string (Int.toString i),
                                                                 string "].buffer = &arg",
@@ -1137,7 +1137,7 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} =
                                                    string (p_buffer_type t),
                                                    string ";",
                                                    newline,
-                                                               
+
                                                    case t of
                                                        Nullable t => box [string "in[",
                                                                           string (Int.toString i),
@@ -1177,7 +1177,7 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} =
                                                                                newline],
                                                                           string "}",
                                                                           newline]
-                                                                          
+
                                                      | _ => buffers t,
                                                    newline]
                                           end) inputs,
@@ -1404,7 +1404,7 @@ fun dmlPrepared {loc, id, dml, inputs, mode} =
                                                                       string (Int.toString i),
                                                                       string ";",
                                                                       newline]
-                                                                   
+
                                                     | _ => box [string "in[",
                                                                 string (Int.toString i),
                                                                 string "].buffer = &arg",
@@ -1425,7 +1425,7 @@ fun dmlPrepared {loc, id, dml, inputs, mode} =
                                                                        string "].is_unsigned = 1;",
                                                                        newline]
                                                      | _ => box [],
-                                                               
+
                                                    case t of
                                                        Nullable t => box [string "in[",
                                                                           string (Int.toString i),
@@ -1465,7 +1465,7 @@ fun dmlPrepared {loc, id, dml, inputs, mode} =
                                                                                newline],
                                                                           string "}",
                                                                           newline]
-                                                                          
+
                                                      | _ => buffers t,
                                                    newline]
                                           end) inputs,
@@ -1529,6 +1529,7 @@ fun p_blank _ = "?"
 
 val () = addDbms {name = "mysql",
                   header = Config.msheader,
+                  randomFunction = "RAND",
                   link = "-lmysqlclient",
                   init = init,
                   p_sql_type = p_sql_type,
diff --git a/src/postgres.sml b/src/postgres.sml
index 3a2fd40d..db9c9d3a 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -16,7 +16,7 @@
  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
@@ -645,7 +645,7 @@ fun queryCommon {loc, query, cols, doCols} =
          newline,
          newline,
          string "uw_pop_cleanup(ctx);",
-         newline]    
+         newline]
 
 fun query {loc, cols, doCols} =
     box [string "PGconn *conn = uw_get_db(ctx);",
@@ -1037,6 +1037,7 @@ fun p_cast (s, t) = s ^ "::" ^ p_sql_type t
 fun p_blank (n, t) = p_cast ("$" ^ Int.toString n, t)
 
 val () = addDbms {name = "postgres",
+                  randomFunction = "RANDOM",
                   header = Config.pgheader,
                   link = "-lpq",
                   p_sql_type = p_sql_type,
diff --git a/src/settings.sig b/src/settings.sig
index 26e220fd..62b7a748 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -16,7 +16,7 @@
  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
@@ -26,10 +26,10 @@
  *)
 
 signature SETTINGS = sig
-    
+
     val setDebug : bool -> unit
     val getDebug : unit -> bool
-                           
+
     val clibFile : string -> string
 
     (* How do all application URLs begin? *)
@@ -143,6 +143,8 @@ signature SETTINGS = sig
     type dbms = {
          name : string,
          (* Call it this on the command line *)
+         randomFunction : string,
+         (* DBMS's name for random number-generating function *)
          header : string,
          (* Include this C header file *)
          link : string,
diff --git a/src/settings.sml b/src/settings.sml
index b421f38a..017c5095 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -467,6 +467,7 @@ datatype failure_mode = Error | None
 
 type dbms = {
      name : string,
+     randomFunction : string,
      header : string,
      link : string,
      p_sql_type : sql_type -> string,
@@ -511,6 +512,7 @@ type dbms = {
 
 val dbmses = ref ([] : dbms list)
 val curDb = ref ({name = "",
+                  randomFunction = "",
                   header = "",
                   link = "",
                   p_sql_type = fn _ => "",
diff --git a/src/sqlite.sml b/src/sqlite.sml
index 1dc0b754..f7d8f824 100644
--- a/src/sqlite.sml
+++ b/src/sqlite.sml
@@ -16,7 +16,7 @@
  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
@@ -255,7 +255,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
                       string "static void uw_db_validate(uw_context ctx) { }"],
              newline,
              newline,
-             
+
              string "static void uw_db_init(uw_context ctx) {",
              newline,
              string "sqlite3 *sqlite;",
@@ -308,7 +308,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
              string "}",
              newline,
              newline,
-                  
+
              string "conn = calloc(1, sizeof(uw_conn));",
              newline,
              string "conn->conn = sqlite;",
@@ -820,6 +820,7 @@ fun p_cast (s, _) = s
 fun p_blank _ = "?"
 
 val () = addDbms {name = "sqlite",
+                  randomFunction = "RANDOM",
                   header = Config.sqheader,
                   link = "-lsqlite3",
                   init = init,
diff --git a/src/urweb.grm b/src/urweb.grm
index a495bfe6..7d2bc96b 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -276,7 +276,7 @@ fun tnamesOf (e, _) =
  | LIMIT | OFFSET | ALL
  | TRUE | FALSE | CAND | OR | NOT
  | COUNT | AVG | SUM | MIN | MAX
- | ASC | DESC
+ | ASC | DESC | RANDOM
  | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS | COALESCE | LIKE
  | CURRENT_TIMESTAMP
  | NE | LT | LE | GT | GE
@@ -405,6 +405,7 @@ fun tnamesOf (e, _) =
  | obopt of exp
  | obitem of exp * exp
  | obexps of exp
+ | popt of unit
  | diropt of exp
  | lopt of exp
  | ofopt of exp
@@ -2034,6 +2035,10 @@ obexps : obitem                         (let
                                          in
                                              (EApp (e, obexps), loc)
                                          end)
+       | RANDOM popt                    (EVar (["Basis"], "sql_order_by_random", Infer), s (RANDOMleft, poptright))
+
+popt   :                                ()
+       | LPAREN RPAREN                  ()
 
 diropt :                                (EVar (["Basis"], "sql_asc", Infer), dummy)
        | ASC                            (EVar (["Basis"], "sql_asc", Infer), s (ASCleft, ASCright))
diff --git a/src/urweb.lex b/src/urweb.lex
index b3b590f2..50ebe843 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -490,6 +490,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 
 <INITIAL> "ASC"       => (Tokens.ASC (pos yypos, pos yypos + size yytext));
 <INITIAL> "DESC"      => (Tokens.DESC (pos yypos, pos yypos + size yytext));
+<INITIAL> "RANDOM"    => (Tokens.RANDOM (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "INSERT"    => (Tokens.INSERT (pos yypos, pos yypos + size yytext));
 <INITIAL> "INTO"      => (Tokens.INTO (pos yypos, pos yypos + size yytext));
diff --git a/tests/random.ur b/tests/random.ur
new file mode 100644
index 00000000..b2006302
--- /dev/null
+++ b/tests/random.ur
@@ -0,0 +1,8 @@
+table t : { A : int }
+
+fun main () : transaction page =
+    x <- queryX (SELECT *
+                 FROM t
+                 ORDER BY RANDOM)
+         (fn r => <xml>{[r.T.A]}<br/></xml>);
+    return <xml><body>{x}</body></xml>
diff --git a/tests/random.urp b/tests/random.urp
new file mode 100644
index 00000000..5cc06fe5
--- /dev/null
+++ b/tests/random.urp
@@ -0,0 +1,4 @@
+database dbname=test
+sql random.sql
+
+random
-- 
cgit v1.2.3


From 05b7d79819dd5f006527bef7679b06868b3e0da7 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Sun, 29 Apr 2012 13:17:31 -0400
Subject: Initial support for reusing elaboration results

---
 src/compiler.sml     |  25 ++++--
 src/elab_util.sig    |  11 ++-
 src/elab_util.sml    |  11 +++
 src/elaborate.sig    |   3 +-
 src/elaborate.sml    | 224 +++++++++++++++++++++++++++++++--------------------
 src/mod_db.sig       |  38 +++++++++
 src/mod_db.sml       | 144 +++++++++++++++++++++++++++++++++
 src/source.sml       |   4 +-
 src/source_print.sml |  46 +++++------
 src/sources          |   3 +
 src/urweb.grm        |  13 ++-
 src/urweb.lex        |   1 -
 12 files changed, 394 insertions(+), 129 deletions(-)
 create mode 100644 src/mod_db.sig
 create mode 100644 src/mod_db.sml

(limited to 'src/urweb.lex')

diff --git a/src/compiler.sml b/src/compiler.sml
index ce6f95af..c30c2a04 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -917,7 +917,7 @@ val parse = {
                           val sgn = (Source.SgnConst (#func parseUrs urs), loc)
                       in
                           checkErrors ();
-                          (Source.DFfiStr (mname, sgn), loc)
+                          (Source.DFfiStr (mname, sgn, OS.FileSys.modTime urs), loc)
                       end
 
                   val defed = ref SS.empty
@@ -944,7 +944,7 @@ val parse = {
                                      last = ErrorMsg.dummyPos}
 
                           val ds = #func parseUr ur
-                          val d = (Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc)
+                          val d = (Source.DStr (mname, sgnO, SOME (OS.FileSys.modTime ur), (Source.StrConst ds, loc)), loc)
 
                           val fname = OS.Path.mkCanonical fname
                           val d = case List.find (fn (root, name) =>
@@ -1002,14 +1002,14 @@ val parse = {
                                                                                          else
                                                                                              (Source.StrVar part, loc)
                                                                            in
-                                                                               (Source.DStr (part, NONE, imp),
+                                                                               (Source.DStr (part, NONE, NONE, imp),
                                                                                 loc) :: ds
                                                                            end
                                                                        else
                                                                            ds) [] (!fulls)
                                                   in
                                                       defed := SS.add (!defed, this);
-                                                      (Source.DStr (piece, NONE,
+                                                      (Source.DStr (piece, NONE, NONE,
                                                                     (Source.StrConst (if old then
                                                                                           simOpen ()
                                                                                           @ [makeD this pieces]
@@ -1092,11 +1092,20 @@ fun clibFile s = OS.Path.joinDirFile {dir = Config.libC,
 
 val elaborate = {
     func = fn file => let
-                  val basis = #func parseUrs (libFile "basis.urs")
-                  val topSgn = #func parseUrs (libFile "top.urs")
-                  val topStr = #func parseUr (libFile "top.ur")
+                  val basisF = libFile "basis.urs"
+                  val topF = libFile "top.urs"
+                  val topF' = libFile "top.ur"
+
+                  val basis = #func parseUrs basisF
+                  val topSgn = #func parseUrs topF
+                  val topStr = #func parseUr topF'
+
+                  val tm1 = OS.FileSys.modTime topF
+                  val tm2 = OS.FileSys.modTime topF'
               in
-                  Elaborate.elabFile basis topStr topSgn ElabEnv.empty file
+                  Elaborate.elabFile basis (OS.FileSys.modTime basisF)
+                                     topStr topSgn (if Time.< (tm1, tm2) then tm2 else tm1)
+                                     ElabEnv.empty file
               end,
     print = ElabPrint.p_file ElabEnv.empty
 }
diff --git a/src/elab_util.sig b/src/elab_util.sig
index 8a013554..b63d9b7f 100644
--- a/src/elab_util.sig
+++ b/src/elab_util.sig
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2010, Adam Chlipala
+(* Copyright (c) 2008-2010, 2012, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
@@ -229,6 +229,15 @@ structure Decl : sig
                 decl : 'context -> Elab.decl' -> Elab.decl',
                 bind : 'context * binder -> 'context}
                -> 'context -> Elab.decl -> Elab.decl
+
+    val fold : {kind : Elab.kind' * 'state -> 'state,
+               con : Elab.con' * 'state -> 'state,
+               exp : Elab.exp' * 'state -> 'state,
+               sgn_item : Elab.sgn_item' * 'state -> 'state,
+               sgn : Elab.sgn' * 'state -> 'state,
+               str : Elab.str' * 'state -> 'state,
+               decl : Elab.decl' * 'state -> 'state}
+              -> 'state -> Elab.decl -> 'state
 end
 
 structure File : sig
diff --git a/src/elab_util.sml b/src/elab_util.sml
index df78616a..b799bbc4 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -1180,6 +1180,17 @@ fun mapB {kind, con, exp, sgn_item, sgn, str, decl, bind} ctx s =
         S.Continue (s, ()) => s
       | S.Return _ => raise Fail "ElabUtil.Decl.mapB: Impossible"
 
+fun fold {kind, con, exp, sgn_item, sgn, str, decl} (st : 'a) d : 'a =
+    case mapfold {kind = fn k => fn st => S.Continue (k, kind (k, st)),
+                  con = fn c => fn st => S.Continue (c, con (c, st)),
+                  exp = fn e => fn st => S.Continue (e, exp (e, st)),
+                  sgn_item = fn sgi => fn st => S.Continue (sgi, sgn_item (sgi, st)),
+                  sgn = fn s => fn st => S.Continue (s, sgn (s, st)),
+                  str = fn str' => fn st => S.Continue (str', str (str', st)),
+                  decl = fn d => fn st => S.Continue (d, decl (d, st))} d st of
+        S.Continue (_, st) => st
+      | S.Return _ => raise Fail "ElabUtil.Decl.fold: Impossible"
+
 end
 
 structure File = struct
diff --git a/src/elaborate.sig b/src/elaborate.sig
index cc83b213..db325340 100644
--- a/src/elaborate.sig
+++ b/src/elaborate.sig
@@ -27,7 +27,8 @@
 
 signature ELABORATE = sig
 
-    val elabFile : Source.sgn_item list -> Source.decl list -> Source.sgn_item list
+    val elabFile : Source.sgn_item list -> Time.time
+                   -> Source.decl list -> Source.sgn_item list -> Time.time
                    -> ElabEnv.env -> Source.file -> Elab.file
 
     val resolveClass : ElabEnv.env -> Elab.con -> Elab.exp option
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 71f5196f..c712ee2a 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -3641,7 +3641,7 @@ and wildifyStr env (str, sgn) =
                                  | L.DClass (x, _, _) => ndelCon (nd, x)
                                  | L.DVal (x, _, _) => ndelVal (nd, x)
                                  | L.DOpen _ => nempty
-                                 | L.DStr (x, _, (L.StrConst ds', _)) =>
+                                 | L.DStr (x, _, _, (L.StrConst ds', _)) =>
                                    (case SM.find (nmods nd, x) of
                                         NONE => nd
                                       | SOME (env, nd') => naddMod (nd, x, (env, removeUsed (nd', ds'))))
@@ -3711,11 +3711,11 @@ and wildifyStr env (str, sgn) =
 
                          val ds = ds @ ds'
                      in
-                         map (fn d as (L.DStr (x, s, (L.StrConst ds', loc')), loc) =>
+                         map (fn d as (L.DStr (x, s, tm, (L.StrConst ds', loc')), loc) =>
                                  (case SM.find (nmods nd, x) of
                                       NONE => d
                                     | SOME (env, nd') =>
-                                      (L.DStr (x, s, (L.StrConst (extend (env, nd', ds')), loc')), loc))
+                                      (L.DStr (x, s, tm, (L.StrConst (extend (env, nd', ds')), loc')), loc))
                                | d => d) ds
                      end
              in
@@ -3923,56 +3923,80 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
                     ([(L'.DSgn (x, n, sgn'), loc)], (env', denv, enD gs' @ gs))
                 end
 
-              | L.DStr (x, sgno, str) =>
-                let
-                    val () = if x = "Basis" then
-                                 raise Fail "Not allowed to redefine structure 'Basis'"
-                             else
-                                 ()
+              | L.DStr (x, sgno, tmo, str) =>
+                (case ModDb.lookup dAll of
+                     SOME d =>
+                     let
+                         val env' = E.declBinds env d
+                         val denv' = dopenConstraints (loc, env', denv) {str = x, strs = []}
+                     in
+                         ([d], (env', denv', []))
+                     end
+                   | NONE =>
+                     let
+                         val () = if x = "Basis" then
+                                      raise Fail "Not allowed to redefine structure 'Basis'"
+                                  else
+                                      ()
 
-                    val formal = Option.map (elabSgn (env, denv)) sgno
+                         val formal = Option.map (elabSgn (env, denv)) sgno
 
-                    val (str', sgn', gs') =
-                        case formal of
-                            NONE =>
-                            let
-                                val (str', actual, gs') = elabStr (env, denv) str
-                            in
-                                (str', selfifyAt env {str = str', sgn = actual}, gs')
-                            end
-                          | SOME (formal, gs1) =>
-                            let
-                                val str = wildifyStr env (str, formal)
-                                val (str', actual, gs2) = elabStr (env, denv) str
-                            in
-                                subSgn env loc (selfifyAt env {str = str', sgn = actual}) formal;
-                                (str', formal, enD gs1 @ gs2)
-                            end
+                         val (str', sgn', gs') =
+                             case formal of
+                                 NONE =>
+                                 let
+                                     val (str', actual, gs') = elabStr (env, denv) str
+                                 in
+                                     (str', selfifyAt env {str = str', sgn = actual}, gs')
+                                 end
+                               | SOME (formal, gs1) =>
+                                 let
+                                     val str = wildifyStr env (str, formal)
+                                     val (str', actual, gs2) = elabStr (env, denv) str
+                                 in
+                                     subSgn env loc (selfifyAt env {str = str', sgn = actual}) formal;
+                                     (str', formal, enD gs1 @ gs2)
+                                 end
 
-                    val (env', n) = E.pushStrNamed env x sgn'
-                    val denv' =
-                        case #1 str' of
-                            L'.StrConst _ => dopenConstraints (loc, env', denv) {str = x, strs = []}
-                          | L'.StrApp _ => dopenConstraints (loc, env', denv) {str = x, strs = []}
-                          | _ => denv
-                in
-                    case #1 (hnormSgn env sgn') of
-                        L'.SgnFun _ =>
-                        (case #1 str' of
-                             L'.StrFun _ => ()
-                           | _ => strError env (FunctorRebind loc))
-                      | _ => ();
-                    ([(L'.DStr (x, n, sgn', str'), loc)], (env', denv', gs' @ gs))
-                end
+                         val (env', n) = E.pushStrNamed env x sgn'
+                         val denv' =
+                             case #1 str' of
+                                 L'.StrConst _ => dopenConstraints (loc, env', denv) {str = x, strs = []}
+                               | L'.StrApp _ => dopenConstraints (loc, env', denv) {str = x, strs = []}
+                               | _ => denv
 
-              | L.DFfiStr (x, sgn) =>
-                let
-                    val (sgn', gs') = elabSgn (env, denv) sgn
+                         val dNew = (L'.DStr (x, n, sgn', str'), loc)
+                     in
+                         case #1 (hnormSgn env sgn') of
+                             L'.SgnFun _ =>
+                             (case #1 str' of
+                                  L'.StrFun _ => ()
+                                | _ => strError env (FunctorRebind loc))
+                           | _ => ();
+                         Option.map (fn tm => ModDb.insert (dNew, tm)) tmo;
+                         ([dNew], (env', denv', gs' @ gs))
+                     end)
 
-                    val (env', n) = E.pushStrNamed env x sgn'
-                in
-                    ([(L'.DFfiStr (x, n, sgn'), loc)], (env', denv, enD gs' @ gs))
-                end
+              | L.DFfiStr (x, sgn, tm) =>
+                (case ModDb.lookup dAll of
+                     SOME d =>
+                     let
+                         val env' = E.declBinds env d
+                         val denv' = dopenConstraints (loc, env', denv) {str = x, strs = []}
+                     in
+                         ([d], (env', denv', []))
+                     end
+                   | NONE =>
+                     let
+                         val (sgn', gs') = elabSgn (env, denv) sgn
+                                           
+                         val (env', n) = E.pushStrNamed env x sgn'
+
+                         val dNew = (L'.DFfiStr (x, n, sgn'), loc)
+                     in
+                         ModDb.insert (dNew, tm);
+                         ([dNew], (env', denv, enD gs' @ gs))
+                     end)
 
               | L.DOpen (m, ms) =>
                 (case E.lookupStr env m of
@@ -4431,24 +4455,36 @@ and elabStr (env, denv) (str, loc) =
 
 fun resolveClass env = E.resolveClass (hnormCon env) (consEq env dummy) env
 
-fun elabFile basis topStr topSgn env file =
+fun elabFile basis basis_tm topStr topSgn top_tm env file =
     let
         val () = mayDelay := true
         val () = delayedUnifs := []
         val () = delayedExhaustives := []
 
-        val (sgn, gs) = elabSgn (env, D.empty) (L.SgnConst basis, ErrorMsg.dummySpan)
-        val () = case gs of
-                     [] => ()
-                   | _ => (app (fn (_, env, _, c1, c2) =>
-                                   prefaces "Unresolved"
-                                   [("c1", p_con env c1),
-                                    ("c2", p_con env c2)]) gs;
-                           raise Fail "Unresolved disjointness constraints in Basis")
-
-        val (env', basis_n) = E.pushStrNamed env "Basis" sgn
+        val d = (L.DFfiStr ("Basis", (L.SgnConst basis, ErrorMsg.dummySpan), basis_tm), ErrorMsg.dummySpan)
+        val (basis_n, env', sgn) =
+            case ModDb.lookup d of
+                NONE =>
+                let
+                    val (sgn, gs) = elabSgn (env, D.empty) (L.SgnConst basis, ErrorMsg.dummySpan)
+                    val () = case gs of
+                                 [] => ()
+                               | _ => (app (fn (_, env, _, c1, c2) =>
+                                               prefaces "Unresolved"
+                                                        [("c1", p_con env c1),
+                                                         ("c2", p_con env c2)]) gs;
+                                       raise Fail "Unresolved disjointness constraints in Basis")
+
+                    val (env', basis_n) = E.pushStrNamed env "Basis" sgn
+                in
+                    ModDb.insert ((L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan), basis_tm);
+                    (basis_n, env', sgn)
+                end
+              | SOME (d' as (L'.DFfiStr (_, basis_n, sgn), _)) =>
+                (basis_n, E.pushStrNamedAs env "Basis" basis_n sgn, sgn)
+              | _ => raise Fail "Elaborate: Basis impossible"
+                     
         val () = basis_r := basis_n
-
         val (ds, env') = dopen env' {str = basis_n, strs = [], sgn = sgn}
 
         fun discoverC r x =
@@ -4463,34 +4499,50 @@ fun elabFile basis topStr topSgn env file =
         val () = discoverC char "char"
         val () = discoverC table "sql_table"
 
-        val (topSgn, gs) = elabSgn (env', D.empty) (L.SgnConst topSgn, ErrorMsg.dummySpan)
-        val () = case gs of
-                     [] => ()
-                   | _ => raise Fail "Unresolved disjointness constraints in top.urs"
-        val (topStr, topSgn', gs) = elabStr (env', D.empty) (L.StrConst topStr, ErrorMsg.dummySpan)
-        val () = case gs of
-                     [] => ()
-                   | _ => app (fn Disjoint (loc, env, denv, c1, c2) =>
-                                  (case D.prove env denv (c1, c2, loc) of
-                                       [] => ()
-                                     | _ =>
-                                       (prefaces "Unresolved constraint in top.ur"
-                                                 [("loc", PD.string (ErrorMsg.spanToString loc)),
-                                                  ("c1", p_con env c1),
-                                                  ("c2", p_con env c2)];
-                                        raise Fail "Unresolved constraint in top.ur"))
-                                | TypeClass (env, c, r, loc) =>
-                                  let
-                                      val c = normClassKey env c
-                                  in
-                                      case resolveClass env c of
-                                          SOME e => r := SOME e
-                                        | NONE => expError env (Unresolvable (loc, c))
-                                  end) gs
+        val d = (L.DStr ("Top", SOME (L.SgnConst topSgn, ErrorMsg.dummySpan),
+                         SOME (if Time.< (top_tm, basis_tm) then basis_tm else top_tm),
+                         (L.StrConst topStr, ErrorMsg.dummySpan)), ErrorMsg.dummySpan)
+        val (top_n, env', topSgn, topStr) =
+            case ModDb.lookup d of
+                NONE =>
+                let
+                    val (topSgn, gs) = elabSgn (env', D.empty) (L.SgnConst topSgn, ErrorMsg.dummySpan)
+                    val () = case gs of
+                                 [] => ()
+                               | _ => raise Fail "Unresolved disjointness constraints in top.urs"
+                    val (topStr, topSgn', gs) = elabStr (env', D.empty) (L.StrConst topStr, ErrorMsg.dummySpan)
+
+                    val () = case gs of
+                                 [] => ()
+                               | _ => app (fn Disjoint (loc, env, denv, c1, c2) =>
+                                              (case D.prove env denv (c1, c2, loc) of
+                                                   [] => ()
+                                                 | _ =>
+                                                   (prefaces "Unresolved constraint in top.ur"
+                                                             [("loc", PD.string (ErrorMsg.spanToString loc)),
+                                                              ("c1", p_con env c1),
+                                                              ("c2", p_con env c2)];
+                                                    raise Fail "Unresolved constraint in top.ur"))
+                                            | TypeClass (env, c, r, loc) =>
+                                              let
+                                                  val c = normClassKey env c
+                                              in
+                                                  case resolveClass env c of
+                                                      SOME e => r := SOME e
+                                                    | NONE => expError env (Unresolvable (loc, c))
+                                              end) gs
 
-        val () = subSgn env' ErrorMsg.dummySpan topSgn' topSgn
+                    val () = subSgn env' ErrorMsg.dummySpan topSgn' topSgn
+
+                    val (env', top_n) = E.pushStrNamed env' "Top" topSgn
+                in
+                    ModDb.insert ((L'.DStr ("Top", top_n, topSgn, topStr), ErrorMsg.dummySpan), top_tm);
+                    (top_n, env', topSgn, topStr)
+                end
+              | SOME (d' as (L'.DStr (_, top_n, topSgn, topStr), _)) =>
+                (top_n, E.declBinds env' d', topSgn, topStr)
+              | _ => raise Fail "Elaborate: Top impossible"                
 
-        val (env', top_n) = E.pushStrNamed env' "Top" topSgn
         val () = top_r := top_n
 
         val (ds', env') = dopen env' {str = top_n, strs = [], sgn = topSgn}
diff --git a/src/mod_db.sig b/src/mod_db.sig
new file mode 100644
index 00000000..2b98ae6f
--- /dev/null
+++ b/src/mod_db.sig
@@ -0,0 +1,38 @@
+(* Copyright (c) 2012, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+(* Cache of module code, with dependency information *)
+
+signature MOD_DB = sig
+    val reset : unit -> unit
+
+    val insert : Elab.decl * Time.time -> unit
+    (* Here's a declaration, including the modification timestamp of the file it came from.
+     * We might invalidate other declarations that depend on this one, if the timestamp has changed. *)
+
+    val lookup : Source.decl -> Elab.decl option
+end
diff --git a/src/mod_db.sml b/src/mod_db.sml
new file mode 100644
index 00000000..ba9bcc3a
--- /dev/null
+++ b/src/mod_db.sml
@@ -0,0 +1,144 @@
+(* Copyright (c) 2012, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+(* Cache of module code, with dependency information *)
+
+structure ModDb :> MOD_DB = struct
+
+open Elab
+
+structure SK = struct
+type ord_key = string
+val compare = String.compare
+end
+
+structure SS = BinarySetFn(SK)
+structure SM = BinaryMapFn(SK)
+structure IM = IntBinaryMap
+
+type oneMod = {Decl : decl,
+               When : Time.time,
+               Deps : SS.set}
+
+val byName = ref (SM.empty : oneMod SM.map)
+val byId = ref (IM.empty : string IM.map)
+
+fun reset () = (byName := SM.empty;
+                byId := IM.empty)
+
+fun insert (d, tm) =
+    let
+        val xn =
+            case #1 d of
+                DStr (x, n, _, _) => SOME (x, n)
+              | DFfiStr (x, n, _) => SOME (x, n)
+              | _ => NONE
+    in
+        case xn of
+            NONE => ()
+          | SOME (x, n) =>
+            let
+                val skipIt =
+                    case SM.find (!byName, x) of
+                        NONE => false
+                      | SOME r => #When r = tm
+            in
+                if skipIt then
+                    ()
+                else
+                    let
+                        fun doMod (n', deps) =
+                            case IM.find (!byId, n') of
+                                NONE => deps
+                              | SOME x' =>
+                                SS.union (deps,
+                                          SS.add (case SM.find (!byName, x') of
+                                                      NONE => SS.empty
+                                                    | SOME {Deps = ds, ...} => ds, x'))
+
+                        val deps = ElabUtil.Decl.fold {kind = #2,
+                                                       con = fn (c, deps) =>
+                                                                case c of
+                                                                    CModProj (n', _, _) => doMod (n', deps)
+                                                                  | _ => deps,
+                                                       exp = fn (e, deps) =>
+                                                                case e of
+                                                                    EModProj (n', _, _) => doMod (n', deps)
+                                                                  | _ => deps,
+                                                       sgn_item = #2,
+                                                       sgn = fn (sg, deps) =>
+                                                                case sg of
+                                                                    SgnProj (n', _, _) => doMod (n', deps)
+                                                                  | _ => deps,
+                                                       str = fn (st, deps) =>
+                                                                case st of
+                                                                    StrVar n' => doMod (n', deps)
+                                                                  | _ => deps,
+                                                       decl = fn (d, deps) =>
+                                                                 case d of
+                                                                     DDatatypeImp (_, _, n', _, _, _, _) => doMod (n', deps)
+                                                                   | _ => deps}
+                                                      SS.empty d
+                    in
+                        byName := SM.insert (SM.filter (fn r => if SS.member (#Deps r, x) then
+                                                                    case #1 (#Decl r) of
+                                                                        DStr (_, n', _, _) =>
+                                                                        (byId := #1 (IM.remove (!byId, n'));
+                                                                         false)
+                                                                      | _ => raise Fail "ModDb: Impossible decl"
+                                                                else
+                                                                    true) (!byName),
+                                             x,
+                                             {Decl = d,
+                                              When = tm,
+                                              Deps = deps});
+                        byId := IM.insert (!byId, n, x)
+                    end
+            end
+    end
+
+fun lookup (d : Source.decl) =
+    case #1 d of
+        Source.DStr (x, _, SOME tm, _) =>
+        (case SM.find (!byName, x) of
+             NONE => NONE
+           | SOME r =>
+             if tm = #When r then
+                 SOME (#Decl r)
+             else
+                 NONE)
+      | Source.DFfiStr (x, _, tm) =>
+        (case SM.find (!byName, x) of
+             NONE => NONE
+           | SOME r =>
+             if tm = #When r then
+                 SOME (#Decl r)
+             else
+                 NONE)
+      | _ => NONE
+
+end
diff --git a/src/source.sml b/src/source.sml
index b85384ab..ce29904d 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -154,8 +154,8 @@ datatype decl' =
        | DVal of string * con option * exp
        | DValRec of (string * con option * exp) list
        | DSgn of string * sgn
-       | DStr of string * sgn option * str
-       | DFfiStr of string * sgn
+       | DStr of string * sgn option * Time.time option * str
+       | DFfiStr of string * sgn * Time.time
        | DOpen of string * string list
        | DConstraint of con * con
        | DOpenConstraints of string * string list
diff --git a/src/source_print.sml b/src/source_print.sml
index f6218d22..aad673f3 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -569,33 +569,33 @@ fun p_decl ((d, _) : decl) =
                               string "=",
                               space,
                               p_sgn sgn]
-      | DStr (x, NONE, str) => box [string "structure",
+      | DStr (x, NONE, _, str) => box [string "structure",
+                                       space,
+                                       string x,
+                                       space,
+                                       string "=",
+                                       space,
+                                       p_str str]
+      | DStr (x, SOME sgn, _, str) => box [string "structure",
+                                           space,
+                                           string x,
+                                           space,
+                                           string ":",
+                                           space,
+                                           p_sgn sgn,
+                                           space,
+                                           string "=",
+                                           space,
+                                           p_str str]
+      | DFfiStr (x, sgn, _) => box [string "extern",
+                                    space,
+                                    string "structure",
                                     space,
                                     string x,
                                     space,
-                                    string "=",
+                                    string ":",
                                     space,
-                                    p_str str]
-      | DStr (x, SOME sgn, str) => box [string "structure",
-                                        space,
-                                        string x,
-                                        space,
-                                        string ":",
-                                        space,
-                                        p_sgn sgn,
-                                        space,
-                                        string "=",
-                                        space,
-                                        p_str str]
-      | DFfiStr (x, sgn) => box [string "extern",
-                                 space,
-                                 string "structure",
-                                 space,
-                                 string x,
-                                 space,
-                                 string ":",
-                                 space,
-                                 p_sgn sgn]
+                                    p_sgn sgn]
       | DOpen (m, ms) => box [string "open",
                               space,
                               p_list_sep (string ".") string (m :: ms)]
diff --git a/src/sources b/src/sources
index 4011ce3b..551d4ca5 100644
--- a/src/sources
+++ b/src/sources
@@ -78,6 +78,9 @@ disjoint.sml
 elab_err.sig
 elab_err.sml
 
+mod_db.sig
+mod_db.sml
+
 elaborate.sig
 elaborate.sml
 
diff --git a/src/urweb.grm b/src/urweb.grm
index c81ca9e6..0fe9b987 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -262,7 +262,7 @@ fun tnamesOf (e, _) =
  | ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW | BANG
  | FN | PLUSPLUS | MINUSMINUS | MINUSMINUSMINUS | DOLLAR | TWIDDLE | CARET
  | LET | IN
- | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | SELECT1
+ | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | SQL | SELECT1
  | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | VIEW
  | COOKIE | STYLE | TASK | POLICY
  | CASE | IF | THEN | ELSE | ANDALSO | ORELSE
@@ -493,17 +493,16 @@ decl   : CON SYMBOL cargl2 kopt EQ cexp (let
        | FUN valis                      ([(DValRec valis, s (FUNleft, valisright))])
 
        | SIGNATURE CSYMBOL EQ sgn       ([(DSgn (CSYMBOL, sgn), s (SIGNATUREleft, sgnright))])
-       | STRUCTURE CSYMBOL EQ str       ([(DStr (CSYMBOL, NONE, str), s (STRUCTUREleft, strright))])
-       | STRUCTURE CSYMBOL COLON sgn EQ str ([(DStr (CSYMBOL, SOME sgn, str), s (STRUCTUREleft, strright))])
+       | STRUCTURE CSYMBOL EQ str       ([(DStr (CSYMBOL, NONE, NONE, str), s (STRUCTUREleft, strright))])
+       | STRUCTURE CSYMBOL COLON sgn EQ str ([(DStr (CSYMBOL, SOME sgn, NONE, str), s (STRUCTUREleft, strright))])
        | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN EQ str
-                                        ([(DStr (CSYMBOL1, NONE,
+                                        ([(DStr (CSYMBOL1, NONE, NONE,
                                                  (StrFun (CSYMBOL2, sgn1, NONE, str), s (FUNCTORleft, strright))),
                                            s (FUNCTORleft, strright))])
        | FUNCTOR CSYMBOL LPAREN CSYMBOL COLON sgn RPAREN COLON sgn EQ str
-                                        ([(DStr (CSYMBOL1, NONE,
+                                        ([(DStr (CSYMBOL1, NONE, NONE,
                                                  (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))),
                                            s (FUNCTORleft, strright))])
-       | EXTERN STRUCTURE CSYMBOL COLON sgn ([(DFfiStr (CSYMBOL, sgn), s (EXTERNleft, sgnright))])
        | OPEN mpath                     (case mpath of
                                              [] => raise Fail "Impossible mpath parse [1]"
                                            | m :: ms => [(DOpen (m, ms), s (OPENleft, mpathright))])
@@ -516,7 +515,7 @@ decl   : CON SYMBOL cargl2 kopt EQ cexp (let
                                                          foldl (fn (m, str) => (StrProj (str, m), loc))
                                                          (StrVar m, loc) ms
                                          in
-                                             [(DStr ("anon", NONE, (StrApp (m, str), loc)), loc),
+                                             [(DStr ("anon", NONE, NONE, (StrApp (m, str), loc)), loc),
                                               (DOpen ("anon", []), loc)]
                                          end)
        | OPEN CONSTRAINTS mpath         (case mpath of
diff --git a/src/urweb.lex b/src/urweb.lex
index 50ebe843..55fe4216 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -426,7 +426,6 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 <INITIAL> "end"       => (Tokens.END (pos yypos, pos yypos + size yytext));
 <INITIAL> "functor"   => (Tokens.FUNCTOR (pos yypos, pos yypos + size yytext));
 <INITIAL> "where"     => (Tokens.WHERE (pos yypos, pos yypos + size yytext));
-<INITIAL> "extern"    => (Tokens.EXTERN (pos yypos, pos yypos + size yytext));
 <INITIAL> "include"   => (Tokens.INCLUDE (pos yypos, pos yypos + size yytext));
 <INITIAL> "open"      => (Tokens.OPEN (pos yypos, pos yypos + size yytext));
 <INITIAL> "constraint"=> (Tokens.CONSTRAINT (pos yypos, pos yypos + size yytext));
-- 
cgit v1.2.3


From 75fa1fd2ad8aae9a88dfacd1a85eb80f645a3b74 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Fri, 4 May 2012 10:07:27 -0400
Subject: Reinitialize lexer state properly

---
 src/urweb.lex       | 7 ++++++-
 tests/badcomment.ur | 1 +
 2 files changed, 7 insertions(+), 1 deletion(-)
 create mode 100644 tests/badcomment.ur

(limited to 'src/urweb.lex')

diff --git a/src/urweb.lex b/src/urweb.lex
index 55fe4216..5d3d6dbe 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -40,6 +40,10 @@ local
   val commentLevel = ref 0
   val commentPos = ref 0
 in
+  fun reset () =
+      (commentLevel := 0;
+       commentPos := 0)
+
   fun enterComment pos =
       (if !commentLevel = 0 then
            commentPos := pos
@@ -109,7 +113,8 @@ fun exitBrace () =
 	    braceLevels := (s, i-1) :: rest
       | _ => ()
 
-fun initialize () = (xmlTag := [];
+fun initialize () = (reset ();
+                     xmlTag := [];
 		     xmlString := false)
 
 
diff --git a/tests/badcomment.ur b/tests/badcomment.ur
new file mode 100644
index 00000000..099d449a
--- /dev/null
+++ b/tests/badcomment.ur
@@ -0,0 +1 @@
+(* uhoh
-- 
cgit v1.2.3


From 8b6941ac380392e36a30a06fb558c47a8fe7d2d8 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Sat, 2 Jun 2012 16:00:50 -0400
Subject: Compiled a window function use

---
 lib/ur/basis.urs | 16 ++++++++++
 src/monoize.sml  | 54 +++++++++++++++++++++++++++++++++-
 src/urweb.grm    | 90 +++++++++++++++++++++++++++++++++++++++++---------------
 src/urweb.lex    |  3 ++
 tests/window.ur  | 11 +++++++
 tests/window.urp |  6 ++++
 6 files changed, 156 insertions(+), 24 deletions(-)
 create mode 100644 tests/window.ur
 create mode 100644 tests/window.urp

(limited to 'src/urweb.lex')

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 27b6393b..2a4d28cf 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -564,6 +564,22 @@ val sql_maxable_option : t ::: Type -> sql_maxable t -> sql_maxable (option t)
 val sql_max : t ::: Type -> nt ::: Type -> sql_maxable t -> nullify t nt -> sql_aggregate t nt
 val sql_min : t ::: Type -> nt ::: Type -> sql_maxable t -> nullify t nt -> sql_aggregate t nt
 
+con sql_window :: {{Type}} -> {{Type}} -> {Type} -> Type -> Type
+val sql_window : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+                 -> t ::: Type
+                 -> sql_window tables agg exps t
+                 -> sql_exp tables agg exps allow_window t
+
+val sql_window_aggregate : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+                           -> t ::: Type -> nt ::: Type
+                           -> sql_aggregate t nt
+                           -> sql_exp tables agg exps allow_window t
+                           -> sql_window tables agg exps nt
+val sql_window_count : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+                       -> sql_window tables agg exps int
+val sql_window_rank : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+                      -> sql_window tables agg exps int
+
 con sql_nfunc :: Type -> Type
 val sql_nfunc : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
                 -> aw ::: {Unit} -> t ::: Type
diff --git a/src/monoize.sml b/src/monoize.sml
index 7fba8c98..1a70894f 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -299,6 +299,8 @@ fun monoType env =
                     (L'.TRecord [], loc)
                   | L.CApp ((L.CFfi ("Basis", "sql_maxable"), _), _) =>
                     (L'.TRecord [], loc)
+                  | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_window"), _), _), _), _), _), _), _), _) =>
+                    (L'.TFfi ("Basis", "string"), loc)
                   | L.CApp ((L.CFfi ("Basis", "sql_arith"), _), _) =>
                     (L'.TRecord [], loc)
                   | L.CApp ((L.CFfi ("Basis", "sql_nfunc"), _), _) =>
@@ -2728,7 +2730,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                    sc ")"]
             in
                 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
-                           (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), main), loc)), loc),
+                           (L'.EAbs ("e1", s, s, main), loc)), loc),
                  fm)
             end
 
@@ -2778,6 +2780,56 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                  (L'.EPrim (Prim.String "MIN"), loc)), loc)), loc),
              fm)
 
+          | L.ECApp (
+            (L.ECApp (
+             (L.ECApp (
+              (L.ECApp (
+               (L.EFfi ("Basis", "sql_window"), _),
+               _), _),
+              _), _),
+             _), _),
+            _) =>
+            let
+                val s = (L'.TFfi ("Basis", "string"), loc)
+                fun sc s = (L'.EPrim (Prim.String s), loc)
+
+                val main = strcat [(L'.ERel 0, loc),
+                                   sc " OVER ()"]
+            in
+                ((L'.EAbs ("w", s, s, main), loc),
+                 fm)
+            end
+
+          | L.ECApp (
+            (L.ECApp (
+             (L.ECApp (
+              (L.ECApp (
+               (L.ECApp (
+                (L.EFfi ("Basis", "sql_window_aggregate"), _),
+                _), _),
+               _), _),
+              _), _),
+             _), _),
+            _) =>
+            let
+                val s = (L'.TFfi ("Basis", "string"), loc)
+                fun sc s = (L'.EPrim (Prim.String s), loc)
+
+                val main = strcat [(L'.ERel 1, loc),
+                                   sc "(",
+                                   (L'.ERel 0, loc),
+                                   sc ")"]
+            in
+                ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
+                           (L'.EAbs ("e1", s, s, main), loc)), loc),
+                 fm)
+            end
+
+          | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_window_count"), _), _), _), _), _), _) =>
+            ((L'.EPrim (Prim.String "COUNT(*)"), loc), fm)
+          | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_window_rank"), _), _), _), _), _), _) =>
+            ((L'.EPrim (Prim.String "RANK()"), loc), fm)
+
           | L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm)
           | L.EFfi ("Basis", "sql_desc") => ((L'.EPrim (Prim.String " DESC"), loc), fm)
           | L.ECApp (
diff --git a/src/urweb.grm b/src/urweb.grm
index 1419ef3f..831ec4a8 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -332,7 +332,7 @@ fun parseStyle s pos =
  | UNION | INTERSECT | EXCEPT
  | LIMIT | OFFSET | ALL
  | TRUE | FALSE | CAND | OR | NOT
- | COUNT | AVG | SUM | MIN | MAX
+ | COUNT | AVG | SUM | MIN | MAX | RANK
  | ASC | DESC | RANDOM
  | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS | COALESCE | LIKE
  | CURRENT_TIMESTAMP
@@ -340,6 +340,7 @@ fun parseStyle s pos =
  | CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES
  | JOIN | INNER | CROSS | OUTER | LEFT | RIGHT | FULL
  | CIF | CTHEN | CELSE
+ | OVER | PARTITION
 
 %nonterm
    file of decl list
@@ -455,6 +456,7 @@ fun parseStyle s pos =
  | selis of select_item list
  | select of select
  | sqlexp of exp
+ | window of unit option
  | wopt of exp
  | groupi of group_item
  | groupis of group_item list
@@ -2025,29 +2027,68 @@ sqlexp : TRUE                           (sql_inject (EVar (["Basis"], "True", In
        | NULL                           (sql_inject ((EVar (["Basis"], "None", Infer), 
                                                       s (NULLleft, NULLright))))
 
-       | COUNT LPAREN STAR RPAREN       (let
-                                             val loc = s (COUNTleft, RPARENright)
-                                         in
-                                             (EVar (["Basis"], "sql_count", Infer), loc)
-                                         end)
-       | COUNT LPAREN sqlexp RPAREN     (let
-                                             val loc = s (COUNTleft, RPARENright)
-
-                                             val e = (EVar (["Basis"], "sql_count_col", Infer), loc)
-                                             val e = (EApp ((EVar (["Basis"], "sql_aggregate", Infer), loc),
-                                                            e), loc)
-                                         in
-                                             (EApp (e, sqlexp), loc)
-                                         end)
-       | sqlagg LPAREN sqlexp RPAREN    (let
-                                             val loc = s (sqlaggleft, RPARENright)
+       | COUNT LPAREN STAR RPAREN window (let
+                                              val loc = s (COUNTleft, windowright)
+                                          in
+                                              case window of
+                                                  NONE => (EVar (["Basis"], "sql_count", Infer), loc)
+                                                | SOME _ =>
+                                                  let
+                                                      val e = (EVar (["Basis"], "sql_window_count", Infer), loc)
+                                                  in
+                                                      (EApp ((EVar (["Basis"], "sql_window", Infer), loc), e), loc)
+                                                  end
+                                          end)
+       | RANK UNIT window                (let
+                                              val loc = s (RANKleft, windowright)
+                                              val e = (EVar (["Basis"], "sql_window_rank", Infer), loc)
+                                          in
+                                              (EApp ((EVar (["Basis"], "sql_window", Infer), loc), e), loc)
+                                          end)
+       | COUNT LPAREN sqlexp RPAREN window (let
+                                                val loc = s (COUNTleft, windowright)
+                                                          
+                                                val e = (EVar (["Basis"], "sql_count_col", Infer), loc)
+                                            in
+                                                case window of
+                                                    NONE =>
+                                                    let
+                                                        val e = (EApp ((EVar (["Basis"], "sql_aggregate", Infer), loc),
+                                                                       e), loc)
+                                                    in
+                                                        (EApp (e, sqlexp), loc)
+                                                    end
+                                                  | SOME _ =>
+                                                    let
+                                                        val e = (EApp ((EVar (["Basis"], "sql_window_aggregate", Infer), loc),
+                                                                       e), loc)
+                                                        val e = (EApp (e, sqlexp), loc)
+                                                    in
+                                                        (EApp ((EVar (["Basis"], "sql_window", Infer), loc), e), loc)
+                                                    end
+                                            end)
+       | sqlagg LPAREN sqlexp RPAREN window (let
+                                                 val loc = s (sqlaggleft, windowright)
 
-                                             val e = (EVar (["Basis"], "sql_" ^ sqlagg, Infer), loc)
-                                             val e = (EApp ((EVar (["Basis"], "sql_aggregate", Infer), loc),
-                                                            e), loc)
-                                         in
-                                             (EApp (e, sqlexp), loc)
-                                         end)
+                                                 val e = (EVar (["Basis"], "sql_" ^ sqlagg, Infer), loc)
+                                             in
+                                                 case window of
+                                                     NONE =>
+                                                     let
+                                                         val e = (EApp ((EVar (["Basis"], "sql_aggregate", Infer), loc),
+                                                                        e), loc)
+                                                     in
+                                                         (EApp (e, sqlexp), loc)
+                                                     end
+                                                   | SOME _ =>
+                                                     let
+                                                         val e = (EApp ((EVar (["Basis"], "sql_window_aggregate", Infer), loc),
+                                                                        e), loc)
+                                                         val e = (EApp (e, sqlexp), loc)
+                                                     in
+                                                         (EApp ((EVar (["Basis"], "sql_window", Infer), loc), e), loc)
+                                                     end
+                                             end)
        | COALESCE LPAREN sqlexp COMMA sqlexp RPAREN
                                         (let
                                              val loc = s (COALESCEright, sqlexp2right)
@@ -2072,6 +2113,9 @@ sqlexp : TRUE                           (sql_inject (EVar (["Basis"], "True", In
                                              (EApp (e, query), loc)
                                          end)
 
+window :                                (NONE)
+       | OVER LPAREN RPAREN             (SOME ())
+
 fname  : SYMBOL                         (EVar (["Basis"], "sql_" ^ SYMBOL, Infer), s (SYMBOLleft, SYMBOLright))
        | LBRACE eexp RBRACE             (eexp)
 
diff --git a/src/urweb.lex b/src/urweb.lex
index 5d3d6dbe..272c5e65 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -463,6 +463,8 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 <INITIAL> "OFFSET"    => (Tokens.OFFSET (pos yypos, pos yypos + size yytext));
 <INITIAL> "ALL"       => (Tokens.ALL (pos yypos, pos yypos + size yytext));
 <INITIAL> "SELECT1"   => (Tokens.SELECT1 (pos yypos, pos yypos + size yytext));
+<INITIAL> "OVER"      => (Tokens.OVER (pos yypos, pos yypos + size yytext));
+<INITIAL> "PARTITION" => (Tokens.PARTITION (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "JOIN"      => (Tokens.JOIN (pos yypos, pos yypos + size yytext));
 <INITIAL> "INNER"     => (Tokens.INNER (pos yypos, pos yypos + size yytext));
@@ -487,6 +489,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 <INITIAL> "SUM"       => (Tokens.SUM (pos yypos, pos yypos + size yytext));
 <INITIAL> "MIN"       => (Tokens.MIN (pos yypos, pos yypos + size yytext));
 <INITIAL> "MAX"       => (Tokens.MAX (pos yypos, pos yypos + size yytext));
+<INITIAL> "RANK"      => (Tokens.RANK (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "IF"        => (Tokens.CIF (pos yypos, pos yypos + size yytext));
 <INITIAL> "THEN"      => (Tokens.CTHEN (pos yypos, pos yypos + size yytext));
diff --git a/tests/window.ur b/tests/window.ur
new file mode 100644
index 00000000..fd93679c
--- /dev/null
+++ b/tests/window.ur
@@ -0,0 +1,11 @@
+table empsalary : { Depname : string,
+                   Empno : int,
+                   Salary : int }
+
+fun main () : transaction page =
+    x <- queryX (SELECT empsalary.Depname, empsalary.Empno, empsalary.Salary, RANK() AS R
+                 FROM empsalary)
+                (fn r => <xml>{[r.Empsalary.Depname]}, {[r.Empsalary.Empno]}, {[r.Empsalary.Salary]}, {[r.R]}<br/></xml>);
+    return <xml><body>
+      {x}
+    </body></xml>
diff --git a/tests/window.urp b/tests/window.urp
new file mode 100644
index 00000000..d1fb21a9
--- /dev/null
+++ b/tests/window.urp
@@ -0,0 +1,6 @@
+debug
+database dbname=test
+sql window.sql
+rewrite url Window/*
+
+window
-- 
cgit v1.2.3


From 797db05343b520b16ea4f8eeab5fea6255d3284d Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Sun, 3 Jun 2012 11:29:31 -0400
Subject: Lighter-weight encoding of window function use

---
 demo/batchFun.ur       |   2 +-
 demo/crud.ur           |   4 +-
 demo/more/dbgrid.ur    |   8 +-
 demo/more/orm.ur       |  10 +-
 demo/more/versioned.ur |  12 +--
 doc/manual.tex         | 177 ++++++++++++++++---------------
 lib/ur/basis.urs       | 191 +++++++++++++++++----------------
 lib/ur/top.ur          |  10 +-
 lib/ur/top.urs         |  14 +--
 src/elab_err.sml       |   6 +-
 src/monoize.sml        | 280 +++++++++++++++++++++++++------------------------
 src/settings.sml       |   2 +-
 src/urweb.grm          |  87 +++++++--------
 src/urweb.lex          |   4 +-
 tests/window.ur        |   4 +-
 15 files changed, 417 insertions(+), 394 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/demo/batchFun.ur b/demo/batchFun.ur
index 69a68423..d69d68af 100644
--- a/demo/batchFun.ur
+++ b/demo/batchFun.ur
@@ -46,7 +46,7 @@ functor Make(M : sig
     fun add r =
         dml (insert t
                     (@foldR2 [fst] [colMeta]
-                      [fn cols => $(map (fn t => sql_exp [] [] [] disallow_window t.1) cols)]
+                      [fn cols => $(map (fn t => sql_exp [] [] [] t.1) cols)]
                       (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] input col acc =>
                           acc ++ {nm = @sql_inject col.Inject input})
                       {} M.fl (r -- #Id) M.cols
diff --git a/demo/crud.ur b/demo/crud.ur
index 0222e30f..4d2753ea 100644
--- a/demo/crud.ur
+++ b/demo/crud.ur
@@ -93,7 +93,7 @@ functor Make(M : sig
         id <- nextval seq;
         dml (insert tab
                     (@foldR2 [snd] [colMeta]
-                      [fn cols => $(map (fn t => sql_exp [] [] [] disallow_window t.1) cols)]
+                      [fn cols => $(map (fn t => sql_exp [] [] [] t.1) cols)]
                       (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] =>
                        fn input col acc => acc ++ {nm = @sql_inject col.Inject (col.Parse input)})
                       {} M.fl inputs M.cols
@@ -110,7 +110,7 @@ functor Make(M : sig
             fun save (inputs : $(map snd M.cols)) =
                 dml (update [map fst M.cols]
                             (@foldR2 [snd] [colMeta]
-                              [fn cols => $(map (fn t => sql_exp [T = [Id = int] ++ map fst M.cols] [] [] disallow_window t.1) cols)]
+                              [fn cols => $(map (fn t => sql_exp [T = [Id = int] ++ map fst M.cols] [] [] t.1) cols)]
                               (fn [nm :: Name] [t ::_] [rest ::_] [[nm] ~ rest] =>
                                fn input col acc => acc ++ {nm =
                                                            @sql_inject col.Inject (col.Parse input)})
diff --git a/demo/more/dbgrid.ur b/demo/more/dbgrid.ur
index 13092db6..fc593533 100644
--- a/demo/more/dbgrid.ur
+++ b/demo/more/dbgrid.ur
@@ -385,7 +385,7 @@ functor Make(M : sig
                        val wholeRow = @Folder.concat ! M.keyFolder M.rowFolder
 
                        fun ensql [env] (r : $(M.key ++ M.row)) =
-                           @map2 [rawMeta] [ident] [sql_exp env [] [] disallow_window]
+                           @map2 [rawMeta] [ident] [sql_exp env [] []]
                             (fn [t] meta v => @sql_inject meta.Inj v)
                             wholeRow M.raw r
 
@@ -396,12 +396,12 @@ functor Make(M : sig
                            dml (insert M.tab (ensql row));
                            return row
 
-                       fun selector (r : $M.key) : sql_exp [T = M.key ++ M.row] [] [] disallow_window bool =
+                       fun selector (r : $M.key) : sql_exp [T = M.key ++ M.row] [] [] bool =
                          @foldR2 [rawMeta] [ident]
-                          [fn key => rest :: {Type} -> [rest ~ key] => sql_exp [T = key ++ rest] [] [] disallow_window bool]
+                          [fn key => rest :: {Type} -> [rest ~ key] => sql_exp [T = key ++ rest] [] [] bool]
                           (fn [nm :: Name] [t :: Type] [key :: {Type}] [[nm] ~ key]
                                            (meta : rawMeta t) (v : t)
-                                           (exp : rest :: {Type} -> [rest ~ key] => sql_exp [T = key ++ rest] [] [] disallow_window bool)
+                                           (exp : rest :: {Type} -> [rest ~ key] => sql_exp [T = key ++ rest] [] [] bool)
                                            [rest :: {Type}] [rest ~ [nm = t] ++ key] =>
                               (WHERE T.{nm} = {@sql_inject meta.Inj v} AND {exp [[nm = t] ++ rest]}))
                           (fn [rest :: {Type}] [rest ~ []] => (WHERE TRUE))
diff --git a/demo/more/orm.ur b/demo/more/orm.ur
index 2e1fc2e0..468281f7 100644
--- a/demo/more/orm.ur
+++ b/demo/more/orm.ur
@@ -32,8 +32,8 @@ functor Table(M : sig
     val id = {Link = fn id => resultOut (SELECT * FROM t WHERE t.Id = {[id]}),
               Inj = inj}
 
-    fun ensql [avail ::_] (r : row') : $(map (sql_exp avail [] [] disallow_window) fs') =
-        @map2 [meta] [fst] [fn ts :: (Type * Type) => sql_exp avail [] [] disallow_window ts.1]
+    fun ensql [avail ::_] (r : row') : $(map (sql_exp avail [] []) fs') =
+        @map2 [meta] [fst] [fn ts :: (Type * Type) => sql_exp avail [] [] ts.1]
          (fn [ts] meta v => @sql_inject meta.Inj v)
          M.folder M.cols r
 
@@ -53,11 +53,11 @@ functor Table(M : sig
 
     val list = resultsOut (SELECT * FROM t)
 
-    con col = fn t => {Exp : sql_exp [T = fs] [] [] disallow_window t,
+    con col = fn t => {Exp : sql_exp [T = fs] [] [] t,
                        Inj : sql_injectable t}
     val idCol = {Exp = sql_field [#T] [#Id], Inj = _}
     con meta' = fn (fs :: {Type}) (col :: Type, parent :: Type) =>
-                   {Col : {Exp : sql_exp [T = fs] [] [] disallow_window col,
+                   {Col : {Exp : sql_exp [T = fs] [] [] col,
                            Inj : sql_injectable col},
                     Parent : $fs -> transaction (option parent)}
     val cols = @foldR [meta] [fn before => after :: {(Type * Type)} -> [before ~ after] =>
@@ -75,7 +75,7 @@ functor Table(M : sig
                 M.folder M.cols
                 [[Id = (id, row)]] !
 
-    type filter = sql_exp [T = fs] [] [] disallow_window bool
+    type filter = sql_exp [T = fs] [] [] bool
     fun find (f : filter) = resultOut (SELECT * FROM t WHERE {f})
     fun search (f : filter) = resultsOut (SELECT * FROM t WHERE {f})
 
diff --git a/demo/more/versioned.ur b/demo/more/versioned.ur
index 5da8704c..d08ebcb0 100644
--- a/demo/more/versioned.ur
+++ b/demo/more/versioned.ur
@@ -24,7 +24,7 @@ functor Make(M : sig
                          Eq : eq t}
 
     fun keyRecd (r : $(M.key ++ M.data)) =
-        @map2 [sql_injectable] [ident] [sql_exp [] [] [] disallow_window]
+        @map2 [sql_injectable] [ident] [sql_exp [] [] []]
          (fn [t] => @sql_inject)
          M.keyFolder M.key (r --- M.data)
 
@@ -34,18 +34,18 @@ functor Make(M : sig
                           ({Version = (SQL {[vr]}), When = (SQL CURRENT_TIMESTAMP)}
                                ++ keyRecd r
                                ++ @map2 [dmeta] [ident]
-                               [fn t => sql_exp [] [] [] disallow_window (option t)]
+                               [fn t => sql_exp [] [] [] (option t)]
                                (fn [t] x v => @sql_inject (@sql_option_prim x.Inj)
                                                (Some v))
                                M.dataFolder M.data (r --- M.key)))
 
-    fun keyExp (r : $M.key) : sql_exp [T = all] [] [] disallow_window bool =
+    fun keyExp (r : $M.key) : sql_exp [T = all] [] [] bool =
         @foldR2 [sql_injectable] [ident] [fn before => after :: {Type} -> [before ~ after]
-                                          => sql_exp [T = before ++ after] [] [] disallow_window bool]
+                                          => sql_exp [T = before ++ after] [] [] bool]
          (fn [nm :: Name] [t :: Type] [before :: {Type}] [[nm] ~ before]
                           (inj : sql_injectable t) (v : t)
                           (e : after :: {Type} -> [before ~ after]
-                           => sql_exp [T = before ++ after] [] [] disallow_window bool)
+                           => sql_exp [T = before ++ after] [] [] bool)
                           [after :: {Type}] [[nm = t] ++ before ~ after] =>
              (SQL t.{nm} = {[v]} AND {e [[nm = t] ++ after]}))
          (fn [after :: {Type}] [[] ~ after] => (SQL TRUE))
@@ -113,7 +113,7 @@ functor Make(M : sig
           | Some cur =>
             vr <- nextval s;
             let
-                val r' = @map3 [dmeta] [ident] [ident] [fn t => sql_exp [] [] [] disallow_window (option t)]
+                val r' = @map3 [dmeta] [ident] [ident] [fn t => sql_exp [] [] [] (option t)]
                           (fn [t] (meta : dmeta t) old new =>
                               @sql_inject (@sql_option_prim meta.Inj)
                                (if @@eq [_] meta.Eq old new then
diff --git a/doc/manual.tex b/doc/manual.tex
index 7f8b01c2..589177dd 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -1595,7 +1595,7 @@ $$\begin{array}{l}
 
 The last kind of constraint is a \texttt{CHECK} constraint, which attaches a boolean invariant over a row's contents.  It is defined using the $\mt{sql\_exp}$ type family, which we discuss in more detail below.
 $$\begin{array}{l}
-  \mt{val} \; \mt{check} : \mt{fs} ::: \{\mt{Type}\} \to \mt{sql\_exp} \; [] \; [] \; \mt{fs} \; \mt{disallow\_window} \; \mt{bool} \to \mt{sql\_constraint} \; \mt{fs} \; []
+  \mt{val} \; \mt{check} : \mt{fs} ::: \{\mt{Type}\} \to \mt{sql\_exp} \; [] \; [] \; \mt{fs} \; \mt{bool} \to \mt{sql\_constraint} \; \mt{fs} \; []
 \end{array}$$
 
 Section \ref{tables} shows the expanded syntax of the $\mt{table}$ declaration and signature item that includes constraints.  There is no other way to use constraints with SQL in Ur/Web.
@@ -1662,11 +1662,11 @@ $$\begin{array}{l}
   \hspace{.1in} \Rightarrow [\mt{empties} \sim \mt{selectedFields}] \\
   \hspace{.1in} \Rightarrow \{\mt{Distinct} : \mt{bool}, \\
   \hspace{.2in} \mt{From} : \mt{sql\_from\_items} \; \mt{free} \; \mt{tables}, \\
-  \hspace{.2in} \mt{Where} : \mt{sql\_exp} \; (\mt{free} \rc \mt{tables}) \; \mt{afree} \; [] \; \mt{disallow\_window} \; \mt{bool}, \\
+  \hspace{.2in} \mt{Where} : \mt{sql\_exp} \; (\mt{free} \rc \mt{tables}) \; \mt{afree} \; [] \; \mt{bool}, \\
   \hspace{.2in} \mt{GroupBy} : \mt{sql\_subset} \; \mt{tables} \; \mt{grouped}, \\
-  \hspace{.2in} \mt{Having} : \mt{sql\_exp} \; (\mt{free} \rc \mt{grouped}) \; (\mt{afree} \rc \mt{tables}) \; [] \; \mt{disallow\_window} \; \mt{bool}, \\
+  \hspace{.2in} \mt{Having} : \mt{sql\_exp} \; (\mt{free} \rc \mt{grouped}) \; (\mt{afree} \rc \mt{tables}) \; [] \; \mt{bool}, \\
   \hspace{.2in} \mt{SelectFields} : \mt{sql\_subset} \; \mt{grouped} \; (\mt{map} \; (\lambda \_ \Rightarrow []) \; \mt{empties} \rc \mt{selectedFields}), \\
-  \hspace{.2in} \mt {SelectExps} : \$(\mt{map} \; (\mt{sql\_exp} \; (\mt{free} \rc \mt{grouped}) \; (\mt{afree} \rc \mt{tables}) \; [] \; \mt{allow\_window}) \; \mt{selectedExps}) \} \\
+  \hspace{.2in} \mt {SelectExps} : \$(\mt{map} \; (\mt{sql\_expw} \; (\mt{free} \rc \mt{grouped}) \; (\mt{afree} \rc \mt{tables}) \; []) \; \mt{selectedExps}) \} \\
   \hspace{.1in} \to \mt{sql\_query1} \; \mt{free} \; \mt{afree} \; \mt{tables} \; \mt{selectedFields} \; \mt{selectedExps}
 \end{array}$$
 
@@ -1680,26 +1680,24 @@ $$\begin{array}{l}
 \mt{val} \; \mt{sql\_subset\_all} : \mt{tables} :: \{\{\mt{Type}\}\} \to \mt{sql\_subset} \; \mt{tables} \; \mt{tables}
 \end{array}$$
 
-SQL expressions are used in several places, including $\mt{SELECT}$, $\mt{WHERE}$, $\mt{HAVING}$, and $\mt{ORDER} \; \mt{BY}$ clauses.  They reify a fragment of the standard SQL expression language, while making it possible to inject ``native'' Ur values in some places.  The arguments to the $\mt{sql\_exp}$ type family respectively give the unrestricted-availability table fields, the table fields that may only be used in arguments to aggregate functions, the available selected expressions, whether window functions are allowed, and the type of the expression.  Two abstract constructors are declared to use to specify window function allowedness.
+SQL expressions are used in several places, including $\mt{SELECT}$, $\mt{WHERE}$, $\mt{HAVING}$, and $\mt{ORDER} \; \mt{BY}$ clauses.  They reify a fragment of the standard SQL expression language, while making it possible to inject ``native'' Ur values in some places.  The arguments to the $\mt{sql\_exp}$ type family respectively give the unrestricted-availability table fields, the table fields that may only be used in arguments to aggregate functions, the available selected expressions, and the type of the expression.
 $$\begin{array}{l}
-  \mt{con} \; \mt{sql\_exp} :: \{\{\mt{Type}\}\} \to \{\{\mt{Type}\}\} \to \{\mt{Type}\} \to \mt{Type} \to \{\mt{Unit}\} \to \mt{Type} \\
-  \mt{con} \; \mt{disallow\_window} :: \{\mt{Unit}\} \\
-  \mt{con} \; \mt{allow\_window} :: \{\mt{Unit}\}
+  \mt{con} \; \mt{sql\_exp} :: \{\{\mt{Type}\}\} \to \{\{\mt{Type}\}\} \to \{\mt{Type}\} \to \mt{Type} \to \mt{Type}
 \end{array}$$
 
 Any field in scope may be converted to an expression.
 $$\begin{array}{l}
   \mt{val} \; \mt{sql\_field} : \mt{otherTabs} ::: \{\{\mt{Type}\}\} \to \mt{otherFields} ::: \{\mt{Type}\} \\
-  \hspace{.1in} \to \mt{aw} ::: \{\mt{Unit}\} \to \mt{fieldType} ::: \mt{Type} \to \mt{agg} ::: \{\{\mt{Type}\}\} \\
+  \hspace{.1in} \to \mt{fieldType} ::: \mt{Type} \to \mt{agg} ::: \{\{\mt{Type}\}\} \\
   \hspace{.1in} \to \mt{exps} ::: \{\mt{Type}\} \\
   \hspace{.1in} \to \mt{tab} :: \mt{Name} \to \mt{field} :: \mt{Name} \\
-  \hspace{.1in} \to \mt{sql\_exp} \; ([\mt{tab} = [\mt{field} = \mt{fieldType}] \rc \mt{otherFields}] \rc \mt{otherTabs}) \; \mt{agg} \; \mt{exps} \; \mt{aw} \; \mt{fieldType}
+  \hspace{.1in} \to \mt{sql\_exp} \; ([\mt{tab} = [\mt{field} = \mt{fieldType}] \rc \mt{otherFields}] \rc \mt{otherTabs}) \; \mt{agg} \; \mt{exps} \; \mt{fieldType}
 \end{array}$$
 
 There is an analogous function for referencing named expressions.
 $$\begin{array}{l}
-  \mt{val} \; \mt{sql\_exp} : \mt{tabs} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{aw} ::: \{\mt{Unit}\} \to \mt{t} ::: \mt{Type} \to \mt{rest} ::: \{\mt{Type}\} \to \mt{nm} :: \mt{Name} \\
-  \hspace{.1in} \to \mt{sql\_exp} \; \mt{tabs} \; \mt{agg} \; ([\mt{nm} = \mt{t}] \rc \mt{rest}) \; \mt{aw} \; \mt{t}
+  \mt{val} \; \mt{sql\_exp} : \mt{tabs} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{t} ::: \mt{Type} \to \mt{rest} ::: \{\mt{Type}\} \to \mt{nm} :: \mt{Name} \\
+  \hspace{.1in} \to \mt{sql\_exp} \; \mt{tabs} \; \mt{agg} \; ([\mt{nm} = \mt{t}] \rc \mt{rest}) \; \mt{t}
 \end{array}$$
 
 Ur values of appropriate types may be injected into SQL expressions.
@@ -1718,8 +1716,8 @@ $$\begin{array}{l}
   \mt{val} \; \mt{sql\_prim} : \mt{t} ::: \mt{Type} \to \mt{sql\_injectable\_prim} \; \mt{t} \to \mt{sql\_injectable} \; \mt{t} \\
   \mt{val} \; \mt{sql\_option\_prim} : \mt{t} ::: \mt{Type} \to \mt{sql\_injectable\_prim} \; \mt{t} \to \mt{sql\_injectable} \; (\mt{option} \; \mt{t}) \\
   \\
-  \mt{val} \; \mt{sql\_inject} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{aw} ::: \{\mt{Unit}\} \to \mt{t} ::: \mt{Type} \to \mt{sql\_injectable} \; \mt{t} \\
-  \hspace{.1in} \to \mt{t} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{aw} \; \mt{t}
+  \mt{val} \; \mt{sql\_inject} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{t} ::: \mt{Type} \to \mt{sql\_injectable} \; \mt{t} \\
+  \hspace{.1in} \to \mt{t} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t}
 \end{array}$$
 
 Additionally, most function-free types may be injected safely, via the $\mt{serialized}$ type family.
@@ -1732,44 +1730,39 @@ $$\begin{array}{l}
 
 We have the SQL nullness test, which is necessary because of the strange SQL semantics of equality in the presence of null values.
 $$\begin{array}{l}
-  \mt{val} \; \mt{sql\_is\_null} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{aw} ::: \{\mt{Unit}\} \to \mt{t} ::: \mt{Type} \\
-  \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; (\mt{option} \; \mt{aw} \; \mt{t}) \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{aw} \; \mt{bool}
+  \mt{val} \; \mt{sql\_is\_null} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{t} ::: \mt{Type} \\
+  \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; (\mt{option} \; \mt{t}) \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{bool}
 \end{array}$$
 
 As another way of dealing with null values, there is also a restricted form of the standard \cd{COALESCE} function.
 $$\begin{array}{l}
   \mt{val} \; \mt{sql\_coalesce} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \\
-  \hspace{.1in} \to \mt{aw} ::: \{\mt{Unit}\} \to \mt{t} ::: \mt{Type} \\
-  \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{aw} \; (\mt{option} \; \mt{t}) \\
-  \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{aw} \; \mt{t} \\
-  \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{aw} \; \mt{t}
+  \hspace{.1in} \to \mt{t} ::: \mt{Type} \\
+  \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; (\mt{option} \; \mt{t}) \\
+  \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t} \\
+  \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t}
 \end{array}$$
 
 We have generic nullary, unary, and binary operators.
 $$\begin{array}{l}
   \mt{con} \; \mt{sql\_nfunc} :: \mt{Type} \to \mt{Type} \\
   \mt{val} \; \mt{sql\_current\_timestamp} : \mt{sql\_nfunc} \; \mt{time} \\
-  \mt{val} \; \mt{sql\_nfunc} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{aw} ::: \{\mt{Unit}\} \to \mt{t} ::: \mt{Type} \\
-  \hspace{.1in} \to \mt{sql\_nfunc} \; \mt{t} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{aw} \; \mt{t}
-\end{array}$$
+  \mt{val} \; \mt{sql\_nfunc} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{t} ::: \mt{Type} \\
+  \hspace{.1in} \to \mt{sql\_nfunc} \; \mt{t} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t} \\\end{array}$$
 
 $$\begin{array}{l}
   \mt{con} \; \mt{sql\_unary} :: \mt{Type} \to \mt{Type} \to \mt{Type} \\
   \mt{val} \; \mt{sql\_not} : \mt{sql\_unary} \; \mt{bool} \; \mt{bool} \\
-  \mt{val} \; \mt{sql\_unary} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{aw} ::: \{\mt{Unit}\} \to \mt{arg} ::: \mt{Type} \to \mt{res} ::: \mt{Type} \\
-  \hspace{.1in} \to \mt{sql\_unary} \; \mt{arg} \; \mt{res} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{aw} \; \mt{arg} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{aw} \; \mt{res}
+  \mt{val} \; \mt{sql\_unary} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{arg} ::: \mt{Type} \to \mt{res} ::: \mt{Type} \\
+  \hspace{.1in} \to \mt{sql\_unary} \; \mt{arg} \; \mt{res} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{arg} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{res} \\
 \end{array}$$
 
 $$\begin{array}{l}
   \mt{con} \; \mt{sql\_binary} :: \mt{Type} \to \mt{Type} \to \mt{Type} \to \mt{Type} \\
   \mt{val} \; \mt{sql\_and} : \mt{sql\_binary} \; \mt{bool} \; \mt{bool} \; \mt{bool} \\
   \mt{val} \; \mt{sql\_or} : \mt{sql\_binary} \; \mt{bool} \; \mt{bool} \; \mt{bool} \\
-  \mt{val} \; \mt{sql\_binary} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \\
-  \hspace{.1in} \to \mt{aw} ::: \{\mt{Unit}\} \to \mt{arg_1} ::: \mt{Type} \to \mt{arg_2} ::: \mt{Type} \to \mt{res} ::: \mt{Type} \\
-  \hspace{.1in} \to \mt{sql\_binary} \; \mt{arg_1} \; \mt{arg_2} \; \mt{res} \\
-  \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{aw} \; \mt{arg_1} \\
-  \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{aw} \; \mt{arg_2} \\
-  \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{aw} \; \mt{res}
+  \mt{val} \; \mt{sql\_binary} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{arg_1} ::: \mt{Type} \to \mt{arg_2} ::: \mt{Type} \to \mt{res} ::: \mt{Type} \\
+  \hspace{.1in} \to \mt{sql\_binary} \; \mt{arg_1} \; \mt{arg_2} \; \mt{res} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{arg_1} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{arg_2} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{res}
 \end{array}$$
 
 $$\begin{array}{l}
@@ -1786,13 +1779,13 @@ $$\begin{array}{l}
 
 Finally, we have aggregate functions.  The $\mt{COUNT(\ast)}$ syntax is handled specially, since it takes no real argument.  The other aggregate functions are placed into a general type family, using constructor classes to restrict usage to properly-typed arguments.  The key aspect of the $\mt{sql\_aggregate}$ function's type is the shift of aggregate-function-only fields into unrestricted fields.
 $$\begin{array}{l}
-  \mt{val} \; \mt{sql\_count} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \mt{aw} ::: \{\mt{Unit}\} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{aw} \; \mt{int}
+  \mt{val} \; \mt{sql\_count} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{int}
 \end{array}$$
 
 $$\begin{array}{l}
   \mt{con} \; \mt{sql\_aggregate} :: \mt{Type} \to \mt{Type} \to \mt{Type} \\
-  \mt{val} \; \mt{sql\_aggregate} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{aw} ::: \{\mt{Type}\} \mt{dom} ::: \mt{Type} \to \mt{ran} ::: \mt{Type} \\
-  \hspace{.1in} \to \mt{sql\_aggregate} \; \mt{dom} \; \mt{ran} \to \mt{sql\_exp} \; \mt{agg} \; \mt{agg} \; \mt{exps} \; \mt{aw} \; \mt{dom} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{aw} \; \mt{ran}
+  \mt{val} \; \mt{sql\_aggregate} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{dom} ::: \mt{Type} \to \mt{ran} ::: \mt{Type} \\
+  \hspace{.1in} \to \mt{sql\_aggregate} \; \mt{dom} \; \mt{ran} \to \mt{sql\_exp} \; \mt{agg} \; \mt{agg} \; \mt{exps} \; \mt{dom} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{ran}
 \end{array}$$
 
 $$\begin{array}{l}
@@ -1819,43 +1812,20 @@ $$\begin{array}{l}
   \mt{val} \; \mt{sql\_min} : \mt{t} ::: \mt{Type} \to \mt{nt} ::: \mt{Type} \to \mt{sql\_maxable} \; \mt{t} \to \mt{nullify} \; \mt{t} \; \mt{nt} \to \mt{sql\_aggregate} \; \mt{t} \; \mt{nt}
 \end{array}$$
 
-There is a fancier class of aggregates called \emph{window functions}, defined in the SQL standard but currently only supported by Postgres, among the DBMSes that Ur/Web supports.  Here are the type family and associated combinator for creating a window function expression:
-
-$$\begin{array}{l}
-\mt{con} \; \mt{sql\_window} :: \{\{\mt{Type}\}\} \to \{\{\mt{Type}\}\} \to \{\mt{Type}\} \to \mt{Type} \to \mt{Type} \\
-\mt{val} \; \mt{sql\_window} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \\
-\hspace{.1in} \to \mt{t} ::: \mt{Type} \\
-\hspace{.1in} \to \mt{sql\_window} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t} \\
-\hspace{.1in} \to \mt{sql\_partition} \; \mt{tables} \; \mt{agg} \; \mt{exps} \\
-\hspace{.1in} \to \mt{sql\_order\_by} \; \mt{tables} \; \mt{exps} \\
-\hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{allow\_window} \; \mt{t}
-\end{array}$$
-
-The function argument for an SQL \cd{PARTITION BY} clause uses the following type family and combinators:
-$$\begin{array}{l}
-\mt{con} \; \mt{sql\_partition} :: \{\{\mt{Type}\}\} \to \{\{\mt{Type}\}\} \to \{\mt{Type}\} \to \mt{Type} \\
-\mt{val} \; \mt{sql\_no\_partition} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \\
-\hspace{.1in} \to \mt{sql\_partition} \; \mt{tables} \; \mt{agg} \; \mt{exps} \\
-\mt{val} \; \mt{sql\_partition} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{t} ::: \mt{Type} \\
-\hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{disallow\_window} \; \mt{t} \\
-\hspace{.1in} \to \mt{sql\_partition} \; \mt{tables} \; \mt{agg} \; \mt{exps}
-\end{array}$$
-
 Any SQL query that returns single columns may be turned into a subquery expression.
 
 $$\begin{array}{l}
-\mt{val} \; \mt{sql\_subquery} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{nm} ::: \mt{Name} \\
-\hspace{.1in} \to \mt{aw} ::: \{\mt{Unit}\} \to \mt{t} ::: \mt{Type} \to \mt{nt} ::: \mt{Type} \\
-\hspace{.1in} \to \mt{nullify} \; \mt{t} \; \mt{nt} \to \mt{sql\_query} \; \mt{tables} \; \mt{agg} \; [\mt{nm} = \mt{t}] \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{aw} \; \mt{nt}
+\mt{val} \; \mt{sql\_subquery} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{nm} ::: \mt{Name} \to \mt{t} ::: \mt{Type} \to \mt{nt} ::: \mt{Type} \\
+\hspace{.1in} \to \mt{nullify} \; \mt{t} \; \mt{nt} \to \mt{sql\_query} \; \mt{tables} \; \mt{agg} \; [\mt{nm} = \mt{t}] \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{nt}
 \end{array}$$
 
 There is also an \cd{IF..THEN..ELSE..} construct that is compiled into standard SQL \cd{CASE} expressions.
 $$\begin{array}{l}
-\mt{val} \; \mt{sql\_if\_then\_else} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{aw} ::: \{\mt{Unit}\} \to \mt{t} ::: \mt{Type} \\
-\hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{aw} \; \mt{bool} \\
-\hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{aw} \; \mt{t} \\
-\hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{aw} \; \mt{t} \\
-\hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{aw} \; \mt{t}
+\mt{val} \; \mt{sql\_if\_then\_else} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{t} ::: \mt{Type} \\
+\hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{bool} \\
+\hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t} \\
+\hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t} \\
+\hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t}
 \end{array}$$
 
 \texttt{FROM} clauses are specified using a type family, whose arguments are the free table variables and the table variables bound by this clause.
@@ -1870,7 +1840,7 @@ $$\begin{array}{l}
   \mt{val} \; \mt{sql\_inner\_join} : \mt{free} ::: \{\{\mt{Type}\}\} \to \mt{tabs1} ::: \{\{\mt{Type}\}\} \to \mt{tabs2} ::: \{\{\mt{Type}\}\} \\
   \hspace{.1in} \to [\mt{free} \sim \mt{tabs1}] \Rightarrow [\mt{free} \sim \mt{tabs2}] \Rightarrow [\mt{tabs1} \sim \mt{tabs2}] \\
   \hspace{.1in} \Rightarrow \mt{sql\_from\_items} \; \mt{free} \; \mt{tabs1} \to \mt{sql\_from\_items} \; \mt{free} \; \mt{tabs2} \\
-  \hspace{.1in} \to \mt{sql\_exp} \; (\mt{free} \rc \mt{tabs1} \rc \mt{tabs2}) \; [] \; [] \; \mt{disallow\_window} \; \mt{bool} \\
+  \hspace{.1in} \to \mt{sql\_exp} \; (\mt{free} \rc \mt{tabs1} \rc \mt{tabs2}) \; [] \; [] \; \mt{bool} \\
   \hspace{.1in} \to \mt{sql\_from\_items} \; \mt{free} \; (\mt{tabs1} \rc \mt{tabs2})
 \end{array}$$
 
@@ -1888,7 +1858,7 @@ $$\begin{array}{l}
   \hspace{.1in} \to [\mt{free} \sim \mt{tabs1}] \Rightarrow [\mt{free} \sim \mt{tabs2}] \Rightarrow [\mt{tabs1} \sim \mt{tabs2}] \\
  \hspace{.1in} \Rightarrow \$(\mt{map} \; (\lambda \mt{r} \Rightarrow \$(\mt{map} \; (\lambda \mt{p} :: (\mt{Type} \times \mt{Type}) \Rightarrow \mt{nullify} \; \mt{p}.1 \; \mt{p}.2) \; \mt{r})) \; \mt{tabs2}) \\
  \hspace{.1in} \to \mt{sql\_from\_items} \; \mt{free} \; \mt{tabs1} \to \mt{sql\_from\_items} \; \mt{free} \; (\mt{map} \; (\mt{map} \; (\lambda \mt{p} :: (\mt{Type} \times \mt{Type}) \Rightarrow \mt{p}.1)) \; \mt{tabs2}) \\
- \hspace{.1in} \to \mt{sql\_exp} \; (\mt{free} \rc \mt{tabs1} \rc \mt{map} \; (\mt{map} \; (\lambda \mt{p} :: (\mt{Type} \times \mt{Type}) \Rightarrow \mt{p}.1)) \; \mt{tabs2}) \; [] \; [] \; \mt{disallow\_window} \; \mt{bool} \\
+ \hspace{.1in} \to \mt{sql\_exp} \; (\mt{free} \rc \mt{tabs1} \rc \mt{map} \; (\mt{map} \; (\lambda \mt{p} :: (\mt{Type} \times \mt{Type}) \Rightarrow \mt{p}.1)) \; \mt{tabs2}) \; [] \; [] \; \mt{bool} \\
  \hspace{.1in} \to \mt{sql\_from\_items} \; \mt{free} \; (\mt{tabs1} \rc \mt{map} \; (\mt{map} \; (\lambda \mt{p} :: (\mt{Type} \times \mt{Type}) \Rightarrow \mt{p}.2)) \; \mt{tabs2})
 \end{array}$$
 
@@ -1900,8 +1870,9 @@ $$\begin{array}{l}
   \\
   \mt{con} \; \mt{sql\_order\_by} :: \{\{\mt{Type}\}\} \to \{\mt{Type}\} \to \mt{Type} \\
   \mt{val} \; \mt{sql\_order\_by\_Nil} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{exps} :: \{\mt{Type}\} \to \mt{sql\_order\_by} \; \mt{tables} \; \mt{exps} \\
-  \mt{val} \; \mt{sql\_order\_by\_Cons} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{t} ::: \mt{Type} \\
-  \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; [] \; \mt{exps} \; \mt{allow\_window} \; \mt{t} \to \mt{sql\_direction} \to \mt{sql\_order\_by} \; \mt{tables} \; \mt{exps} \to \mt{sql\_order\_by} \; \mt{tables} \; \mt{exps} \\
+  \mt{val} \; \mt{sql\_order\_by\_Cons} : \mt{tf} ::: (\{\{\mt{Type}\}\} \to \{\{\mt{Type}\}\} \to \{\mt{Type}\} \to \mt{Type} \to \mt{Type}) \\
+  \hspace{.1in} \to \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{t} ::: \mt{Type} \\
+  \hspace{.1in} \to \mt{sql\_window} \; \mt{tf} \to \mt{tf} \; \mt{tables} \; [] \; \mt{exps} \; \mt{t} \to \mt{sql\_direction} \to \mt{sql\_order\_by} \; \mt{tables} \; \mt{exps} \to \mt{sql\_order\_by} \; \mt{tables} \; \mt{exps} \\
   \mt{val} \; \mt{sql\_order\_by\_random} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{sql\_order\_by} \; \mt{tables} \; \mt{exps} \\
   \\
   \mt{type} \; \mt{sql\_limit} \\
@@ -1913,6 +1884,45 @@ $$\begin{array}{l}
   \mt{val} \; \mt{sql\_offset} : \mt{int} \to \mt{sql\_offset}
 \end{array}$$
 
+When using Postgres, \cd{SELECT} and \cd{ORDER BY} are allowed to contain top-level uses of \emph{window functions}.  A separate type family \cd{sql\_expw} is provided for such cases, with some type class convenience for overloading between normal and window expressions.
+$$\begin{array}{l}
+  \mt{con} \; \mt{sql\_expw} :: \{\{\mt{Type}\}\} \to \{\{\mt{Type}\}\} \to \{\mt{Type}\} \to \mt{Type} \to \mt{Type} \\
+  \\
+  \mt{class} \; \mt{sql\_window} :: (\{\{\mt{Type}\}\} \to \{\{\mt{Type}\}\} \to \{\mt{Type}\} \to \mt{Type} \to \mt{Type}) \to \mt{Type} \\
+  \mt{val} \; \mt{sql\_window\_normal} : \mt{sql\_window} \; \mt{sql\_exp} \\
+  \mt{val} \; \mt{sql\_window\_fancy} : \mt{sql\_window} \; \mt{sql\_expw} \\
+  \mt{val} \; \mt{sql\_window} : \mt{tf} ::: (\{\{\mt{Type}\}\} \to \{\{\mt{Type}\}\} \to \{\mt{Type}\} \to \mt{Type} \to \mt{Type}) \\
+  \hspace{.1in} \to \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{t} ::: \mt{Type} \\
+  \hspace{.1in} \to \mt{sql\_window} \; \mt{tf} \\
+  \hspace{.1in} \to \mt{tf} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t} \\
+  \hspace{.1in} \to \mt{sql\_expw} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t} \\
+  \\
+  \mt{con} \; \mt{sql\_partition} :: \{\{\mt{Type}\}\} \to \{\{\mt{Type}\}\} \to \{\mt{Type}\} \to \mt{Type} \\
+  \mt{val} \; \mt{sql\_no\_partition} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \\
+  \hspace{.1in} \to \mt{sql\_partition} \; \mt{tables} \; \mt{agg} \; \mt{exps} \\
+  \mt{val} \; \mt{sql\_partition} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \mt{t} ::: \mt{Type} \\
+  \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t} \\
+  \hspace{.1in} \to \mt{sql\_partition} \; \mt{tables} \; \mt{agg} \; \mt{exps} \\
+  \\
+  \mt{con} \; \mt{sql\_window\_function} :: \{\{\mt{Type}\}\} \to \{\{\mt{Type}\}\} \to \{\mt{Type}\} \to \mt{Type} \to \mt{Type} \\
+  \mt{val} \; \mt{sql\_window\_function} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \\
+  \hspace{.1in} \to \mt{t} ::: \mt{Type} \\
+  \hspace{.1in} \to \mt{sql\_window\_function} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t} \\
+  \hspace{.1in} \to \mt{sql\_partition} \; \mt{tables} \; \mt{agg} \; \mt{exps} \\
+  \hspace{.1in} \to \mt{sql\_order\_by} \; \mt{tables} \; \mt{exps} \\
+  \hspace{.1in} \to \mt{sql\_expw} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t} \\
+  \\
+  \mt{val} \; \mt{sql\_window\_aggregate} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \\
+  \hspace{.1in} \to \mt{t} ::: \mt{Type} \to \mt{nt} ::: \mt{Type} \\
+  \hspace{.1in} \to \mt{sql\_aggregate} \; \mt{t} \; \mt{nt} \\
+  \hspace{.1in} \to \mt{sql\_exp} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{t} \\
+  \hspace{.1in} \to \mt{sql\_window\_function} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{nt} \\
+  \mt{val} \; \mt{sql\_window\_count} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \\
+  \hspace{.1in} \to \mt{sql\_window\_function} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{int} \\
+  \mt{val} \; \mt{sql\_rank} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{agg} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \\
+  \hspace{.1in} \to \mt{sql\_window\_function} \; \mt{tables} \; \mt{agg} \; \mt{exps} \; \mt{int}
+\end{array}$$
+
 
 \subsubsection{DML}
 
@@ -1932,19 +1942,19 @@ $$\begin{array}{l}
 Properly-typed records may be used to form $\mt{INSERT}$ commands.
 $$\begin{array}{l}
   \mt{val} \; \mt{insert} : \mt{fields} ::: \{\mt{Type}\} \to \mt{sql\_table} \; \mt{fields} \\
-  \hspace{.1in} \to \$(\mt{map} \; (\mt{sql\_exp} \; [] \; [] \; [] \; \mt{disallow\_window}) \; \mt{fields}) \to \mt{dml}
+  \hspace{.1in} \to \$(\mt{map} \; (\mt{sql\_exp} \; [] \; [] \; []) \; \mt{fields}) \to \mt{dml}
 \end{array}$$
 
 An $\mt{UPDATE}$ command is formed from a choice of which table fields to leave alone and which to change, along with an expression to use to compute the new value of each changed field and a $\mt{WHERE}$ clause.  Note that, in the table environment applied to expressions, the table being updated is hardcoded at the name $\mt{T}$.  The parsing extension for $\mt{UPDATE}$ will elaborate all table-free field references to use table variable $\mt{T}$.
 $$\begin{array}{l}
   \mt{val} \; \mt{update} : \mt{unchanged} ::: \{\mt{Type}\} \to \mt{changed} :: \{\mt{Type}\} \to [\mt{changed} \sim \mt{unchanged}] \\
-  \hspace{.1in} \Rightarrow \$(\mt{map} \; (\mt{sql\_exp} \; [\mt{T} = \mt{changed} \rc \mt{unchanged}] \; [] \; [] \; \mt{disallow\_window}) \; \mt{changed}) \\
-  \hspace{.1in} \to \mt{sql\_table} \; (\mt{changed} \rc \mt{unchanged}) \to \mt{sql\_exp} \; [\mt{T} = \mt{changed} \rc \mt{unchanged}] \; [] \; [] \; \mt{disallow\_window} \; \mt{bool} \to \mt{dml}
+  \hspace{.1in} \Rightarrow \$(\mt{map} \; (\mt{sql\_exp} \; [\mt{T} = \mt{changed} \rc \mt{unchanged}] \; [] \; []) \; \mt{changed}) \\
+  \hspace{.1in} \to \mt{sql\_table} \; (\mt{changed} \rc \mt{unchanged}) \to \mt{sql\_exp} \; [\mt{T} = \mt{changed} \rc \mt{unchanged}] \; [] \; [] \; \mt{bool} \to \mt{dml}
 \end{array}$$
 
 A $\mt{DELETE}$ command is formed from a table and a $\mt{WHERE}$ clause.  The above use of $\mt{T}$ is repeated.
 $$\begin{array}{l}
-  \mt{val} \; \mt{delete} : \mt{fields} ::: \{\mt{Type}\} \to \mt{sql\_table} \; \mt{fields} \to \mt{sql\_exp} \; [\mt{T} = \mt{fields}] \; [] \; [] \; \mt{disallow\_window} \; \mt{bool} \to \mt{dml}
+  \mt{val} \; \mt{delete} : \mt{fields} ::: \{\mt{Type}\} \to \mt{sql\_table} \; \mt{fields} \to \mt{sql\_exp} \; [\mt{T} = \mt{fields}] \; [] \; [] \; \mt{bool} \to \mt{dml}
 \end{array}$$
 
 \subsubsection{Sequences}
@@ -2188,7 +2198,7 @@ $$\begin{array}{rrcll}
   \textrm{Pre-queries} & q &::=& \mt{SELECT} \; [\mt{DISTINCT}] \; P \; \mt{FROM} \; F,^+ \; [\mt{WHERE} \; E] \; [\mt{GROUP} \; \mt{BY} \; p,^+] \; [\mt{HAVING} \; E] \\
   &&& \mid q \; R \; q \mid \{\{\{e\}\}\} \\
   \textrm{Relational operators} & R &::=& \mt{UNION} \mid \mt{INTERSECT} \mid \mt{EXCEPT} \\
-  \textrm{$\mt{ORDER \; BY}$ items} & O &::=& \mt{RANDOM} [()] \mid E \; [o] \mid E \; [o], O
+  \textrm{$\mt{ORDER \; BY}$ items} & O &::=& \mt{RANDOM} [()] \mid \hat{E} \; [o] \mid \hat{E} \; [o], O
 \end{array}$$
 
 $$\begin{array}{rrcll}
@@ -2197,7 +2207,7 @@ $$\begin{array}{rrcll}
   \textrm{Pre-projections} & p &::=& t.f & \textrm{one column from a table} \\
   &&& t.\{\{c\}\} & \textrm{a record of columns from a table (of kind $\{\mt{Type}\}$)} \\
   &&& t.* & \textrm{all columns from a table} \\
-  &&& E \; [\mt{AS} \; f] & \textrm{expression column} \\
+  &&& \hat{E} \; [\mt{AS} \; f] & \textrm{expression column} \\
   \textrm{Table names} & t &::=& x & \textrm{constant table name (automatically capitalized)} \\
   &&& X & \textrm{constant table name} \\
   &&& \{\{c\}\} & \textrm{computed table name (of kind $\mt{Name}$)} \\
@@ -2216,8 +2226,7 @@ $$\begin{array}{rrcll}
   \textrm{SQL expressions} & E &::=& t.f & \textrm{column references} \\
   &&& X & \textrm{named expression references} \\
   &&& \{[e]\} & \textrm{injected native Ur expressions} \\
-  &&& \{e\} & \textrm{computed expressions, probably using} \\
-    &&&& \hspace{.1in} \textrm{$\mt{sql\_exp}$ directly} \\
+  &&& \{e\} & \textrm{computed expressions, probably using $\mt{sql\_exp}$ directly} \\
   &&& \mt{TRUE} \mid \mt{FALSE} & \textrm{boolean constants} \\
   &&& \ell & \textrm{primitive type literals} \\
   &&& \mt{NULL} & \textrm{null value (injection of $\mt{None}$)} \\
@@ -2226,12 +2235,10 @@ $$\begin{array}{rrcll}
   &&& n & \textrm{nullary operators} \\
   &&& u \; E & \textrm{unary operators} \\
   &&& E \; b \; E & \textrm{binary operators} \\
-  &&& \mt{COUNT}(\ast) \; [w] & \textrm{count number of rows} \\
-  &&& \mt{RANK}() \; [w] & \textrm{rank in sequence (Postgres only)} \\
-  &&& a(E) \; [w] & \textrm{other aggregate function} \\
+  &&& \mt{COUNT}(\ast) & \textrm{count number of rows} \\
+  &&& a(E) & \textrm{other aggregate function} \\
   &&& \mt{IF} \; E \; \mt{THEN} \; E \; \mt{ELSE} \; E & \textrm{conditional} \\
-  &&& (Q) & \textrm{subquery (must return a single} \\
-  &&&& \hspace{.1in} \textrm{expression column)} \\
+  &&& (Q) & \textrm{subquery (must return a single expression column)} \\
   &&& (E) & \textrm{explicit precedence} \\
   \textrm{Nullary operators} & n &::=& \mt{CURRENT\_TIMESTAMP} \\
   \textrm{Unary operators} & u &::=& \mt{NOT} \\
@@ -2239,7 +2246,13 @@ $$\begin{array}{rrcll}
   \textrm{Aggregate functions} & a &::=& \mt{COUNT} \mid \mt{AVG} \mid \mt{SUM} \mid \mt{MIN} \mid \mt{MAX} \\
   \textrm{Directions} & o &::=& \mt{ASC} \mid \mt{DESC} \mid \{e\} \\
   \textrm{SQL integer} & N &::=& n \mid \{e\} \\
-  \textrm{Window} & w &::=& \mt{OVER} \; ([\mt{PARTITION} \; \mt{BY} \; E] \; [\mt{ORDER} \; \mt{BY} \; O]) & \textrm{(Postgres only)}
+  \textrm{Windowable expressions} & \hat{E} &::=& E \\
+  &&& w \; [\mt{OVER} \; ( & \textrm{(Postgres only)} \\
+  &&& \hspace{.1in} [\mt{PARTITION} \; \mt{BY} \; E] \\
+  &&& \hspace{.1in} [\mt{ORDER} \; \mt{BY} \; O])] \\
+  \textrm{Window function} & w &::=& \mt{RANK}() \\
+  &&& \mt{COUNT}(*) \\
+  &&& a(E)
 \end{array}$$
 
 Additionally, an SQL expression may be inserted into normal Ur code with the syntax $(\mt{SQL} \; E)$ or $(\mt{WHERE} \; E)$.  Similar shorthands exist for other nonterminals, with the prefix $\mt{FROM}$ for $\mt{FROM}$ items and $\mt{SELECT1}$ for pre-queries.
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 68e20fb0..bea6e105 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -305,23 +305,15 @@ val foreign_key : mine1 ::: Name -> t ::: Type -> mine ::: {Type} -> munused :::
            OnUpdate : propagation_mode ([mine1 = t] ++ mine)}
        -> sql_constraint ([mine1 = t] ++ mine ++ munused) []
 
-con allow_window :: {Unit}
-con disallow_window :: {Unit}
-
-con sql_exp :: {{Type}} (* Free tables, for normal use *)
-    -> {{Type}}         (* Free tables, for use in arguments to aggregate functions *)
-    -> {Type}           (* Free ad-hoc variables *)
-    -> {Unit}           (* Allow window functions here?  ([allow_window] indicates yes.) *)
-    -> Type             (* SQL type of this expression *)
-    -> Type
-val sql_exp_weaken : fs ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> aw ::: {Unit} -> t ::: Type
+con sql_exp :: {{Type}} -> {{Type}} -> {Type} -> Type -> Type
+val sql_exp_weaken : fs ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type
                      -> fs' ::: {{Type}} -> agg' ::: {{Type}} -> exps' ::: {Type}
                      -> [fs ~ fs'] => [agg ~ agg'] => [exps ~ exps'] =>
-                     sql_exp fs agg exps aw t
-                     -> sql_exp (fs ++ fs') (agg ++ agg') (exps ++ exps') aw t
+                     sql_exp fs agg exps t
+                     -> sql_exp (fs ++ fs') (agg ++ agg') (exps ++ exps') t
 
 val check : fs ::: {Type}
-            -> sql_exp [] [] fs disallow_window bool
+            -> sql_exp [] [] fs bool
             -> sql_constraint fs []
 
 
@@ -359,7 +351,7 @@ val sql_from_comma : free ::: {{Type}} -> tabs1 ::: {{Type}} -> tabs2 ::: {{Type
 val sql_inner_join : free ::: {{Type}} -> tabs1 ::: {{Type}} -> tabs2 ::: {{Type}}
                      -> [free ~ tabs1] => [free ~ tabs2] => [tabs1 ~ tabs2]
     => sql_from_items free tabs1 -> sql_from_items free tabs2
-       -> sql_exp (free ++ tabs1 ++ tabs2) [] [] disallow_window bool
+       -> sql_exp (free ++ tabs1 ++ tabs2) [] [] bool
        -> sql_from_items free (tabs1 ++ tabs2)
 
 class nullify :: Type -> Type -> Type
@@ -370,14 +362,14 @@ val sql_left_join : free ::: {{Type}} -> tabs1 ::: {{Type}} -> tabs2 ::: {{(Type
                      -> [free ~ tabs1] => [free ~ tabs2] => [tabs1 ~ tabs2]
     => $(map (fn r => $(map (fn p :: (Type * Type) => nullify p.1 p.2) r)) tabs2)
        -> sql_from_items free tabs1 -> sql_from_items free (map (map (fn p :: (Type * Type) => p.1)) tabs2)
-       -> sql_exp (free ++ tabs1 ++ map (map (fn p :: (Type * Type) => p.1)) tabs2) [] [] disallow_window bool
+       -> sql_exp (free ++ tabs1 ++ map (map (fn p :: (Type * Type) => p.1)) tabs2) [] [] bool
        -> sql_from_items free (tabs1 ++ map (map (fn p :: (Type * Type) => p.2)) tabs2)
 
 val sql_right_join : free ::: {{Type}} -> tabs1 ::: {{(Type * Type)}} -> tabs2 ::: {{Type}}
                      -> [free ~ tabs1] => [free ~ tabs2] => [tabs1 ~ tabs2]
     => $(map (fn r => $(map (fn p :: (Type * Type) => nullify p.1 p.2) r)) tabs1)
        -> sql_from_items free (map (map (fn p :: (Type * Type) => p.1)) tabs1) -> sql_from_items free tabs2
-       -> sql_exp (free ++ map (map (fn p :: (Type * Type) => p.1)) tabs1 ++ tabs2) [] [] disallow_window bool
+       -> sql_exp (free ++ map (map (fn p :: (Type * Type) => p.1)) tabs1 ++ tabs2) [] [] bool
        -> sql_from_items free (map (map (fn p :: (Type * Type) => p.2)) tabs1 ++ tabs2)
 
 val sql_full_join : free ::: {{Type}} -> tabs1 ::: {{(Type * Type)}} -> tabs2 ::: {{(Type * Type)}}
@@ -385,9 +377,12 @@ val sql_full_join : free ::: {{Type}} -> tabs1 ::: {{(Type * Type)}} -> tabs2 ::
     => $(map (fn r => $(map (fn p :: (Type * Type) => nullify p.1 p.2) r)) (tabs1 ++ tabs2))
        -> sql_from_items free (map (map (fn p :: (Type * Type) => p.1)) tabs1)
        -> sql_from_items free (map (map (fn p :: (Type * Type) => p.1)) tabs2)
-       -> sql_exp (free ++ map (map (fn p :: (Type * Type) => p.1)) (tabs1 ++ tabs2)) [] [] disallow_window bool
+       -> sql_exp (free ++ map (map (fn p :: (Type * Type) => p.1)) (tabs1 ++ tabs2)) [] [] bool
        -> sql_from_items free (map (map (fn p :: (Type * Type) => p.2)) (tabs1 ++ tabs2))
 
+(** [ORDER BY] and [SELECT] expressions may use window functions, so we introduce a type family for such expressions. *)
+con sql_expw :: {{Type}} -> {{Type}} -> {Type} -> Type -> Type
+
 val sql_query1 : free ::: {{Type}}
                  -> afree ::: {{Type}}
                  -> tables ::: {{Type}}
@@ -401,11 +396,11 @@ val sql_query1 : free ::: {{Type}}
                  => [empties ~ selectedFields]
                  => {Distinct : bool,
                      From : sql_from_items free tables,
-                     Where : sql_exp (free ++ tables) afree [] disallow_window bool,
+                     Where : sql_exp (free ++ tables) afree [] bool,
                      GroupBy : sql_subset tables grouped,
-                     Having : sql_exp (free ++ grouped) (afree ++ tables) [] disallow_window bool,
+                     Having : sql_exp (free ++ grouped) (afree ++ tables) [] bool,
                      SelectFields : sql_subset grouped (map (fn _ => []) empties ++ selectedFields),
-                     SelectExps : $(map (sql_exp (free ++ grouped) (afree ++ tables) [] allow_window)
+                     SelectExps : $(map (sql_expw (free ++ grouped) (afree ++ tables) [])
                                             selectedExps) }
                  -> sql_query1 free afree tables selectedFields selectedExps
 
@@ -432,10 +427,21 @@ type sql_direction
 val sql_asc : sql_direction
 val sql_desc : sql_direction
 
+(** This type class supports automatic injection of either regular or window expressions into [sql_expw]. *)
+class sql_window :: ({{Type}} -> {{Type}} -> {Type} -> Type -> Type) -> Type
+val sql_window_normal : sql_window sql_exp
+val sql_window_fancy : sql_window sql_expw
+val sql_window : tf ::: ({{Type}} -> {{Type}} -> {Type} -> Type -> Type)
+                 -> tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type
+                 -> sql_window tf
+                 -> tf tables agg exps t
+                 -> sql_expw tables agg exps t
+
 con sql_order_by :: {{Type}} -> {Type} -> Type
 val sql_order_by_Nil : tables ::: {{Type}} -> exps :: {Type} -> sql_order_by tables exps
-val sql_order_by_Cons : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type
-                        -> sql_exp tables [] exps allow_window t -> sql_direction
+val sql_order_by_Cons : tf ::: ({{Type}} -> {{Type}} -> {Type} -> Type -> Type) -> tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type
+                        -> sql_window tf
+                        -> tf tables [] exps t -> sql_direction
                         -> sql_order_by tables exps
                         -> sql_order_by tables exps
 val sql_order_by_random : tables ::: {{Type}} -> exps ::: {Type}
@@ -462,42 +468,42 @@ val sql_query : free ::: {{Type}}
                 -> sql_query free afree selectedFields selectedExps
 
 val sql_field : otherTabs ::: {{Type}} -> otherFields ::: {Type}
-                -> aw ::: {Unit} -> fieldType ::: Type -> agg ::: {{Type}}
+                -> fieldType ::: Type -> agg ::: {{Type}}
                 -> exps ::: {Type}
                 -> tab :: Name -> field :: Name
                 -> sql_exp
                        ([tab = [field = fieldType] ++ otherFields] ++ otherTabs)
-                       agg exps aw fieldType
+                       agg exps fieldType
 
-val sql_exp : tabs ::: {{Type}} -> agg ::: {{Type}} -> aw ::: {Unit} -> t ::: Type -> rest ::: {Type}
+val sql_exp : tabs ::: {{Type}} -> agg ::: {{Type}} -> t ::: Type -> rest ::: {Type}
               -> nm :: Name
-              -> sql_exp tabs agg ([nm = t] ++ rest) aw t
+              -> sql_exp tabs agg ([nm = t] ++ rest) t
 
 class sql_injectable
 val sql_prim : t ::: Type -> sql_injectable_prim t -> sql_injectable t
 val sql_option_prim : t ::: Type -> sql_injectable_prim t -> sql_injectable (option t)
 
 val sql_inject : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                 -> aw ::: {Unit} -> t ::: Type
-                 -> sql_injectable t -> t -> sql_exp tables agg exps aw t
+                 -> t ::: Type
+                 -> sql_injectable t -> t -> sql_exp tables agg exps t
 
 val sql_is_null : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                  -> aw ::: {Unit} -> t ::: Type
-                  -> sql_exp tables agg exps aw (option t)
-                  -> sql_exp tables agg exps aw bool
+                  -> t ::: Type
+                  -> sql_exp tables agg exps (option t)
+                  -> sql_exp tables agg exps bool
 
 val sql_coalesce : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                  -> aw ::: {Unit} -> t ::: Type
-                  -> sql_exp tables agg exps aw (option t)
-                  -> sql_exp tables agg exps aw t
-                  -> sql_exp tables agg exps aw t
+                  -> t ::: Type
+                  -> sql_exp tables agg exps (option t)
+                  -> sql_exp tables agg exps t
+                  -> sql_exp tables agg exps t
 
 val sql_if_then_else : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                       -> aw ::: {Unit} -> t ::: Type
-                       -> sql_exp tables agg exps aw bool
-                       -> sql_exp tables agg exps aw t
-                       -> sql_exp tables agg exps aw t
-                       -> sql_exp tables agg exps aw t
+                       -> t ::: Type
+                       -> sql_exp tables agg exps bool
+                       -> sql_exp tables agg exps t
+                       -> sql_exp tables agg exps t
+                       -> sql_exp tables agg exps t
 
 class sql_arith
 val sql_arith_int : sql_arith int
@@ -507,9 +513,9 @@ val sql_arith_option : t ::: Type -> sql_arith t -> sql_arith (option t)
 con sql_unary :: Type -> Type -> Type
 val sql_not : sql_unary bool bool
 val sql_unary : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                -> aw ::: {Unit} -> arg ::: Type -> res ::: Type
-                -> sql_unary arg res -> sql_exp tables agg exps aw arg
-                -> sql_exp tables agg exps aw res
+                -> arg ::: Type -> res ::: Type
+                -> sql_unary arg res -> sql_exp tables agg exps arg
+                -> sql_exp tables agg exps res
 
 val sql_neg : t ::: Type -> sql_arith t -> sql_unary t t
 
@@ -517,10 +523,10 @@ con sql_binary :: Type -> Type -> Type -> Type
 val sql_and : sql_binary bool bool bool
 val sql_or : sql_binary bool bool bool
 val sql_binary : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                 -> aw ::: {Unit} -> arg1 ::: Type -> arg2 ::: Type -> res ::: Type
-                 -> sql_binary arg1 arg2 res -> sql_exp tables agg exps aw arg1
-                 -> sql_exp tables agg exps aw arg2
-                 -> sql_exp tables agg exps aw res
+                 -> arg1 ::: Type -> arg2 ::: Type -> res ::: Type
+                 -> sql_binary arg1 arg2 res -> sql_exp tables agg exps arg1
+                 -> sql_exp tables agg exps arg2
+                 -> sql_exp tables agg exps res
 
 val sql_plus : t ::: Type -> sql_arith t -> sql_binary t t t
 val sql_minus : t ::: Type -> sql_arith t -> sql_binary t t t
@@ -537,14 +543,14 @@ val sql_ge : t ::: Type -> sql_binary t t bool
 
 val sql_like : sql_binary string string bool
 
-val sql_count : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> aw ::: {Unit}
-                -> sql_exp tables agg exps aw int
+val sql_count : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+                -> sql_exp tables agg exps int
 
 con sql_aggregate :: Type -> Type -> Type
 val sql_aggregate : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                    -> aw ::: {Unit} -> dom ::: Type -> ran ::: Type
-                    -> sql_aggregate dom ran -> sql_exp agg agg exps aw dom
-                    -> sql_exp tables agg exps aw ran
+                    -> dom ::: Type -> ran ::: Type
+                    -> sql_aggregate dom ran -> sql_exp agg agg exps dom
+                    -> sql_exp tables agg exps ran
 
 val sql_count_col : t ::: Type -> sql_aggregate (option t) int
 
@@ -564,56 +570,59 @@ val sql_maxable_option : t ::: Type -> sql_maxable t -> sql_maxable (option t)
 val sql_max : t ::: Type -> nt ::: Type -> sql_maxable t -> nullify t nt -> sql_aggregate t nt
 val sql_min : t ::: Type -> nt ::: Type -> sql_maxable t -> nullify t nt -> sql_aggregate t nt
 
-con sql_partition :: {{Type}} -> {{Type}} -> {Type} -> Type
-val sql_no_partition : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                       -> sql_partition tables agg exps
-val sql_partition : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type
-                    -> sql_exp tables agg exps disallow_window t
-                    -> sql_partition tables agg exps
-
-con sql_window :: {{Type}} -> {{Type}} -> {Type} -> Type -> Type
-val sql_window : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                 -> t ::: Type
-                 -> sql_window tables agg exps t
-                 -> sql_partition tables agg exps
-                 -> sql_order_by tables exps
-                 -> sql_exp tables agg exps allow_window t
-
-val sql_window_aggregate : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                           -> t ::: Type -> nt ::: Type
-                           -> sql_aggregate t nt
-                           -> sql_exp tables agg exps disallow_window t
-                           -> sql_window tables agg exps nt
-val sql_window_count : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                       -> sql_window tables agg exps int
-val sql_window_rank : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                      -> sql_window tables agg exps int
-
 con sql_nfunc :: Type -> Type
 val sql_nfunc : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                -> aw ::: {Unit} -> t ::: Type
-                -> sql_nfunc t -> sql_exp tables agg exps aw t
+                -> t ::: Type
+                -> sql_nfunc t -> sql_exp tables agg exps t
 val sql_current_timestamp : sql_nfunc time
 
 con sql_ufunc :: Type -> Type -> Type
 val sql_ufunc : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                -> aw ::: {Unit} -> dom ::: Type -> ran ::: Type
-                -> sql_ufunc dom ran -> sql_exp tables agg exps aw dom
-                -> sql_exp tables agg exps aw ran
+                -> dom ::: Type -> ran ::: Type
+                -> sql_ufunc dom ran -> sql_exp tables agg exps dom
+                -> sql_exp tables agg exps ran
 val sql_octet_length : sql_ufunc blob int
 val sql_known : t ::: Type -> sql_ufunc t bool
 val sql_lower : sql_ufunc string string
 val sql_upper : sql_ufunc string string
 
-val sql_nullable : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> aw ::: {Unit} -> t ::: Type
+val sql_nullable : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type
                    -> sql_injectable_prim t
-                   -> sql_exp tables agg exps aw t
-                   -> sql_exp tables agg exps aw (option t)
+                   -> sql_exp tables agg exps t
+                   -> sql_exp tables agg exps (option t)
 
-val sql_subquery : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> nm ::: Name -> aw ::: {Unit} -> t ::: Type -> nt ::: Type
+val sql_subquery : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> nm ::: Name -> t ::: Type -> nt ::: Type
                    -> nullify t nt
                    -> sql_query tables agg [] [nm = t]
-                   -> sql_exp tables agg exps aw nt
+                   -> sql_exp tables agg exps nt
+
+(** Window function expressions *)
+
+con sql_partition :: {{Type}} -> {{Type}} -> {Type} -> Type
+val sql_no_partition : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+                       -> sql_partition tables agg exps
+val sql_partition : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type
+                    -> sql_exp tables agg exps t
+                    -> sql_partition tables agg exps
+
+con sql_window_function :: {{Type}} -> {{Type}} -> {Type} -> Type -> Type
+val sql_window_function : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+                          -> t ::: Type
+                          -> sql_window_function tables agg exps t
+                          -> sql_partition tables agg exps
+                          -> sql_order_by tables exps
+                          -> sql_expw tables agg exps t
+
+val sql_window_aggregate : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+                           -> t ::: Type -> nt ::: Type
+                           -> sql_aggregate t nt
+                           -> sql_exp tables agg exps t
+                           -> sql_window_function tables agg exps nt
+val sql_window_count : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+                       -> sql_window_function tables agg exps int
+val sql_rank : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+               -> sql_window_function tables agg exps int
+
 
 (*** Executing queries *)
 
@@ -637,19 +646,19 @@ val tryDml : dml -> transaction (option string)
 
 val insert : fields ::: {Type} -> uniques ::: {{Unit}}
              -> sql_table fields uniques
-             -> $(map (fn t :: Type => sql_exp [] [] [] disallow_window t) fields)
+             -> $(map (fn t :: Type => sql_exp [] [] [] t) fields)
              -> dml
 
 val update : unchanged ::: {Type} -> uniques ::: {{Unit}} -> changed :: {Type} ->
              [changed ~ unchanged] =>
-                $(map (fn t :: Type => sql_exp [T = changed ++ unchanged] [] [] disallow_window t) changed)
+                $(map (fn t :: Type => sql_exp [T = changed ++ unchanged] [] [] t) changed)
                 -> sql_table (changed ++ unchanged) uniques
-                -> sql_exp [T = changed ++ unchanged] [] [] disallow_window bool
+                -> sql_exp [T = changed ++ unchanged] [] [] bool
                 -> dml
 
 val delete : fields ::: {Type} -> uniques ::: {{Unit}}
              -> sql_table fields uniques
-             -> sql_exp [T = fields] [] [] disallow_window bool
+             -> sql_exp [T = fields] [] [] bool
              -> dml
 
 (*** Sequences *)
diff --git a/lib/ur/top.ur b/lib/ur/top.ur
index 60774ba5..e504204e 100644
--- a/lib/ur/top.ur
+++ b/lib/ur/top.ur
@@ -376,14 +376,14 @@ fun nonempty [fs] [us] (t : sql_table fs us) =
     oneRowE1 (SELECT COUNT( * ) > 0 AS B FROM t)
 
 fun eqNullable [tables ::: {{Type}}] [agg ::: {{Type}}] [exps ::: {Type}]
-    [aw ::: {Unit}] [t ::: Type] (_ : sql_injectable (option t))
-    (e1 : sql_exp tables agg exps aw (option t))
-    (e2 : sql_exp tables agg exps aw (option t)) =
+    [t ::: Type] (_ : sql_injectable (option t))
+    (e1 : sql_exp tables agg exps (option t))
+    (e2 : sql_exp tables agg exps (option t)) =
     (SQL ({e1} IS NULL AND {e2} IS NULL) OR {e1} = {e2})
 
 fun eqNullable' [tables ::: {{Type}}] [agg ::: {{Type}}] [exps ::: {Type}]
-    [aw ::: {Unit}] [t ::: Type] (_ : sql_injectable (option t))
-    (e1 : sql_exp tables agg exps aw (option t))
+    [t ::: Type] (_ : sql_injectable (option t))
+    (e1 : sql_exp tables agg exps (option t))
     (e2 : option t) =
     case e2 of
         None => (SQL {e1} IS NULL)
diff --git a/lib/ur/top.urs b/lib/ur/top.urs
index def3bc63..489e744d 100644
--- a/lib/ur/top.urs
+++ b/lib/ur/top.urs
@@ -269,15 +269,15 @@ val nonempty : fs ::: {Type} -> us ::: {{Unit}} -> sql_table fs us
                -> transaction bool
 
 val eqNullable : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                 -> aw ::: {Unit} -> t ::: Type -> sql_injectable (option t)
-                 -> sql_exp tables agg exps aw (option t)
-                 -> sql_exp tables agg exps aw (option t)
-                 -> sql_exp tables agg exps aw bool
+                 -> t ::: Type -> sql_injectable (option t)
+                 -> sql_exp tables agg exps (option t)
+                 -> sql_exp tables agg exps (option t)
+                 -> sql_exp tables agg exps bool
 
 val eqNullable' : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                  -> aw ::: {Unit} -> t ::: Type -> sql_injectable (option t)
-                  -> sql_exp tables agg exps aw (option t)
+                  -> t ::: Type -> sql_injectable (option t)
+                  -> sql_exp tables agg exps (option t)
                   -> option t
-                  -> sql_exp tables agg exps aw bool
+                  -> sql_exp tables agg exps bool
 
 val mkRead' : t ::: Type -> (string -> option t) -> string -> read t
diff --git a/src/elab_err.sml b/src/elab_err.sml
index 0e04cf51..4754d4ce 100644
--- a/src/elab_err.sml
+++ b/src/elab_err.sml
@@ -242,7 +242,11 @@ fun expError env err =
          eprefaces' ([("Class constraint", p_con env c)]
                      @ (case E.resolveFailureCause () of
                             NONE => []
-                          | SOME c' => [("Reduced to unresolvable", p_con env c')])))
+                          | SOME c' => [("Reduced to unresolvable", p_con env c')]))(*;
+         app (fn (c, rs) => (eprefaces' [("CLASS", p_con env c)];
+                             app (fn (c, e) => eprefaces' [("RULE", p_con env c),
+                                                           ("IMPL", p_exp env e)]) rs))
+             (E.listClasses env)*))
       | IllegalRec (x, e) =>
         (ErrorMsg.errorAt (#2 e) "Illegal 'val rec' righthand side (must be a function abstraction)";
          eprefaces' [("Variable", PD.string x),
diff --git a/src/monoize.sml b/src/monoize.sml
index 8224b26f..4985c932 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -249,7 +249,13 @@ fun monoType env =
                     (L'.TFfi ("Basis", "string"), loc)
                   | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_from_items"), _), _), _), _) =>
                     (L'.TFfi ("Basis", "string"), loc)
-                  | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _), _), _) =>
+                  | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _) =>
+                    (L'.TFfi ("Basis", "string"), loc)
+                  | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_expw"), _), _), _), _), _), _), _), _) =>
+                    (L'.TFfi ("Basis", "string"), loc)
+                  | L.CApp ((L.CFfi ("Basis", "sql_window"), _), _) =>
+                    (L'.TRecord [], loc)
+                  | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_window_function"), _), _), _), _), _), _), _), _) =>
                     (L'.TFfi ("Basis", "string"), loc)
                   | L.CApp ((L.CApp ((L.CFfi ("Basis", "primary_key"), _), _), _), _) =>
                     (L'.TFfi ("Basis", "string"), loc)
@@ -299,16 +305,16 @@ fun monoType env =
                     (L'.TRecord [], loc)
                   | L.CApp ((L.CFfi ("Basis", "sql_maxable"), _), _) =>
                     (L'.TRecord [], loc)
-                  | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_partition"), _), _), _), _), _), _) =>
-                    (L'.TFfi ("Basis", "string"), loc)
-                  | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_window"), _), _), _), _), _), _), _), _) =>
-                    (L'.TFfi ("Basis", "string"), loc)
                   | L.CApp ((L.CFfi ("Basis", "sql_arith"), _), _) =>
                     (L'.TRecord [], loc)
                   | L.CApp ((L.CFfi ("Basis", "sql_nfunc"), _), _) =>
                     (L'.TFfi ("Basis", "string"), loc)
                   | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_ufunc"), _), _), _), _) =>
                     (L'.TFfi ("Basis", "string"), loc)
+                  | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_partition"), _), _), _), _), _), _) =>
+                    (L'.TFfi ("Basis", "string"), loc)
+                  | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_window"), _), _), _), _), _), _), _), _) =>
+                    (L'.TFfi ("Basis", "string"), loc)
 
                   | L.CApp ((L.CFfi ("Basis", "channel"), _), _) =>
                     (L'.TFfi ("Basis", "channel"), loc)
@@ -2111,9 +2117,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             (L.ECApp (
              (L.ECApp (
               (L.ECApp (
-               (L.ECApp (
-                (L.EFfi ("Basis", "sql_inject"), _),
-                _), _),
+               (L.EFfi ("Basis", "sql_inject"), _),
                _), _),
               _), _),
              _), _),
@@ -2426,7 +2430,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
           | L.ECApp (
             (L.ECApp (
              (L.ECApp (
-              (L.EFfi ("Basis", "sql_order_by_Cons"), _),
+              (L.ECApp (
+               (L.EFfi ("Basis", "sql_order_by_Cons"), _),
+               _), _),
               _), _),
              _), _),
             _) =>
@@ -2434,19 +2440,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                 val s = (L'.TFfi ("Basis", "string"), loc)
                 fun sc s = (L'.EPrim (Prim.String s), loc)
             in
-                ((L'.EAbs ("e1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
-                           (L'.EAbs ("d", s, (L'.TFun (s, s), loc),
-                                     (L'.EAbs ("e2", s, s,
-                                               (L'.ECase ((L'.ERel 0, loc),
-                                                          [((L'.PPrim (Prim.String ""), loc),
-                                                            strcat [(L'.ERel 2, loc),
-                                                                    (L'.ERel 1, loc)]),
-                                                           ((L'.PWild, loc),
-                                                            strcat [(L'.ERel 2, loc),
-                                                                    (L'.ERel 1, loc),
-                                                                    sc ", ",
-                                                                    (L'.ERel 0, loc)])],
-                                                          {disc = s, result = s}), loc)), loc)), loc)), loc),
+                ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc),
+                           (L'.EAbs ("e1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
+                                     (L'.EAbs ("d", s, (L'.TFun (s, s), loc),
+                                               (L'.EAbs ("e2", s, s,
+                                                         (L'.ECase ((L'.ERel 0, loc),
+                                                                    [((L'.PPrim (Prim.String ""), loc),
+                                                                      strcat [(L'.ERel 2, loc),
+                                                                              (L'.ERel 1, loc)]),
+                                                                     ((L'.PWild, loc),
+                                                                      strcat [(L'.ERel 2, loc),
+                                                                              (L'.ERel 1, loc),
+                                                                              sc ", ",
+                                                                              (L'.ERel 0, loc)])],
+                                                                    {disc = s, result = s}), loc)), loc)), loc)), loc)), loc),
                  fm)
             end
 
@@ -2512,10 +2519,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
              (L.ECApp (
               (L.ECApp (
                (L.ECApp (
-                (L.ECApp (
                  (L.EFfi ("Basis", "sql_unary"), _),
                  _), _),
-                _), _),
                _), _),
               _), _),
              _), _),
@@ -2544,9 +2549,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
               (L.ECApp (
                (L.ECApp (
                 (L.ECApp (
-                 (L.ECApp (
-                  (L.EFfi ("Basis", "sql_binary"), _),
-                  _), _),
+                 (L.EFfi ("Basis", "sql_binary"), _),
                  _), _),
                 _), _),
                _), _),
@@ -2579,9 +2582,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                (L.ECApp (
                 (L.ECApp (
                  (L.ECApp (
-                  (L.ECApp (
-                   (L.EFfi ("Basis", "sql_field"), _),
-                   _), _),
+                  (L.EFfi ("Basis", "sql_field"), _),
                   _), _),
                  _), _),
                 _), _),
@@ -2595,9 +2596,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
              (L.ECApp (
               (L.ECApp (
                (L.ECApp (
-                (L.ECApp (
-                 (L.EFfi ("Basis", "sql_exp"), _),
-                 _), _),
+                (L.EFfi ("Basis", "sql_exp"), _),
                 _), _),
                _), _),
               _), _),
@@ -2701,9 +2700,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
           | L.ECApp (
             (L.ECApp (
              (L.ECApp (
-              (L.ECApp (
-               (L.EFfi ("Basis", "sql_count"), _),
-               _), _),
+              (L.EFfi ("Basis", "sql_count"), _),
               _), _),
              _), _),
             _) => ((L'.EPrim (Prim.String "COUNT(*)"), loc),
@@ -2714,9 +2711,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
              (L.ECApp (
               (L.ECApp (
                (L.ECApp (
-                (L.ECApp (
-                 (L.EFfi ("Basis", "sql_aggregate"), _),
-                 _), _),
+                (L.EFfi ("Basis", "sql_aggregate"), _),
                 _), _),
                _), _),
               _), _),
@@ -2732,7 +2727,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                    sc ")"]
             in
                 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
-                           (L'.EAbs ("e1", s, s, main), loc)), loc),
+                           (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), main), loc)), loc),
                  fm)
             end
 
@@ -2781,73 +2776,33 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                  (L'.EPrim (Prim.String "MIN"), loc)), loc)), loc),
              fm)
 
-          | L.ECApp (
-            (L.ECApp (
-             (L.ECApp (
-               (L.EFfi ("Basis", "sql_no_partition"), _),
-               _), _),
-             _), _),
-            _) => ((L'.EPrim (Prim.String ""), loc), fm)
-          | L.ECApp (
-            (L.ECApp (
-             (L.ECApp (
-              (L.ECApp (
-               (L.EFfi ("Basis", "sql_partition"), _),
-               _), _),
-              _), _),
-             _), _),
-            _) =>
-            let
-                val s = (L'.TFfi ("Basis", "string"), loc)
-            in
-                ((L'.EAbs ("e", s, s, strcat [(L'.EPrim (Prim.String "PARTITION BY "), loc), (L'.ERel 0, loc)]), loc),
-                 fm)
-            end
-
+          | L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm)
+          | L.EFfi ("Basis", "sql_desc") => ((L'.EPrim (Prim.String " DESC"), loc), fm)
           | L.ECApp (
             (L.ECApp (
              (L.ECApp (
               (L.ECApp (
-               (L.EFfi ("Basis", "sql_window"), _),
+               (L.EFfi ("Basis", "sql_nfunc"), _),
                _), _),
               _), _),
              _), _),
-            _) =>
+           _) =>
             let
-                val () = if #windowFunctions (Settings.currentDbms ()) then
-                             ()
-                         else
-                             ErrorMsg.errorAt loc "The DBMS you've selected doesn't support window functions."
-
                 val s = (L'.TFfi ("Basis", "string"), loc)
                 fun sc s = (L'.EPrim (Prim.String s), loc)
-
-                val main = strcat [(L'.ERel 2, loc),
-                                   sc " OVER (",
-                                   (L'.ERel 1, loc),
-                                   (L'.ECase ((L'.ERel 0, loc),
-                                              [((L'.PPrim (Prim.String ""), loc),
-                                                sc ""),
-                                               ((L'.PWild, loc),
-                                                strcat [sc " ORDER BY ",
-                                                        (L'.ERel 0, loc)])],
-                                              {disc = s,
-                                               result = s}), loc),
-                                   sc ")"]
             in
-                ((L'.EAbs ("w", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
-                           (L'.EAbs ("p", s, (L'.TFun (s, s), loc),
-                                     (L'.EAbs ("o", s, s,
-                                               main), loc)), loc)), loc),
+                ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc),
                  fm)
             end
 
+          | L.EFfi ("Basis", "sql_window_normal") => ((L'.ERecord [], loc), fm)
+          | L.EFfi ("Basis", "sql_window_fancy") => ((L'.ERecord [], loc), fm)
           | L.ECApp (
             (L.ECApp (
              (L.ECApp (
               (L.ECApp (
                (L.ECApp (
-                (L.EFfi ("Basis", "sql_window_aggregate"), _),
+                (L.EFfi ("Basis", "sql_window"), _),
                 _), _),
                _), _),
               _), _),
@@ -2855,43 +2810,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             _) =>
             let
                 val s = (L'.TFfi ("Basis", "string"), loc)
-                fun sc s = (L'.EPrim (Prim.String s), loc)
-
-                val main = strcat [(L'.ERel 1, loc),
-                                   sc "(",
-                                   (L'.ERel 0, loc),
-                                   sc ")"]
             in
-                ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
-                           (L'.EAbs ("e1", s, s, main), loc)), loc),
+                ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, s), loc),
+                           (L'.EAbs ("e", s, s,
+                                     (L'.ERel 0, loc)), loc)), loc),
                  fm)
             end
 
-          | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_window_count"), _), _), _), _), _), _) =>
-            ((L'.EPrim (Prim.String "COUNT(*)"), loc), fm)
-          | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_window_rank"), _), _), _), _), _), _) =>
-            ((L'.EPrim (Prim.String "RANK()"), loc), fm)
-
-          | L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm)
-          | L.EFfi ("Basis", "sql_desc") => ((L'.EPrim (Prim.String " DESC"), loc), fm)
-          | L.ECApp (
-            (L.ECApp (
-             (L.ECApp (
-              (L.ECApp (
-               (L.ECApp (
-                (L.EFfi ("Basis", "sql_nfunc"), _),
-                _), _),
-               _), _),
-              _), _),
-             _), _),
-            _) =>
-            let
-                val s = (L'.TFfi ("Basis", "string"), loc)
-                fun sc s = (L'.EPrim (Prim.String s), loc)
-            in
-                ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc),
-                 fm)
-            end
           | L.EFfi ("Basis", "sql_current_timestamp") => ((L'.EPrim (Prim.String "CURRENT_TIMESTAMP"), loc), fm)
 
           | L.ECApp (
@@ -2899,9 +2824,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
              (L.ECApp (
               (L.ECApp (
                (L.ECApp (
-                (L.ECApp (
-                 (L.EFfi ("Basis", "sql_ufunc"), _),
-                 _), _),
+                (L.EFfi ("Basis", "sql_ufunc"), _),
                 _), _),
                _), _),
               _), _),
@@ -2935,9 +2858,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
              (L.ECApp (
               (L.ECApp (
                (L.ECApp (
-                (L.ECApp (
-                 (L.EFfi ("Basis", "sql_is_null"), _), _),
-                 _), _),
+                (L.EFfi ("Basis", "sql_is_null"), _), _),
                 _), _),
                _), _),
               _), _)) =>
@@ -2978,11 +2899,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
              (L.ECApp (
               (L.ECApp (
                (L.ECApp (
-                (L.ECApp (
-                 (L.ECApp (
-                  (L.EFfi ("Basis", "sql_if_then_else"), _), _),
-                  _), _),
-                 _), _),
+                (L.EFfi ("Basis", "sql_if_then_else"), _), _),
                 _), _),
                _), _),
               _), _)) =>
@@ -3007,9 +2924,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             (L.ECApp (
              (L.ECApp (
               (L.ECApp (
-               (L.ECApp (
-                (L.EFfi ("Basis", "sql_nullable"), _),
-                _), _),
+               (L.EFfi ("Basis", "sql_nullable"), _),
                _), _),
               _), _),
              _), _),
@@ -3030,9 +2945,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
               (L.ECApp (
                (L.ECApp (
                 (L.ECApp (
-                 (L.ECApp (
-                  (L.EFfi ("Basis", "sql_subquery"), _),
-                  _), _),
+                 (L.EFfi ("Basis", "sql_subquery"), _),
                  _), _),
                 _), _),
                _), _),
@@ -3051,6 +2964,97 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                  fm)
             end
 
+          | L.ECApp (
+            (L.ECApp (
+             (L.ECApp (
+               (L.EFfi ("Basis", "sql_no_partition"), _),
+               _), _),
+             _), _),
+            _) => ((L'.EPrim (Prim.String ""), loc), fm)
+          | L.ECApp (
+            (L.ECApp (
+             (L.ECApp (
+              (L.ECApp (
+               (L.EFfi ("Basis", "sql_partition"), _),
+               _), _),
+              _), _),
+             _), _),
+            _) =>
+            let
+                val s = (L'.TFfi ("Basis", "string"), loc)
+            in
+                ((L'.EAbs ("e", s, s, strcat [(L'.EPrim (Prim.String "PARTITION BY "), loc), (L'.ERel 0, loc)]), loc),
+                 fm)
+            end
+
+          | L.ECApp (
+            (L.ECApp (
+             (L.ECApp (
+              (L.ECApp (
+               (L.EFfi ("Basis", "sql_window_function"), _),
+               _), _),
+              _), _),
+             _), _),
+            _) =>
+            let
+                val () = if #windowFunctions (Settings.currentDbms ()) then
+                             ()
+                         else
+                             ErrorMsg.errorAt loc "The DBMS you've selected doesn't support window functions."
+
+                val s = (L'.TFfi ("Basis", "string"), loc)
+                fun sc s = (L'.EPrim (Prim.String s), loc)
+
+                val main = strcat [(L'.ERel 2, loc),
+                                   sc " OVER (",
+                                   (L'.ERel 1, loc),
+                                   (L'.ECase ((L'.ERel 0, loc),
+                                              [((L'.PPrim (Prim.String ""), loc),
+                                                sc ""),
+                                               ((L'.PWild, loc),
+                                                strcat [sc " ORDER BY ",
+                                                        (L'.ERel 0, loc)])],
+                                              {disc = s,
+                                               result = s}), loc),
+                                   sc ")"]
+            in
+                ((L'.EAbs ("w", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
+                           (L'.EAbs ("p", s, (L'.TFun (s, s), loc),
+                                     (L'.EAbs ("o", s, s,
+                                               main), loc)), loc)), loc),
+                 fm)
+            end
+
+          | L.ECApp (
+            (L.ECApp (
+             (L.ECApp (
+              (L.ECApp (
+               (L.ECApp (
+                (L.EFfi ("Basis", "sql_window_aggregate"), _),
+                _), _),
+               _), _),
+              _), _),
+             _), _),
+            _) =>
+            let
+                val s = (L'.TFfi ("Basis", "string"), loc)
+                fun sc s = (L'.EPrim (Prim.String s), loc)
+
+                val main = strcat [(L'.ERel 1, loc),
+                                   sc "(",
+                                   (L'.ERel 0, loc),
+                                   sc ")"]
+            in
+                ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
+                           (L'.EAbs ("e1", s, s, main), loc)), loc),
+                 fm)
+            end
+
+          | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_window_count"), _), _), _), _), _), _) =>
+            ((L'.EPrim (Prim.String "COUNT(*)"), loc), fm)
+          | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_rank"), _), _), _), _), _), _) =>
+            ((L'.EPrim (Prim.String "RANK()"), loc), fm)
+
           | L.EFfiApp ("Basis", "nextval", [(e, _)]) =>
             let
                 val (e, fm) = monoExp (env, st, fm) e
diff --git a/src/settings.sml b/src/settings.sml
index 3b89ce46..28739d6a 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -538,7 +538,7 @@ type dbms = {
      falseString : string,
      onlyUnion : bool,
      nestedRelops : bool,
-     windowFunctions : bool
+     windowFunctions: bool
 }
 
 val dbmses = ref ([] : dbms list)
diff --git a/src/urweb.grm b/src/urweb.grm
index eec8f8c1..708e5fcd 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -309,7 +309,7 @@ fun applyWindow loc e window =
                                         (ECApp ((EVar (["Basis"], "sql_order_by_Nil", Infer), dummy),
                                                 (CWild (KRecord (KType, dummy), dummy), dummy)),
                                          dummy)))
-        val e' = (EVar (["Basis"], "sql_window", Infer), loc)
+        val e' = (EVar (["Basis"], "sql_window_function", Infer), loc)
         val e' = (EApp (e', e), loc)
         val e' = (EApp (e', pb), loc)
     in
@@ -345,7 +345,7 @@ fun applyWindow loc e window =
  | UNION | INTERSECT | EXCEPT
  | LIMIT | OFFSET | ALL
  | TRUE | FALSE | CAND | OR | NOT
- | COUNT | AVG | SUM | MIN | MAX | RANK
+ | COUNT | AVG | SUM | MIN | MAX | RANK | PARTITION | OVER
  | ASC | DESC | RANDOM
  | INSERT | INTO | VALUES | UPDATE | SET | DELETE | NULL | IS | COALESCE | LIKE
  | CURRENT_TIMESTAMP
@@ -353,7 +353,6 @@ fun applyWindow loc e window =
  | CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES
  | JOIN | INNER | CROSS | OUTER | LEFT | RIGHT | FULL
  | CIF | CTHEN | CELSE
- | OVER | PARTITION
 
 %nonterm
    file of decl list
@@ -1755,6 +1754,8 @@ query1 : SELECT dopt select FROM tables wopt gopt hopt
                                                           exps)
                                                      end
 
+                                             val exps = map (fn (c, e) => (c, (EApp ((EVar (["Basis"], "sql_window", Infer), loc), e), loc))) exps
+
                                              val sel = (CRecord sel, loc)
 
                                              val grp = case gopt of
@@ -2041,49 +2042,37 @@ sqlexp : TRUE                           (sql_inject (EVar (["Basis"], "True", In
        | NULL                           (sql_inject ((EVar (["Basis"], "None", Infer), 
                                                       s (NULLleft, NULLright))))
 
-       | COUNT LPAREN STAR RPAREN window (let
-                                              val loc = s (COUNTleft, windowright)
-                                          in
-                                              case window of
-                                                  NONE => (EVar (["Basis"], "sql_count", Infer), loc)
-                                                | SOME _ =>
-                                                  let
-                                                      val e = (EVar (["Basis"], "sql_window_count", Infer), loc)
-                                                  in
-                                                      applyWindow loc e window
-                                                  end
-                                          end)
-       | RANK UNIT window                (let
-                                              val loc = s (RANKleft, windowright)
-                                              val e = (EVar (["Basis"], "sql_window_rank", Infer), loc)
-                                          in
-                                              applyWindow loc e window
-                                          end)
-       | COUNT LPAREN sqlexp RPAREN window (let
-                                                val loc = s (COUNTleft, windowright)
-                                                          
-                                                val e = (EVar (["Basis"], "sql_count_col", Infer), loc)
-                                            in
-                                                case window of
-                                                    NONE =>
-                                                    let
-                                                        val e = (EApp ((EVar (["Basis"], "sql_aggregate", Infer), loc),
-                                                                       e), loc)
-                                                    in
-                                                        (EApp (e, sqlexp), loc)
-                                                    end
-                                                  | SOME _ =>
-                                                    let
-                                                        val e = (EApp ((EVar (["Basis"], "sql_window_aggregate", Infer), loc),
-                                                                       e), loc)
-                                                        val e = (EApp (e, sqlexp), loc)
-                                                    in
-                                                        applyWindow loc e window
-                                                    end
-                                            end)
+       | COUNT LPAREN STAR RPAREN window(let
+                                             val loc = s (COUNTleft, windowright)
+                                         in
+                                             case window of
+                                                 NONE => (EVar (["Basis"], "sql_count", Infer), loc)
+                                               | SOME _ => applyWindow loc (EVar (["Basis"], "sql_window_count", Infer), loc) window
+                                         end)
+       | COUNT LPAREN sqlexp RPAREN window(let
+                                               val loc = s (COUNTleft, RPARENright)
+                                               val e = (EVar (["Basis"], "sql_count_col", Infer), loc)
+                                           in
+                                               case window of
+                                                   NONE =>
+                                                   let
+                                                       val e = (EApp ((EVar (["Basis"], "sql_aggregate", Infer), loc),
+                                                                      e), loc)
+                                                   in
+                                                       (EApp (e, sqlexp), loc)
+                                                   end
+                                                 | SOME _ =>
+                                                   let
+                                                       val e = (EVar (["Basis"], "sql_count_col", Infer), loc)
+                                                       val e = (EApp ((EVar (["Basis"], "sql_window_aggregate", Infer), loc),
+                                                                      e), loc)
+                                                   in
+                                                       applyWindow loc (EApp (e, sqlexp), loc) window
+                                                   end
+                                           end)
        | sqlagg LPAREN sqlexp RPAREN window (let
-                                                 val loc = s (sqlaggleft, windowright)
-
+                                                 val loc = s (sqlaggleft, RPARENright)
+                                                           
                                                  val e = (EVar (["Basis"], "sql_" ^ sqlagg, Infer), loc)
                                              in
                                                  case window of
@@ -2098,11 +2087,15 @@ sqlexp : TRUE                           (sql_inject (EVar (["Basis"], "True", In
                                                      let
                                                          val e = (EApp ((EVar (["Basis"], "sql_window_aggregate", Infer), loc),
                                                                         e), loc)
-                                                         val e = (EApp (e, sqlexp), loc)
                                                      in
-                                                         applyWindow loc e window
+                                                         applyWindow loc (EApp (e, sqlexp), loc) window
                                                      end
                                              end)
+       | RANK UNIT window               (let
+                                             val loc = s (RANKleft, windowright)
+                                         in
+                                             applyWindow loc (EVar (["Basis"], "sql_rank", Infer), loc) window
+                                         end)
        | COALESCE LPAREN sqlexp COMMA sqlexp RPAREN
                                         (let
                                              val loc = s (COALESCEright, sqlexp2right)
diff --git a/src/urweb.lex b/src/urweb.lex
index 272c5e65..0994ecec 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -463,8 +463,6 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 <INITIAL> "OFFSET"    => (Tokens.OFFSET (pos yypos, pos yypos + size yytext));
 <INITIAL> "ALL"       => (Tokens.ALL (pos yypos, pos yypos + size yytext));
 <INITIAL> "SELECT1"   => (Tokens.SELECT1 (pos yypos, pos yypos + size yytext));
-<INITIAL> "OVER"      => (Tokens.OVER (pos yypos, pos yypos + size yytext));
-<INITIAL> "PARTITION" => (Tokens.PARTITION (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "JOIN"      => (Tokens.JOIN (pos yypos, pos yypos + size yytext));
 <INITIAL> "INNER"     => (Tokens.INNER (pos yypos, pos yypos + size yytext));
@@ -490,6 +488,8 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 <INITIAL> "MIN"       => (Tokens.MIN (pos yypos, pos yypos + size yytext));
 <INITIAL> "MAX"       => (Tokens.MAX (pos yypos, pos yypos + size yytext));
 <INITIAL> "RANK"      => (Tokens.RANK (pos yypos, pos yypos + size yytext));
+<INITIAL> "PARTITION" => (Tokens.PARTITION (pos yypos, pos yypos + size yytext));
+<INITIAL> "OVER"      => (Tokens.OVER (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "IF"        => (Tokens.CIF (pos yypos, pos yypos + size yytext));
 <INITIAL> "THEN"      => (Tokens.CTHEN (pos yypos, pos yypos + size yytext));
diff --git a/tests/window.ur b/tests/window.ur
index dc338a43..c0eaf6e2 100644
--- a/tests/window.ur
+++ b/tests/window.ur
@@ -1,6 +1,6 @@
 table empsalary : { Depname : string,
-                   Empno : int,
-                   Salary : int }
+                    Empno : int,
+                    Salary : int }
 
 fun main () : transaction page =
     x <- queryX (SELECT empsalary.Depname, empsalary.Empno, empsalary.Salary,
-- 
cgit v1.2.3


From 53c633b53e8825cb9058fb88e86d1ca7828b83e6 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Thu, 27 Dec 2012 15:34:11 -0500
Subject: Add some name-mangling rules to allow XML attribute 'name' and
 attributes with dashes

---
 lib/ur/list.ur       | 12 ++++++++++++
 lib/ur/list.urs      |  3 +++
 src/monoize.sml      |  5 +++++
 src/urweb.grm        | 11 +++++++----
 src/urweb.lex        |  3 ++-
 tests/attrMangle.ur  |  5 +++++
 tests/attrMangle.urp |  4 ++++
 tests/goofy.urs      |  1 +
 8 files changed, 39 insertions(+), 5 deletions(-)
 create mode 100644 tests/attrMangle.ur
 create mode 100644 tests/attrMangle.urp
 create mode 100644 tests/goofy.urs

(limited to 'src/urweb.lex')

diff --git a/lib/ur/list.ur b/lib/ur/list.ur
index bce5335e..cbb4faf2 100644
--- a/lib/ur/list.ur
+++ b/lib/ur/list.ur
@@ -437,3 +437,15 @@ fun mapXiM [m ::: Type -> Type] (_ : monad m) [a] [ctx ::: {Unit}] (f : int -> a
     in
         mapXiM' 0
     end
+
+fun tabulateM [m] (_ : monad m) [a] (f : int -> m a) n =
+    let
+        fun tabulate' n acc =
+            if n <= 0 then
+                return acc
+            else
+                (v <- f (n-1);
+                 tabulate' (n-1) (v :: acc))
+    in
+        tabulate' n []
+    end
diff --git a/lib/ur/list.urs b/lib/ur/list.urs
index b26c9ad9..66007a39 100644
--- a/lib/ur/list.urs
+++ b/lib/ur/list.urs
@@ -63,6 +63,9 @@ val all : a ::: Type -> (a -> bool) -> t a -> bool
 val app : m ::: (Type -> Type) -> monad m -> a ::: Type
           -> (a -> m unit) -> t a -> m unit
 
+val tabulateM : m ::: (Type -> Type) -> monad m -> a ::: Type
+                -> (int -> m a) -> int -> m (t a)
+
 val mapQuery : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type
                -> [tables ~ exps] =>
     sql_query [] [] tables exps
diff --git a/src/monoize.sml b/src/monoize.sml
index 39e4853b..d324b235 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3364,8 +3364,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                         val x =
                                                             case x of
                                                                 "Typ" => "Type"
+                                                              | "Nam" => "Name"
                                                               | "Link" => "Href"
                                                               | _ => x
+
+                                                        val x = String.translate (fn #"_" => "-"
+                                                                                   | ch => String.str ch) x
+
                                                         val xp = " " ^ lowercaseFirst x ^ "=\""
 
                                                         val (e, fm) = fooify env fm (e, t)
diff --git a/src/urweb.grm b/src/urweb.grm
index a45c7ffa..c2a48742 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -35,6 +35,12 @@ val dummy = ErrorMsg.dummySpan
 fun capitalize "" = ""
   | capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
 
+fun makeAttr s =
+    case s of
+        "type" => "Typ"
+      | "name" => "Nam"
+      | _ => capitalize (String.translate (fn ch => if ch = #"-" then "_" else str ch) s)
+
 fun entable t =
     case #1 t of
         TRecord c => c
@@ -1648,10 +1654,7 @@ attr   : SYMBOL EQ attrv                (case SYMBOL of
 					   | "dynStyle" => DynStyle attrv
 					   | _ =>
                                              let
-                                                 val sym =
-                                                     case SYMBOL of
-                                                         "type" => "Typ"
-                                                       | x => capitalize x
+                                                 val sym = makeAttr SYMBOL
                                              in
                                                  Normal ((CName sym, s (SYMBOLleft, SYMBOLright)),
                                                          if (sym = "Href" orelse sym = "Src")
diff --git a/src/urweb.lex b/src/urweb.lex
index 0994ecec..293c6dc6 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -177,6 +177,7 @@ fun unescape loc s =
 %s COMMENT STRING CHAR XML XMLTAG;
 
 id = [a-z_][A-Za-z0-9_']*;
+xmlid = [A-Za-z][A-Za-z0-9-_]*;
 cid = [A-Z][A-Za-z0-9_]*;
 ws = [\ \t\012\r];
 intconst = [0-9]+;
@@ -313,7 +314,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 
 <XMLTAG> {ws}+        => (lex ());
 
-<XMLTAG> {id}         => (Tokens.SYMBOL (yytext, yypos, yypos + size yytext));
+<XMLTAG> {xmlid}      => (Tokens.SYMBOL (yytext, yypos, yypos + size yytext));
 <XMLTAG> "="          => (Tokens.EQ (yypos, yypos + size yytext));
 
 <XMLTAG> {intconst}   => (case Int64.fromString yytext of
diff --git a/tests/attrMangle.ur b/tests/attrMangle.ur
new file mode 100644
index 00000000..6efb0513
--- /dev/null
+++ b/tests/attrMangle.ur
@@ -0,0 +1,5 @@
+open Goofy
+
+fun main () : transaction page = return <xml><body>
+  <goofy name="beppo" data-role="excellence"/>
+</body></xml>
diff --git a/tests/attrMangle.urp b/tests/attrMangle.urp
new file mode 100644
index 00000000..5059998b
--- /dev/null
+++ b/tests/attrMangle.urp
@@ -0,0 +1,4 @@
+ffi goofy
+rewrite all AttrMangle/*
+
+attrMangle
diff --git a/tests/goofy.urs b/tests/goofy.urs
new file mode 100644
index 00000000..71b55f42
--- /dev/null
+++ b/tests/goofy.urs
@@ -0,0 +1 @@
+val goofy : bodyTag [Nam = string, Data_role = string]
-- 
cgit v1.2.3


From 0c83e8f7c345a27be3cae77eeb2d7cb8658e5e9c Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Fri, 2 May 2014 19:19:09 -0400
Subject: New lessSafeFfi

---
 doc/manual.tex          | 18 ++++++++++++
 src/compiler.sml        |  1 +
 src/corify.sml          | 75 ++++++++++++++++++++++++++++++++++++++++++++-----
 src/elab.sml            |  3 +-
 src/elab_env.sml        |  1 +
 src/elab_print.sml      |  1 +
 src/elab_util.sml       |  8 +++++-
 src/elaborate.sml       | 15 ++++++++++
 src/elisp/urweb-mode.el |  2 +-
 src/expl.sml            |  1 +
 src/expl_env.sml        |  1 +
 src/expl_print.sml      |  1 +
 src/expl_rename.sml     | 10 +++++++
 src/explify.sml         |  1 +
 src/settings.sig        |  7 +++++
 src/settings.sml        |  8 ++++++
 src/source.sml          |  8 ++++++
 src/source_print.sml    |  1 +
 src/unnest.sml          |  1 +
 src/urweb.grm           | 21 ++++++++++++--
 src/urweb.lex           |  1 +
 tests/lessSafeFfi.ur    | 19 +++++++++++++
 tests/lessSafeFfi.urp   |  5 ++++
 tests/lessSafeFfi.urs   |  1 +
 24 files changed, 198 insertions(+), 12 deletions(-)
 create mode 100644 tests/lessSafeFfi.ur
 create mode 100644 tests/lessSafeFfi.urp
 create mode 100644 tests/lessSafeFfi.urs

(limited to 'src/urweb.lex')

diff --git a/doc/manual.tex b/doc/manual.tex
index db4994a5..b233473e 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -2530,6 +2530,24 @@ FFI modules may introduce new tags as values with $\mt{Basis.tag}$ types.  See \
 
 The onus is on the coder of a new tag's interface to think about consequences for code injection attacks, messing with the DOM in ways that may break Ur/Web reactive programming, etc.
 
+\subsection{The Less Safe FFI}
+
+An alternative interface is provided for declaring FFI functions inline within normal Ur/Web modules.  This facility must be opted into with the \texttt{lessSafeFfi} \texttt{.urp} directive, since it breaks a crucial property, allowing code in a \texttt{.ur} file to break basic invariants of the Ur/Web type system.  Without this option, one only needs to audit \texttt{.urp} files to be sure an application obeys the type-system rules.  The alternative interface may be more convenient for such purposes as declaring an FFI function typed in terms of some type local to a module.
+
+When the less safe mode is enabled, declarations like this one are accepted, at the top level of a \texttt{.ur} file:
+\begin{verbatim}
+  ffi foo : int -> int
+\end{verbatim}
+
+Now \texttt{foo} is available as a normal function.  If called in server-side code, and if the above declaration appeared in \texttt{bar.ur}, the C function will be linked as \texttt{uw\_Bar\_foo()}.  It is also possible to declare an FFI function to be implemented in JavaScript, using a general facility for including modifiers in an FFI declaration.  The modifiers appear before the colon, separated by spaces.  Here are the available ones, which have the same semantics as corresponding \texttt{.urp} directives.
+\begin{itemize}
+\item \texttt{effectful}
+\item \texttt{benignEffectful}
+\item \texttt{clientOnly}
+\item \texttt{serverOnly}
+\item \texttt{jsFunc "putJsFuncNameHere"}
+\end{itemize}
+
 
 \section{Compiler Phases}
 
diff --git a/src/compiler.sml b/src/compiler.sml
index cc4e33c5..269a7824 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -874,6 +874,7 @@ fun parseUrp' accLibs fname =
                                    | "timeFormat" => Settings.setTimeFormat arg
                                    | "noMangleSql" => Settings.setMangleSql false
                                    | "html5" => Settings.setIsHtml5 true
+                                   | "lessSafeFfi" => Settings.setLessSafeFfi true
 
                                    | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
                                  read ()
diff --git a/src/corify.sml b/src/corify.sml
index 085b2eb8..b08ef7eb 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -643,6 +643,12 @@ fun corifyExp st (e, loc) =
 
       | L.ELet (x, t, e1, e2) => (L'.ELet (x, corifyCon st t, corifyExp st e1, corifyExp st e2), loc)
 
+fun isTransactional (c, _) =
+    case c of
+        L'.TFun (_, c) => isTransactional c
+      | L'.CApp ((L'.CFfi ("Basis", "transaction"), _), _) => true
+      | _ => false
+
 fun corifyDecl mods (all as (d, loc : EM.span), st) =
     case d of
         L.DCon (x, n, k, c) =>
@@ -970,12 +976,6 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
                                                in
                                                    transactify c
                                                end
-
-                                       fun isTransactional (c, _) =
-                                           case c of
-                                               L'.TFun (_, c) => isTransactional c
-                                             | L'.CApp ((L'.CFfi ("Basis", "transaction"), _), _) => true
-                                             | _ => false
                                    in
                                        if isTransactional c then
                                            let
@@ -1164,6 +1164,66 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
                       ([], st))
         end
 
+      | L.DFfi (x, n, modes, t) =>
+        let
+            val m = case St.name st of
+                        [m] => m
+                      | _ => (ErrorMsg.errorAt loc "Used 'ffi' declaration beneath module top level";
+                              "")
+
+            val name = (m, x)
+
+            val (st, n) = St.bindVal st x n
+            val s = doRestify Settings.Url (mods, x)
+
+            val t' = corifyCon st t
+
+            fun numArgs (t : L'.con) =
+                case #1 t of
+                    L'.TFun (_, ran) => 1 + numArgs ran
+                  | _ => 0
+
+            fun makeArgs (i, t : L'.con, acc) =
+                case #1 t of
+                    L'.TFun (dom, ran) => makeArgs (i-1, ran, ((L'.ERel i, loc), dom) :: acc)
+                  | _ => rev acc
+
+            fun wrapAbs (i, t : L'.con, tTrans, e) =
+                case (#1 t, #1 tTrans) of
+                    (L'.TFun (dom, ran), L'.TFun (_, ran')) => (L'.EAbs ("x" ^ Int.toString i, dom, ran, wrapAbs (i+1, ran, ran', e)), loc)
+                  | _ => e
+
+            fun getRan (t : L'.con) =
+                case #1 t of
+                    L'.TFun (_, ran) => getRan ran
+                  | _ => t
+
+            fun addLastBit (t : L'.con) =
+                case #1 t of
+                    L'.TFun (dom, ran) => (L'.TFun (dom, addLastBit ran), #2 t)
+                  | _ => (L'.TFun ((L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc), t), loc)
+
+            val e = (L'.EFfiApp (m, x, makeArgs (numArgs t' - 1, t', [])), loc)
+            val (e, tTrans) = if isTransactional t' then
+                                  ((L'.EAbs ("_", (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc), getRan t', e), loc), addLastBit t')
+                              else
+                                  (e, t')
+            val e = wrapAbs (0, t', tTrans, e)
+        in
+            app (fn Source.Effectful => Settings.addEffectful name
+                  | Source.BenignEffectful => Settings.addBenignEffectful name
+                  | Source.ClientOnly => Settings.addClientOnly name
+                  | Source.ServerOnly => Settings.addServerOnly name
+                  | Source.JsFunc s => Settings.addJsFunc (name, s)) modes;
+
+            if isTransactional t' andalso not (Settings.isBenignEffectful name) then
+                Settings.addEffectful name
+            else
+                ();
+
+            ([(L'.DVal (x, n, t', e, s), loc)], st)
+        end
+
 and corifyStr mods ((str, loc), st) =
     case str of
         L.StrConst ds =>
@@ -1237,7 +1297,8 @@ fun maxName ds = foldl (fn ((d, _), n) =>
                              | L.DStyle (_, _, n') => Int.max (n, n')
                              | L.DTask _ => n
                              | L.DPolicy _ => n
-                             | L.DOnError _ => n)
+                             | L.DOnError _ => n
+                             | L.DFfi (_, n', _, _) => Int.max (n, n'))
                        0 ds
 
 and maxNameStr (str, _) =
diff --git a/src/elab.sml b/src/elab.sml
index 2dab5c34..249531f1 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2011, Adam Chlipala
+(* Copyright (c) 2008-2011, 2014, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
@@ -181,6 +181,7 @@ datatype decl' =
        | DTask of exp * exp
        | DPolicy of exp
        | DOnError of int * string list * string
+       | DFfi of string * int * Source.ffi_mode list * con
 
      and str' =
          StrConst of decl list
diff --git a/src/elab_env.sml b/src/elab_env.sml
index 465fb7e4..9fbe7bd7 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -1681,5 +1681,6 @@ fun declBinds env (d, loc) =
       | DTask _ => env
       | DPolicy _ => env
       | DOnError _ => env
+      | DFfi (x, n, _, t) => pushENamedAs env x n t
 
 end
diff --git a/src/elab_print.sml b/src/elab_print.sml
index 7ce94c97..957d4646 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -852,6 +852,7 @@ fun p_decl env (dAll as (d, _) : decl) =
                            space,
                            p_exp env e1]
       | DOnError _ => string "ONERROR"
+      | DFfi _ => string "FFI"
 
 and p_str env (str, _) =
     case str of
diff --git a/src/elab_util.sml b/src/elab_util.sml
index 60245585..fef55852 100644
--- a/src/elab_util.sml
+++ b/src/elab_util.sml
@@ -927,7 +927,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
                                                    bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc)))
                                                  | DTask _ => ctx
                                                  | DPolicy _ => ctx
-                                                 | DOnError _ => ctx,
+                                                 | DOnError _ => ctx
+                                                 | DFfi (x, _, _, t) => bind (ctx, NamedE (x, t)),
                                                mfd ctx d)) ctx ds,
                      fn ds' => (StrConst ds', loc))
               | StrVar _ => S.return2 strAll
@@ -1056,6 +1057,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f
                      fn e1' =>
                         (DPolicy e1', loc))
               | DOnError _ => S.return2 dAll
+              | DFfi (x, n, modes, t) =>
+                S.map2 (mfc ctx t,
+                        fn t' =>
+                           (DFfi (x, n, modes, t'), loc))
 
         and mfvi ctx (x, n, c, e) =
             S.bind2 (mfc ctx c,
@@ -1234,6 +1239,7 @@ and maxNameDecl (d, _) =
       | DTask _ => 0
       | DPolicy _ => 0
       | DOnError _ => 0
+      | DFfi (_, n, _, _) => n
 and maxNameStr (str, _) =
     case str of
         StrConst ds => maxName ds
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 97ac610b..d492883f 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -2999,6 +2999,7 @@ and sgiOfDecl (d, loc) =
       | L'.DTask _ => []
       | L'.DPolicy _ => []
       | L'.DOnError _ => []
+      | L'.DFfi (x, n, _, t) => [(L'.SgiVal (x, n, t), loc)]
 
 and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) =
     ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1),
@@ -4298,6 +4299,20 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
                          ([(L'.DOnError (n, ms, s), loc)], (env, denv, gs))
                      end)
 
+              | L.DFfi (x, modes, t) =>
+                let
+                    val () = if Settings.getLessSafeFfi () then
+                                 ()
+                             else
+                                 ErrorMsg.errorAt loc "To enable 'ffi' declarations, the .urp directive 'lessSafeFfi' is mandatory."
+
+                    val (t', _, gs1) = elabCon (env, denv) t
+                    val t' = normClassConstraint env t'
+                    val (env', n) = E.pushENamed env x t'
+                in
+                    ([(L'.DFfi (x, n, modes, t'), loc)], (env', denv, enD gs1 @ gs))
+                end
+
         (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*)
     in
         (*prefaces "/elabDecl" [("d", SourcePrint.p_decl dAll),
diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el
index f183a9ab..edbff1b0 100644
--- a/src/elisp/urweb-mode.el
+++ b/src/elisp/urweb-mode.el
@@ -139,7 +139,7 @@ See doc for the variable `urweb-mode-info'."
 	       "of" "open" "let" "in"
 	       "rec" "sequence" "sig" "signature" "cookie" "style" "task" "policy"
 	       "struct" "structure" "table" "view" "then" "type" "val" "where"
-	       "with"
+	       "with" "ffi"
 
                "Name" "Type" "Unit")
   "A regexp that matches any non-SQL keywords of Ur/Web.")
diff --git a/src/expl.sml b/src/expl.sml
index 0d4e63cc..3d784e3f 100644
--- a/src/expl.sml
+++ b/src/expl.sml
@@ -150,6 +150,7 @@ datatype decl' =
        | DTask of exp * exp
        | DPolicy of exp
        | DOnError of int * string list * string
+       | DFfi of string * int * Source.ffi_mode list * con
 
      and str' =
          StrConst of decl list
diff --git a/src/expl_env.sml b/src/expl_env.sml
index f5a5eb0a..5712a72d 100644
--- a/src/expl_env.sml
+++ b/src/expl_env.sml
@@ -346,6 +346,7 @@ fun declBinds env (d, loc) =
       | DTask _ => env
       | DPolicy _ => env
       | DOnError _ => env
+      | DFfi (x, n, _, t) => pushENamed env x n t
 
 fun sgiBinds env (sgi, loc) =
     case sgi of
diff --git a/src/expl_print.sml b/src/expl_print.sml
index a830dccb..22d246e2 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -731,6 +731,7 @@ fun p_decl env (dAll as (d, _) : decl) =
                            space,
                            p_exp env e1]
       | DOnError _ => string "ONERROR"
+      | DFfi _ => string "FFI"
 
 and p_str env (str, _) =
     case str of
diff --git a/src/expl_rename.sml b/src/expl_rename.sml
index 7e7a155a..bb763a60 100644
--- a/src/expl_rename.sml
+++ b/src/expl_rename.sml
@@ -219,6 +219,7 @@ fun renameDecl st (all as (d, loc)) =
         (case St.lookup (st, n) of
              NONE => all
            | SOME n' => (DOnError (n', xs, x), loc))
+      | DFfi (x, n, modes, t) => (DFfi (x, n, modes, renameCon st t), loc)
 
 and renameStr st (all as (str, loc)) =
     case str of
@@ -413,6 +414,15 @@ fun dupDecl (all as (d, loc), st) =
         (case St.lookup (st, n) of
              NONE => ([all], st)
            | SOME n' => ([(DOnError (n', xs, x), loc)], st))
+      | DFfi (x, n, modes, t) =>
+        let
+            val (st, n') = St.bind (st, n)
+            val t' = renameCon st t
+        in
+            ([(DFfi (x, n, modes, t'), loc),
+              (DVal (x, n', t', (ENamed n, loc)), loc)],
+             st)
+        end
 
 fun rename {NextId, FormalName, FormalId, Body = all as (str, loc)} =
     case str of
diff --git a/src/explify.sml b/src/explify.sml
index 4c60bd20..fd0f3277 100644
--- a/src/explify.sml
+++ b/src/explify.sml
@@ -198,6 +198,7 @@ fun explifyDecl (d, loc : EM.span) =
       | L.DTask (e1, e2) => SOME (L'.DTask (explifyExp e1, explifyExp e2), loc)
       | L.DPolicy e1 => SOME (L'.DPolicy (explifyExp e1), loc)
       | L.DOnError v => SOME (L'.DOnError v, loc)
+      | L.DFfi (x, n, modes, t) => SOME (L'.DFfi (x, n, modes, explifyCon t), loc)
 
 and explifyStr (str, loc) =
     case str of
diff --git a/src/settings.sig b/src/settings.sig
index 20dd00c2..29c4c506 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -78,18 +78,22 @@ signature SETTINGS = sig
 
     (* Which FFI functions should not have their calls removed or reordered, but cause no lasting effects? *)
     val setBenignEffectful : ffi list -> unit
+    val addBenignEffectful : ffi -> unit
     val isBenignEffectful : ffi -> bool
 
     (* Which FFI functions may only be run in clients? *)
     val setClientOnly : ffi list -> unit
+    val addClientOnly : ffi -> unit
     val isClientOnly : ffi -> bool
 
     (* Which FFI functions may only be run on servers? *)
     val setServerOnly : ffi list -> unit
+    val addServerOnly : ffi -> unit
     val isServerOnly : ffi -> bool
 
     (* Which FFI functions may be run in JavaScript?  (JavaScript function names included) *)
     val setJsFuncs : (ffi * string) list -> unit
+    val addJsFunc : ffi * string -> unit
     val jsFunc : ffi -> string option
     val allJsFuncs : unit -> (ffi * string) list
 
@@ -271,4 +275,7 @@ signature SETTINGS = sig
 
     val setIsHtml5 : bool -> unit
     val getIsHtml5 : unit -> bool
+
+    val setLessSafeFfi : bool -> unit
+    val getLessSafeFfi : unit -> bool
 end
diff --git a/src/settings.sml b/src/settings.sml
index 4cdb4119..f00a4853 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -194,6 +194,7 @@ val benignBase = basis ["get_cookie",
 
 val benign = ref benignBase
 fun setBenignEffectful ls = benign := S.addList (benignBase, ls)
+fun addBenignEffectful x = benign := S.add (!benign, x)
 fun isBenignEffectful x = S.member (!benign, x)
 
 val clientBase = basis ["get_client_source",
@@ -225,6 +226,7 @@ val clientBase = basis ["get_client_source",
                         "giveFocus"]
 val client = ref clientBase
 fun setClientOnly ls = client := S.addList (clientBase, ls)
+fun addClientOnly x = client := S.add (!client, x)
 fun isClientOnly x = S.member (!client, x)
 
 val serverBase = basis ["requestHeader",
@@ -240,6 +242,7 @@ val serverBase = basis ["requestHeader",
                         "firstFormField"]
 val server = ref serverBase
 fun setServerOnly ls = server := S.addList (serverBase, ls)
+fun addServerOnly x = server := S.add (!server, x)
 fun isServerOnly x = S.member (!server, x)
 
 val basisM = foldl (fn ((k, v : string), m) => M.insert (m, ("Basis", k), v)) M.empty
@@ -364,6 +367,7 @@ val jsFuncsBase = basisM [("alert", "alert"),
 val jsFuncs = ref jsFuncsBase
 fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
 fun jsFunc x = M.find (!jsFuncs, x)
+fun addJsFunc (k, v) = jsFuncs := M.insert (!jsFuncs, k, v)
 fun allJsFuncs () = M.listItemsi (!jsFuncs)
 
 datatype pattern_kind = Exact | Prefix
@@ -735,4 +739,8 @@ val html5 = ref false
 fun setIsHtml5 b = html5 := b
 fun getIsHtml5 () = !html5
 
+val less = ref false
+fun setLessSafeFfi b = less := b
+fun getLessSafeFfi () = !less
+
 end
diff --git a/src/source.sml b/src/source.sml
index eea7ad4c..2a741dd9 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -147,6 +147,13 @@ and pat = pat' located
 and exp = exp' located
 and edecl = edecl' located
 
+datatype ffi_mode =
+         Effectful
+       | BenignEffectful
+       | ClientOnly
+       | ServerOnly
+       | JsFunc of string
+
 datatype decl' =
          DCon of string * kind option * con
        | DDatatype of (string * string list * (string * con option) list) list
@@ -169,6 +176,7 @@ datatype decl' =
        | DTask of exp * exp
        | DPolicy of exp
        | DOnError of string * string list * string
+       | DFfi of string * ffi_mode list * con
 
      and str' =
          StrConst of decl list
diff --git a/src/source_print.sml b/src/source_print.sml
index fdacfe6c..db56a0db 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -674,6 +674,7 @@ fun p_decl ((d, _) : decl) =
                            space,
                            p_exp e1]
       | DOnError _ => string "ONERROR"
+      | DFfi _ => string "FFI"
 
 and p_str (str, _) =
     case str of
diff --git a/src/unnest.sml b/src/unnest.sml
index 17bfd39f..fceb5026 100644
--- a/src/unnest.sml
+++ b/src/unnest.sml
@@ -452,6 +452,7 @@ fun unnest file =
                   | DTask _ => explore ()
                   | DPolicy _ => explore ()
                   | DOnError _ => default ()
+                  | DFfi _ => default ()
             end
 
         and doStr (all as (str, loc), st) =
diff --git a/src/urweb.grm b/src/urweb.grm
index 7aec9492..157ecfac 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2012, Adam Chlipala
+(* Copyright (c) 2008-2014, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
@@ -365,7 +365,7 @@ fun patternOut (e : exp) =
  | LPAREN | RPAREN | LBRACK | RBRACK | LBRACE | RBRACE
  | EQ | COMMA | COLON | DCOLON | DCOLONWILD | TCOLON | TCOLONWILD | DOT | HASH | UNDER | UNDERUNDER | BAR
  | PLUS | MINUS | DIVIDE | DOTDOTDOT | MOD | AT
- | CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS
+ | CON | LTYPE | VAL | REC | AND | FUN | MAP | UNIT | KUNIT | CLASS | FFI
  | DATATYPE | OF
  | TYPE | NAME
  | ARROW | LARROW | DARROW | STAR | SEMI | KARROW | DKARROW | BANG
@@ -532,6 +532,9 @@ fun patternOut (e : exp) =
  | enterDml of unit
  | leaveDml of unit
 
+ | ffi_mode of ffi_mode
+ | ffi_modes of ffi_mode list
+
 
 %verbose                                (* print summary of errors *)
 %pos int                                (* positions *)
@@ -645,6 +648,7 @@ decl   : CON SYMBOL cargl2 kopt EQ cexp (let
        | STYLE SYMBOL                   ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))])
        | TASK eapps EQ eexp             ([(DTask (eapps, eexp), s (TASKleft, eexpright))])
        | POLICY eexp                    ([(DPolicy eexp, s (POLICYleft, eexpright))])
+       | FFI SYMBOL ffi_modes COLON cexp([(DFfi (SYMBOL, ffi_modes, cexp), s (FFIleft, cexpright))])
 
 dtype  : SYMBOL dargs EQ barOpt dcons   (SYMBOL, dargs, dcons)
 
@@ -2267,3 +2271,16 @@ sqlagg : AVG                             ("avg")
        | SUM                             ("sum")
        | MIN                             ("min")
        | MAX                             ("max")
+
+ffi_mode : SYMBOL                        (case SYMBOL of
+                                              "effectful" => Effectful
+                                            | "benignEffectful" => BenignEffectful
+                                            | "clientOnly" => ClientOnly
+                                            | "serverOnly" => ServerOnly
+                                            | _ => (ErrorMsg.errorAt (s (SYMBOLleft, SYMBOLright)) "Invalid FFI mode"; Effectful))
+         | SYMBOL STRING                 (case SYMBOL of
+                                              "jsFunc" => JsFunc STRING
+                                            | _ => (ErrorMsg.errorAt (s (SYMBOLleft, SYMBOLright)) "Invalid FFI mode"; Effectful))
+
+ffi_modes :                              ([])
+          | ffi_mode ffi_modes           (ffi_mode :: ffi_modes)
diff --git a/src/urweb.lex b/src/urweb.lex
index 293c6dc6..15ae448e 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -445,6 +445,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 <INITIAL> "style"     => (Tokens.STYLE (pos yypos, pos yypos + size yytext));
 <INITIAL> "task"      => (Tokens.TASK (pos yypos, pos yypos + size yytext));
 <INITIAL> "policy"    => (Tokens.POLICY (pos yypos, pos yypos + size yytext));
+<INITIAL> "ffi"       => (Tokens.FFI (pos yypos, pos yypos + size yytext));
 
 <INITIAL> "Type"      => (Tokens.TYPE (pos yypos, pos yypos + size yytext));
 <INITIAL> "Name"      => (Tokens.NAME (pos yypos, pos yypos + size yytext));
diff --git a/tests/lessSafeFfi.ur b/tests/lessSafeFfi.ur
new file mode 100644
index 00000000..da79bfdc
--- /dev/null
+++ b/tests/lessSafeFfi.ur
@@ -0,0 +1,19 @@
+ffi foo : int -> int
+ffi bar serverOnly benignEffectful : int -> transaction unit
+ffi baz : transaction int
+
+ffi bup jsFunc "jsbup" : int -> transaction unit
+
+fun other () : transaction page =
+    (*bar 17;
+    q <- baz;*)
+    return <xml><body>
+      (*{[foo 42]}, {[q]}*)
+      <button onclick={fn _ => bup 32}/>
+    </body></xml>
+
+fun main () = return <xml><body>
+  <form>
+    <submit action={other}/>
+  </form>
+</body></xml>
diff --git a/tests/lessSafeFfi.urp b/tests/lessSafeFfi.urp
new file mode 100644
index 00000000..729c5272
--- /dev/null
+++ b/tests/lessSafeFfi.urp
@@ -0,0 +1,5 @@
+rewrite all LessSafeFfi/*
+debug
+lessSafeFfi
+
+lessSafeFfi
diff --git a/tests/lessSafeFfi.urs b/tests/lessSafeFfi.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/lessSafeFfi.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page
-- 
cgit v1.2.3


From b2b29ea1e208836b21842ce2126fb9fd8521247e Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Tue, 25 Nov 2014 08:21:09 -0500
Subject: Tiny lexer change for SML/NJ compatibility (suggested by Ziv Scully)

---
 src/urweb.lex | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'src/urweb.lex')

diff --git a/src/urweb.lex b/src/urweb.lex
index 0d316ed2..195fd735 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -177,7 +177,7 @@ fun unescape loc s =
 %s COMMENT STRING CHAR XML XMLTAG;
 
 id = [a-z_][A-Za-z0-9_']*;
-xmlid = [A-Za-z][A-Za-z0-9-_]*;
+xmlid = [A-Za-z][A-Za-z0-9_-]*;
 cid = [A-Z][A-Za-z0-9_]*;
 ws = [\ \t\012\r];
 intconst = [0-9]+;
-- 
cgit v1.2.3


From 86df1742d90c9ae13843188c0772554ed2eaa666 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Sun, 16 Nov 2014 14:39:38 -0500
Subject: Some more HTML5 input types

---
 lib/ur/basis.urs     | 11 +++++++++++
 src/monoize.sml      |  9 +++++++++
 src/urweb.grm        |  1 +
 src/urweb.lex        |  8 ++++----
 tests/html5_forms.ur | 21 +++++++++++++++++++++
 5 files changed, 46 insertions(+), 4 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 7691cdce..9fb04484 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -969,6 +969,17 @@ val email : textWidget
 val search : textWidget
 val url_ : textWidget
 val tel : textWidget
+val color : textWidget
+
+val number : formTag float [] ([Value = float, Min = float, Max = float, Step = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs)
+val range : formTag float [] ([Value = float, Min = float, Max = float, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs)
+val date : formTag string [] ([Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs)
+val datetime : formTag string [] ([Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs)
+val datetime_local : formTag string [] ([Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs)
+val month : formTag string [] ([Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs)
+val week : formTag string [] ([Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs)
+val timeInput : formTag string [] ([Value = string, Min = string, Max = string, Size = int, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs)
+
 
 
 type file
diff --git a/src/monoize.sml b/src/monoize.sml
index 96323c9e..9ca21058 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3667,6 +3667,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                       | "search" => input "search"
                       | "url_" => input "url"
                       | "tel" => input "tel"
+                      | "color" => input "color"
+                      | "number" => input "number"
+                      | "range" => input "range"
+                      | "date" => input "date"
+                      | "datetime" => input "datetime"
+                      | "datetime_local" => input "datetime-local"
+                      | "month" => input "month"
+                      | "week" => input "week"
+                      | "timeInput" => input "time"
                       | "textarea" =>
 			(case targs of
                              [_, (L.CName name, _)] =>
diff --git a/src/urweb.grm b/src/urweb.grm
index 85e5f092..5b568a8c 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -222,6 +222,7 @@ fun tagIn bt =
     case bt of
         "table" => "tabl"
       | "url" => "url_"
+      | "datetime-local" => "datetime_local"
       | _ => bt
 
 datatype prop_kind = Delete | Update
diff --git a/src/urweb.lex b/src/urweb.lex
index 15ae448e..0d316ed2 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -277,19 +277,19 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
                                    continue ())
                           end);
 
-<INITIAL> "<" {id} "/>"=>(let
+<INITIAL> "<" {xmlid} "/>"=>(let
 			      val tag = String.substring (yytext, 1, size yytext - 3)
 			  in
 			      Tokens.XML_BEGIN_END (tag, yypos, yypos + size yytext)
 			  end);
-<INITIAL> "<" {id} ">"=> (let
+<INITIAL> "<" {xmlid} ">"=> (let
 			      val tag = String.substring (yytext, 1, size yytext - 2)
 			  in
 			      YYBEGIN XML;
 			      xmlTag := tag :: (!xmlTag);
 			      Tokens.XML_BEGIN (tag, yypos, yypos + size yytext)
 			  end);
-<XML> "</" {id} ">"   => (let
+<XML> "</" {xmlid} ">" => (let
 			      val id = String.substring (yytext, 2, size yytext - 3)
 			  in
 			      case !xmlTag of
@@ -304,7 +304,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 			          Tokens.END_TAG (id, yypos, yypos + size yytext)
 			  end);
 
-<XML> "<" {id}        => (YYBEGIN XMLTAG;
+<XML> "<" {xmlid}     => (YYBEGIN XMLTAG;
 			  Tokens.BEGIN_TAG (String.extract (yytext, 1, NONE),
 					    yypos, yypos + size yytext));
 
diff --git a/tests/html5_forms.ur b/tests/html5_forms.ur
index a9bf7f77..507ea3cf 100644
--- a/tests/html5_forms.ur
+++ b/tests/html5_forms.ur
@@ -6,6 +6,15 @@ fun handler r = return <xml><body>
   E: {[r.E]}<br/>
   F: {[r.F]}<br/>
   G: {[r.G]}<br/>
+  H: {[r.H]}<br/>
+  I: {[r.I]}<br/>
+  J: {[r.J]}<br/>
+  K: {[r.K]}<br/>
+  L: {[r.L]}<br/>
+  M: {[r.M]}<br/>
+  N: {[r.N]}<br/>
+  O: {[r.O]}<br/>
+  P: {[r.P]}<br/>
 </body></xml>
 
 fun main () =
@@ -19,6 +28,18 @@ fun main () =
         <tel{#F}/>
         <search{#G}/>
 
+        <hr/>
+
+        <color{#H}/>
+        <number{#I} min={17.0} max={32.8} value={20.6} step={2.5}/>
+        <range{#J} min={17.0} max={32.8} value={20.6}/>
+        <date{#K}/>
+        <datetime{#L}/>
+        <datetime-local{#M}/>
+        <month{#N}/>
+        <week{#O}/>
+        <timeInput{#P}/>
+
         <submit action={handler}/>
       </form>
     </body></xml>
-- 
cgit v1.2.3


From 476f12674420391e24afd1846e176eabe550d36c Mon Sep 17 00:00:00 2001
From: Ziv Scully <ziv@mit.edu>
Date: Sat, 29 Nov 2014 03:37:59 -0500
Subject: Basic field-resolution invalidation.

---
 caching-tests/test.db  | Bin 5120 -> 0 bytes
 caching-tests/test.sql |  16 ----
 caching-tests/test.ur  |  66 ++++++++--------
 caching-tests/test.urs |   8 +-
 src/cjr_print.sml      |  28 +++++--
 src/cjrize.sml         |  10 +--
 src/iflow.sml          |  10 ++-
 src/jscomp.sml         |  19 ++---
 src/mono.sml           |   7 +-
 src/mono_opt.sml       |  25 +++---
 src/mono_print.sml     |   8 +-
 src/mono_util.sml      |  23 +++---
 src/monoize.sig        |   2 +
 src/monoize.sml        |  38 +++++----
 src/sqlcache.sml       | 211 +++++++++++++++++++++++++++----------------------
 src/urweb.lex          |  14 ++--
 16 files changed, 266 insertions(+), 219 deletions(-)
 delete mode 100644 caching-tests/test.db
 delete mode 100644 caching-tests/test.sql

(limited to 'src/urweb.lex')

diff --git a/caching-tests/test.db b/caching-tests/test.db
deleted file mode 100644
index a4661341..00000000
Binary files a/caching-tests/test.db and /dev/null differ
diff --git a/caching-tests/test.sql b/caching-tests/test.sql
deleted file mode 100644
index 7ade7278..00000000
--- a/caching-tests/test.sql
+++ /dev/null
@@ -1,16 +0,0 @@
-CREATE TABLE uw_Test_foo01(uw_id int8 NOT NULL, uw_bar text NOT NULL,
- PRIMARY KEY (uw_id)
-  
- );
- 
- CREATE TABLE uw_Test_foo10(uw_id int8 NOT NULL, uw_bar text NOT NULL,
-  PRIMARY KEY (uw_id)
-   
-  );
-  
-  CREATE TABLE uw_Test_tab(uw_id int8 NOT NULL, uw_val int8 NOT NULL,
-   PRIMARY KEY (uw_id)
-    
-   );
-   
-   
\ No newline at end of file
diff --git a/caching-tests/test.ur b/caching-tests/test.ur
index 931612bc..2722bcdc 100644
--- a/caching-tests/test.ur
+++ b/caching-tests/test.ur
@@ -11,26 +11,26 @@ fun cache01 () =
          | Some row => <xml>{[row.Foo01.Bar]}</xml>}
     </body></xml>
 
-fun cache10 () =
-    res <- queryX (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42)
-                  (fn row => <xml>{[row.Foo10.Bar]}</xml>);
-    return <xml><body>
-      Reading 2.
-      {res}
-    </body></xml>
+(* fun cache10 () = *)
+(*     res <- queryX (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42) *)
+(*                   (fn row => <xml>{[row.Foo10.Bar]}</xml>); *)
+(*     return <xml><body> *)
+(*       Reading 2. *)
+(*       {res} *)
+(*     </body></xml> *)
 
-fun cache11 () =
-    res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42);
-    bla <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42);
-    return <xml><body>
-      Reading 1 and 2.
-      {case res of
-           None => <xml>?</xml>
-         | Some row => <xml>{[row.Foo01.Bar]}</xml>}
-      {case bla of
-           None => <xml>?</xml>
-         | Some row => <xml>{[row.Foo10.Bar]}</xml>}
-    </body></xml>
+(* fun cache11 () = *)
+(*     res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42); *)
+(*     bla <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42); *)
+(*     return <xml><body> *)
+(*       Reading 1 and 2. *)
+(*       {case res of *)
+(*            None => <xml>?</xml> *)
+(*          | Some row => <xml>{[row.Foo01.Bar]}</xml>} *)
+(*       {case bla of *)
+(*            None => <xml>?</xml> *)
+(*          | Some row => <xml>{[row.Foo10.Bar]}</xml>} *)
+(*     </body></xml> *)
 
 fun flush01 () =
     dml (INSERT INTO foo01 (Id, Bar) VALUES (42, "baz01"));
@@ -39,18 +39,18 @@ fun flush01 () =
       Flushed 1!
     </body></xml>
 
-fun flush10 () =
-    dml (UPDATE foo10 SET Bar = "baz10" WHERE Id = 42);
-    return <xml><body>
-      Flushed 2!
-    </body></xml>
+(* fun flush10 () = *)
+(*     dml (UPDATE foo10 SET Bar = "baz10" WHERE Id = 42); *)
+(*     return <xml><body> *)
+(*       Flushed 2! *)
+(*     </body></xml> *)
 
-fun flush11 () =
-    dml (UPDATE foo01 SET Bar = "baz11" WHERE Id = 42);
-    dml (UPDATE foo10 SET Bar = "baz11" WHERE Id = 42);
-    return <xml><body>
-      Flushed 1 and 2!
-    </body></xml>
+(* fun flush11 () = *)
+(*     dml (UPDATE foo01 SET Bar = "baz11" WHERE Id = 42); *)
+(*     dml (UPDATE foo10 SET Bar = "baz11" WHERE Id = 42); *)
+(*     return <xml><body> *)
+(*       Flushed 1 and 2! *)
+(*     </body></xml> *)
 
 fun cache id =
     res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]});
@@ -63,9 +63,9 @@ fun cache id =
 
 fun flush id =
     res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]});
-    dml (case res of
-             None => (INSERT INTO tab (Id, Val) VALUES ({[id]}, 0))
-           | Some row => (UPDATE tab SET Val = {[row.Tab.Val + 1]} WHERE Id = {[id]}));
+    (case res of
+         None => dml (INSERT INTO tab (Id, Val) VALUES ({[id]}, 0))
+       | Some row => dml (UPDATE tab SET Val = {[row.Tab.Val + 1]} WHERE Id = {[id]}));
     return <xml><body>
       (* Flushed {[id]}! *)
       {case res of
diff --git a/caching-tests/test.urs b/caching-tests/test.urs
index ace4ba28..30bff733 100644
--- a/caching-tests/test.urs
+++ b/caching-tests/test.urs
@@ -1,8 +1,8 @@
 val cache01 : unit -> transaction page
-val cache10 : unit -> transaction page
-val cache11 : unit -> transaction page
+(* val cache10 : unit -> transaction page *)
+(* val cache11 : unit -> transaction page *)
 val flush01 : unit -> transaction page
-val flush10 : unit -> transaction page
-val flush11 : unit -> transaction page
+(* val flush10 : unit -> transaction page *)
+(* val flush11 : unit -> transaction page *)
 val cache : int -> transaction page
 val flush : int -> transaction page
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 56310b81..81dfefaa 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -3410,14 +3410,22 @@ fun p_file env (ds, ps) =
                               fun paramRepeatInit itemi sep =
                                   if params = 0 then "" else sep ^ paramRepeat itemi sep
                               val args = paramRepeatInit (fn p => "uw_Basis_string p" ^ p) ", "
-                              val decls = paramRepeat (fn p => "uw_Basis_string param" ^ i ^ "_" ^ p ^ " = NULL;") "\n"
+                              val decls = paramRepeat (fn p => "uw_Basis_string param" ^ i ^ "_"
+                                                               ^ p ^ " = NULL;")
+                                                      "\n"
                               val sets = paramRepeat (fn p => "param" ^ i ^ "_" ^ p
-                                                             ^ " = strdup(p" ^ p ^ ");") "\n"
-                              val frees = paramRepeat (fn p => "free(param" ^ i ^ "_" ^ p ^ ");") "\n"
-                              (* Starting || makes logic easier when there are no parameters. *)
+                                                              ^ " = strdup(p" ^ p ^ ");")
+                                                     "\n"
+                              val frees = paramRepeat (fn p => "free(param" ^ i ^ "_" ^ p ^ ");")
+                                                      "\n"
                               val eqs = paramRepeatInit (fn p => "strcmp(param" ^ i ^ "_" ^ p
                                                                  ^ ", p" ^ p ^ ")")
                                                         " || "
+                              (* Using [!=] instead of [==] to mimic [strcmp]. *)
+                              val eqsNull = paramRepeatInit (fn p => "(p" ^ p ^ " == NULL || "
+                                                                     ^ "!strcmp(param" ^ i ^ "_"
+                                                                     ^ p ^ ", p" ^ p ^ "))")
+                                                            " && "
                           in box [string "static char *cacheQuery",
                                   string i,
                                   string " = NULL;",
@@ -3471,13 +3479,21 @@ fun p_file env (ds, ps) =
                                   newline,
                                   string "static uw_unit uw_Sqlcache_flush",
                                   string i,
-                                  string "(uw_context ctx) {\n free(cacheQuery",
+                                  string "(uw_context ctx",
+                                  string args,
+                                  string ") {\n if (cacheQuery",
+                                  string i,
+                                  string " != NULL",
+                                  string eqsNull,
+                                  string ") {\n free(cacheQuery",
                                   string i,
                                   string ");\n cacheQuery",
                                   string i,
                                   string " = NULL;\n puts(\"SQLCACHE: flushed ",
                                   string i,
-                                  string ".\");\n return uw_unit_v;\n };",
+                                  string ".\");}\n else { puts(\"SQLCACHE: keeping ",
+                                  string i,
+                                  string "\"); } return uw_unit_v;\n };",
                                   newline,
                                   newline]
                           end)
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 11174162..b20d6d22 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -16,7 +16,7 @@
  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
@@ -431,7 +431,7 @@ fun cifyExp (eAll as (e, loc), sm) =
           | L.EClosure _ => (ErrorMsg.errorAt loc "Nested closure remains in code generation";
                              (dummye, sm))
 
-          | L.EQuery {exps, tables, state, query, body, initial} =>
+          | L.EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} =>
             let
                 val (exps', sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
                                                         let
@@ -586,7 +586,7 @@ fun cifyDecl ((d, loc), sm) =
         let
             val (vis, sm) = ListUtil.foldlMap
                             (fn ((x, n, t, e, _), sm) =>
-                                let                                    
+                                let
                                     val (t, sm) = cifyTyp (t, sm)
 
                                     fun unravel (tAll as (t, _), eAll as (e, _)) =
@@ -601,7 +601,7 @@ fun cifyDecl ((d, loc), sm) =
                                             (ErrorMsg.errorAt loc "Function isn't explicit at code generation";
                                              ([], tAll, eAll))
                                           | _ => ([], tAll, eAll)
-                                                 
+
                                     val (args, ran, e) = unravel (t, e)
                                     val (e, sm) = cifyExp (e, sm)
                               in
@@ -610,7 +610,7 @@ fun cifyDecl ((d, loc), sm) =
                             sm vis
         in
             (SOME (L'.DFunRec vis, loc), NONE, sm)
-        end        
+        end
 
       | L.DExport (ek, s, n, ts, t, b) =>
         let
diff --git a/src/iflow.sml b/src/iflow.sml
index f68d8f72..b8346baa 100644
--- a/src/iflow.sml
+++ b/src/iflow.sml
@@ -1870,14 +1870,15 @@ val namer = MonoUtil.File.map {typ = fn t => t,
                                         case e of
                                             EDml (e, fm) =>
                                             nameSubexps (fn (_, e') => (EDml (e', fm), #2 e)) e
-                                          | EQuery {exps, tables, state, query, body, initial} =>
+                                          | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} =>
                                             nameSubexps (fn (liftBy, e') =>
                                                             (EQuery {exps = exps,
                                                                      tables = tables,
                                                                      state = state,
                                                                      query = e',
                                                                      body = mliftExpInExp liftBy 2 body,
-                                                                     initial = mliftExpInExp liftBy 0 initial},
+                                                                     initial = mliftExpInExp liftBy 0 initial,
+                                                                     sqlcacheInfo = sqlcacheInfo},
                                                              #2 query)) query
                                           | _ => e,
                                      decl = fn d => d}
@@ -2070,11 +2071,12 @@ fun check (file : file) =
                           | ESeq (e1, e2) => (ESeq (doExp env e1, doExp env e2), loc)
                           | ELet (x, t, e1, e2) => (ELet (x, t, doExp env e1, doExp (Unknown :: env) e2), loc)
                           | EClosure (n, es) => (EClosure (n, map (doExp env) es), loc)
-                          | EQuery {exps, tables, state, query, body, initial} =>
+                          | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} =>
                             (EQuery {exps = exps, tables = tables, state = state,
                                      query = doExp env query,
                                      body = doExp (Unknown :: Unknown :: env) body,
-                                     initial = doExp env initial}, loc)
+                                     initial = doExp env initial,
+                                     sqlcacheInfo = sqlcacheInfo}, loc)
                           | EDml (e1, mode) =>
                             (case parse dml e1 of
                                  NONE => ()
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 1a476739..a4ee95f0 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -16,7 +16,7 @@
  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
@@ -195,7 +195,7 @@ fun process (file : file) =
                                                           str loc "}"])],
                                             {disc = t, result = s}), loc)
                          val body = (EAbs ("x", t, s, body), loc)
-                                    
+
                          val st = {decls = ("jsify", n', (TFun (t, s), loc),
                                             body, "jsify") :: #decls st,
                                    script = #script st,
@@ -575,7 +575,7 @@ fun process (file : file) =
                                                 val e = String.translate (fn #"'" => "\\'"
                                                                            | #"\\" => "\\\\"
                                                                            | ch => String.str ch) e
-                                                
+
                                                 val sc = "urfuncs[" ^ Int.toString n ^ "] = {c:\"t\",f:'"
                                                          ^ e ^ "'};\n"
                                             in
@@ -799,7 +799,7 @@ fun process (file : file) =
                                       | _ => default ()
                             in
                                 seek (e', [x])
-                            end  
+                            end
 
                           | ECase (e', pes, _) =>
                             let
@@ -1030,7 +1030,7 @@ fun process (file : file) =
                | ERel _ => (e, st)
                | ENamed _ => (e, st)
                | ECon (_, _, NONE) => (e, st)
-               | ECon (dk, pc, SOME e) => 
+               | ECon (dk, pc, SOME e) =>
                  let
                      val (e, st) = exp outer (e, st)
                  in
@@ -1082,7 +1082,7 @@ fun process (file : file) =
                  in
                      ((EBinop (bi, s, e1, e2), loc), st)
                  end
-                 
+
                | ERecord xets =>
                  let
                      val (xets, st) = ListUtil.foldlMap (fn ((x, e, t), st) =>
@@ -1176,7 +1176,7 @@ fun process (file : file) =
                      ((EClosure (n, es), loc), st)
                  end
 
-               | EQuery {exps, tables, state, query, body, initial} =>
+               | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} =>
                  let
                      val row = exps @ map (fn (x, xts) => (x, (TRecord xts, loc))) tables
                      val row = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row
@@ -1187,7 +1187,8 @@ fun process (file : file) =
                      val (initial, st) = exp outer (initial, st)
                  in
                      ((EQuery {exps = exps, tables = tables, state = state,
-                               query = query, body = body, initial = initial}, loc), st)
+                               query = query, body = body, initial = initial,
+                               sqlcacheInfo = sqlcacheInfo}, loc), st)
                  end
                | EDml (e, mode) =>
                  let
@@ -1257,7 +1258,7 @@ fun process (file : file) =
                  in
                      ((ESignalSource e, loc), st)
                  end
-                 
+
                | EServerCall (e1, t, ef, fm) =>
                  let
                      val (e1, st) = exp outer (e1, st)
diff --git a/src/mono.sml b/src/mono.sml
index 1e402e57..5185e48c 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -16,7 +16,7 @@
  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
@@ -107,7 +107,8 @@ datatype exp' =
                      state : typ,
                      query : exp, (* exp of string type containing sql query *)
                      body : exp,
-                     initial : exp }
+                     initial : exp,
+                     sqlcacheInfo : exp }
        | EDml of exp * failure_mode
        | ENextval of exp
        | ESetval of exp * exp
@@ -119,7 +120,7 @@ datatype exp' =
        | ESignalReturn of exp
        | ESignalBind of exp * exp
        | ESignalSource of exp
-                              
+
        | EServerCall of exp * typ * effect * failure_mode
        | ERecv of exp * typ
        | ESleep of exp
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index d1e5ce55..97f78d3d 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -16,7 +16,7 @@
  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
@@ -166,7 +166,7 @@ fun exp e =
             e
 
       | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => exp (EStrcat (e1, e2))
-           
+
       | EStrcat ((EPrim (Prim.String (Prim.Html, s1)), loc), (EPrim (Prim.String (Prim.Html, s2)), _)) =>
         let
             val s =
@@ -179,7 +179,7 @@ fun exp e =
         in
             EPrim (Prim.String (Prim.Html, s))
         end
-                            
+
       | EStrcat ((EPrim (Prim.String (_, s1)), loc), (EPrim (Prim.String (_, s2)), _)) =>
         EPrim (Prim.String (Prim.Normal, s1 ^ s2))
 
@@ -397,18 +397,20 @@ fun exp e =
                         initial = (EPrim (Prim.String (k, "")), _),
                         body = (EStrcat ((EPrim (Prim.String (_, s)), _),
                                          (EStrcat ((ERel 0, _),
-                                                   e'), _)), _)}, loc) =>
+                                                   e'), _)), _),
+                        sqlcacheInfo}, loc) =>
         if (case k of Prim.Normal => s = "" | Prim.Html => CharVector.all Char.isSpace s) then
             EQuery {exps = exps, tables = tables, query = query,
                     state = (TRecord [], loc),
                     initial = (ERecord [], loc),
-                    body = (optExp (EWrite e', loc), loc)}
+                    body = (optExp (EWrite e', loc), loc),
+                    sqlcacheInfo = Monoize.urlifiedUnit}
         else
             e
 
       | EWrite (EQuery {exps, tables, state, query,
                         initial = (EPrim (Prim.String (_, "")), _),
-                        body}, loc) =>
+                        body, sqlcacheInfo}, loc) =>
         let
             fun passLets (depth, (e', _), lets) =
                 case e' of
@@ -423,7 +425,8 @@ fun exp e =
                             EQuery {exps = exps, tables = tables, query = query,
                                     state = (TRecord [], loc),
                                     initial = (ERecord [], loc),
-                                    body = body}
+                                    body = body,
+                                    sqlcacheInfo = Monoize.urlifiedUnit}
                         end
                     else
                         e
@@ -532,7 +535,7 @@ fun exp e =
          else
              ENone (TFfi ("Basis", "string"), loc))
 
-      | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String (_, s)), loc), _)]) => 
+      | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String (_, s)), loc), _)]) =>
         let
             fun uwify (cs, acc) =
                 case cs of
@@ -560,7 +563,7 @@ fun exp e =
             EPrim (Prim.String (Prim.Normal, s))
         end
 
-      | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String (_, s)), loc), _)]) => 
+      | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String (_, s)), loc), _)]) =>
         let
             fun uwify (cs, acc) =
                 case cs of
@@ -585,7 +588,7 @@ fun exp e =
             EPrim (Prim.String (Prim.Normal, s))
         end
 
-      | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String (_, s)), _), _)]) => 
+      | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String (_, s)), _), _)]) =>
         EPrim (Prim.String (Prim.Normal, unAs s))
       | EFfiApp ("Basis", "unAs", [(e', _)]) =>
         let
@@ -620,7 +623,7 @@ fun exp e =
         EFfiApp ("Basis", "attrifyChar_w", [e])
 
       | EBinop (_, "+", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.+ (n1, n2)))
-        
+
       | _ => e
 
 and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
diff --git a/src/mono_print.sml b/src/mono_print.sml
index c81b362a..0ff51f37 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -16,7 +16,7 @@
  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
@@ -310,7 +310,7 @@ fun p_exp' par env (e, _) =
                                                                       p_exp env e]) es,
                                  string ")"]
 
-      | EQuery {exps, tables, state, query, body, initial} =>
+      | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} =>
         box [string "query[",
              p_list (fn (x, t) => box [string x, space, string ":", space, p_typ env t]) exps,
              string "] [",
@@ -391,7 +391,7 @@ fun p_vali env (x, n, t, e, s) =
                           string "__",
                           string (Int.toString n)]
                  else
-                     string x        
+                     string x
     in
         box [xp,
              space,
@@ -541,7 +541,7 @@ fun p_decl env (dAll as (d, _) : decl) =
                           space,
                           p_policy env p]
       | DOnError _ => string "ONERROR"
-                          
+
 fun p_file env (file, _) =
     let
         val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
diff --git a/src/mono_util.sml b/src/mono_util.sml
index fd80c64f..ba10ad32 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -314,7 +314,7 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
                      fn es' =>
                         (EClosure (n, es'), loc))
 
-              | EQuery {exps, tables, state, query, body, initial} =>
+              | EQuery {exps, tables, state, query, body, initial, sqlcacheInfo} =>
                 S.bind2 (ListUtil.mapfold (fn (x, t) =>
                                               S.map2 (mft t,
                                                       fn t' => (x, t'))) exps,
@@ -334,15 +334,20 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
                                                                                  RelE ("acc", dummyt)))
                                                                           body,
                                                                    fn body' =>
-                                                                      S.map2 (mfe ctx initial,
+                                                                      (* ASK: is this the right thing to do? *)
+                                                                      S.bind2 (mfe ctx initial,
                                                                            fn initial' =>
-                                                                              (EQuery {exps = exps',
-                                                                                       tables = tables',
-                                                                                       state = state',
-                                                                                       query = query',
-                                                                                       body = body',
-                                                                                       initial = initial'},
-                                                                               loc)))))))
+                                                                              S.map2 (mfe (bind (ctx, RelE ("queryResult", dummyt)))
+                                                                                          sqlcacheInfo,
+                                                                                    fn sqlcacheInfo' =>
+                                                                                       (EQuery {exps = exps',
+                                                                                                tables = tables',
+                                                                                                state = state',
+                                                                                                query = query',
+                                                                                                body = body',
+                                                                                                initial = initial',
+                                                                                                sqlcacheInfo = sqlcacheInfo},
+                                                                                        loc))))))))
 
               | EDml (e, fm) =>
                 S.map2 (mfe ctx e,
diff --git a/src/monoize.sig b/src/monoize.sig
index 951db01b..549bf6ee 100644
--- a/src/monoize.sig
+++ b/src/monoize.sig
@@ -31,4 +31,6 @@ signature MONOIZE = sig
 
     val liftExpInExp : int -> Mono.exp -> Mono.exp
 
+    val urlifiedUnit : Mono.exp
+
 end
diff --git a/src/monoize.sml b/src/monoize.sml
index 2d225813..5c314c54 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -681,6 +681,16 @@ fun fooifyExp fk env =
 val attrifyExp = fooifyExp Attr
 val urlifyExp = fooifyExp Url
 
+val urlifiedUnit =
+    let
+        val loc = ErrorMsg.dummySpan
+        (* Urlifies [ERel 0] to match the [sqlcacheInfo] field of [EQuery]s. *)
+        val (urlified, _) = urlifyExp CoreEnv.empty (Fm.empty 0)
+                                      ((L'.ERel 0, loc), (L'.TRecord [], loc))
+    in
+        urlified
+    end
+
 datatype 'a failable_search =
          Found of 'a
        | NotFound
@@ -1957,26 +1967,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                                                           (L'.TFun (un, state), loc)),
                                                  loc)), loc)
 
-                             val body'' = (L'.EApp (
+                             val body' = (L'.EApp (
                                           (L'.EApp (
                                            (L'.EApp ((L'.ERel 4, loc),
                                                      (L'.ERel 1, loc)), loc),
                                            (L'.ERel 0, loc)), loc),
                                           (L'.ERecord [], loc)), loc)
-                             val body' = (L'.EQuery {exps = exps,
-                                                      tables = tables,
-                                                      state = state,
-                                                      query = (L'.ERel 3, loc),
-                                                      body = body'',
-                                                      initial = (L'.ERel 1, loc)},
-                                           loc)
-                             val (body, fm) = if Settings.getSqlcache () then
-                                                  let
-                                                      val (urlifiedRel0, fm) = urlifyExp env fm ((L'.ERel 0, loc), state)
-                                                  in
-                                                      (Sqlcache.instrumentQuery (body', urlifiedRel0), fm)
-                                                  end
-                                              else (body', fm)
+                             val (urlifiedRel0, fm) = urlifyExp env fm ((L'.ERel 0, loc), state)
+                             val body = (L'.EQuery {exps = exps,
+                                                    tables = tables,
+                                                    state = state,
+                                                    query = (L'.ERel 3, loc),
+                                                    body = body',
+                                                    initial = (L'.ERel 1, loc),
+                                                    sqlcacheInfo = urlifiedRel0},
+                                         loc)
+                             val body = if Settings.getSqlcache ()
+                                        then Sqlcache.instrumentQuery (body, urlifiedRel0)
+                                        else body
                          in
                              ((L'.EAbs ("q", s, (L'.TFun (ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc)), loc),
                                         (L'.EAbs ("f", ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc),
diff --git a/src/sqlcache.sml b/src/sqlcache.sml
index d8169926..b555ca7a 100644
--- a/src/sqlcache.sml
+++ b/src/sqlcache.sml
@@ -176,12 +176,10 @@ fun normalize' (negate : 'atom -> 'atom) (norm : normalForm) =
 
 fun normalize negate norm = normalize' negate norm o flatten o pushNegate negate false
 
-fun mapFormulaSigned positive mf =
- fn Atom x => Atom (mf (positive, x))
-  | Negate f => Negate (mapFormulaSigned (not positive) mf f)
-  | Combo (n, fs) => Combo (n, map (mapFormulaSigned positive mf) fs)
-
-fun mapFormula mf = mapFormulaSigned true (fn (_, x) => mf x)
+fun mapFormula mf =
+ fn Atom x => Atom (mf x)
+  | Negate f => Negate (mapFormula mf f)
+  | Combo (n, fs) => Combo (n, map (mapFormula mf) fs)
 
 (* SQL analysis. *)
 
@@ -225,11 +223,10 @@ val compare =
 end
 
 structure UF = UnionFindFn(AtomExpKey)
-
-(* val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula *)
-(*                    * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula *)
-(*                    -> Mono.exp' IM.map list = *)
-(*     let *)
+val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula
+                   * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula
+                   -> atomExp IM.map list =
+    let
         val toKnownEquality =
          (* [NONE] here means unkown. Anything that isn't a comparison between
             two knowns shouldn't be used, and simply dropping unused terms is
@@ -297,12 +294,12 @@ structure UF = UnionFindFn(AtomExpKey)
                        (SOME IM.empty)
         fun dnf (fQuery, fDml) =
             normalize negateCmp Dnf (Combo (Cnf, [markQuery fQuery, markDml fDml]))
-    (* in *)
-        val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula
-                           * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula
-                           -> atomExp IM.map list =
-            List.mapPartial (mergeEqs o map eqsOfClass o equivClasses) o dnf
-    (* end *)
+    in
+        (* val conflictMaps : (Sql.cmp * Sql.sqexp * Sql.sqexp) formula *)
+        (*                    * (Sql.cmp * Sql.sqexp * Sql.sqexp) formula *)
+        (*                    -> atomExp IM.map list = *)
+        List.mapPartial (mergeEqs o map eqsOfClass o equivClasses) o dnf
+    end
 
 val rec sqexpToFormula =
  fn Sql.SqTrue => Combo (Cnf, [])
@@ -338,32 +335,21 @@ fun valsToFormula (table, vals) =
     Combo (Cnf, map (fn (field, v) => Atom (Sql.Eq, Sql.Field (table, field), v)) vals)
 
 val rec dmlToFormula =
- fn Sql.Insert tableVals => valsToFormula tableVals
+ fn Sql.Insert (table, vals) => valsToFormula (table, vals)
   | Sql.Delete (table, wher) => renameTables [(table, "T")] (sqexpToFormula wher)
-  (* TODO: refine formula for the vals part, which could take into account the wher part. *)
-  (* TODO: use pushNegate instead of mapFormulaSigned? *)
   | Sql.Update (table, vals, wher) =>
     let
-        val f = sqexpToFormula wher
-        fun update (positive, a) =
-            let
-                fun updateIfNecessary field =
-                    case List.find (fn (f, _) => field = f) vals of
-                        SOME (_, v) => (if positive then Sql.Eq else Sql.Ne,
-                                        Sql.Field (table, field),
-                                        v)
-                      | NONE => a
-            in
-                case a of
-                    (_, Sql.Field (_, field), _) => updateIfNecessary field
-                  | (_, _, Sql.Field (_, field)) => updateIfNecessary field
-                  | _ => a
-            end
+        val fWhere = sqexpToFormula wher
+        val fVals = valsToFormula (table, vals)
+        (* TODO: don't use field name hack. *)
+        val markField =
+         fn Sql.Field (t, v) => Sql.Field (t, v ^ "*")
+          | e => e
+        val mark = mapFormula (fn (cmp, e1, e2) => (cmp, markField e1, markField e2))
     in
         renameTables [(table, "T")]
-                     (Combo (Dnf, [f,
-                                   Combo (Cnf, [valsToFormula (table, vals),
-                                                mapFormulaSigned true update f])]))
+                     (Combo (Dnf, [Combo (Cnf, [fVals, mark fWhere]),
+                                   Combo (Cnf, [mark fVals, fWhere])]))
     end
 
 val rec tablesQuery =
@@ -482,54 +468,62 @@ fun fileMapfold doExp file start =
 
 fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ())
 
+fun factorOutNontrivial text =
+    let
+        val loc = ErrorMsg.dummySpan
+        fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
+        val chunks = Sql.chunkify text
+        val (newText, newVariables) =
+            (* Important that this is foldr (to oppose foldl below). *)
+            List.foldr
+                (fn (chunk, (qText, newVars)) =>
+                    (* Variable bound to the head of newBs will have the lowest index. *)
+                    case chunk of
+                        Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
+                      | Sql.Exp e =>
+                        let
+                            val n = length newVars
+                        in
+                            (* This is the (n + 1)th new variable, so there are
+                               already n new variables bound, so we increment
+                               indices by n. *)
+                            (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
+                        end
+                      | Sql.String s => (strcat (stringExp s, qText), newVars))
+                (stringExp "", [])
+                chunks
+        fun wrapLets e' =
+            (* Important that this is foldl (to oppose foldr above). *)
+            List.foldl (fn (v, e') => ELet ("sqlArgz", stringTyp, v, (e', loc)))
+                       e'
+                       newVariables
+        val numArgs = length newVariables
+    in
+        (newText, wrapLets, numArgs)
+    end
+
 fun addChecking file =
     let
-        fun doExp (queryInfo as (tableToIndices, indexToQuery)) =
+        fun doExp (queryInfo as (tableToIndices, indexToQueryNumArgs)) =
          fn e' as ELet (v, t,
-                        queryExp' as (EQuery {query = origQueryText,
-                                              initial, body, state, tables, exps}, queryLoc),
+                        (EQuery {query = origQueryText,
+                                 initial, body, state, tables, exps, sqlcacheInfo}, queryLoc),
                         letBody) =>
             let
-                val loc = ErrorMsg.dummySpan
-                val chunks = Sql.chunkify origQueryText
-                fun strcat (e1, e2) = (EStrcat (e1, e2), loc)
-                val (newQueryText, newVariables) =
-                    (* Important that this is foldr (to oppose foldl below). *)
-                    List.foldr
-                        (fn (chunk, (qText, newVars)) =>
-                            (* Variable bound to the head of newBs will have the lowest index. *)
-                            case chunk of
-                                Sql.Exp (e as (EPrim _, _)) => (strcat (e, qText), newVars)
-                              | Sql.Exp e =>
-                                let
-                                    val n = length newVars
-                                in
-                                    (* This is the (n + 1)th new variable, so
-                                       there are already n new variables bound,
-                                       so we increment indices by n. *)
-                                    (strcat ((ERel (~(n+1)), loc), qText), incRels n e :: newVars)
-                                end
-                              | Sql.String s => (strcat (stringExp s, qText), newVars))
-                        (stringExp "", [])
-                        chunks
-                fun wrapLets e' =
-                    (* Important that this is foldl (to oppose foldr above). *)
-                    List.foldl (fn (v, e') => ELet ("sqlArgz", stringTyp, v, (e', loc)))
-                               e'
-                               newVariables
-                val numArgs = length newVariables
+                val (newQueryText, wrapLets, numArgs) = factorOutNontrivial origQueryText
                 (* Increment once for each new variable just made. *)
-                val queryExp = incRels (length newVariables)
+                val queryExp = incRels numArgs
                                        (EQuery {query = newQueryText,
                                                 initial = initial,
                                                 body = body,
                                                 state = state,
                                                 tables = tables,
-                                                exps = exps},
+                                                exps = exps,
+                                                sqlcacheInfo = sqlcacheInfo},
                                         queryLoc)
                 val (EQuery {query = queryText, ...}, _) = queryExp
-                val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText));
-                val args = List.tabulate (numArgs, fn n => (ERel n, loc))
+                val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty queryText))
+                val args = List.tabulate (numArgs, fn n => (ERel n, ErrorMsg.dummySpan))
                 fun bind x f = Option.mapPartial f x
                 fun guard b x = if b then x else NONE
                 (* DEBUG: set first boolean argument to true to turn on printing. *)
@@ -542,11 +536,11 @@ fun addChecking file =
                     bind (IM.find (!urlifiedRel0s, index)) (fn urlifiedRel0 =>
                     SOME (wrapLets (ELet (v, t,
                                           cacheWrap (queryExp, index, urlifiedRel0, args),
-                                          incRelsBound 1 (length newVariables) letBody)),
+                                          incRelsBound 1 numArgs letBody)),
                           (SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, index))
                                     tableToIndices
                                     (tablesQuery queryParsed),
-                           IM.insert (indexToQuery, index, (queryParsed, numArgs))))))))
+                           IM.insert (indexToQueryNumArgs, index, (queryParsed, numArgs))))))))
             in
                 case attempt of
                     SOME pair => pair
@@ -558,10 +552,12 @@ fun addChecking file =
         fileMapfold (fn exp => fn state => doExp state exp) file (SIMM.empty, IM.empty)
     end
 
+val gunk : (Sql.query * Sql.dml * Mono.exp list list) list ref = ref []
+
 val gunk' : (((Sql.cmp * Sql.sqexp * Sql.sqexp) formula)
              * ((Sql.cmp * Sql.sqexp * Sql.sqexp) formula)) list ref = ref []
 
-fun invalidations (nQueryArgs, query, dml) =
+fun invalidations ((query, numArgs), dml) =
     let
         val loc = ErrorMsg.dummySpan
         val optionAtomExpToExp =
@@ -578,9 +574,10 @@ fun invalidations (nQueryArgs, query, dml) =
             let
                 fun inv n = if n < 0 then [] else IM.find (eqs, n) :: inv (n - 1)
             in
-                inv (nQueryArgs - 1)
+                inv (numArgs - 1)
             end
-        (* *)
+        (* Tests if [ys] makes [xs] a redundant cache invalidation. [NONE] here
+           represents unknown, which means a wider invalidation. *)
         val rec madeRedundantBy : atomExp option list * atomExp option list -> bool =
          fn ([], []) => true
           | (NONE :: xs, _ :: ys) => madeRedundantBy (xs, ys)
@@ -601,39 +598,67 @@ fun invalidations (nQueryArgs, query, dml) =
         (map (map optionAtomExpToExp) o removeRedundant o map eqsToInvalidation) eqss
     end
 
-val gunk : Mono.exp list list list ref = ref []
 
-fun addFlushing (file, queryInfo as (tableToIndices, indexToQuery)) =
+(* gunk := (queryParsed, dmlParsed, invalidations (numArgs, queryParsed, dmlParsed)) :: !gunk); *)
+
+fun addFlushing (file, (tableToIndices, indexToQueryNumArgs)) =
     let
-        val allIndices = SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] tableToIndices
-        val flushes = map (fn i => ffiAppCache' ("flush", i, []))
+        (* TODO: write this. *)
+        val allInvs = () (* SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] tableToIndices *)
+        val flushes = List.concat o
+                      map (fn (i, argss) =>
+                              map (fn args =>
+                                      ffiAppCache' ("flush", i,
+                                                    map (fn arg => (arg, stringTyp)) args)) argss)
         val doExp =
-         fn dmlExp as EDml (dmlText, _) =>
+         fn EDml (origDmlText, failureMode) =>
             let
-                val indices =
+                val (newDmlText, wrapLets, numArgs) = factorOutNontrivial origDmlText
+                val dmlText = incRels numArgs newDmlText
+                val dmlExp = EDml (dmlText, failureMode)
+                val () = Print.preface ("sqlcache> ", (MonoPrint.p_exp MonoEnv.empty dmlText))
+                val invs =
                     case Sql.parse Sql.dml dmlText of
                         SOME dmlParsed =>
-                        map (fn i => ((case IM.find (indexToQuery, i) of
-                                           NONE => ()
-                                         | SOME (queryParsed, numArgs) =>
-                                           gunk := invalidations (numArgs, queryParsed, dmlParsed) :: !gunk);
-                                      i)) (SIMM.findList (tableToIndices, tableDml dmlParsed))
-                      | NONE => allIndices
+                        map (fn i => (case IM.find (indexToQueryNumArgs, i) of
+                                          SOME queryNumArgs =>
+                                          (i, invalidations (queryNumArgs, dmlParsed))
+                                        (* TODO: fail more gracefully. *)
+                                        | NONE => raise Match))
+                            (SIMM.findList (tableToIndices, tableDml dmlParsed))
+                      (* TODO: fail more gracefully. *)
+                      | NONE => raise Match
             in
-                sequence (flushes indices @ [dmlExp])
+                wrapLets (sequence (flushes invs @ [dmlExp]))
             end
           | e' => e'
     in
         fileMap doExp file
     end
 
+val inlineSql =
+    let
+        val doExp =
+         (* TODO: EQuery, too? *)
+         (* ASK: should this live in [MonoOpt]? *)
+         fn EDml ((ECase (disc, cases, {disc = dTyp, ...}), loc), failureMode) =>
+            let
+                val newCases = map (fn (p, e) => (p, (EDml (e, failureMode), loc))) cases
+            in
+                ECase (disc, newCases, {disc = dTyp, result = (TRecord [], loc)})
+            end
+          | e => e
+    in
+        fileMap doExp
+    end
+
 fun go file =
     let
         val () = Sql.sqlcacheMode := true
-        val file' = addFlushing (addChecking file)
+        val file' = addFlushing (addChecking (inlineSql file))
         val () = Sql.sqlcacheMode := false
     in
-         file'
+        file'
     end
 
 end
diff --git a/src/urweb.lex b/src/urweb.lex
index 0d316ed2..785f7a81 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -18,7 +18,7 @@
  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
@@ -50,7 +50,7 @@ in
        else
            ();
        commentLevel := !commentLevel + 1)
-    
+
   fun exitComment () =
       (ignore (commentLevel := !commentLevel - 1);
        if !commentLevel = 0 then
@@ -58,15 +58,15 @@ in
        else
            ())
 
-  fun eof () = 
-    let 
+  fun eof () =
+    let
       val pos = ErrorMsg.lastLineStart ()
     in
       if !commentLevel > 0 then
           ErrorMsg.errorAt' (!commentPos, !commentPos) "Unterminated comment"
       else
           ();
-      Tokens.EOF (pos, pos) 
+      Tokens.EOF (pos, pos)
     end
 end
 
@@ -177,7 +177,7 @@ fun unescape loc s =
 %s COMMENT STRING CHAR XML XMLTAG;
 
 id = [a-z_][A-Za-z0-9_']*;
-xmlid = [A-Za-z][A-Za-z0-9-_]*;
+xmlid = [A-Za-z][A-Za-z0-9_-]*;
 cid = [A-Z][A-Za-z0-9_]*;
 ws = [\ \t\012\r];
 intconst = [0-9]+;
@@ -300,7 +300,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 				       Tokens.XML_END (yypos, yypos + size yytext))
 			          else
 				      Tokens.END_TAG (id, yypos, yypos + size yytext)
-			        | _ => 
+			        | _ =>
 			          Tokens.END_TAG (id, yypos, yypos + size yytext)
 			  end);
 
-- 
cgit v1.2.3


From fbbec2e6b041b89827bafaf1f2f82f42ab8ea508 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Thu, 5 Mar 2015 14:50:31 -0500
Subject: Some new infix operators, contributed by Gabriel Riba

---
 src/urweb.grm | 32 ++++++++++++++++++++++++++++++++
 src/urweb.lex |  9 +++++++++
 2 files changed, 41 insertions(+)

(limited to 'src/urweb.lex')

diff --git a/src/urweb.grm b/src/urweb.grm
index 56e6d2ac..7fc34793 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -216,6 +216,14 @@ fun native_op (oper, e1, e2, loc) =
         (EApp (e, e2), loc)
     end
 
+fun top_binop (oper, e1, e2, loc) =
+    let
+        val e = (EVar (["Top"], oper, Infer), loc)
+        val e = (EApp (e, e1), loc)
+    in
+        (EApp (e, e2), loc)
+    end
+
 val inDml = ref false
 
 fun tagIn bt =
@@ -395,6 +403,8 @@ fun patternOut (e : exp) =
  | CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES
  | JOIN | INNER | CROSS | OUTER | LEFT | RIGHT | FULL
  | CIF | CTHEN | CELSE
+ | FWDAPP | REVAPP | COMPOSE | ANDTHEN
+ | BACKTICK_PATH of string
 
 %nonterm
    file of decl list
@@ -565,6 +575,12 @@ fun patternOut (e : exp) =
 %right CAND
 %nonassoc EQ NE LT LE GT GE IS
 %right ARROW
+
+%left REVAPP
+%right FWDAPP
+%left BACKTICK_PATH
+%right COMPOSE ANDTHEN
+
 %right CARET PLUSPLUS
 %left MINUSMINUS MINUSMINUSMINUS
 %left PLUS MINUS
@@ -1202,6 +1218,22 @@ eexp   : eapps                          (case #1 eapps of
        | eexp GT eexp                   (native_op ("gt", eexp1, eexp2, s (eexp1left, eexp2right)))
        | eexp GE eexp                   (native_op ("ge", eexp1, eexp2, s (eexp1left, eexp2right)))
 
+       | eexp FWDAPP eexp               (EApp (eexp1, eexp2), s (eexp1left, eexp2right))
+       | eexp REVAPP eexp               (EApp (eexp2, eexp1), s (eexp1left, eexp2right))
+       | eexp COMPOSE eexp              (top_binop ("compose", eexp1, eexp2, s (eexp1left, eexp2right)))
+       | eexp ANDTHEN eexp              (top_binop ("compose", eexp2, eexp1, s (eexp1left, eexp2right)))
+       | eexp BACKTICK_PATH eexp        (let
+                                                val path = String.tokens (fn ch => ch = #".") BACKTICK_PATH
+                                                val pathModules = List.take (path, (length path -1))
+                                                val pathOp = List.last path
+
+                                                val e = (EVar (pathModules, pathOp, Infer)
+                                                        , s (BACKTICK_PATHleft, BACKTICK_PATHright))
+                                                val e = (EApp (e, eexp1), s (eexp1left, BACKTICK_PATHright))
+                                        in
+                                                (EApp (e, eexp2), s (eexp1left, eexp2right))
+                                        end)
+
        | eexp ANDALSO eexp              (let
                                              val loc = s (eexp1left, eexp2right)
                                          in
diff --git a/src/urweb.lex b/src/urweb.lex
index 195fd735..716c44ba 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -376,6 +376,15 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 <INITIAL> "&&"        => (Tokens.ANDALSO (pos yypos, pos yypos + size yytext));
 <INITIAL> "||"        => (Tokens.ORELSE (pos yypos, pos yypos + size yytext));
 
+<INITIAL> "<<<"       => (Tokens.COMPOSE (pos yypos, pos yypos + size yytext));
+<INITIAL> ">>>"       => (Tokens.ANDTHEN (pos yypos, pos yypos + size yytext));
+<INITIAL> "<|"        => (Tokens.FWDAPP (pos yypos, pos yypos + size yytext));
+<INITIAL> "|>"        => (Tokens.REVAPP (pos yypos, pos yypos + size yytext));
+
+<INITIAL> "`" ({cid} ".")* {id} "`"  => (Tokens.BACKTICK_PATH ( (* strip backticks *)
+                                                              substring (yytext,1,size yytext -2),
+                                                              pos yypos, pos yypos + size yytext));
+
 <INITIAL> "="         => (Tokens.EQ (pos yypos, pos yypos + size yytext));
 <INITIAL> "<>"        => (Tokens.NE (pos yypos, pos yypos + size yytext));
 <INITIAL> "<"         => (Tokens.LT (pos yypos, pos yypos + size yytext));
-- 
cgit v1.2.3


From b5e81a0d27da103e5e771f78a319bae1cfa1703c Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Thu, 5 Mar 2015 15:03:04 -0500
Subject: Hexadecimal integer literals, contributed by Gabriel Riba

---
 src/urweb.lex | 7 +++++++
 1 file changed, 7 insertions(+)

(limited to 'src/urweb.lex')

diff --git a/src/urweb.lex b/src/urweb.lex
index 716c44ba..e1ffd1c3 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -182,6 +182,7 @@ cid = [A-Z][A-Za-z0-9_]*;
 ws = [\ \t\012\r];
 intconst = [0-9]+;
 realconst = [0-9]+\.[0-9]*;
+hexconst = 0x[0-9A-F]{1,8};
 notags = ([^<{\n(]|(\([^\*<{\n]))+;
 xcom = ([^\-]|(-[^\-]))+;
 oint = [0-9][0-9][0-9];
@@ -541,6 +542,12 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 <INITIAL> {id}        => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext));
 <INITIAL> {cid}       => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext));
 
+<INITIAL> {hexconst}  => (case StringCvt.scanString (Int64.scan StringCvt.HEX) (String.extract (yytext, 2, NONE)) of
+                              SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext)
+                            | NONE   => (ErrorMsg.errorAt' (pos yypos, pos yypos)
+                                                           ("Expected hexInt, received: " ^ yytext);
+                                         continue ()));
+
 <INITIAL> {intconst}  => (case Int64.fromString yytext of
                               SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext)
                             | NONE   => (ErrorMsg.errorAt' (pos yypos, pos yypos)
-- 
cgit v1.2.3


From 40f97e49084e04f74f12dd9bccd05c9da11dd591 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Thu, 28 May 2015 10:23:43 -0400
Subject: Handling overflow in integer literals (contributed by Gabriel Riba)

---
 src/urweb.lex | 18 +++++++++++++-----
 1 file changed, 13 insertions(+), 5 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/src/urweb.lex b/src/urweb.lex
index e1ffd1c3..fcf10d94 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -182,7 +182,7 @@ cid = [A-Z][A-Za-z0-9_]*;
 ws = [\ \t\012\r];
 intconst = [0-9]+;
 realconst = [0-9]+\.[0-9]*;
-hexconst = 0x[0-9A-F]{1,8};
+hexconst = 0x[0-9A-F]+;
 notags = ([^<{\n(]|(\([^\*<{\n]))+;
 xcom = ([^\-]|(-[^\-]))+;
 oint = [0-9][0-9][0-9];
@@ -542,17 +542,25 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 <INITIAL> {id}        => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext));
 <INITIAL> {cid}       => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext));
 
-<INITIAL> {hexconst}  => (case StringCvt.scanString (Int64.scan StringCvt.HEX) (String.extract (yytext, 2, NONE)) of
+<INITIAL> {hexconst}  => (let val digits = String.extract (yytext, 2, NONE)
+                              val v = (StringCvt.scanString (Int64.scan StringCvt.HEX) digits)
+                                      handle Overflow => NONE
+                          in
+                          case v of
                               SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext)
                             | NONE   => (ErrorMsg.errorAt' (pos yypos, pos yypos)
                                                            ("Expected hexInt, received: " ^ yytext);
-                                         continue ()));
+                                         continue ())
+                         end);
 
-<INITIAL> {intconst}  => (case Int64.fromString yytext of
+<INITIAL> {intconst}  => (let val v = (Int64.fromString yytext) handle Overflow => NONE
+                          in 
+                          case v of
                               SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext)
                             | NONE   => (ErrorMsg.errorAt' (pos yypos, pos yypos)
                                                            ("Expected int, received: " ^ yytext);
-                                         continue ()));
+                                         continue ())
+                         end);
 <INITIAL> {realconst} => (case Real64.fromString yytext of
                             SOME x => Tokens.FLOAT (x, pos yypos, pos yypos + size yytext)
                           | NONE   => (ErrorMsg.errorAt' (pos yypos, pos yypos)
-- 
cgit v1.2.3


From 57424b901657e7c798fc7e4b20427c2d42835203 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Thu, 28 May 2015 10:28:15 -0400
Subject: Remove duplicate lexer line

---
 src/urweb.lex | 2 --
 1 file changed, 2 deletions(-)

(limited to 'src/urweb.lex')

diff --git a/src/urweb.lex b/src/urweb.lex
index fcf10d94..c44a4c1d 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -537,8 +537,6 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 
 <INITIAL> "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext));
 
-<INITIAL> "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext));
-
 <INITIAL> {id}        => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext));
 <INITIAL> {cid}       => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext));
 
-- 
cgit v1.2.3


From de90e13f1cd152318791f47d75280f03e768c7cc Mon Sep 17 00:00:00 2001
From: Gabriel Riba Faura <griba2001@gmail.com>
Date: Wed, 3 Jun 2015 08:34:23 +0200
Subject: location literal _LOC_

---
 src/urweb.lex | 6 ++++++
 1 file changed, 6 insertions(+)

(limited to 'src/urweb.lex')

diff --git a/src/urweb.lex b/src/urweb.lex
index c44a4c1d..eada3611 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -537,6 +537,12 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 
 <INITIAL> "CURRENT_TIMESTAMP" => (Tokens.CURRENT_TIMESTAMP (pos yypos, pos yypos + size yytext));
 
+<INITIAL> "_LOC_" => (let val strLoc = ErrorMsg.spanToString (ErrorMsg.spanOf
+                                            (pos yypos, pos yypos + size yytext))
+                      in
+                          Tokens.STRING (strLoc, pos yypos, pos yypos + size yytext)
+                      end);
+
 <INITIAL> {id}        => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext));
 <INITIAL> {cid}       => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext));
 
-- 
cgit v1.2.3


From 443fa1a2ad02b653c96de2fb159fbdb510a87171 Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adam@chlipala.net>
Date: Thu, 11 Jun 2015 19:06:32 -0400
Subject: Allow apostrophes in capitalized identifiers

---
 src/urweb.lex | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'src/urweb.lex')

diff --git a/src/urweb.lex b/src/urweb.lex
index eada3611..f32ddf1e 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -178,7 +178,7 @@ fun unescape loc s =
 
 id = [a-z_][A-Za-z0-9_']*;
 xmlid = [A-Za-z][A-Za-z0-9_-]*;
-cid = [A-Z][A-Za-z0-9_]*;
+cid = [A-Z][A-Za-z0-9_']*;
 ws = [\ \t\012\r];
 intconst = [0-9]+;
 realconst = [0-9]+\.[0-9]*;
-- 
cgit v1.2.3