open

5 files changed, 85 insertions, 30 deletions

diff --git a/src/elaborate.sml b/src/elaborate.sml
index a96d90c7..3c0c7ed4 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -1016,6 +1016,7 @@ datatype str_error =
          UnboundStr of ErrorMsg.span * string
        | NotFunctor of L'.sgn
        | FunctorRebind of ErrorMsg.span
+       | UnOpenable of L'.sgn
 
 fun strError env err =
     case err of
@@ -1026,6 +1027,9 @@ fun strError env err =
          eprefaces' [("Signature", p_sgn env sgn)])
       | FunctorRebind loc =>
         ErrorMsg.errorAt loc "Attempt to rebind functor"
+      | UnOpenable sgn =>
+        (ErrorMsg.errorAt (#2 sgn) "Un-openable structure";
+         eprefaces' [("Signature", p_sgn env sgn)])
 
 val hnormSgn = E.hnormSgn
 
@@ -1360,6 +1364,35 @@ fun selfifyAt env {str, sgn} =
           | SOME (str, strs) => selfify env {sgn = sgn, str = str, strs = strs}
     end
 
+fun dopen env {str, strs, sgn} =
+    let
+        val m = foldl (fn (m, str) => (L'.StrProj (str, m), #2 sgn))
+                (L'.StrVar str, #2 sgn) strs
+    in
+        case #1 (hnormSgn env sgn) of
+            L'.SgnConst sgis =>
+            ListUtil.foldlMap (fn ((sgi, loc), env') =>
+                                  case sgi of
+                                      L'.SgiConAbs (x, n, k) =>
+                                      ((L'.DCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc),
+                                       E.pushCNamedAs env' x n k NONE)
+                                    | L'.SgiCon (x, n, k, c) =>
+                                      ((L'.DCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc),
+                                       E.pushCNamedAs env' x n k (SOME c))
+                                    | L'.SgiVal (x, n, t) =>
+                                      ((L'.DVal (x, n, t, (L'.EModProj (str, strs, x), loc)), loc),
+                                       E.pushENamedAs env' x n t)
+                                    | L'.SgiStr (x, n, sgn) =>
+                                      ((L'.DStr (x, n, sgn, (L'.StrProj (m, x), loc)), loc),
+                                       E.pushStrNamedAs env' x n sgn)
+                                    | L'.SgiSgn (x, n, sgn) =>
+                                      ((L'.DSgn (x, n, (L'.SgnProj (str, strs, x), loc)), loc),
+                                       E.pushSgnNamedAs env' x n sgn))
+                              env sgis
+          | _ => (strError env (UnOpenable sgn);
+                  ([], env))
+    end
+
 fun elabDecl ((d, loc), env) =
     let
         
@@ -1392,7 +1425,7 @@ fun elabDecl ((d, loc), env) =
                         ()
                     );
 
-                ((L'.DCon (x, n, k', c'), loc), env')
+                ([(L'.DCon (x, n, k', c'), loc)], env')
             end
           | L.DVal (x, co, e) =>
             let
@@ -1428,7 +1461,7 @@ fun elabDecl ((d, loc), env) =
                     else
                         ());
 
-                ((L'.DVal (x, n, c', e'), loc), env')
+                ([(L'.DVal (x, n, c', e'), loc)], env')
             end
 
           | L.DSgn (x, sgn) =>
@@ -1436,7 +1469,7 @@ fun elabDecl ((d, loc), env) =
                 val sgn' = elabSgn env sgn
                 val (env', n) = E.pushSgnNamed env x sgn'
             in
-                ((L'.DSgn (x, n, sgn'), loc), env')
+                ([(L'.DSgn (x, n, sgn'), loc)], env')
             end
 
           | L.DStr (x, sgno, str) =>
@@ -1459,7 +1492,7 @@ fun elabDecl ((d, loc), env) =
                        | _ => strError env (FunctorRebind loc))
                   | _ => ();
 
-                ((L'.DStr (x, n, sgn', str'), loc), env')
+                ([(L'.DStr (x, n, sgn', str'), loc)], env')
             end
 
           | L.DFfiStr (x, sgn) =>
@@ -1468,15 +1501,31 @@ fun elabDecl ((d, loc), env) =
 
                 val (env', n) = E.pushStrNamed env x sgn'
             in
-                ((L'.DFfiStr (x, n, sgn'), loc), env')
+                ([(L'.DFfiStr (x, n, sgn'), loc)], env')
             end
+
+          | L.DOpen (m, ms) =>
+            (case E.lookupStr env m of
+                 NONE => (strError env (UnboundStr (loc, m));
+                          ([], env))
+               | SOME (n, sgn) =>
+                 let
+                     val (_, sgn) = foldl (fn (m, (str, sgn)) =>
+                                              case E.projectStr env {str = str, sgn = sgn, field = m} of
+                                                  NONE => (strError env (UnboundStr (loc, m));
+                                                           (strerror, sgnerror))
+                                                | SOME sgn => ((L'.StrProj (str, m), loc), sgn))
+                                          ((L'.StrVar n, loc), sgn) ms
+                 in
+                     dopen env {str = n, strs = ms, sgn = sgn}
+                 end)
     end
 
 and elabStr env (str, loc) =
     case str of
         L.StrConst ds =>
         let
-            val (ds', env') = ListUtil.foldlMap elabDecl env ds
+            val (ds', env') = ListUtil.foldlMapConcat elabDecl env ds
             val sgis = map sgiOfDecl ds'
         in
             ((L'.StrConst ds', loc), (L'.SgnConst sgis, loc))
@@ -1540,28 +1589,7 @@ fun elabFile basis env file =
         val sgn = elabSgn env (L.SgnConst basis, ErrorMsg.dummySpan)
         val (env', basis_n) = E.pushStrNamed env "Basis" sgn
 
-        val (ds, env') =
-            case #1 (hnormSgn env' sgn) of
-                L'.SgnConst sgis =>
-                ListUtil.foldlMap (fn ((sgi, loc), env') =>
-                                      case sgi of
-                                          L'.SgiConAbs (x, n, k) =>
-                                          ((L'.DCon (x, n, k, (L'.CModProj (basis_n, [], x), loc)), loc),
-                                           E.pushCNamedAs env' x n k NONE)
-                                        | L'.SgiCon (x, n, k, c) =>
-                                          ((L'.DCon (x, n, k, (L'.CModProj (basis_n, [], x), loc)), loc),
-                                           E.pushCNamedAs env' x n k (SOME c))
-                                        | L'.SgiVal (x, n, t) =>
-                                          ((L'.DVal (x, n, t, (L'.EModProj (basis_n, [], x), loc)), loc),
-                                           E.pushENamedAs env' x n t)
-                                        | L'.SgiStr (x, n, sgn) =>
-                                          ((L'.DStr (x, n, sgn, (L'.StrProj ((L'.StrVar basis_n, loc), x), loc)), loc),
-                                           E.pushStrNamedAs env' x n sgn)
-                                        | L'.SgiSgn (x, n, sgn) =>
-                                          ((L'.DSgn (x, n, (L'.SgnProj (basis_n, [], x), loc)), loc),
-                                           E.pushSgnNamedAs env' x n sgn))
-                env' sgis
-              | _ => raise Fail "Non-constant Basis signature"
+        val (ds, env') = dopen env' {str = basis_n, strs = [], sgn = sgn}
 
         fun discoverC r x =
             case E.lookupC env' x of
@@ -1573,7 +1601,7 @@ fun elabFile basis env file =
         val () = discoverC float "float"
         val () = discoverC string "string"
 
-        val (file, _) = ListUtil.foldlMap elabDecl env' file
+        val (file, _) = ListUtil.foldlMapConcat elabDecl env' file
     in
         (L'.DFfiStr ("Basis", basis_n, sgn), ErrorMsg.dummySpan) :: ds @ file
     end
diff --git a/src/lacweb.grm b/src/lacweb.grm
index 4c3ed51e..e36630ae 100644
--- a/src/lacweb.grm
+++ b/src/lacweb.grm
@@ -123,6 +123,9 @@ decl   : CON SYMBOL EQ cexp             (DCon (SYMBOL, NONE, cexp), s (CONleft,
                                                (StrFun (CSYMBOL2, sgn1, SOME sgn2, str), s (FUNCTORleft, strright))),
                                          s (FUNCTORleft, strright))
        | EXTERN STRUCTURE CSYMBOL COLON sgn (DFfiStr (CSYMBOL, sgn), s (EXTERNleft, sgnright))
+       | OPEN mpath                     (case mpath of
+                                             [] => raise Fail "Impossible mpath parse [1]"
+                                           | m :: ms => (DOpen (m, ms), s (OPENleft, mpathright)))
 
 sgn    : sgntm                          (sgntm)
        | FUNCTOR LPAREN CSYMBOL COLON sgn RPAREN COLON sgn
@@ -130,7 +133,7 @@ sgn    : sgntm                          (sgntm)
 
 sgntm  : SIG sgis END                   (SgnConst sgis, s (SIGleft, ENDright))
        | mpath                          (case mpath of
-                                             [] => raise Fail "Impossible mpath parse"
+                                             [] => raise Fail "Impossible mpath parse [2]"
                                            | [x] => SgnVar x
                                            | m :: ms => SgnProj (m,
                                                                  List.take (ms, length ms - 1),
diff --git a/src/source.sml b/src/source.sml
index 2939664c..9ea1ea20 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -101,6 +101,7 @@ datatype decl' =
        | DSgn of string * sgn
        | DStr of string * sgn option * str
        | DFfiStr of string * sgn
+       | DOpen of string * string list
 
      and str' =
          StrConst of decl list
diff --git a/src/source_print.sml b/src/source_print.sml
index 49adadc3..ca72c014 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -356,6 +356,9 @@ fun p_decl ((d, _) : decl) =
                                  string ":",
                                  space,
                                  p_sgn sgn]
+      | DOpen (m, ms) => box [string "open",
+                              space,
+                              p_list_sep (string ".") string (m :: ms)]
 
 and p_str (str, _) =
     case str of
diff --git a/tests/open.lac b/tests/open.lac
new file mode 100644
index 00000000..47f81219
--- /dev/null
+++ b/tests/open.lac
@@ -0,0 +1,20 @@
+structure S = struct
+        type t = int
+        val x = 0
+
+        structure S' : sig type u val y : t end = struct
+                type u = t
+                val y = x
+        end
+
+        signature Sig = sig
+                type t
+                val x : t
+        end
+end
+
+open S.S'
+open S
+open S'
+
+structure S' : Sig = S