changeset 398:ab3177746c78

Simple listShop working
author Adam Chlipala <adamc@hcoop.net>
date Tue, 21 Oct 2008 13:24:54 -0400
parents 4d519baf357c
children 2d64457eedb1
files demo/listFun.ur demo/listFun.urs demo/listShop.ur demo/listShop.urp src/cjr_print.sml src/compiler.sml src/core_util.sml src/corify.sml src/mono_reduce.sml tests/unurlify.ur tests/unurlify.urp
diffstat 11 files changed, 389 insertions(+), 306 deletions(-) [+]
line wrap: on
line diff
--- a/demo/listFun.ur	Tue Oct 21 12:06:35 2008 -0400
+++ b/demo/listFun.ur	Tue Oct 21 13:24:54 2008 -0400
@@ -1,5 +1,27 @@
+open List
+
 functor Make(M : sig
                  type t
+                 val toString : t -> string
+                 val fromString : string -> option t
              end) = struct
-    fun main () = return <xml/>
+    fun toXml (ls : list M.t) =
+        case ls of
+            Nil => <xml>[]</xml>
+          | Cons (x, ls') => <xml>{[M.toString x]} :: {toXml ls'}</xml>
+      
+    fun console (ls : list M.t) = return <xml><body>
+      Current list: {toXml ls}<br/>
+
+      <form>
+        Add element: <textbox{#X}/> <submit action={cons ls}/>
+      </form>
+    </body></xml>
+
+    and cons (ls : list M.t) (r : {X : string}) =
+        case M.fromString r.X of
+            None => return <xml><body>Invalid string!</body></xml>
+          | Some v => console (Cons (v, ls))
+
+    fun main () = console Nil
 end
--- a/demo/listFun.urs	Tue Oct 21 12:06:35 2008 -0400
+++ b/demo/listFun.urs	Tue Oct 21 13:24:54 2008 -0400
@@ -1,5 +1,7 @@
 functor Make(M : sig
                  type t
+                 val toString : t -> string
+                 val fromString : string -> option t
              end) : sig
     val main : unit -> transaction page
 end
--- a/demo/listShop.ur	Tue Oct 21 12:06:35 2008 -0400
+++ b/demo/listShop.ur	Tue Oct 21 13:24:54 2008 -0400
@@ -1,9 +1,13 @@
 structure I = struct
     type t = int
+    val toString = show _
+    val fromString = read _
 end
 
 structure S = struct
     type t = string
+    val toString = show _
+    val fromString = read _
 end
 
 structure IL = ListFun.Make(I)
--- a/demo/listShop.urp	Tue Oct 21 12:06:35 2008 -0400
+++ b/demo/listShop.urp	Tue Oct 21 13:24:54 2008 -0400
@@ -1,3 +1,4 @@
+debug
 
 list
 listFun
--- a/src/cjr_print.sml	Tue Oct 21 12:06:35 2008 -0400
+++ b/src/cjr_print.sml	Tue Oct 21 13:24:54 2008 -0400
@@ -1463,217 +1463,249 @@
                 str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
 
         fun unurlify (t, loc) =
-            case t of
-                TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)")
+            let
+                fun unurlify' rf t =
+                    case t of
+                        TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)")
 
-              | TRecord 0 => string "uw_unit_v"
-              | TRecord i =>
-                let
-                    val xts = E.lookupStruct env i
-                in
-                    box [string "({",
-                         newline,
-                         box (map (fn (x, t) =>
-                                      box [p_typ env t,
-                                           space,
-                                           string x,
-                                           space,
-                                           string "=",
-                                           space,
-                                           unurlify t,
-                                           string ";",
-                                           newline]) xts),
-                         string "struct",
-                         space,
-                         string "__uws_",
-                         string (Int.toString i),
-                         space,
-                         string "tmp",
-                         space,
-                         string "=",
-                         space,
-                         string "{",
-                         space,
-                         p_list_sep (box [string ",", space]) (fn (x, _) => string x) xts,
-                         space,
-                         string "};",
-                         newline,
-                         string "tmp;",
-                         newline,
-                         string "})"]
-                end
-
-              | TDatatype (Enum, i, _) =>
-                let
-                    val (x, xncs) = E.lookupDatatype env i
-
-                    fun doEm xncs =
-                        case xncs of
-                            [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), (enum __uwe_"
-                                          ^ x ^ "_" ^ Int.toString i ^ ")0)")
-                          | (x', n, to) :: rest =>
-                            box [string "((!strncmp(request, \"",
-                                 string x',
-                                 string "\", ",
-                                 string (Int.toString (size x')),
-                                 string ") && (request[",
-                                 string (Int.toString (size x')),
-                                 string "] == 0 || request[",
-                                 string (Int.toString (size x')),
-                                 string ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n),
-                                 space,
-                                 string ":",
-                                 space,
-                                 doEm rest,
-                                 string ")"]
-                in
-                    doEm xncs
-                end
-
-              | TDatatype (Option, i, xncs) =>
-                let
-                    val (x, _) = E.lookupDatatype env i
-
-                    val (no_arg, has_arg, t) =
-                        case !xncs of
-                            [(no_arg, _, NONE), (has_arg, _, SOME t)] =>
-                            (no_arg, has_arg, t)
-                          | [(has_arg, _, SOME t), (no_arg, _, NONE)] =>
-                            (no_arg, has_arg, t)
-                          | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype"
-                in
-                    box [string "(request[0] == '/' ? ++request : request,",
-                         newline,
-                         string "((!strncmp(request, \"",
-                         string no_arg,
-                         string "\", ",
-                         string (Int.toString (size no_arg)),
-                         string ") && (request[",
-                         string (Int.toString (size no_arg)),
-                         string "] == 0 || request[",
-                         string (Int.toString (size no_arg)),
-                         string "] == '/')) ? (request",
-                         space,
-                         string "+=",
-                         space,
-                         string (Int.toString (size no_arg)),
-                         string ", NULL) : ((!strncmp(request, \"",
-                         string has_arg,
-                         string "\", ",
-                         string (Int.toString (size has_arg)),
-                         string ") && (request[",
-                         string (Int.toString (size has_arg)),
-                         string "] == 0 || request[",
-                         string (Int.toString (size has_arg)),
-                         string "] == '/')) ? (request",
-                         space,
-                         string "+=",
-                         space,
-                         string (Int.toString (size has_arg)),
-                         string ", (request[0] == '/' ? ++request : NULL), ",
-                         newline,
-                         
-                         case #1 t of
-                             TDatatype _ => unurlify t
-                           | TFfi ("Basis", "string") => unurlify t
-                           | _ => box [string "({",
-                                       newline,
-                                       p_typ env t,
-                                       space,
-                                       string "*tmp",
-                                       space,
-                                       string "=",
-                                       space,
-                                       string "uw_malloc(ctx, sizeof(",
-                                       p_typ env t,
-                                       string "));",
-                                       newline,
-                                       string "*tmp",
-                                       space,
-                                       string "=",
-                                       space,
-                                       unurlify t,
-                                       string ";",
-                                       newline,
-                                       string "tmp;",
-                                       newline,
-                                       string "})"],
-                         string ")",
-                         newline,
-                         string ":",
-                         space,
-                         string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL))))")]
-                end                     
-
-              | TDatatype (Default, i, _) =>
-                let
-                    val (x, xncs) = E.lookupDatatype env i
-
-                    fun doEm xncs =
-                        case xncs of
-                            [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL)")
-                          | (x', n, to) :: rest =>
-                            box [string "((!strncmp(request, \"",
-                                 string x',
-                                 string "\", ",
-                                 string (Int.toString (size x')),
-                                 string ") && (request[",
-                                 string (Int.toString (size x')),
-                                 string "] == 0 || request[",
-                                 string (Int.toString (size x')),
-                                 string "] == '/')) ? ({",
+                      | TRecord 0 => string "uw_unit_v"
+                      | TRecord i =>
+                        let
+                            val xts = E.lookupStruct env i
+                        in
+                            box [string "({",
                                  newline,
+                                 box (map (fn (x, t) =>
+                                              box [p_typ env t,
+                                                   space,
+                                                   string "uwr_",
+                                                   string x,
+                                                   space,
+                                                   string "=",
+                                                   space,
+                                                   unurlify' rf (#1 t),
+                                                   string ";",
+                                                   newline]) xts),
                                  string "struct",
                                  space,
-                                 string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i),
+                                 string "__uws_",
+                                 string (Int.toString i),
                                  space,
-                                 string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_",
-                                 string x,
-                                 string "_",
-                                 string (Int.toString i),
-                                 string "));",
-                                 newline,
-                                 string "tmp->tag",
+                                 string "tmp",
                                  space,
                                  string "=",
                                  space,
-                                 string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n),
-                                 string ";",
+                                 string "{",
+                                 space,
+                                 p_list_sep (box [string ",", space]) (fn (x, _) => box [string "uwr_",
+                                                                                         string x]) xts,
+                                 space,
+                                 string "};",
                                  newline,
-                                 string "request",
-                                 space,
-                                 string "+=",
-                                 space,
-                                 string (Int.toString (size x')),
-                                 string ";",
-                                 newline,
-                                 string "if (request[0] == '/') ++request;",
-                                 newline,
-                                 case to of
-                                     NONE => box []
-                                   | SOME t => box [string "tmp->data.uw_",
-                                                    p_ident x',
-                                                    space,
-                                                    string "=",
-                                                    space,
-                                                    unurlify t,
-                                                    string ";",
-                                                    newline],
                                  string "tmp;",
                                  newline,
-                                 string "})",
-                                 space,
-                                 string ":",
-                                 space,
-                                 doEm rest,
-                                 string ")"]
-                in
-                    doEm xncs
-                end
+                                 string "})"]
+                        end
 
-              | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
-                      space)
+                      | TDatatype (Enum, i, _) =>
+                        let
+                            val (x, xncs) = E.lookupDatatype env i
 
+                            fun doEm xncs =
+                                case xncs of
+                                    [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), (enum __uwe_"
+                                                  ^ x ^ "_" ^ Int.toString i ^ ")0)")
+                                  | (x', n, to) :: rest =>
+                                    box [string "((!strncmp(request, \"",
+                                         string x',
+                                         string "\", ",
+                                         string (Int.toString (size x')),
+                                         string ") && (request[",
+                                         string (Int.toString (size x')),
+                                         string "] == 0 || request[",
+                                         string (Int.toString (size x')),
+                                         string ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n),
+                                         space,
+                                         string ":",
+                                         space,
+                                         doEm rest,
+                                         string ")"]
+                        in
+                            doEm xncs
+                        end
+
+                      | TDatatype (Option, i, xncs) =>
+                        if IS.member (rf, i) then
+                            box [string "unurlify_",
+                                 string (Int.toString i),
+                                 string "()"]
+                        else
+                            let
+                                val (x, _) = E.lookupDatatype env i
+
+                                val (no_arg, has_arg, t) =
+                                    case !xncs of
+                                        [(no_arg, _, NONE), (has_arg, _, SOME t)] =>
+                                        (no_arg, has_arg, t)
+                                      | [(has_arg, _, SOME t), (no_arg, _, NONE)] =>
+                                        (no_arg, has_arg, t)
+                                      | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype"
+
+                                val rf = IS.add (rf, i)
+                            in
+                                box [string "({",
+                                     space,
+                                     p_typ env t,
+                                     space,
+                                     string "*unurlify_",
+                                     string (Int.toString i),
+                                     string "(void) {",
+                                     newline,
+                                     box [string "return (request[0] == '/' ? ++request : request,",
+                                          newline,
+                                          string "((!strncmp(request, \"",
+                                          string no_arg,
+                                          string "\", ",
+                                          string (Int.toString (size no_arg)),
+                                          string ") && (request[",
+                                          string (Int.toString (size no_arg)),
+                                          string "] == 0 || request[",
+                                          string (Int.toString (size no_arg)),
+                                          string "] == '/')) ? (request",
+                                          space,
+                                          string "+=",
+                                          space,
+                                          string (Int.toString (size no_arg)),
+                                          string ", NULL) : ((!strncmp(request, \"",
+                                          string has_arg,
+                                          string "\", ",
+                                          string (Int.toString (size has_arg)),
+                                          string ") && (request[",
+                                          string (Int.toString (size has_arg)),
+                                          string "] == 0 || request[",
+                                          string (Int.toString (size has_arg)),
+                                          string "] == '/')) ? (request",
+                                          space,
+                                          string "+=",
+                                          space,
+                                          string (Int.toString (size has_arg)),
+                                          string ", (request[0] == '/' ? ++request : NULL), ",
+                                          newline,
+                                          
+                                          case #1 t of
+                                              TDatatype _ => unurlify' rf (#1 t)
+                                            | TFfi ("Basis", "string") => unurlify' rf (#1 t)
+                                            | _ => box [string "({",
+                                                        newline,
+                                                        p_typ env t,
+                                                        space,
+                                                        string "*tmp",
+                                                        space,
+                                                        string "=",
+                                                        space,
+                                                        string "uw_malloc(ctx, sizeof(",
+                                                        p_typ env t,
+                                                        string "));",
+                                                        newline,
+                                                        string "*tmp",
+                                                        space,
+                                                        string "=",
+                                                        space,
+                                                        unurlify' rf (#1 t),
+                                                        string ";",
+                                                        newline,
+                                                        string "tmp;",
+                                                        newline,
+                                                        string "})"],
+                                          string ")",
+                                          newline,
+                                          string ":",
+                                          space,
+                                          string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x
+                                                  ^ "\"), NULL))));"),
+                                          newline],
+                                     string "}",
+                                     newline,
+                                     newline,
+
+                                     string "unurlify_",
+                                     string (Int.toString i),
+                                     string "();",
+                                     newline,
+                                     string "})"]
+                            end
+
+                      | TDatatype (Default, i, _) =>
+                        let
+                            val (x, xncs) = E.lookupDatatype env i
+
+                            fun doEm xncs =
+                                case xncs of
+                                    [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL)")
+                                  | (x', n, to) :: rest =>
+                                    box [string "((!strncmp(request, \"",
+                                         string x',
+                                         string "\", ",
+                                         string (Int.toString (size x')),
+                                         string ") && (request[",
+                                         string (Int.toString (size x')),
+                                         string "] == 0 || request[",
+                                         string (Int.toString (size x')),
+                                         string "] == '/')) ? ({",
+                                         newline,
+                                         string "struct",
+                                         space,
+                                         string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i),
+                                         space,
+                                         string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_",
+                                         string x,
+                                         string "_",
+                                         string (Int.toString i),
+                                         string "));",
+                                         newline,
+                                         string "tmp->tag",
+                                         space,
+                                         string "=",
+                                         space,
+                                         string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n),
+                                         string ";",
+                                         newline,
+                                         string "request",
+                                         space,
+                                         string "+=",
+                                         space,
+                                         string (Int.toString (size x')),
+                                         string ";",
+                                         newline,
+                                         string "if (request[0] == '/') ++request;",
+                                         newline,
+                                         case to of
+                                             NONE => box []
+                                           | SOME (t, _) => box [string "tmp->data.uw_",
+                                                                 p_ident x',
+                                                                 space,
+                                                                 string "=",
+                                                                 space,
+                                                                 unurlify' rf t,
+                                                                 string ";",
+                                                                 newline],
+                                         string "tmp;",
+                                         newline,
+                                         string "})",
+                                         space,
+                                         string ":",
+                                         space,
+                                         doEm rest,
+                                         string ")"]
+                        in
+                            doEm xncs
+                        end
+
+                      | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
+                              space)
+            in
+                unurlify' IS.empty t
+            end
 
         fun p_page (ek, s, n, ts) =
             let
--- a/src/compiler.sml	Tue Oct 21 12:06:35 2008 -0400
+++ b/src/compiler.sml	Tue Oct 21 13:24:54 2008 -0400
@@ -535,7 +535,6 @@
                 else
                     let
                         val dir = OS.FileSys.tmpName ()
-                        val () = OS.FileSys.remove dir
                         val cname = OS.Path.joinDirFile {dir = dir, file = "urweb.c"}
                         val oname = OS.Path.joinDirFile {dir = dir, file = "urweb.o"}
                     in
--- a/src/core_util.sml	Tue Oct 21 12:06:35 2008 -0400
+++ b/src/core_util.sml	Tue Oct 21 13:24:54 2008 -0400
@@ -785,7 +785,9 @@
 val maxName = foldl (fn ((d, _) : decl, count) =>
                         case d of
                             DCon (_, n, _, _) => Int.max (n, count)
-                          | DDatatype (_, n, _, _) => Int.max (n, count)
+                          | DDatatype (_, n, _, ns) =>
+                            foldl (fn ((_, n', _), m) => Int.max (n', m))
+                                  (Int.max (n, count)) ns
                           | DVal (_, n, _, _, _) => Int.max (n, count)
                           | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis
                           | DExport _ => count
--- a/src/corify.sml	Tue Oct 21 12:06:35 2008 -0400
+++ b/src/corify.sml	Tue Oct 21 13:24:54 2008 -0400
@@ -696,7 +696,7 @@
       | L.DSgn _ => ([], st)
 
       | L.DStr (x, n, _, (L.StrFun (xa, na, _, _, str), _)) =>
-        ([], St.bindFunctor st mods x n xa na str)
+        ([], St.bindFunctor st (x :: mods) x n xa na str)
 
       | L.DStr (x, n, _, (L.StrProj (str, x'), _)) =>
         let
--- a/src/mono_reduce.sml	Tue Oct 21 12:06:35 2008 -0400
+++ b/src/mono_reduce.sml	Tue Oct 21 13:24:54 2008 -0400
@@ -275,123 +275,134 @@
       | ENextval e => summarize d e @ [WriteDb]
 
 fun exp env 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', _) => #1 e'
-           | _ => e)
+    let
+        (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*)
 
-      | EApp ((EAbs (x, t, _, e1), loc), e2) =>
-        ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp env e1),
-                                       ("e2", MonoPrint.p_exp env e2)];*)
-        if impure e2 then
-            #1 (reduceExp env (ELet (x, t, e2, e1), loc))
-        else
-            #1 (reduceExp env (subExpInExp (0, e2) e1)))
+        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)
 
-      | ECase (e', pes, {disc, result}) =>
-        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
+              | 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)))
 
-            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
-            search pes
-        end
+              | ECase (e', pes, {disc, result}) =>
+                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
 
-      | EField ((ERecord xes, _), x) =>
-        (case List.find (fn (x', _, _) => x' = x) xes of
-             SOME (_, e, _) => #1 e
-           | NONE => 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
+                    search pes
+                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))
+              | EField ((ERecord xes, _), x) =>
+                (case List.find (fn (x', _, _) => x' = x) xes of
+                     SOME (_, e, _) => #1 e
+                   | NONE => e)
 
-      | ELet (x, t, e, (EAbs (x', t' as (TRecord [], _), ran, e'), loc)) =>
-        EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e, swapExpVars 0 e'), loc))
+              | 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', b) =>
-        if impure e' then
-            let
-                val effs_e' = summarize 0 e'
-                val effs_b = summarize 0 b
+              | ELet (x, t, e, (EAbs (x', t' as (TRecord [], _), ran, e'), loc)) =>
+                EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e, swapExpVars 0 e'), loc))
 
-                fun does eff = List.exists (fn eff' => eff' = eff) effs_e'
-                val writesPage = does WritePage
-                val readsDb = does ReadDb
-                val writesDb = does WriteDb
+              | ELet (x, t, e', b) =>
+                if impure e' then
+                    let
+                        val effs_e' = summarize 0 e'
+                        val effs_b = summarize 0 b
 
-                fun verifyUnused eff =
-                    case eff of
-                        UseRel r => r <> 0
-                      | Unsure => false
-                      | _ => true
+                        fun does eff = List.exists (fn eff' => eff' = eff) effs_e'
+                        val writesPage = does WritePage
+                        val readsDb = does ReadDb
+                        val writesDb = does WriteDb
 
-                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
+                        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
+                    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
+                            #1 (reduceExp env (subExpInExp (0, e') b))
+                        else
+                            e
+                    end
+                else
                     #1 (reduceExp env (subExpInExp (0, e') b))
-                else
-                    e
-            end
-        else
-            #1 (reduceExp env (subExpInExp (0, e') b))
 
-      | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) =>
-        EPrim (Prim.String (s1 ^ s2))
+              | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) =>
+                EPrim (Prim.String (s1 ^ s2))
 
-      | _ => e
+              | _ => e
+    in
+        (*Print.prefaces "exp'" [("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*)
+        r
+    end
 
 and bind (env, b) =
     case b of
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/unurlify.ur	Tue Oct 21 13:24:54 2008 -0400
@@ -0,0 +1,7 @@
+datatype list t = Nil | Cons of t * list t
+
+fun handler (ls : list bool) = return <xml/>
+
+fun main () : transaction page = return <xml><body>
+  <a link={handler Nil}>!</a>
+</body></xml>
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/unurlify.urp	Tue Oct 21 13:24:54 2008 -0400
@@ -0,0 +1,3 @@
+debug
+
+unurlify