aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-08-09 08:47:36 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-08-09 08:47:36 -0400
commitbd2d0fe6c8deedc88d985b2c38978b730ff0cd19 (patch)
tree2daf2365908cb5776cc09bcfc90146e1984efb6f
parentb9b67597324deb6e6dfc8ef33c60c110abc2af7b (diff)
A multi-parameter datatype all the way through
-rw-r--r--src/core_print.sml10
-rw-r--r--src/corify.sml8
-rw-r--r--src/elaborate.sml9
-rw-r--r--src/specialize.sml53
-rw-r--r--tests/datatypeP2.lac15
5 files changed, 62 insertions, 33 deletions
diff --git a/src/core_print.sml b/src/core_print.sml
index e4eae55e..52c7648d 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -199,13 +199,15 @@ 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 (_, pc, _, NONE) => box [string "[",
- p_patCon env pc,
- string "]"]
- | ECon (_, pc, _, SOME e) => box [string "[",
+ | ECon (_, pc, ts, NONE) => box [string "[",
+ p_patCon env pc,
+ p_list_sep (box []) (fn t => box [space, string "[", p_con env t, string "]"]) ts,
+ string "]"]
+ | ECon (_, pc, ts, SOME e) => box [string "[",
p_patCon env pc,
space,
p_exp' true env e,
+ p_list_sep (box []) (fn t => box [space, string "[", p_con env t, string "]"]) ts,
string "]"]
| EFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"]
| EFfiApp (m, x, es) => box [string "FFI(",
diff --git a/src/corify.sml b/src/corify.sml
index 075939bf..9c350aee 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -534,11 +534,12 @@ structure St : sig
val dk = CoreUtil.classifyDatatype xncs
val t = (L'.CNamed n, loc)
- val t = ListUtil.foldli (fn (i, _, t) => (L'.CApp (t, (L'.CRel i, loc)), loc)) t xs
+ val nxs = length xs - 1
+ val t = ListUtil.foldli (fn (i, _, t) => (L'.CApp (t, (L'.CRel (nxs - i), loc)), loc)) t xs
val k = (L'.KType, loc)
val dcons = map (fn (x, n, to) =>
let
- val args = ListUtil.mapi (fn (i, _) => (L'.CRel i, loc)) xs
+ val args = ListUtil.mapi (fn (i, _) => (L'.CRel (nxs - i), loc)) xs
val (e, t) =
case to of
NONE => ((L'.ECon (dk, L'.PConVar n, args, NONE), loc), t)
@@ -575,7 +576,8 @@ structure St : sig
((x, n, co), st)
end) st xncs
- val c = ListUtil.foldli (fn (i, _, c) => (L'.CApp (c, (L'.CRel i, loc)), loc)) c xs
+ val nxs = length xs - 1
+ val c = ListUtil.foldli (fn (i, _, c) => (L'.CApp (c, (L'.CRel (nxs - i), loc)), loc)) c xs
val k = (L'.KType, loc)
val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 94c51701..976db303 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -954,7 +954,8 @@ fun elabPat (pAll as (p, loc), (env, denv, bound)) =
val k = (L'.KType, loc)
val unifs = map (fn _ => cunif (loc, k)) xs
- val t = ListUtil.foldli (fn (i, u, t) => subConInCon (i, u) t) t unifs
+ val nxs = length unifs - 1
+ val t = ListUtil.foldli (fn (i, u, t) => subConInCon (nxs - i, u) t) t unifs
val dn = foldl (fn (u, dn) => (L'.CApp (dn, u), loc)) dn unifs
in
ignore (checkPatCon (env, denv) p' pt t);
@@ -1600,7 +1601,8 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) =
val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs
val (env, n) = E.pushCNamed env x k' NONE
val t = (L'.CNamed n, loc)
- val t = ListUtil.foldli (fn (i, _, t) => (L'.CApp (t, (L'.CRel i, loc)), loc)) t xs
+ val nxs = length xs - 1
+ val t = ListUtil.foldli (fn (i, _, t) => (L'.CApp (t, (L'.CRel (nxs - i), loc)), loc)) t xs
val (xcs, (used, env, gs)) =
ListUtil.foldlMap
@@ -2269,7 +2271,8 @@ fun elabDecl ((d, loc), (env, denv, gs)) =
val k' = foldl (fn (_, k') => (L'.KArrow (k, k'), loc)) k xs
val (env, n) = E.pushCNamed env x k' NONE
val t = (L'.CNamed n, loc)
- val t = ListUtil.foldli (fn (i, _, t) => (L'.CApp (t, (L'.CRel i, loc)), loc)) t xs
+ val nxs = length xs - 1
+ val t = ListUtil.foldli (fn (i, _, t) => (L'.CApp (t, (L'.CRel (nxs - i), loc)), loc)) t xs
val (env', denv') = foldl (fn (x, (env', denv')) =>
(E.pushCRel env' x k,
diff --git a/src/specialize.sml b/src/specialize.sml
index 9690f6e7..c8af5199 100644
--- a/src/specialize.sml
+++ b/src/specialize.sml
@@ -77,10 +77,13 @@ fun considerSpecialization (st : state, n, args, dt : datatyp) =
SOME dt' => (#name dt', #constructors dt', st)
| NONE =>
let
+ (*val () = Print.prefaces "Args" [("args", Print.p_list (CorePrint.p_con CoreEnv.empty) args)]*)
+
val n' = #count st
+ val nxs = length args - 1
fun sub t = ListUtil.foldli (fn (i, arg, t) =>
- subConInCon (i, arg) t) t args
+ subConInCon (nxs - i, arg) t) t args
val (cons, (count, cmap)) =
ListUtil.foldlMap (fn ((x, n, to), (count, cmap)) =>
@@ -240,28 +243,32 @@ val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl}
fun specialize file =
let
fun doDecl (all as (d, _), st : state) =
- case d of
- DDatatype (x, n, xs, xnts) =>
- ([all], {count = #count st,
- datatypes = IM.insert (#datatypes st, n,
- {name = x,
- params = length xs,
- constructors = xnts,
- specializations = CM.empty}),
- constructors = foldl (fn ((_, n', _), constructors) =>
- IM.insert (constructors, n', n))
- (#constructors st) xnts,
- decls = []})
- | _ =>
- let
- val (d, st) = specDecl st all
- in
- (rev (d :: #decls st),
- {count = #count st,
- datatypes = #datatypes st,
- constructors = #constructors st,
- decls = []})
- end
+ let
+ (*val () = Print.preface ("decl:", CorePrint.p_decl CoreEnv.empty all)*)
+ in
+ case d of
+ DDatatype (x, n, xs, xnts) =>
+ ([all], {count = #count st,
+ datatypes = IM.insert (#datatypes st, n,
+ {name = x,
+ params = length xs,
+ constructors = xnts,
+ specializations = CM.empty}),
+ constructors = foldl (fn ((_, n', _), constructors) =>
+ IM.insert (constructors, n', n))
+ (#constructors st) xnts,
+ decls = []})
+ | _ =>
+ let
+ val (d, st) = specDecl st all
+ in
+ (rev (d :: #decls st),
+ {count = #count st,
+ datatypes = #datatypes st,
+ constructors = #constructors st,
+ decls = []})
+ end
+ end
val (ds, _) = ListUtil.foldlMapConcat doDecl
{count = U.File.maxName file + 1,
diff --git a/tests/datatypeP2.lac b/tests/datatypeP2.lac
new file mode 100644
index 00000000..09cc964a
--- /dev/null
+++ b/tests/datatypeP2.lac
@@ -0,0 +1,15 @@
+datatype sum a b = Left of a | Right of b
+
+val l : sum int string = Left 5
+val r : sum int string = Right "Hi"
+
+val show = fn x : sum int string => case x of Left _ => "Left _" | Right s => s
+
+val page = fn x => <html><body>
+ {cdata (show x)}
+</body></html>
+
+val main : unit -> page = fn () => <html><body>
+ <li><a link={page l}>Left</a></li>
+ <li><a link={page r}>Right</a></li>
+</body></html>