Add module-type definitions

lib/module.ml

@@ -17,13 +17,16 @@ and item =
   | Mmutual_rec of loc * (loc * string * int option * typ) list
   | Mlocal_module of loc * string * t
   | Mmodule_alias of loc * string * Path.t * string option (* filename option *)
+  | Mmodule_type of loc * string * intf
 
-and sg_kind = Stypedef | Svalue
+and sg_kind = Module_type.item_kind = Mtypedef | Mvalue
 and sig_item = string * loc * typ * sg_kind [@@deriving sexp]
+and intf = sig_item list
+and impl = item list
 
 and t = {
-  s : sig_item list;
-  i : item list;
+  s : intf; (* TODO use module_type.t here *)
+  i : impl;
   objects : (string * bool (* transitive dep needs load *)) list;
 }
 
@@ -74,8 +77,8 @@ let absolute_module_name ~mname fname = "_" ^ Path.mod_name mname ^ "_" ^ fname
 let is_polymorphic_func (f : Typed_tree.func) =
   is_polymorphic (Tfun (f.tparams, f.ret, f.kind))
 
-let add_type_sig loc name t m = { m with s = (name, loc, t, Stypedef) :: m.s }
-let add_value_sig loc name t m = { m with s = (name, loc, t, Svalue) :: m.s }
+let add_type_sig loc name t m = { m with s = (name, loc, t, Mtypedef) :: m.s }
+let add_value_sig loc name t m = { m with s = (name, loc, t, Mvalue) :: m.s }
 let add_type loc t m = { m with i = Mtype (loc, t) :: m.i }
 
 let add_local_module loc id newm ~into =
@@ -89,6 +92,9 @@ let add_module_alias loc key mname ~into =
   in
   { into with i = Mmodule_alias (loc, key, mname, filename) :: into.i }
 
+let add_module_type loc id mtype m =
+  { m with i = Mmodule_type (loc, id, mtype) :: m.i }
+
 let type_of_func (func : Typed_tree.func) =
   Tfun (func.tparams, func.ret, func.kind)
 
@@ -449,13 +455,12 @@ let rec map_item ~mname ~f = function
   | Mlocal_module (l, name, t) ->
       Mlocal_module (l, name, map_t ~mname:(Path.append name mname) ~f t)
   | Mmodule_alias _ as m -> m
+  | Mmodule_type (l, name, intf) -> Mmodule_type (l, name, map_intf ~f intf)
 
 and map_t ~mname ~f m =
-  {
-    m with
-    s = List.map (fun (n, l, t, k) -> (n, l, f t, k)) m.s;
-    i = List.map (map_item ~mname ~f) m.i;
-  }
+  { m with s = map_intf ~f m.s; i = List.map (map_item ~mname ~f) m.i }
+
+and map_intf ~f intf = List.map (fun (n, l, t, k) -> (n, l, f t, k)) intf
 
 (* Number qvars from 0 and change names of Var-nodes to their unique form.
    _<module_name>_name*)
@@ -491,22 +496,27 @@ let rec fold_canonize_item mname (ts_sub, nsub) = function
       let t = canonize_t (Path.append n mname) t in
       ((ts_sub, nsub), Mlocal_module (loc, n, t))
   | Mmodule_alias _ as m -> ((ts_sub, nsub), m)
+  | Mmodule_type (loc, n, intf) ->
+      let intf = canonize_intf Types.Smap.empty intf in
+      ((ts_sub, nsub), Mmodule_type (loc, n, intf))
 
 and canonize_t mname m =
   let (ts_sub, _), i =
     List.fold_left_map (fold_canonize_item mname)
       (Types.Smap.empty, Smap.empty)
       m.i
   in
-  let _, s =
-    List.fold_left_map
-      (fun sub (key, l, t, k) ->
-        let sub, t = canonize sub t in
-        (sub, (key, l, t, k)))
-      ts_sub m.s
-  in
+  let s = canonize_intf ts_sub m.s in
   { m with s; i }
 
+and canonize_intf ts_sub intf =
+  List.fold_left_map
+    (fun sub (key, l, t, k) ->
+      let sub, t = canonize sub t in
+      (sub, (key, l, t, k)))
+    ts_sub intf
+  |> snd
+
 let modpath_of_kind = function
   | Clocal p -> p
   | Cfile (name, _) -> Path.Pid name
@@ -587,15 +597,16 @@ let rec add_to_env env foreign (mname, m) =
                   load_foreign loc foreign fname mname;
                   Env.add_module ~key (Env.Cm_located mname) env
               | Some cached ->
-                  Env.add_module ~key (envmodule_of_cached mname cached) env))
+                  Env.add_module ~key (envmodule_of_cached mname cached) env)
+          | Mmodule_type (_, name, intf) -> Env.add_module_type name intf env)
         env m.i
   | l ->
       List.fold_left
         (fun env (name, loc, typ, kind) ->
           match kind with
           (* Not in the signature of the module we add it to *)
-          | Stypedef -> Env.add_type name ~in_sig:false typ env
-          | Svalue -> Env.(add_value name { def_value with typ } loc env))
+          | Mtypedef -> Env.add_type name ~in_sig:false typ env
+          | Mvalue -> Env.(add_value name { def_value with typ } loc env))
         env l
 
 and make_scope env loc foreign mname m =
@@ -749,32 +760,32 @@ let extract_name_type env = function
   | Mtype (l, t) -> (
       match t with
       | Trecord (_, Some n, _) | Tvariant (_, n, _) | Talias (n, _) ->
-          Some (Path.get_hd n, l, t, Stypedef)
+          Some (Path.get_hd n, l, t, Mtypedef)
       | t ->
           print_endline (string_of_type t (Env.modpath env));
           failwith "Internal Error: Type does not have a name")
-  | Mfun (l, t, n) | Mext (l, t, n, _) -> Some (n.user, l, t, Svalue)
-  | Mpoly_fun (l, abs, n, _) -> Some (n, l, type_of_func abs.func, Svalue)
+  | Mfun (l, t, n) | Mext (l, t, n, _) -> Some (n.user, l, t, Mvalue)
+  | Mpoly_fun (l, abs, n, _) -> Some (n, l, type_of_func abs.func, Mvalue)
   | Mmutual_rec _ -> None
   | Mlocal_module (l, n, _) ->
       (* Do we have to deal with this? *)
-      Some (n, l, Tunit, Svalue)
-  | Mmodule_alias _ -> None
+      Some (n, l, Tunit, Mvalue)
+  | Mmodule_alias _ | Mmodule_type _ -> None
 
 let find_item name kind (n, _, _, tkind) =
   match (kind, tkind) with
-  | (Svalue, Svalue | Stypedef, Stypedef) when String.equal name n -> true
+  | (Mvalue, Mvalue | Mtypedef, Mtypedef) when String.equal name n -> true
   | _ -> false
 
-let validate_signature env m =
+let validate_intf env intf impl =
   (* Go through signature and check that the implemented types match.
      Implementation is appended to a list, so the most current bindings are the ones we pick.
      That's exactly what we want. Also, set correct unique name to signature binding. *)
   let mn = Env.modpath env in
-  match m.s with
-  | [] -> m
+  match intf with
+  | [] -> intf
   | _ ->
-      let impl = List.filter_map (extract_name_type env) m.i in
+      let impl = List.filter_map (extract_name_type env) impl in
       let f (name, loc, styp, kind) =
         match (List.find_opt (find_item name kind) impl, kind) with
         | Some (n, loc, ityp, ikind), _ ->
@@ -784,8 +795,8 @@ let validate_signature env m =
             if b then (
               (* Query value to mark it as used in the env *)
               (match ikind with
-              | Svalue -> ignore (Env.query_val_opt loc (Path.Pid n) env)
-              | Stypedef -> ());
+              | Mvalue -> ignore (Env.query_val_opt loc (Path.Pid n) env)
+              | Mtypedef -> ());
               (* Use implementation type to retain closures *)
               (name, loc, ityp, kind))
             else
@@ -797,7 +808,7 @@ let validate_signature env m =
                   (string_of_type_subst subst ityp mn)
               in
               raise (Error (loc, msg))
-        | None, Stypedef -> (
+        | None, Mtypedef -> (
             (* Typedefs don't have to be given a second time. Except: When the initial type is abstract *)
             match clean styp with
             | Tabstract _ ->
@@ -807,7 +818,7 @@ let validate_signature env m =
                        "Abstract type " ^ string_of_type styp mn
                        ^ " not implemented" ))
             | _ -> (name, loc, styp, kind))
-        | None, Svalue ->
+        | None, Mvalue ->
             let msg =
               Printf.sprintf
                 "Mismatch between implementation and signature: Missing \
@@ -816,4 +827,19 @@ let validate_signature env m =
             in
             raise (Error (loc, msg))
       in
-      { m with s = List.map f m.s }
+      List.map f intf
+
+let validate_signature env m = { m with s = validate_intf env m.s m.i }
+
+let validate_intf env intf m =
+  match m.s with
+  | [] -> validate_intf env intf m.i |> ignore
+  | s ->
+      ignore s;
+      failwith "TODO"
+
+let to_module_type { s; i; _ } =
+  match (s, i) with
+  | [], _ -> failwith "Internal Error: Module type is empty"
+  | items, [] -> items
+  | _ -> failwith "Internal Error: Module type has an implementation"

lib/module.mli

@@ -40,6 +40,7 @@ val add_external :
 
 val add_local_module : loc -> string -> t -> into:t -> t
 val add_module_alias : loc -> string -> Path.t -> into:t -> t
+val add_module_type : loc -> string -> Module_type.t -> t -> t
 val clear_cache : unit -> unit
 val object_names : unit -> string list
 val register_module : Env.t -> Ast.loc -> Path.t -> t -> (Env.t, unit) result
@@ -52,4 +53,8 @@ val find_module :
 val scope_of_located : Env.t -> Path.t -> Env.scope
 val to_channel : out_channel -> outname:string -> t -> unit
 val append_externals : Env.ext list -> Env.ext list
+val validate_intf : Env.t -> Module_type.t -> t -> unit
 val validate_signature : Env.t -> t -> t
+
+val to_module_type : t -> Module_type.t
+(** Throws if [t] isn't a pure module type *)

lib/module_type.ml

@@ -0,0 +1,3 @@
+type item_kind = Mtypedef | Mvalue
+type item = string * Ast.loc * Types.typ * item_kind
+type t = item list

lib/typing/env.ml

@@ -108,6 +108,7 @@ type scope = {
   types : (typ * bool) Map.t;
   kind : scope_kind; (* Another list for local scopes (like in if) *)
   modules : cached_module Map.t; (* Locally declared modules *)
+  module_types : Module_type.t Map.t;
 }
 
 and cached_module = Cm_located of Path.t | Cm_cached of Path.t * scope
@@ -143,6 +144,7 @@ let empty_scope kind =
     types = Map.empty;
     kind;
     modules = Map.empty;
+    module_types = Map.empty;
   }
 
 let empty ~find_module ~scope_of_located ~abs_module_name modpath =
@@ -319,6 +321,11 @@ let add_module_alias loc ~key ~mname env =
   let cached_module = start env mname in
   add_module ~key cached_module env
 
+let add_module_type key mtype env =
+  let scope, tl = decap_exn env in
+  let module_types = Map.add key mtype scope.module_types in
+  { env with values = { scope with module_types } :: tl }
+
 let open_thing thing modpath env =
   (* Due to the ref, we have to create a new object every time *)
   (match env.values with
@@ -631,6 +638,14 @@ let find_module_opt ?(query = false) loc name env =
       match kind with Cm_located path | Cm_cached (path, _) -> path)
     loc name env
 
+let find_module_type_opt loc name env =
+  find_general
+    ~find:(fun key scope -> Map.find_opt key scope.module_types)
+    ~found:(fun scope mtype ->
+      mark_module_used scope;
+      mtype)
+    loc name env
+
 let find_label_opt key env =
   let rec aux = function
     | [] -> None

lib/typing/env.mli

@@ -66,6 +66,7 @@ val change_type : key -> typ -> t -> t
 val add_type : string -> in_sig:bool -> typ -> t -> t
 val add_module : key:string -> cached_module -> t -> t
 val add_module_alias : Ast.loc -> key:string -> mname:Path.t -> t -> t
+val add_module_type : string -> Module_type.t -> t -> t
 val open_function : t -> t
 val open_toplevel : Path.t -> t -> t
 val close_function : t -> t * closed list * touched list * unused
@@ -95,6 +96,7 @@ val query_type : instantiate:(typ -> typ) -> Ast.loc -> Path.t -> t -> typ
 (** [query_type name env] is like [find_type], but instantiates new types for parametrized types*)
 
 val find_module_opt : ?query:bool -> Ast.loc -> Path.t -> t -> Path.t option
+val find_module_type_opt : Ast.loc -> Path.t -> t -> Module_type.t option
 
 val find_label_opt : key -> t -> label option
 (** [find_label_opt labelname env] returns the name of first record with a matching label *)

lib/typing/typing.ml

@@ -1419,7 +1419,21 @@ and convert_prog env items modul =
         let mname = Env.find_module_opt loc (Path.Pid key) env |> Option.get in
         let m = Module.add_module_alias loc key mname ~into:m in
         (env, items, m)
-    | Module_type _ -> failwith "TODO module type"
+    | Module_type ((loc, id), vals) ->
+        (* This look a bit awkward for this use case. The split of adding first
+           signature types and values after is from the way module signatures are used.
+           That is, the types don't need to be duplictated in the module proper. *)
+        let mname = Path.append id (Env.modpath env) in
+        let tmpenv = Env.open_toplevel mname env in
+        let sigenv, tmpm =
+          List.fold_left add_signature_types (tmpenv, Module.empty) vals
+        in
+        let tmpm = List.fold_left (add_signature_vals sigenv) tmpm vals in
+        let _ = Env.close_toplevel tmpenv in
+        let mt = Module.to_module_type tmpm in
+        let m = Module.add_module_type loc id mt m in
+        let env = Env.add_module_type id mt env in
+        (env, items, m)
   and aux_stmt (old, env, items, m) = function
     (* TODO dedup *)
     | Ast.Let (loc, decl, block) ->
@@ -1524,7 +1538,6 @@ let to_typed ?(check_ret = true) ~mname msg_fn ~std (sign, prog) =
   let items = List.map (fun item -> (mname, item)) items in
   let items = List.rev !Module.poly_funcs @ items in
 
-  (* print_endline (String.concat ", " (List.map string_of_type typeinsts)); *)
   ({ externals; items }, m)
 
 let typecheck (prog : Ast.prog) =

schmu-mode.el

@@ -125,6 +125,7 @@ the syntax table, so `forward-word' works as expected.")
     "rec"
     "signature"
     "module"
+    "module-type"
 
     ,@schmu-var-decl-forms
     ,@schmu-function-decl-forms)
@@ -385,6 +386,7 @@ STATE is the `parse-partial-sexp' state for that position."
           (when-let 1)
           (signature 0)
           (module 1)
+          (module-type 1)
           (while 1))))
 
 ;;;###autoload

test/typing.ml

@@ -790,6 +790,9 @@ let test_type_decl_not_unique () =
 let test_type_decl_open_before () =
   test "unit" "(module m (type t int)) (open m) (type t float)"
 
+let test_mtype_define () =
+  test "unit" "(module-type tt (type t) (def random (fun unit int)))"
+
 let case str test = test_case str `Quick test
 
 (* Run it *)
@@ -1157,4 +1160,5 @@ let () =
           case "not unique" test_type_decl_not_unique;
           case "open before" test_type_decl_open_before;
         ] );
+      ("module type", [ case "define" test_mtype_define ]);
     ]