FFI datatypes

11 files changed, 128 insertions, 59 deletions

diff --git a/src/cjr.sml b/src/cjr.sml
index 4c9cf4c3..d260e8b3 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -40,7 +40,7 @@ withtype typ = typ' located
 
 datatype patCon =
          PConVar of int
-       | PConFfi of string * string
+       | PConFfi of {mod : string, datatyp : string, con : string}
 
 datatype pat' =
          PWild
@@ -55,7 +55,7 @@ datatype exp' =
          EPrim of Prim.t
        | ERel of int
        | ENamed of int
-       | ECon of int * exp option
+       | ECon of patCon * exp option
        | EFfi of string * string
        | EFfiApp of string * string * exp list
        | EApp of exp * exp
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 4a6971b0..d35c93fe 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -266,46 +266,54 @@ fun newGoto () =
     end
 end
 
+fun patConInfo env pc =
+    case pc of
+        PConVar n =>
+        let
+            val (x, _, dn) = E.lookupConstructor env n
+            val (dx, _) = E.lookupDatatype env dn
+        in
+            ("__lwd_" ^ dx ^ "_" ^ Int.toString dn,
+             "__lwc_" ^ x ^ "_" ^ Int.toString n)
+        end
+      | PConFfi {mod = m, datatyp, con} =>
+        ("lw_" ^ m ^ "_" ^ datatyp,
+         "lw_" ^ m ^ "_" ^ con)
+
 fun p_exp' par env (e, loc) =
     case e of
         EPrim p => Prim.p_t p
       | ERel n => p_rel env n
       | ENamed n => p_enamed env n
-      | ECon (n, eo) =>
+      | ECon (pc, eo) =>
         let
-            val (x, _, dn) = E.lookupConstructor env n
-            val (dx, _) = E.lookupDatatype env dn
+            val (xd, xc) = patConInfo env pc
         in
             box [string "({",
                  newline,
                  string "struct",
                  space,
-                 string "__lwd_",
-                 string dx,
-                 string "_",
-                 string (Int.toString dn),
+                 string xd,
                  space,
                  string "*tmp",
                  space,
                  string "=",
                  space,
-                 string "lw_malloc(ctx, sizeof(struct __lwd_",
-                 string dx,
-                 string "_",
-                 string (Int.toString dn),
+                 string "lw_malloc(ctx, sizeof(struct ",
+                 string xd,
                  string "));",
                  newline,
                  string "tmp->tag",
                  space,
                  string "=",
                  space,
-                 string ("__lwc_" ^ x ^ "_" ^ Int.toString n),
+                 string xc,
                  string ";",
                  newline,
                  case eo of
                      NONE => box []
-                   | SOME e => box [string "tmp->data.__lwc_",
-                                    string x,
+                   | SOME e => box [string "tmp->data.",
+                                    string xd,
                                     space,
                                     string "=",
                                     space,
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 8e410f92..eedc594e 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -143,7 +143,7 @@ fun cifyExp ((e, loc), sm) =
         L.EPrim p => ((L'.EPrim p, loc), sm)
       | L.ERel n => ((L'.ERel n, loc), sm)
       | L.ENamed n => ((L'.ENamed n, loc), sm)
-      | L.ECon (n, eo) =>
+      | L.ECon (pc, eo) =>
         let
             val (eo, sm) =
                 case eo of
@@ -155,7 +155,7 @@ fun cifyExp ((e, loc), sm) =
                         (SOME e, sm)
                     end
         in
-            ((L'.ECon (n, eo), loc), sm)
+            ((L'.ECon (cifyPatCon pc, eo), loc), sm)
         end
       | L.EFfi mx => ((L'.EFfi mx, loc), sm)
       | L.EFfiApp (m, x, es) =>
diff --git a/src/core.sml b/src/core.sml
index 257f7ed1..1ecc9691 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -61,7 +61,7 @@ withtype con = con' located
 
 datatype patCon =
          PConVar of int
-       | PConFfi of string * string
+       | PConFfi of {mod : string, datatyp : string, con : string}
 
 datatype pat' =
          PWild
@@ -76,7 +76,7 @@ datatype exp' =
          EPrim of Prim.t
        | ERel of int
        | ENamed of int
-       | ECon of int * exp option
+       | ECon of patCon * exp option
        | EFfi of string * string
        | EFfiApp of string * string * exp list
        | EApp of exp * exp
diff --git a/src/core_print.sml b/src/core_print.sml
index 520ca903..d749bdf9 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -162,11 +162,11 @@ fun p_con_named env n =
 fun p_patCon env pc =
     case pc of
         PConVar n => p_con_named env n
-      | PConFfi (m, x) => box [string "FFI(",
-                               string m,
-                               string ".",
-                               string x,
-                               string ")"]
+      | PConFfi {mod = m, con, ...} => box [string "FFI(",
+                                            string m,
+                                            string ".",
+                                            string con,
+                                            string ")"]
 
 fun p_pat' par env (p, _) =
     case p of
@@ -199,8 +199,8 @@ fun p_exp' par env (e, _) =
               string (#1 (E.lookupERel env n)))
          handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
       | ENamed n => p_enamed env n
-      | ECon (n, NONE) => p_con_named env n
-      | ECon (n, SOME e) => parenIf par (box [p_con_named env n,
+      | ECon (pc, NONE) => p_patCon env pc
+      | ECon (pc, SOME e) => parenIf par (box [p_patCon env pc,
                                               space,
                                               p_exp' true env e])
       | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
diff --git a/src/corify.sml b/src/corify.sml
index a3cbb92e..81c32f40 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -62,7 +62,7 @@ structure St : sig
 
     val enter : t -> t
     val leave : t -> {outer : t, inner : t}
-    val ffi : string -> L'.con SM.map -> t
+    val ffi : string -> L'.con SM.map -> string SM.map -> t
 
     datatype core_con =
              CNormal of int
@@ -99,7 +99,8 @@ datatype flattening =
                      strs : flattening SM.map,
                      funs : (string * int * L.str) SM.map}
        | FFfi of {mod : string,
-                  vals : L'.con SM.map}
+                  vals : L'.con SM.map,
+                  constructors : string SM.map}
                            
 type t = {
      cons : int IM.map,
@@ -258,10 +259,13 @@ fun lookupConstructorById ({constructors, ...} : t) n =
 
 fun lookupConstructorByName ({current, ...} : t) x =
     case current of
-        FFfi {mod = m, ...} => L'.PConFfi (m, x)
+        FFfi {mod = m, constructors, ...} =>
+        (case SM.find (constructors, x) of
+             NONE => raise Fail "Corify.St.lookupConstructorByName [1]"
+           | SOME n => L'.PConFfi {mod = m, datatyp = n, con = x})
       | FNormal {constructors, ...} =>
         case SM.find (constructors, x) of
-            NONE => raise Fail "Corify.St.lookupConstructorByName"
+            NONE => raise Fail "Corify.St.lookupConstructorByName [2]"
           | SOME n => n
 
 fun enter {cons, constructors, vals, strs, funs, current, nested} =
@@ -296,7 +300,7 @@ fun leave {cons, constructors, vals, strs, funs, current, nested = m1 :: rest} =
          inner = dummy current}
   | leave _ = raise Fail "Corify.St.leave"
 
-fun ffi m vals = dummy (FFfi {mod = m, vals = vals})
+fun ffi m vals constructors = dummy (FFfi {mod = m, vals = vals, constructors = constructors})
 
 fun bindStr ({cons, constructors, vals, strs, funs,
               current = FNormal {cons = mcons, constructors = mconstructors,
@@ -506,9 +510,9 @@ fun corifyDecl ((d, loc : EM.span), st) =
                                 let
                                     val (e, t) =
                                         case to of
-                                            NONE => ((L'.ECon (n, NONE), loc), t)
+                                            NONE => ((L'.ECon (L'.PConVar n, NONE), loc), t)
                                           | SOME t' => ((L'.EAbs ("x", t', t,
-                                                                  (L'.ECon (n, SOME (L'.ERel 0, loc)), loc)),
+                                                                  (L'.ECon (L'.PConVar n, SOME (L'.ERel 0, loc)), loc)),
                                                          loc),
                                                         (L'.TFun (t', t), loc))
                                 in
@@ -601,8 +605,8 @@ fun corifyDecl ((d, loc : EM.span), st) =
         (case sgn of
              L.SgnConst sgis =>
              let
-                 val (ds, cmap, st) =
-                     foldl (fn ((sgi, _), (ds, cmap, st)) =>
+                 val (ds, cmap, conmap, st) =
+                     foldl (fn ((sgi, _), (ds, cmap, conmap, st)) =>
                                case sgi of
                                    L.SgiConAbs (x, n, k) =>
                                    let
@@ -610,6 +614,7 @@ fun corifyDecl ((d, loc : EM.span), st) =
                                    in
                                        ((L'.DCon (x, n', corifyKind k, (L'.CFfi (m, x), loc)), loc) :: ds,
                                         cmap,
+                                        conmap,
                                         st)
                                    end
                                  | L.SgiCon (x, n, k, _) =>
@@ -618,16 +623,56 @@ fun corifyDecl ((d, loc : EM.span), st) =
                                    in
                                        ((L'.DCon (x, n', corifyKind k, (L'.CFfi (m, x), loc)), loc) :: ds,
                                         cmap,
+                                        conmap,
+                                        st)
+                                   end
+
+                                 | L.SgiDatatype (x, n, xnts) =>
+                                   let
+                                       val (st, n') = St.bindCon st x n
+                                       val (xnts, (st, cmap, conmap)) =
+                                           ListUtil.foldlMap
+                                               (fn ((x', n, to), (st, cmap, conmap)) =>
+                                                   let
+                                                       val st = St.bindConstructor st x' n
+                                                                                   (L'.PConFfi {mod = m,
+                                                                                                datatyp = x,
+                                                                                                con = x'})
+                                                       val st = St.bindConstructorVal st x' n
+
+                                                       val dt = (L'.CNamed n', loc)
+
+                                                       val (to, cmap) =
+                                                           case to of
+                                                               NONE => (NONE, SM.insert (cmap, x', dt))
+                                                             | SOME t =>
+                                                               let
+                                                                   val t = corifyCon st t
+                                                               in
+                                                                   (SOME t, SM.insert (cmap, x',
+                                                                                       (L'.TFun (t, dt), loc)))
+                                                               end
+
+                                                       val conmap = SM.insert (conmap, x', x)
+                                                   in
+                                                       ((x', n, to),
+                                                        (st, cmap, conmap))
+                                                   end) (st, cmap, conmap) xnts
+                                   in
+                                       ((L'.DDatatype (x, n', xnts), loc) :: ds,
+                                        cmap,
+                                        conmap,
                                         st)
                                    end
 
                                  | L.SgiVal (x, _, c) =>
                                    (ds,
                                     SM.insert (cmap, x, corifyCon st c),
+                                    conmap,
                                     st)
-                                 | _ => (ds, cmap, st)) ([], SM.empty, st) sgis
+                                 | _ => (ds, cmap, conmap, st)) ([], SM.empty, SM.empty, st) sgis
 
-                 val st = St.bindStr st m n (St.ffi m cmap)
+                 val st = St.bindStr st m n (St.ffi m cmap conmap)
              in
                  (rev ds, st)
              end
diff --git a/src/mono.sml b/src/mono.sml
index f8c7dbfe..2c55721a 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -39,7 +39,7 @@ withtype typ = typ' located
 
 datatype patCon =
          PConVar of int
-       | PConFfi of string * string
+       | PConFfi of {mod : string, datatyp : string, con : string}
 
 datatype pat' =
          PWild
@@ -54,7 +54,7 @@ datatype exp' =
          EPrim of Prim.t
        | ERel of int
        | ENamed of int
-       | ECon of int * exp option
+       | ECon of patCon * exp option
        | EFfi of string * string
        | EFfiApp of string * string * exp list
        | EApp of exp * exp
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 6fa871ec..6558115c 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -185,7 +185,6 @@ fun exp e =
       | EWrite (EFfiApp ("Basis", "urlifyString", [e]), _) =>
         EFfiApp ("Basis", "urlifyString_w", [e])
 
-
       | EWrite (ECase (discE, pes, {disc, ...}), loc) =>
         optExp (ECase (discE,
                        map (fn (p, e) => (p, (EWrite e, loc))) pes,
diff --git a/src/mono_print.sml b/src/mono_print.sml
index e069c1ec..ea8458eb 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -80,11 +80,11 @@ fun p_con_named env n =
 fun p_patCon env pc =
     case pc of
         PConVar n => p_con_named env n
-      | PConFfi (m, x) => box [string "FFI(",
-                               string m,
-                               string ".",
-                               string x,
-                               string ")"]
+      | PConFfi {mod = m, con, ...} => box [string "FFI(",
+                                            string m,
+                                            string ".",
+                                            string con,
+                                            string ")"]
 
 fun p_pat' par env (p, _) =
     case p of
@@ -117,10 +117,10 @@ fun p_exp' par env (e, _) =
               string (#1 (E.lookupERel env n)))
          handle E.UnboundRel _ => string ("UNBOUND_" ^ Int.toString n))
       | ENamed n => p_enamed env n
-      | ECon (n, NONE) => p_con_named env n
-      | ECon (n, SOME e) => parenIf par (box [p_con_named env n,
-                                              space,
-                                              p_exp' true env e])
+      | ECon (pc, NONE) => p_patCon env pc
+      | ECon (pc, SOME e) => parenIf par (box [p_patCon env pc,
+                                               space,
+                                               p_exp' true env e])
 
       | EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
       | EFfiApp (m, x, es) => box [string "FFI(",
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 07634a57..20d26547 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -79,18 +79,30 @@ fun match (env, p : pat, e : exp) =
         else
             NONE
 
-      | (PCon (PConVar n1, NONE), ECon (n2, NONE)) =>
+      | (PCon (PConVar n1, NONE), ECon (PConVar n2, NONE)) =>
         if n1 = n2 then
             SOME env
         else
             NONE
 
-      | (PCon (PConVar n1, SOME p), ECon (n2, SOME e)) =>
+      | (PCon (PConVar n1, SOME p), ECon (PConVar n2, SOME e)) =>
         if n1 = n2 then
             match (env, p, e)
         else
             NONE
 
+      | (PCon (PConFfi {mod = m1, con = con1, ...}, NONE), ECon (PConFfi {mod = m2, con = con2, ...}, NONE)) =>
+        if m1 = m2 andalso con1 = con2 then
+            SOME env
+        else
+            NONE
+
+      | (PCon (PConFfi {mod = m1, con = con1, ...}, SOME ep), ECon (PConFfi {mod = m2, con = con2, ...}, SOME e)) =>
+        if m1 = m2 andalso con1 = con2 then
+            match (env, p, e)
+        else
+            NONE
+
       | (PRecord xps, ERecord xes) =>
         let
             fun consider (xps, env) =
diff --git a/src/monoize.sml b/src/monoize.sml
index 94442132..a1d1d570 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -156,7 +156,13 @@ fun lookup (t as {count, map, decls}) k n thunk =
     end
 
 end
-                
+
+
+fun capitalize s =
+    if s = "" then
+        s
+    else
+        str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
 
 fun fooifyExp fk env =
     let
@@ -193,9 +199,7 @@ fun fooifyExp fk env =
                 end
               | _ =>
                 case t of
-                    L'.TFfi ("Basis", "string") => ((L'.EFfiApp ("Basis", fk2s fk ^ "ifyString", [e]), loc), fm)
-                  | L'.TFfi ("Basis", "int") => ((L'.EFfiApp ("Basis", fk2s fk ^ "ifyInt", [e]), loc), fm)
-                  | L'.TFfi ("Basis", "float") => ((L'.EFfiApp ("Basis", fk2s fk ^ "ifyFloat", [e]), loc), fm)
+                    L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [e]), loc), fm)
                   | L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm)
 
                   | L'.TDatatype (i, _) =>
@@ -306,7 +310,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
             L.EPrim p => ((L'.EPrim p, loc), fm)
           | L.ERel n => ((L'.ERel n, loc), fm)
           | L.ENamed n => ((L'.ENamed n, loc), fm)
-          | L.ECon (n, eo) =>
+          | L.ECon (pc, eo) =>
             let
                 val (eo, fm) =
                     case eo of
@@ -318,7 +322,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
                             (SOME e, fm)
                         end
             in
-                ((L'.ECon (n, eo), loc), fm)
+                ((L'.ECon (monoPatCon pc, eo), loc), fm)
             end
           | L.EFfi mx => ((L'.EFfi mx, loc), fm)
           | L.EFfiApp (m, x, es) =>
@@ -416,7 +420,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
 
                                           val fooify =
                                               case x of
-                                                  "Link" => urlifyExp
+                                                  "Href" => urlifyExp
+                                                | "Link" => urlifyExp
                                                 | "Action" => urlifyExp
                                                 | _ => attrifyExp