summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/cjr.sml2
-rw-r--r--src/cjr_env.sml4
-rw-r--r--src/cjr_print.sml6
-rw-r--r--src/cjrize.sml16
-rw-r--r--src/core_env.sig3
-rw-r--r--src/core_env.sml27
-rw-r--r--src/mono.sml2
-rw-r--r--src/mono_env.sig4
-rw-r--r--src/mono_env.sml22
-rw-r--r--src/mono_print.sml8
-rw-r--r--src/mono_reduce.sml2
-rw-r--r--src/mono_shake.sml2
-rw-r--r--src/mono_util.sig2
-rw-r--r--src/mono_util.sml14
-rw-r--r--src/monoize.sml13
15 files changed, 89 insertions, 38 deletions
diff --git a/src/cjr.sml b/src/cjr.sml
index b5174255..59f5cb2f 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -33,7 +33,7 @@ datatype typ' =
TTop
| TFun of typ * typ
| TRecord of int
- | TDatatype of int
+ | TDatatype of int * (string * int * typ option) list
| TFfi of string * string
withtype typ = typ' located
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index 88d7972f..84f13f4d 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -122,8 +122,8 @@ fun declBinds env (d, loc) =
let
val env = pushDatatype env x n xncs
in
- 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))
+ foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (TDatatype (n, xncs), loc)
+ | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (TDatatype (n, xncs), 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 ab102800..b0ea7214 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 = (TDatatype 0, ErrorMsg.dummySpan)
+val dummyTyp = (TDatatype (0, []), ErrorMsg.dummySpan)
fun p_typ' par env (t, loc) =
case t of
@@ -69,7 +69,7 @@ fun p_typ' par env (t, loc) =
space,
string "__lws_",
string (Int.toString i)]
- | TDatatype n =>
+ | TDatatype (n, _) =>
(box [string "struct",
space,
string ("__lwd_" ^ #1 (E.lookupDatatype env n) ^ "_" ^ Int.toString n ^ "*")]
@@ -445,7 +445,7 @@ fun p_file env (ds, ps) =
string "})"]
end
- | TDatatype i =>
+ | TDatatype (i, _) =>
let
val (x, xncs) = E.lookupDatatype env i
diff --git a/src/cjrize.sml b/src/cjrize.sml
index cf32e414..a4f35723 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -84,7 +84,21 @@ fun cifyTyp ((t, loc), sm) =
in
((L'.TRecord si, loc), sm)
end
- | L.TNamed n => ((L'.TDatatype n, loc), sm)
+ | L.TDatatype (n, xncs) =>
+ let
+ val (xncs, sm) = ListUtil.foldlMap (fn ((x, n, to), sm) =>
+ case to of
+ NONE => ((x, n, NONE), sm)
+ | SOME t =>
+ let
+ val (t, sm) = cifyTyp (t, sm)
+ in
+ ((x, n, SOME t), sm)
+ end)
+ sm xncs
+ in
+ ((L'.TDatatype (n, xncs), loc), sm)
+ end
| L.TFfi mx => ((L'.TFfi mx, loc), sm)
val dummye = (L'.EPrim (Prim.Int 0), ErrorMsg.dummySpan)
diff --git a/src/core_env.sig b/src/core_env.sig
index 59087ace..b2005fa8 100644
--- a/src/core_env.sig
+++ b/src/core_env.sig
@@ -42,6 +42,9 @@ signature CORE_ENV = sig
val pushCNamed : env -> string -> int -> Core.kind -> Core.con option -> env
val lookupCNamed : env -> int -> string * Core.kind * Core.con option
+ val pushDatatype : env -> string -> int -> (string * int * Core.con option) list -> env
+ val lookupDatatype : env -> int -> string * (string * int * Core.con option) list
+
val pushERel : env -> string -> Core.con -> env
val lookupERel : env -> int -> string * Core.con
diff --git a/src/core_env.sml b/src/core_env.sml
index 8973c96e..cb10a354 100644
--- a/src/core_env.sml
+++ b/src/core_env.sml
@@ -61,6 +61,8 @@ type env = {
relC : (string * kind) list,
namedC : (string * kind * con option) IM.map,
+ datatypes : (string * (string * int * con option) list) IM.map,
+
relE : (string * con) list,
namedE : (string * con * exp option * string) IM.map
}
@@ -69,6 +71,8 @@ val empty = {
relC = [],
namedC = IM.empty,
+ datatypes = IM.empty,
+
relE = [],
namedE = IM.empty
}
@@ -77,6 +81,8 @@ fun pushCRel (env : env) x k =
{relC = (x, k) :: #relC env,
namedC = IM.map (fn (x, k, co) => (x, k, Option.map lift co)) (#namedC env),
+ datatypes = #datatypes env,
+
relE = map (fn (x, c) => (x, lift c)) (#relE env),
namedE = IM.map (fn (x, c, eo, s) => (x, lift c, eo, s)) (#namedE env)}
@@ -88,6 +94,8 @@ fun pushCNamed (env : env) x n k co =
{relC = #relC env,
namedC = IM.insert (#namedC env, n, (x, k, co)),
+ datatypes = #datatypes env,
+
relE = #relE env,
namedE = #namedE env}
@@ -96,10 +104,26 @@ fun lookupCNamed (env : env) n =
NONE => raise UnboundNamed n
| SOME x => x
+fun pushDatatype (env : env) x n xncs =
+ {relC = #relC env,
+ namedC = #namedC env,
+
+ datatypes = IM.insert (#datatypes env, n, (x, xncs)),
+
+ relE = #relE env,
+ namedE = #namedE env}
+
+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 =
{relC = #relC env,
namedC = #namedC env,
+ datatypes = #datatypes env,
+
relE = (x, t) :: #relE env,
namedE = #namedE env}
@@ -111,6 +135,8 @@ fun pushENamed (env : env) x n t eo s =
{relC = #relC env,
namedC = #namedC env,
+ datatypes = #datatypes env,
+
relE = #relE env,
namedE = IM.insert (#namedE env, n, (x, t, eo, s))}
@@ -124,6 +150,7 @@ fun declBinds env (d, loc) =
DCon (x, n, k, c) => pushCNamed env x n k (SOME c)
| DDatatype (x, n, xncs) =>
let
+ val env = pushDatatype env x n xncs
val env = pushCNamed env x n (KType, loc) NONE
in
foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (CNamed n, loc) NONE ""
diff --git a/src/mono.sml b/src/mono.sml
index cdfcecd3..b1636775 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -32,7 +32,7 @@ type 'a located = 'a ErrorMsg.located
datatype typ' =
TFun of typ * typ
| TRecord of (string * typ) list
- | TNamed of int
+ | TDatatype of int * (string * int * typ option) list
| TFfi of string * string
withtype typ = typ' located
diff --git a/src/mono_env.sig b/src/mono_env.sig
index e1e78b48..e3ff94b6 100644
--- a/src/mono_env.sig
+++ b/src/mono_env.sig
@@ -34,8 +34,8 @@ signature MONO_ENV = sig
exception UnboundRel of int
exception UnboundNamed of int
- val pushTNamed : env -> string -> int -> Mono.typ option -> env
- val lookupTNamed : env -> int -> string * Mono.typ option
+ val pushDatatype : env -> string -> int -> (string * int * Mono.typ option) list -> env
+ val lookupDatatype : env -> int -> string * (string * int * Mono.typ option) list
val pushERel : env -> string -> Mono.typ -> env
val lookupERel : env -> int -> string * Mono.typ
diff --git a/src/mono_env.sml b/src/mono_env.sml
index 00f31c16..3a6a20ba 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.sml
@@ -36,32 +36,32 @@ exception UnboundRel of int
exception UnboundNamed of int
type env = {
- namedT : (string * typ option) IM.map,
+ datatypes : (string * (string * int * typ option) list) IM.map,
relE : (string * typ) list,
namedE : (string * typ * exp option * string) IM.map
}
val empty = {
- namedT = IM.empty,
+ datatypes = IM.empty,
relE = [],
namedE = 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)),
relE = #relE env,
namedE = #namedE 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,
relE = (x, t) :: #relE env,
namedE = #namedE env}
@@ -71,7 +71,7 @@ fun lookupERel (env : env) n =
handle Subscript => raise UnboundRel n
fun pushENamed (env : env) x n t eo s =
- {namedT = #namedT env,
+ {datatypes = #datatypes env,
relE = #relE env,
namedE = IM.insert (#namedE env, n, (x, t, eo, s))}
@@ -85,10 +85,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) NONE ""
- | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (TNamed n, loc)), loc) NONE "")
+ foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (TDatatype (n, xncs), loc) NONE ""
+ | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (TDatatype (n, xncs), loc)), loc) NONE "")
env xncs
end
| DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 4ab38af3..04380a19 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -53,11 +53,11 @@ fun p_typ' par env (t, _) =
space,
p_typ env t]) xcs,
string "}"]
- | TNamed n =>
+ | TDatatype (n, _) =>
if !debug then
- string (#1 (E.lookupTNamed env n) ^ "__" ^ Int.toString n)
+ string (#1 (E.lookupDatatype env n) ^ "__" ^ Int.toString n)
else
- string (#1 (E.lookupTNamed env n))
+ string (#1 (E.lookupDatatype env n))
| TFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
and p_typ env = p_typ' false env
@@ -164,7 +164,7 @@ fun p_vali env (x, n, t, e, s) =
fun p_datatype env (x, n, cons) =
let
- val env = E.pushTNamed env x n NONE
+ val env = E.pushDatatype env x n cons
in
box [string "datatype",
space,
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index d5ea58c6..9b9d8f6a 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -62,7 +62,7 @@ val subExpInExp =
fun bind (env, b) =
case b of
- U.Decl.NamedT (x, n, co) => E.pushTNamed env x n co
+ U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs
| U.Decl.RelE (x, t) => E.pushERel env x t
| U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s
diff --git a/src/mono_shake.sml b/src/mono_shake.sml
index 490c33c8..55054f15 100644
--- a/src/mono_shake.sml
+++ b/src/mono_shake.sml
@@ -56,7 +56,7 @@ fun shake file =
fun typ (c, s) =
case c of
- TNamed n =>
+ TDatatype (n, _) =>
if IS.member (#con s, n) then
s
else
diff --git a/src/mono_util.sig b/src/mono_util.sig
index 4a48671d..4e9d5d91 100644
--- a/src/mono_util.sig
+++ b/src/mono_util.sig
@@ -45,7 +45,7 @@ end
structure Exp : sig
datatype binder =
- NamedT of string * int * Mono.typ option
+ Datatype of string * int * (string * int * Mono.typ option) list
| RelE of string * Mono.typ
| NamedE of string * int * Mono.typ * Mono.exp option * string
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 1232e7dd..a75a0c31 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -57,7 +57,7 @@ fun compare ((t1, _), (t2, _)) =
in
joinL compareFields (xts1, xts2)
end
- | (TNamed n1, TNamed n2) => Int.compare (n1, n2)
+ | (TDatatype (n1, _), TDatatype (n2, _)) => Int.compare (n1, n2)
| (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2))
| (TFun _, _) => LESS
@@ -66,8 +66,8 @@ fun compare ((t1, _), (t2, _)) =
| (TRecord _, _) => LESS
| (_, TRecord _) => GREATER
- | (TNamed _, _) => LESS
- | (_, TNamed _) => GREATER
+ | (TDatatype _, _) => LESS
+ | (_, TDatatype _) => GREATER
and compareFields ((x1, t1), (x2, t2)) =
join (String.compare (x1, x2),
@@ -95,7 +95,7 @@ fun mapfold fc =
(x, t')))
xts,
fn xts' => (TRecord xts', loc))
- | TNamed _ => S.return2 cAll
+ | TDatatype _ => S.return2 cAll
| TFfi _ => S.return2 cAll
in
mft
@@ -125,7 +125,7 @@ end
structure Exp = struct
datatype binder =
- NamedT of string * int * typ option
+ Datatype of string * int * (string * int * typ option) list
| RelE of string * typ
| NamedE of string * int * typ * exp option * string
@@ -324,8 +324,8 @@ fun mapfoldB (all as {bind, ...}) =
case #1 d' of
DDatatype (x, n, xncs) =>
let
- val ctx = bind (ctx, NamedT (x, n, NONE))
- val t = (TNamed n, #2 d')
+ val ctx = bind (ctx, Datatype (x, n, xncs))
+ val t = (TDatatype (n, xncs), #2 d')
in
foldl (fn ((x, n, to), ctx) =>
let
diff --git a/src/monoize.sml b/src/monoize.sml
index e45597b2..c8060937 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -33,7 +33,7 @@ structure Env = CoreEnv
structure L = Core
structure L' = Mono
-val dummyTyp = (L'.TNamed 0, E.dummySpan)
+val dummyTyp = (L'.TDatatype (0, []), E.dummySpan)
fun monoName env (all as (c, loc)) =
let
@@ -65,7 +65,14 @@ fun monoType env (all as (c, loc)) =
(L'.TFfi ("Basis", "string"), loc)
| L.CRel _ => poly ()
- | L.CNamed n => (L'.TNamed n, loc)
+ | L.CNamed n =>
+ let
+ val (_, xncs) = Env.lookupDatatype env n
+
+ val xncs = map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs
+ in
+ (L'.TDatatype (n, xncs), loc)
+ end
| L.CFfi mx => (L'.TFfi mx, loc)
| L.CApp _ => poly ()
| L.CAbs _ => poly ()
@@ -115,7 +122,7 @@ fun fooifyExp name env =
| L'.TFfi ("Basis", "float") => (L'.EFfiApp ("Basis", name ^ "ifyFloat", [e]), loc)
| L'.TRecord [] => (L'.EPrim (Prim.String ""), loc)
- | L'.TNamed _ => (L'.EPrim (Prim.String "A"), loc)
+ | L'.TDatatype _ => (L'.EPrim (Prim.String "A"), loc)
| _ => (E.errorAt loc "Don't know how to encode attribute type";
Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];