Start of unurlify for datatypes

5 files changed, 72 insertions, 20 deletions

diff --git a/src/cjr.sml b/src/cjr.sml
index 621ccf45..b5174255 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -33,7 +33,7 @@ datatype typ' =
          TTop
        | TFun of typ * typ
        | TRecord of int
-       | TNamed of int
+       | TDatatype of int
        | TFfi of string * string
 
 withtype typ = typ' located
diff --git a/src/cjr_env.sig b/src/cjr_env.sig
index 36c3d682..5cd5cb32 100644
--- a/src/cjr_env.sig
+++ b/src/cjr_env.sig
@@ -36,8 +36,8 @@ signature CJR_ENV = sig
     exception UnboundF of int
     exception UnboundStruct of int
 
-    val pushTNamed : env -> string -> int -> Cjr.typ option -> env
-    val lookupTNamed : env -> int -> string * Cjr.typ option
+    val pushDatatype : env -> string -> int -> (string * int * Cjr.typ option) list -> env
+    val lookupDatatype : env -> int -> string * (string * int * Cjr.typ option) list
 
     val pushERel : env -> string -> Cjr.typ -> env
     val lookupERel : env -> int -> string * Cjr.typ
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index 0d34b98f..88d7972f 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -38,7 +38,7 @@ exception UnboundF of int
 exception UnboundStruct of int
 
 type env = {
-     namedT : (string * typ option) IM.map,
+     datatypes : (string * (string * int * typ option) list) IM.map,
 
      numRelE : int,
      relE : (string * typ) list,
@@ -48,7 +48,7 @@ type env = {
 }
 
 val empty = {
-    namedT = IM.empty,
+    datatypes = IM.empty,
 
     numRelE = 0,
     relE = [],
@@ -57,8 +57,8 @@ val empty = {
     structs = IM.empty
 }
 
-fun pushTNamed (env : env) x n co =
-    {namedT = IM.insert (#namedT env, n, (x, co)),
+fun pushDatatype (env : env) x n xncs =
+    {datatypes = IM.insert (#datatypes env, n, (x, xncs)),
 
      numRelE = #numRelE env,
      relE = #relE env,
@@ -66,13 +66,13 @@ fun pushTNamed (env : env) x n co =
 
      structs = #structs env}
 
-fun lookupTNamed (env : env) n =
-    case IM.find (#namedT env, n) of
+fun lookupDatatype (env : env) n =
+    case IM.find (#datatypes env, n) of
         NONE => raise UnboundNamed n
       | SOME x => x
 
 fun pushERel (env : env) x t =
-    {namedT = #namedT env,
+    {datatypes = #datatypes env,
 
      numRelE = #numRelE env + 1,
      relE = (x, t) :: #relE env,
@@ -89,7 +89,7 @@ fun countERels (env : env) = #numRelE env
 fun listERels (env : env) = #relE env
 
 fun pushENamed (env : env) x n t =
-    {namedT = #namedT env,
+    {datatypes = #datatypes env,
 
      numRelE = #numRelE env,
      relE = #relE env,
@@ -103,7 +103,7 @@ fun lookupENamed (env : env) n =
       | SOME x => x
 
 fun pushStruct (env : env) n xts =
-    {namedT = #namedT env,
+    {datatypes = #datatypes env,
 
      numRelE = #numRelE env,
      relE = #relE env,
@@ -120,10 +120,10 @@ fun declBinds env (d, loc) =
     case d of
         DDatatype (x, n, xncs) =>
         let
-            val env = pushTNamed env x n NONE
+            val env = pushDatatype env x n xncs
         in
-            foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (TNamed n, loc)
-                    | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (TNamed n, loc)), loc))
+            foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (TDatatype n, loc)
+                    | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (TDatatype n, loc)), loc))
             env xncs
         end
       | DStruct (n, xts) => pushStruct env n xts
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index c9dfc481..1aab8f02 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -53,7 +53,7 @@ structure CM = BinaryMapFn(struct
 
 val debug = ref false
 
-val dummyTyp = (TNamed 0, ErrorMsg.dummySpan)
+val dummyTyp = (TDatatype 0, ErrorMsg.dummySpan)
 
 fun p_typ' par env (t, loc) =
     case t of
@@ -69,11 +69,11 @@ fun p_typ' par env (t, loc) =
                           space,
                           string "__lws_",
                           string (Int.toString i)]
-      | TNamed n =>
+      | TDatatype n =>
         (box [string "struct",
               space,
-              string ("__lwt_" ^ #1 (E.lookupTNamed env n) ^ "_" ^ Int.toString n ^ "*")]
-         handle CjrEnv.UnboundNamed _ => string ("__lwt_UNBOUND__" ^ Int.toString n))
+              string ("__lwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")]
+         handle CjrEnv.UnboundNamed _ => string ("__lwd_UNBOUND__" ^ Int.toString n))
       | TFfi (m, x) => box [string "lw_", string m, string "_", string x]
 
 and p_typ env = p_typ' false env
@@ -445,6 +445,58 @@ fun p_file env (ds, ps) =
                          string "})"]
                 end
 
+              | TDatatype i =>
+                let
+                    val (x, xncs) = E.lookupDatatype env i
+
+                    fun doEm xncs =
+                        case xncs of
+                            [] => string "Uh oh"
+                          | (x, n, to) :: rest =>
+                            box [string "(!strcmp(request, \"",
+                                 string x,
+                                 string "\") ? ({",
+                                 newline,
+                                 string ("__lwd_" ^ x ^ "_" ^ Int.toString i),
+                                 space,
+                                 string "__lw_tmp;",
+                                 newline,
+                                 string "__lw_tmp.tag",
+                                 space,
+                                 string "=",
+                                 space,
+                                 string ("__lwc_" ^ x ^ "_" ^ Int.toString n),
+                                 string ";",
+                                 newline,
+                                 string "request",
+                                 space,
+                                 string "+=",
+                                 space,
+                                 string (Int.toString (size x)),
+                                 string ";",
+                                 newline,
+                                 case to of
+                                     NONE => box []
+                                   | SOME t => box [string "__lw_tmp.data.",
+                                                    string x,
+                                                    space,
+                                                    string "=",
+                                                    space,
+                                                    unurlify t,
+                                                    string ";",
+                                                    newline],
+                                 string "__lw_tmp;",
+                                 newline,
+                                 string "})",
+                                 space,
+                                 string ":",
+                                 space,
+                                 doEm rest,
+                                 string ")"]
+                in
+                    doEm xncs
+                end
+
               | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
                       space)
 
diff --git a/src/cjrize.sml b/src/cjrize.sml
index c60ff75f..cf32e414 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -84,7 +84,7 @@ fun cifyTyp ((t, loc), sm) =
         in
             ((L'.TRecord si, loc), sm)
         end
-      | L.TNamed n => ((L'.TNamed n, loc), sm)
+      | L.TNamed n => ((L'.TDatatype n, loc), sm)
       | L.TFfi mx => ((L'.TFfi mx, loc), sm)
 
 val dummye = (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan)