Unpolyed a polymorphic function of two arguments

7 files changed, 120 insertions, 70 deletions

diff --git a/src/cjr.sml b/src/cjr.sml
index f9155980..9b6765dc 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -64,7 +64,7 @@ datatype exp' =
        | ESome of typ * exp
        | EFfi of string * string
        | EFfiApp of string * string * exp list
-       | EApp of exp * exp
+       | EApp of exp * exp list
 
        | ERecord of int * (string * exp) list
        | EField of exp * string
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index e2bc37fa..a6eb0ffe 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -57,6 +57,11 @@ val debug = ref false
 
 val dummyTyp = (TDatatype (Enum, 0, ref []), ErrorMsg.dummySpan)
 
+val ident = String.translate (fn #"'" => "PRIME"
+                               | ch => str ch)
+
+val p_ident = string o ident
+
 fun p_typ' par env (t, loc) =
     case t of
         TFun (t1, t2) => parenIf par (box [p_typ' true env t2,
@@ -89,7 +94,7 @@ fun p_typ' par env (t, loc) =
               space,
               string ("__uwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")]
          handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n))
-      | TFfi (m, x) => box [string "uw_", string m, string "_", string x]
+      | TFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x]
       | TOption t =>
         (case #1 t of
              TDatatype _ => p_typ' par env t
@@ -99,15 +104,15 @@ fun p_typ' par env (t, loc) =
 
 and p_typ env = p_typ' false env
 
-fun p_rel env n = string ("__uwr_" ^ #1 (E.lookupERel env n) ^ "_" ^ Int.toString (E.countERels env - n - 1))
+fun p_rel env n = string ("__uwr_" ^ ident (#1 (E.lookupERel env n)) ^ "_" ^ Int.toString (E.countERels env - n - 1))
     handle CjrEnv.UnboundRel _ => string ("__uwr_UNBOUND_" ^ Int.toString (E.countERels env - n - 1))
 
 fun p_enamed env n =
-    string ("__uwn_" ^ #1 (E.lookupENamed env n) ^ "_" ^ Int.toString n)
+    string ("__uwn_" ^ ident (#1 (E.lookupENamed env n)) ^ "_" ^ Int.toString n)
     handle CjrEnv.UnboundNamed _ => string ("__uwn_UNBOUND_" ^ Int.toString n)
 
 fun p_con_named env n =
-    string ("__uwc_" ^ #1 (E.lookupConstructor env n) ^ "_" ^ Int.toString n)
+    string ("__uwc_" ^ ident (#1 (E.lookupConstructor env n)) ^ "_" ^ Int.toString n)
     handle CjrEnv.UnboundNamed _ => string ("__uwc_UNBOUND_" ^ Int.toString n)
 
 fun p_pat_preamble env (p, _) =
@@ -117,7 +122,7 @@ fun p_pat_preamble env (p, _) =
       | PVar (x, t) => (box [p_typ env t,
                              space,
                              string "__uwr_",
-                             string x,
+                             p_ident x,
                              string "_",
                              string (Int.toString (E.countERels env)),
                              string ";",
@@ -139,7 +144,7 @@ fun p_pat_preamble env (p, _) =
 fun p_patCon env pc =
     case pc of
         PConVar n => p_con_named env n
-      | PConFfi {mod = m, con, ...} => string ("uw_" ^ m ^ "_" ^ con)
+      | PConFfi {mod = m, con, ...} => string ("uw_" ^ ident m ^ "_" ^ ident con)
 
 fun p_pat (env, exit, depth) (p, _) =
     case p of
@@ -147,7 +152,7 @@ fun p_pat (env, exit, depth) (p, _) =
         (box [], env)
       | PVar (x, t) =>
         (box [string "__uwr_",
-              string x,
+              p_ident x,
               string "_",
               string (Int.toString (E.countERels env)),
               space,
@@ -198,10 +203,10 @@ fun p_pat (env, exit, depth) (p, _) =
                                           let
                                               val (x, to, _) = E.lookupConstructor env n
                                           in
-                                              ("uw_" ^ x, to)
+                                              ("uw_" ^ ident x, to)
                                           end
                                         | PConFfi {mod = m, con, arg, ...} =>
-                                          ("uw_" ^ m ^ "_" ^ con, arg)
+                                          ("uw_" ^ ident m ^ "_" ^ ident con, arg)
 
                         val t = case to of
                                     NONE => raise Fail "CjrPrint: Constructor mismatch"
@@ -287,7 +292,7 @@ fun p_pat (env, exit, depth) (p, _) =
                                                        string "disc",
                                                        string (Int.toString depth),
                                                        string ".__uwf_",
-                                                       string x,
+                                                       p_ident x,
                                                        string ";",
                                                        newline,
                                                        p,
@@ -379,14 +384,14 @@ fun patConInfo env pc =
             val (x, _, dn) = E.lookupConstructor env n
             val (dx, _) = E.lookupDatatype env dn
         in
-            ("__uwd_" ^ dx ^ "_" ^ Int.toString dn,
-             "__uwc_" ^ x ^ "_" ^ Int.toString n,
-             "uw_" ^ x)
+            ("__uwd_" ^ ident dx ^ "_" ^ Int.toString dn,
+             "__uwc_" ^ ident x ^ "_" ^ Int.toString n,
+             "uw_" ^ ident x)
         end
       | PConFfi {mod = m, datatyp, con, ...} =>
-        ("uw_" ^ m ^ "_" ^ datatyp,
-         "uw_" ^ m ^ "_" ^ con,
-         "uw_" ^ con)
+        ("uw_" ^ ident m ^ "_" ^ ident datatyp,
+         "uw_" ^ ident m ^ "_" ^ ident con,
+         "uw_" ^ ident con)
 
 fun p_unsql env (tAll as (t, loc)) e =
     case t of
@@ -545,7 +550,7 @@ fun p_exp' par env (e, loc) =
                        newline,
                        string "})"])
 
-      | EFfi (m, x) => box [string "uw_", string m, string "_", string x]
+      | EFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x]
       | EError (e, t) =>
         box [string "({",
              newline,
@@ -563,27 +568,18 @@ fun p_exp' par env (e, loc) =
              newline,
              string "})"]
       | EFfiApp (m, x, es) => box [string "uw_",
-                                   string m,
+                                   p_ident m,
                                    string "_",
-                                   string x,
+                                   p_ident x,
                                    string "(ctx, ",
                                    p_list (p_exp env) es,
                                    string ")"]
-      | EApp (e1, e2) =>
-        let
-            fun unravel (f, acc) =
-                case #1 f of
-                    EApp (f', arg) => unravel (f', arg :: acc)
-                  | _ => (f, acc)
-
-            val (f, args) = unravel (e1, [e2])
-        in
-            parenIf par (box [p_exp' true env e1,
-                              string "(ctx,",
-                              space,
-                              p_list_sep (box [string ",", space]) (p_exp env) args,
-                              string ")"])
-        end
+      | EApp (f, args) =>
+        parenIf par (box [p_exp' true env f,
+                          string "(ctx,",
+                          space,
+                          p_list_sep (box [string ",", space]) (p_exp env) args,
+                          string ")"])
 
       | ERecord (i, xes) => box [string "({",
                                  space,
@@ -606,7 +602,7 @@ fun p_exp' par env (e, loc) =
       | EField (e, x) =>
         box [p_exp' true env e,
              string ".__uwf_",
-             string x]
+             p_ident x]
 
       | ECase (e, pes, {disc, result}) =>
         let
@@ -692,7 +688,7 @@ fun p_exp' par env (e, loc) =
                                     p_typ env t,
                                     space,
                                     string "__uwr_",
-                                    string x,
+                                    p_ident x,
                                     string "_",
                                     string (Int.toString (E.countERels env)),
                                     space,
@@ -708,9 +704,9 @@ fun p_exp' par env (e, loc) =
 
       | EQuery {exps, tables, rnum, state, query, body, initial, prepared} =>
         let
-            val exps = map (fn (x, t) => ("__uwf_" ^ x, t)) exps
+            val exps = map (fn (x, t) => ("__uwf_" ^ ident x, t)) exps
             val tables = ListUtil.mapConcat (fn (x, xts) =>
-                                                map (fn (x', t) => ("__uwf_" ^ x ^ ".__uwf_" ^ x', t)) xts)
+                                                map (fn (x', t) => ("__uwf_" ^ ident x ^ ".__uwf_" ^ ident x', t)) xts)
                                             tables
                                                                                               
             val outputs = exps @ tables
@@ -945,7 +941,7 @@ fun p_fun env (fx, n, args, ran, e) =
              space,
              p_typ env ran,
              space,
-             string ("__uwn_" ^ fx ^ "_" ^ Int.toString n),
+             string ("__uwn_" ^ ident fx ^ "_" ^ Int.toString n),
              string "(",
              p_list_sep (box [string ",", space]) (fn x => x)
                         (string "uw_context ctx" :: ListUtil.mapi (fn (i, (_, dom)) =>
@@ -978,7 +974,7 @@ fun p_decl env (dAll as (d, _) : decl) =
                  p_list_sep (box []) (fn (x, t) => box [p_typ env t,
                                                         space,
                                                         string "__uwf_",
-                                                        string x,
+                                                        p_ident x,
                                                         string ";",
                                                         newline]) xts,
                  string "};"]
@@ -986,11 +982,12 @@ fun p_decl env (dAll as (d, _) : decl) =
       | DDatatype (Enum, x, n, xncs) =>
         box [string "enum",
              space,
-             string ("__uwe_" ^ x ^ "_" ^ Int.toString n),
+             string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
              space,
              string "{",
              space,
-             p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__uwc_" ^ x ^ "_" ^ Int.toString n)) xncs,
+             p_list_sep (box [string ",", space]) (fn (x, n, _) =>
+                                                      string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n)) xncs,
              space,
              string "};"]
       | DDatatype (Option, _, _, _) => box []
@@ -1001,24 +998,25 @@ fun p_decl env (dAll as (d, _) : decl) =
         in
             box [string "enum",
                  space,
-                 string ("__uwe_" ^ x ^ "_" ^ Int.toString n),
+                 string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
                  space,
                  string "{",
                  space,
-                 p_list_sep (box [string ",", space]) (fn (x, n, _) => string ("__uwc_" ^ x ^ "_" ^ Int.toString n)) xncs,
+                 p_list_sep (box [string ",", space]) (fn (x, n, _) =>
+                                                          string ("__uwc_" ^ ident x ^ "_" ^ Int.toString n)) xncs,
                  space,
                  string "};",
                  newline,
                  newline,
                  string "struct",
                  space,
-                 string ("__uwd_" ^ x ^ "_" ^ Int.toString n),
+                 string ("__uwd_" ^ ident x ^ "_" ^ Int.toString n),
                  space,
                  string "{",
                  newline,
                  string "enum",
                  space,
-                 string ("__uwe_" ^ x ^ "_" ^ Int.toString n),
+                 string ("__uwe_" ^ ident x ^ "_" ^ Int.toString n),
                  space,
                  string "tag;",
                  newline,
@@ -1030,7 +1028,7 @@ fun p_decl env (dAll as (d, _) : decl) =
                                 newline,
                                 p_list_sep newline (fn (x, n, t) => box [p_typ env t,
                                                                          space,
-                                                                         string ("uw_" ^ x),
+                                                                         string ("uw_" ^ ident x),
                                                                          string ";"]) xncsArgs,
                                 newline,
                                 string "}",
@@ -1045,7 +1043,7 @@ fun p_decl env (dAll as (d, _) : decl) =
       | DVal (x, n, t, e) =>
         box [p_typ env t,
              space,
-             string ("__uwn_" ^ x ^ "_" ^ Int.toString n),
+             string ("__uwn_" ^ ident x ^ "_" ^ Int.toString n),
              space,
              string "=",
              space,
@@ -1061,7 +1059,7 @@ fun p_decl env (dAll as (d, _) : decl) =
                                              space,
                                              p_typ env ran,
                                              space,
-                                             string ("__uwn_" ^ fx ^ "_" ^ Int.toString n),
+                                             string ("__uwn_" ^ ident fx ^ "_" ^ Int.toString n),
                                              string "(uw_context,",
                                              space,
                                              p_list_sep (box [string ",", space])
@@ -1314,7 +1312,7 @@ fun p_file env (ds, ps) =
 
         fun unurlify (t, loc) =
             case t of
-                TFfi (m, t) => string ("uw_" ^ m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)")
+                TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)")
 
               | TRecord 0 => string "uw_unit_v"
               | TRecord i =>
@@ -1370,7 +1368,7 @@ fun p_file env (ds, ps) =
                                  string (Int.toString (size x')),
                                  string "] == 0 || request[",
                                  string (Int.toString (size x')),
-                                 string ("] == '/')) ? __uwc_" ^ x' ^ "_" ^ Int.toString n),
+                                 string ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n),
                                  space,
                                  string ":",
                                  space,
@@ -1475,7 +1473,7 @@ fun p_file env (ds, ps) =
                                  newline,
                                  string "struct",
                                  space,
-                                 string ("__uwd_" ^ x ^ "_" ^ Int.toString i),
+                                 string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i),
                                  space,
                                  string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_",
                                  string x,
@@ -1487,7 +1485,7 @@ fun p_file env (ds, ps) =
                                  space,
                                  string "=",
                                  space,
-                                 string ("__uwc_" ^ x' ^ "_" ^ Int.toString n),
+                                 string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n),
                                  string ";",
                                  newline,
                                  string "request",
@@ -1502,7 +1500,7 @@ fun p_file env (ds, ps) =
                                  case to of
                                      NONE => box []
                                    | SOME t => box [string "tmp->data.uw_",
-                                                    string x',
+                                                    p_ident x',
                                                     space,
                                                     string "=",
                                                     space,
@@ -1540,7 +1538,7 @@ fun p_file env (ds, ps) =
                                  box [box (map (fn (x, t) => box [p_typ env t,
                                                                   space,
                                                                   string "uw_input_",
-                                                                  string x,
+                                                                  p_ident x,
                                                                   string ";",
                                                                   newline]) xts),
                                       newline,
@@ -1571,7 +1569,7 @@ fun p_file env (ds, ps) =
                                                             string "}",
                                                             newline,
                                                             string "uw_input_",
-                                                            string x,
+                                                            p_ident x,
                                                             space,
                                                             string "=",
                                                             space,
@@ -1587,7 +1585,7 @@ fun p_file env (ds, ps) =
                                       string "= {",
                                       newline,
                                       box (map (fn (x, _) => box [string "uw_input_",
-                                                                  string x,
+                                                                  p_ident x,
                                                                   string ",",
                                                                   newline]) xts),
                                       string "};",
@@ -1671,7 +1669,7 @@ fun p_file env (ds, ps) =
                                                               (map (fn (x, t) =>
                                                                        String.concat ["(attname = 'uw_",
                                                                                       CharVector.map
-                                                                                          Char.toLower x,
+                                                                                          Char.toLower (ident x),
                                                                                       "' AND atttypid = (SELECT oid FROM pg_type",
                                                                                       " WHERE typname = '",
                                                                                       p_sqltype' env t,
diff --git a/src/cjrize.sml b/src/cjrize.sml
index d6d7ba5e..9e426751 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -233,10 +233,17 @@ fun cifyExp (eAll as (e, loc), sm) =
         end
       | L.EApp (e1, e2) =>
         let
-            val (e1, sm) = cifyExp (e1, sm)
-            val (e2, sm) = cifyExp (e2, sm)
+            fun unravel (e, args) =
+                case e of
+                    (L.EApp (e1, e2), _) => unravel (e1, e2 :: args)
+                  | _ => (e, args)
+
+            val (f, es) = unravel (e1, [e2])
+
+            val (f, sm) = cifyExp (f, sm)
+            val (es, sm) = ListUtil.foldlMap cifyExp sm es
         in
-            ((L'.EApp (e1, e2), loc), sm)
+            ((L'.EApp (f, es), loc), sm)
         end
       | L.EAbs _ => (ErrorMsg.errorAt loc "Anonymous function remains at code generation";
                      Print.prefaces' [("Function", MonoPrint.p_exp MonoEnv.empty eAll)];
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 11a52a4c..e538f54e 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -95,6 +95,21 @@ fun subExpInExp (n, e1) e2 =
 
 fun typ c = c
 
+val swapExpVars =
+    U.Exp.mapB {typ = fn t => t,
+                exp = fn lower => fn e =>
+                                     case e of
+                                         ERel xn =>
+                                         if xn = lower then
+                                             ERel (lower + 1)
+                                         else if xn = lower + 1 then
+                                             ERel lower
+                                         else
+                                             e
+                                       | _ => e,
+                bind = fn (lower, U.Exp.RelE _) => lower+1
+                        | (lower, _) => lower}
+
 datatype result = Yes of E.env | No | Maybe
 
 fun match (env, p : pat, e : exp) =
@@ -208,6 +223,10 @@ fun exp env e =
       | 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)) =>
+        EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e, swapExpVars 0 e'), loc))
+
       | ELet (x, t, e', b) =>
         if impure e' then
             e
diff --git a/src/prepare.sml b/src/prepare.sml
index bb1af6cc..a6b6a4f3 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -74,12 +74,12 @@ fun prepExp (e as (_, loc), sns) =
         in
             ((EFfiApp (m, x, es), loc), sns)
         end
-      | EApp (e1, e2) =>
+      | EApp (e1, es) =>
         let
             val (e1, sns) = prepExp (e1, sns)
-            val (e2, sns) = prepExp (e2, sns)
+            val (es, sns) = ListUtil.foldlMap prepExp sns es
         in
-            ((EApp (e1, e2), loc), sns)
+            ((EApp (e1, es), loc), sns)
         end
 
       | ERecord (rn, xes) =>
diff --git a/src/unpoly.sml b/src/unpoly.sml
index 917a8cc8..12cff6c8 100644
--- a/src/unpoly.sml
+++ b/src/unpoly.sml
@@ -46,6 +46,19 @@ val subConInCon = E.subConInCon
 val liftConInExp = E.liftConInExp
 val subConInExp = E.subConInExp
 
+fun unpolyNamed (xn, rep) =
+    U.Exp.map {kind = fn k => k,
+               con = fn c => c,
+               exp = fn e =>
+                        case e of
+                            ENamed xn' =>
+                            if xn' = xn then
+                                rep
+                            else
+                                e
+                          | ECApp (e, _) => #1 e
+                          | _ => e}
+
 type state = {
      funcs : (kind list * (string * int * con * exp * string) list) IM.map,
      decls : decl list,
@@ -93,7 +106,14 @@ fun exp (e, st : state) =
                                         in
                                             trim (t, e, cargs)
                                         end
-                                      | (_, _, []) => SOME (t, e)
+                                      | (_, _, []) =>
+                                        let
+                                            val e = foldl (fn ((_, n, n_old, _, _, _), e) =>
+                                                              unpolyNamed (n_old, ENamed n) e)
+                                                    e vis
+                                        in
+                                            SOME (t, e)
+                                        end
                                       | _ => NONE
                             in
                                 (*Print.prefaces "specialize"
@@ -106,19 +126,25 @@ fun exp (e, st : state) =
 
                         val vis = List.map specialize vis
                     in
-                        if List.exists (not o Option.isSome) vis then
+                        if List.exists (not o Option.isSome) vis orelse length cargs > length ks then
                             (e, st)
                         else
                             let
                                 val vis = List.mapPartial (fn x => x) vis
+                                val vis = map (fn (x, n, n_old, t, e, s) =>
+                                                   (x ^ "_unpoly", n, n_old, t, e, s)) vis
                                 val vis' = map (fn (x, n, _, t, e, s) =>
-                                                   (x ^ "_unpoly", n, t, e, s)) vis
+                                                   (x, n, t, e, s)) vis
+
+                                val ks' = List.drop (ks, length cargs)
                             in
                                 case List.find (fn (_, _, n_old, _, _, _) => n_old = n) vis of
                                     NONE => raise Fail "Unpoly: Inconsistent 'val rec' record"
                                   | SOME (_, n, _, _, _, _) =>
                                     (ENamed n,
-                                     {funcs = #funcs st,
+                                     {funcs = foldl (fn (vi, funcs) =>
+                                                        IM.insert (funcs, #2 vi, (ks', vis')))
+                                                    (#funcs st) vis',
                                       decls = (DValRec vis', ErrorMsg.dummySpan) :: #decls st,
                                       nextName = nextName})
                             end
diff --git a/src/urweb.lex b/src/urweb.lex
index 1e7876b4..9cb4d642 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -112,7 +112,7 @@ fun initialize () = (xmlTag := [];
 %s COMMENT STRING XML XMLTAG;
 
 id = [a-z_][A-Za-z0-9_']*;
-cid = [A-Z][A-Za-z0-9_']*;
+cid = [A-Z][A-Za-z0-9_]*;
 ws = [\ \t\012];
 intconst = [0-9]+;
 realconst = [0-9]+\.[0-9]*;