summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/compiler.sml2
-rw-r--r--src/core.sml1
-rw-r--r--src/core_env.sml10
-rw-r--r--src/core_print.sml19
-rw-r--r--src/core_util.sml24
-rw-r--r--src/corify.sml60
-rw-r--r--src/expl_print.sml6
-rw-r--r--src/monoize.sml1
-rw-r--r--src/shake.sml7
-rw-r--r--src/tag.sml1
-rw-r--r--tests/datatypeMod.lac16
11 files changed, 135 insertions, 12 deletions
diff --git a/src/compiler.sml b/src/compiler.sml
index abf9bff5..eadb58d7 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -342,7 +342,7 @@ fun testTag job =
print ("Unbound named " ^ Int.toString n ^ "\n")
fun testReduce job =
- (case tag job of
+ (case reduce job of
NONE => print "Failed\n"
| SOME file =>
(Print.print (CorePrint.p_file CoreEnv.empty file);
diff --git a/src/core.sml b/src/core.sml
index f994d177..b16766b3 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -87,6 +87,7 @@ datatype export_kind =
datatype decl' =
DCon of string * int * kind * con
+ | DDatatype of string * int * (string * int * con option) list
| DVal of string * int * con * exp * string
| DValRec of (string * int * con * exp * string) list
| DExport of export_kind * int
diff --git a/src/core_env.sml b/src/core_env.sml
index c92690bf..8973c96e 100644
--- a/src/core_env.sml
+++ b/src/core_env.sml
@@ -119,9 +119,17 @@ fun lookupENamed (env : env) n =
NONE => raise UnboundNamed n
| SOME x => x
-fun declBinds env (d, _) =
+fun declBinds env (d, loc) =
case d of
DCon (x, n, k, c) => pushCNamed env x n k (SOME c)
+ | DDatatype (x, n, xncs) =>
+ let
+ val env = pushCNamed env x n (KType, loc) NONE
+ in
+ foldl (fn ((x', n', NONE), env) => pushENamed env x' n' (CNamed n, loc) NONE ""
+ | ((x', n', SOME t), env) => pushENamed env x' n' (TFun (t, (CNamed n, loc)), loc) NONE "")
+ env xncs
+ end
| DVal (x, n, t, e, s) => pushENamed env x n t (SOME e) s
| DValRec vis => foldl (fn ((x, n, t, e, s), env) => pushENamed env x n t NONE s) env vis
| DExport _ => env
diff --git a/src/core_print.sml b/src/core_print.sml
index 364f9c06..28080bfa 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -290,6 +290,24 @@ fun p_export_kind ck =
Link => string "link"
| Action => string "action"
+fun p_datatype env (x, n, cons) =
+ let
+ val env = E.pushCNamed env x n (KType, ErrorMsg.dummySpan) NONE
+ in
+ box [string "datatype",
+ space,
+ string x,
+ space,
+ string "=",
+ space,
+ p_list_sep (box [space, string "|", space])
+ (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
+ else string x
+ | (x, _, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
+ else string x, space, string "of", space, p_con env t])
+ cons]
+ end
+
fun p_decl env (dAll as (d, _) : decl) =
case d of
DCon (x, n, k, c) =>
@@ -313,6 +331,7 @@ fun p_decl env (dAll as (d, _) : decl) =
space,
p_con env c]
end
+ | DDatatype x => p_datatype env x
| DVal vi => box [string "val",
space,
p_vali env vi]
diff --git a/src/core_util.sml b/src/core_util.sml
index 1964ce9d..95c4f10f 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -390,6 +390,15 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} =
S.map2 (mfc ctx c,
fn c' =>
(DCon (x, n, k', c'), loc)))
+ | DDatatype (x, n, xncs) =>
+ S.map2 (ListUtil.mapfold (fn (x, n, c) =>
+ case c of
+ NONE => S.return2 (x, n, c)
+ | SOME c =>
+ S.map2 (mfc ctx c,
+ fn c' => (x, n, SOME c'))) xncs,
+ fn xncs' =>
+ (DDatatype (x, n, xncs'), loc))
| DVal vi =>
S.map2 (mfvi ctx vi,
fn vi' =>
@@ -458,6 +467,21 @@ fun mapfoldB (all as {bind, ...}) =
val ctx' =
case #1 d' of
DCon (x, n, k, c) => bind (ctx, NamedC (x, n, k, SOME c))
+ | DDatatype (x, n, xncs) =>
+ let
+ val ctx = bind (ctx, NamedC (x, n, (KType, #2 d'), NONE))
+ val t = (CNamed n, #2 d')
+ in
+ foldl (fn ((x, n, to), ctx) =>
+ let
+ val t = case to of
+ NONE => t
+ | SOME t' => (TFun (t', t), #2 d')
+ in
+ bind (ctx, NamedE (x, n, t, NONE, ""))
+ end)
+ ctx xncs
+ end
| DVal (x, n, t, e, s) => bind (ctx, NamedE (x, n, t, SOME e, s))
| DValRec vis =>
foldl (fn ((x, n, t, e, s), ctx) => bind (ctx, NamedE (x, n, t, NONE, s)))
diff --git a/src/corify.sml b/src/corify.sml
index 0f98e99c..7332395c 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -75,6 +75,7 @@ structure St : sig
ENormal of int
| EFfi of string * L'.con
val bindVal : t -> string -> int -> t * int
+ val bindConstructor : t -> string -> int -> t
val lookupValById : t -> int -> int option
val lookupValByName : t -> string -> core_val
@@ -182,6 +183,25 @@ fun bindVal {cons, vals, strs, funs, current, nested} s n =
n')
end
+fun bindConstructor {cons, vals, strs, funs, current, nested} s n =
+ let
+ val current =
+ case current of
+ FFfi _ => raise Fail "Binding inside FFfi"
+ | FNormal {cons, vals, strs, funs} =>
+ FNormal {cons = cons,
+ vals = SM.insert (vals, s, n),
+ strs = strs,
+ funs = funs}
+ in
+ {cons = cons,
+ vals = IM.insert (vals, n, n),
+ strs = strs,
+ funs = funs,
+ current = current,
+ nested = nested}
+ end
+
fun lookupValById ({vals, ...} : t) n = IM.find (vals, n)
fun lookupValByName ({current, ...} : t) x =
@@ -384,8 +404,44 @@ fun corifyDecl ((d, loc : EM.span), st) =
in
([(L'.DCon (x, n, corifyKind k, corifyCon st c), loc)], st)
end
- | L.DDatatype _ => raise Fail "Corify DDatatype"
- | L.DDatatypeImp _ => raise Fail "Corify DDatatypeImp"
+ | L.DDatatype (x, n, xncs) =>
+ let
+ val (st, n) = St.bindCon st x n
+ val (xncs, st) = ListUtil.foldlMap (fn ((x, n, co), st) =>
+ let
+ val st = St.bindConstructor st x n
+ val co = Option.map (corifyCon st) co
+ in
+ ((x, n, co), st)
+ end) st xncs
+ in
+ ([(L'.DDatatype (x, n, xncs), loc)], st)
+ end
+ | L.DDatatypeImp (x, n, m1, ms, s, xncs) =>
+ let
+ val (st, n) = St.bindCon st x n
+ val c = corifyCon st (L.CModProj (m1, ms, s), loc)
+
+ val (xncs, st) = ListUtil.foldlMap (fn ((x, n, co), st) =>
+ let
+ val (st, n) = St.bindVal st x n
+ val co = Option.map (corifyCon st) co
+ in
+ ((x, n, co), st)
+ end) st xncs
+
+ val cds = map (fn (x, n, co) =>
+ let
+ val t = case co of
+ NONE => c
+ | SOME t' => (L'.TFun (t', c), loc)
+ val e = corifyExp st (L.EModProj (m1, ms, x), loc)
+ in
+ (L'.DVal (x, n, t, e, x), loc)
+ end) xncs
+ in
+ ((L'.DCon (x, n, (L'.KType, loc), c), loc) :: cds, st)
+ end
| L.DVal (x, n, t, e) =>
let
val (st, n) = St.bindVal st x n
diff --git a/src/expl_print.sml b/src/expl_print.sml
index 472d83ae..7d0bfebd 100644
--- a/src/expl_print.sml
+++ b/src/expl_print.sml
@@ -285,8 +285,10 @@ fun p_datatype env (x, n, cons) =
string "=",
space,
p_list_sep (box [space, string "|", space])
- (fn (x, _, NONE) => string x
- | (x, _, SOME t) => box [string x, space, string "of", space, p_con env t])
+ (fn (x, n, NONE) => if !debug then (string (x ^ "__" ^ Int.toString n))
+ else string x
+ | (x, _, SOME t) => box [if !debug then (string (x ^ "__" ^ Int.toString n))
+ else string x, space, string "of", space, p_con env t])
cons]
end
diff --git a/src/monoize.sml b/src/monoize.sml
index 1dcef40a..b17fe805 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -453,6 +453,7 @@ fun monoDecl env (all as (d, loc)) =
in
case d of
L.DCon _ => NONE
+ | L.DDatatype _ => raise Fail "Monoize DDatatype"
| L.DVal (x, n, t, e, s) => SOME (Env.pushENamed env x n t (SOME e) s,
(L'.DVal (x, n, monoType env t, monoExp (env, St.empty) e, s), loc))
| L.DValRec vis =>
diff --git a/src/shake.sml b/src/shake.sml
index 693385d9..c8105b07 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -47,7 +47,9 @@ fun shake file =
(fn ((DExport (_, n), _), page_es) => n :: page_es
| (_, page_es) => page_es) [] file
- val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, c), edef)
+ val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef)
+ | ((DDatatype (_, n, xncs), _), (cdef, edef)) =>
+ (IM.insert (cdef, n, List.mapPartial #3 xncs), edef)
| ((DVal (_, n, t, e, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, (t, e)))
| ((DValRec vis, _), (cdef, edef)) =>
(cdef, foldl (fn ((_, n, t, e, _), edef) => IM.insert (edef, n, (t, e))) edef vis)
@@ -68,7 +70,7 @@ fun shake file =
in
case IM.find (cdef, n) of
NONE => s'
- | SOME c => shakeCon s' c
+ | SOME cs => foldl (fn (c, s') => shakeCon s' c) s' cs
end
| _ => s
@@ -100,6 +102,7 @@ fun shake file =
| SOME (t, e) => shakeExp (shakeCon s t) e) s page_es
in
List.filter (fn (DCon (_, n, _, _), _) => IS.member (#con s, n)
+ | (DDatatype (_, n, _), _) => IS.member (#con s, n)
| (DVal (_, n, _, _, _), _) => IS.member (#exp s, n)
| (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis
| (DExport _, _) => true) file
diff --git a/src/tag.sml b/src/tag.sml
index c61fc23f..74f195a9 100644
--- a/src/tag.sml
+++ b/src/tag.sml
@@ -153,6 +153,7 @@ fun tag file =
val count = foldl (fn ((d, _), count) =>
case d of
DCon (_, n, _, _) => Int.max (n, count)
+ | DDatatype (_, n, _) => Int.max (n, count)
| DVal (_, n, _, _, _) => Int.max (n, count)
| DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis
| DExport _ => count) 0 file
diff --git a/tests/datatypeMod.lac b/tests/datatypeMod.lac
index b5f62166..f82b0098 100644
--- a/tests/datatypeMod.lac
+++ b/tests/datatypeMod.lac
@@ -2,19 +2,27 @@ structure M : sig datatype t = A | B end = struct
datatype t = A | B
end
-val a = M.A
+val ac = M.A
datatype u = datatype M.t
-val a : M.t = A
-val a2 : u = a
+val ac : M.t = A
+val a2 : u = ac
structure M2 = M
structure M3 : sig datatype t = datatype M.t end = M2
structure M4 : sig datatype t = datatype M.t end = M
-val b : M3.t = M4.B
+val bc : M3.t = M4.B
structure Ma : sig type t end = M
structure Magain : sig datatype t = A | B end = M
+
+val page : M.t -> page = fn x => <html><body>
+ Hi.
+</body></html>
+
+val main : unit -> page = fn () => <html><body>
+ <a link={page a2}>Link</a>
+</body></html>
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-08 17:13:31 +0000