summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2008-06-12 17:35:51 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2008-06-12 17:35:51 -0400
commited9e3cb10161dde86a87894155f2f74c60d28c4a (patch)
tree6720f063434c521f4004809f3a557aa8b86a23ce
parent2355b20a32d8ed4924cee84a44831061b2b49b49 (diff)
Matching values in signatures
-rw-r--r--src/compiler.sml3
-rw-r--r--src/elab_print.sml13
-rw-r--r--src/elaborate.sml14
-rw-r--r--tests/modules.lac31
4 files changed, 56 insertions, 5 deletions
diff --git a/src/compiler.sml b/src/compiler.sml
index 9a213ab6..de644d37 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -132,7 +132,8 @@ fun testElaborate filename =
(case elaborate ElabEnv.basis filename of
NONE => print "Failed\n"
| SOME (file, _) =>
- (Print.print (ElabPrint.p_file ElabEnv.basis file);
+ (print "Succeeded\n";
+ Print.print (ElabPrint.p_file ElabEnv.basis file);
print "\n"))
handle ElabEnv.UnboundNamed n =>
print ("Unbound named " ^ Int.toString n ^ "\n")
diff --git a/src/elab_print.sml b/src/elab_print.sml
index c07631a0..435ea13d 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -275,7 +275,14 @@ and p_sgn env (sgn, _) =
case sgn of
SgnConst sgis => box [string "sig",
newline,
- p_list_sep newline (p_sgn_item env) sgis,
+ let
+ val (psgis, _) = ListUtil.foldlMap (fn (sgi, env) =>
+ (p_sgn_item env sgi,
+ E.sgiBinds env sgi))
+ env sgis
+ in
+ p_list_sep newline (fn x => x) psgis
+ end,
newline,
string "end"]
| SgnVar n => string (#1 (E.lookupSgnNamed env n))
@@ -329,13 +336,13 @@ and p_str env (str, _) =
case str of
StrConst ds => box [string "struct",
newline,
- p_list_sep newline (p_decl env) ds,
+ p_file env ds,
newline,
string "end"]
| StrVar n => string (#1 (E.lookupStrNamed env n))
| StrError => string "<ERROR>"
-fun p_file env file =
+and p_file env file =
let
val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
(p_decl env d,
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 3cdb2d9f..c61a84c1 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1072,12 +1072,24 @@ fun subSgn env (all1 as (sgn1, _)) (all2 as (sgn2, loc2)) =
end
| _ => NONE)
+ | L'.SgiVal (x, n2, c2) =>
+ seek (fn sgi1All as (sgi1, _) =>
+ case sgi1 of
+ L'.SgiVal (x, n1, c1) =>
+ let
+ val () = unifyCons env c1 c2
+ handle CUnify (c1, c2, err) =>
+ sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err))
+ in
+ SOME env
+ end
+ | _ => NONE)
+
| _ => raise Fail "Not ready for more sig matching"
end
in
ignore (foldl folder env sgis2)
end
-
fun elabDecl ((d, loc), env) =
let
diff --git a/tests/modules.lac b/tests/modules.lac
index 9d5fbc90..1bdc685c 100644
--- a/tests/modules.lac
+++ b/tests/modules.lac
@@ -26,3 +26,34 @@ structure C = struct
end
structure CoB1 : B1 = C
(*structure CoB2 : B2 = C*)
+
+
+signature NAT = sig
+ type t
+ val zero : t
+end
+structure Nat : NAT = struct
+ type t = int
+ val zero = 0
+end
+(*structure NotNat : NAT = struct
+ type t = int
+ val zero = 0.0
+end*)
+(*structure NotNat : NAT = struct
+ val zero = 0
+end*)
+
+
+signature WOBBLE = sig
+ type t
+ type s
+end
+structure Wobble1 = struct
+ type t = int
+ type s = float
+end
+structure Wobble2 = struct
+ type s = int
+ type t = float
+end