summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2011-08-04 16:44:05 -0400
committerGravatar Adam Chlipala <adam@chlipala.net>2011-08-04 16:44:05 -0400
commit7e42ca73d84c1938c881aa103a9c5bf40a9f1bfb (patch)
tree78a65f7f1e851be7156074a76cc7d95a50a49e6b
parent4342dc1f0558093f01901a7641e6604f9dd7855e (diff)
Fix opening of shadowing, principal-signatured modules that open other modules
-rw-r--r--src/corify.sml4
-rw-r--r--src/elaborate.sml71
-rw-r--r--tests/openRedef.ur16
3 files changed, 68 insertions, 23 deletions
diff --git a/src/corify.sml b/src/corify.sml
index 706a4c2d..d9e5d30c 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -212,7 +212,7 @@ fun lookupConByName ({current, ...} : t) x =
FFfi {mod = m, ...} => CFfi m
| FNormal {cons, ...} =>
case SM.find (cons, x) of
- NONE => raise Fail "Corify.St.lookupConByName"
+ NONE => raise Fail ("Corify.St.lookupConByName " ^ x)
| SOME n => CNormal n
fun bindVal {basis, cons, constructors, vals, strs, funs, current, nested} s n =
@@ -275,7 +275,7 @@ fun lookupValByName ({current, ...} : t) x =
| SOME t => EFfi (m, t))
| FNormal {name, vals, ...} =>
case SM.find (vals, x) of
- NONE => raise Fail ("Corify.St.lookupValByName " ^ String.concatWith "." name ^ "." ^ x)
+ NONE => raise Fail ("Corify.St.lookupValByName " ^ String.concatWith "." (rev name) ^ "." ^ x)
| SOME n => ENormal n
fun bindConstructor {basis, cons, constructors, vals, strs, funs, current, nested} s n n' =
diff --git a/src/elaborate.sml b/src/elaborate.sml
index ed2e0d78..c043ef54 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -2723,6 +2723,8 @@ and selfifyAt env {str, sgn} =
and dopen env {str, strs, sgn} =
let
+ fun isVisible x = x <> "" andalso String.sub (x, 0) <> #"?"
+
val m = foldl (fn (m, str) => (L'.StrProj (str, m), #2 sgn))
(L'.StrVar str, #2 sgn) strs
in
@@ -2734,37 +2736,64 @@ and dopen env {str, strs, sgn} =
val d =
case sgi of
L'.SgiConAbs (x, n, k) =>
- let
- val c = (L'.CModProj (str, strs, x), loc)
- in
- [(L'.DCon (x, n, k, c), loc)]
- end
+ if isVisible x then
+ let
+ val c = (L'.CModProj (str, strs, x), loc)
+ in
+ [(L'.DCon (x, n, k, c), loc)]
+ end
+ else
+ []
| L'.SgiCon (x, n, k, c) =>
- [(L'.DCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc)]
+ if isVisible x then
+ [(L'.DCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc)]
+ else
+ []
| L'.SgiDatatype dts =>
- map (fn (x, n, xs, xncs) => (L'.DDatatypeImp (x, n, str, strs, x, xs, xncs), loc)) dts
+ List.mapPartial (fn (x, n, xs, xncs) => if isVisible x then
+ SOME (L'.DDatatypeImp (x, n, str, strs, x, xs, xncs), loc)
+ else
+ NONE) dts
| L'.SgiDatatypeImp (x, n, m1, ms, x', xs, xncs) =>
- [(L'.DDatatypeImp (x, n, m1, ms, x', xs, xncs), loc)]
+ if isVisible x then
+ [(L'.DDatatypeImp (x, n, m1, ms, x', xs, xncs), loc)]
+ else
+ []
| L'.SgiVal (x, n, t) =>
- [(L'.DVal (x, n, t, (L'.EModProj (str, strs, x), loc)), loc)]
+ if isVisible x then
+ [(L'.DVal (x, n, t, (L'.EModProj (str, strs, x), loc)), loc)]
+ else
+ []
| L'.SgiStr (x, n, sgn) =>
- [(L'.DStr (x, n, sgn, (L'.StrProj (m, x), loc)), loc)]
+ if isVisible x then
+ [(L'.DStr (x, n, sgn, (L'.StrProj (m, x), loc)), loc)]
+ else
+ []
| L'.SgiSgn (x, n, sgn) =>
- [(L'.DSgn (x, n, (L'.SgnProj (str, strs, x), loc)), loc)]
+ if isVisible x then
+ [(L'.DSgn (x, n, (L'.SgnProj (str, strs, x), loc)), loc)]
+ else
+ []
| L'.SgiConstraint (c1, c2) =>
[(L'.DConstraint (c1, c2), loc)]
| L'.SgiClassAbs (x, n, k) =>
- let
- val c = (L'.CModProj (str, strs, x), loc)
- in
- [(L'.DCon (x, n, k, c), loc)]
- end
+ if isVisible x then
+ let
+ val c = (L'.CModProj (str, strs, x), loc)
+ in
+ [(L'.DCon (x, n, k, c), loc)]
+ end
+ else
+ []
| L'.SgiClass (x, n, k, _) =>
- let
- val c = (L'.CModProj (str, strs, x), loc)
- in
- [(L'.DCon (x, n, k, c), loc)]
- end
+ if isVisible x then
+ let
+ val c = (L'.CModProj (str, strs, x), loc)
+ in
+ [(L'.DCon (x, n, k, c), loc)]
+ end
+ else
+ []
in
(d, foldl (fn (d, env') => E.declBinds env' d) env' d)
end)
diff --git a/tests/openRedef.ur b/tests/openRedef.ur
new file mode 100644
index 00000000..2d8161c3
--- /dev/null
+++ b/tests/openRedef.ur
@@ -0,0 +1,16 @@
+structure M = struct
+ con num = int
+ val zero = 0
+end
+
+structure N = struct
+ open M
+ con num = num * num
+ val zero = zero + 1
+end
+
+structure O = struct
+ open N
+
+ val one : num = (zero + 1, zero)
+end