Modular explicits

ocaml/file_formats/cmt_format.ml

@@ -240,6 +240,8 @@ let iter_on_occurrences
           f ~namespace:Type ctyp_env path lid
       | Ttyp_package {pack_path; pack_txt} ->
           f ~namespace:Module_type ctyp_env pack_path pack_txt
+      | Ttyp_functor (_, _, ({pack_path; pack_txt}, _), _) ->
+          f ~namespace:Module_type ctyp_env pack_path pack_txt
       | Ttyp_class (path, lid, _typs) ->
           (* Deprecated syntax to extend a polymorphic variant *)
           f ~namespace:Type ctyp_env path lid

ocaml/ocamldoc/odoc_misc.ml

@@ -500,6 +500,7 @@ let remove_option typ =
     | Tunivar _
     | Tpoly _
     | Tarrow _
+    | Tfunctor _
     | Ttuple _
     | Tunboxed_tuple _
     | Tobject _

ocaml/ocamldoc/odoc_str.ml

@@ -38,6 +38,7 @@ let string_of_variance t v =
 let rec is_arrow_type t =
   match Types.get_desc t with
     Types.Tarrow _ -> true
+  | Types.Tfunctor _ -> true
   | Types.Tlink t2 -> is_arrow_type t2
   | Types.Ttuple _
   | Types.Tunboxed_tuple _
@@ -49,7 +50,7 @@ let rec is_arrow_type t =
 
 let rec need_parent t =
   match Types.get_desc t with
-    Types.Tarrow _ | Types.Ttuple _ | Tunboxed_tuple _ -> true
+    Types.Tarrow _ | Types.Ttuple _ | Types.Tfunctor _ | Tunboxed_tuple _ -> true
   | Types.Tlink t2 -> need_parent t2
   | Types.Tconstr _
   | Types.Tvar _ | Types.Tunivar _ | Types.Tobject _ | Types.Tpoly _

ocaml/ocamldoc/odoc_value.ml

@@ -65,6 +65,8 @@ let parameter_list_from_arrows typ =
     match Types.get_desc t with
       Types.Tarrow ((l,_,_), t1, t2, _) ->
         (l, t1) :: (iter t2)
+    | Types.Tfunctor ((l,_,_), _, (p, fl), t2) ->
+        (l, Ctype.newty (Types.Tpackage (p, fl))) :: (iter t2)
     | Types.Tlink texp
     | Types.Tpoly (texp, _) -> iter texp
     | Types.Tvar _

ocaml/parsing/ast_helper.ml

@@ -72,6 +72,7 @@ module Typ = struct
   let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c))
   let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b))
   let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b))
+  let functor_ ?loc ?attrs a b c d e f = mk ?loc ?attrs (Ptyp_functor (a, b, c, d, e, f))
   let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a)
   let open_ ?loc ?attrs mod_ident t = mk ?loc ?attrs (Ptyp_open (mod_ident, t))
 
@@ -133,6 +134,11 @@ module Typ = struct
             Ptyp_open (mod_ident, loop core_type)
         | Ptyp_extension (s, arg) ->
             Ptyp_extension (s, arg)
+        | Ptyp_functor (lbl, name, ((longident, lst), attrs), codomain, m1, m2) ->
+            Ptyp_functor
+                (lbl, name,
+                ((longident, List.map (fun (n, typ) -> (n, loop typ)) lst), attrs),
+                loop codomain, m1, m2)
       in
       {t with ptyp_desc = desc}
     and loop_row_field field =

ocaml/parsing/ast_helper.mli

@@ -87,6 +87,9 @@ module Typ :
     val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list
                  -> core_type
     val open_ : ?loc:loc -> ?attrs:attrs -> lid -> core_type -> core_type
+    val functor_ : ?loc:loc -> ?attrs:attrs -> arg_label -> str
+                 -> ((lid * (lid * core_type) list) * attributes) -> core_type
+                 -> mode with_loc list -> mode with_loc list -> core_type
     val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type
 
     val force_poly: core_type -> core_type

ocaml/parsing/ast_iterator.ml

@@ -184,6 +184,14 @@ module T = struct
         iter_loc sub mod_ident;
         sub.typ sub t
     | Ptyp_extension x -> sub.extension sub x
+    | Ptyp_functor (_, s, ((lid, l), attrs), t2, m1, m2) ->
+            iter_loc sub s;
+            iter_loc sub lid;
+            sub.attributes sub attrs;
+            List.iter (iter_tuple (iter_loc sub) (sub.typ sub)) l;
+            sub.typ sub t2;
+            sub.modes sub m1;
+            sub.modes sub m2
 
   let iter_type_declaration sub
      ({ptype_name; ptype_params; ptype_cstrs;

ocaml/parsing/ast_mapper.ml

@@ -226,6 +226,13 @@ module T = struct
     | Ptyp_open (mod_ident, t) ->
         open_ ~loc ~attrs (map_loc sub mod_ident) (sub.typ sub t)
     | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x)
+    | Ptyp_functor (lbl, s, ((lid, l), attrs), t, m1, m2) ->
+        functor_ ~loc ~attrs lbl (map_loc sub s)
+          ((map_loc sub lid, List.map (map_tuple (map_loc sub) (sub.typ sub)) l),
+           sub.attributes sub attrs)
+          (sub.typ sub t)
+          (sub.modes sub m1)
+          (sub.modes sub m2)
 
   let map_type_declaration sub
      ({ptype_name; ptype_params; ptype_cstrs;

ocaml/parsing/depend.ml

@@ -131,6 +131,7 @@ let rec add_type bv ty =
     let bv = open_module bv mod_ident.txt in
     add_type bv t
   | Ptyp_extension e -> handle_extension e
+  | Ptyp_functor (_, _, (pt, _), t2, _, _) -> add_package_type bv pt; add_type bv t2
 
 and add_type_jst bv : Jane_syntax.Core_type.t -> _ = function
   | Jtyp_layout typ -> add_type_jst_layouts bv typ

ocaml/parsing/parser.mly

@@ -227,7 +227,7 @@ let mktyp_curry typ loc =
 
 let maybe_curry_typ typ loc =
   match typ.ptyp_desc with
-  | Ptyp_arrow _ ->
+  | Ptyp_arrow _ | Ptyp_functor _ ->
       if List.exists is_curry_attr typ.ptyp_attributes then typ
       else mktyp_curry typ (make_loc loc)
   | _ -> typ
@@ -4365,8 +4365,41 @@ strict_function_or_labeled_tuple_type:
     { let ty, ltys = $3 in
       mktyp ~loc:$sloc (Ptyp_tuple ((Some label, ty) :: ltys))
     }
+  (* TODO handle modes *)
+  | mktyp(
+      label = arg_label
+      mty_with_mode = with_optional_mode_expr(module_arg)
+      MINUSGREATER
+      codomain = strict_function_or_labeled_tuple_type
+        { let (((attrs1, id, mty), _mty_loc), arg_modes) = mty_with_mode in
+          let (lid, cstrs, attrs2) = package_type_of_module_type mty in
+          let attrs = attrs1 @ attrs2 in
+          Ptyp_functor(label, id, ((lid, cstrs), attrs), codomain, arg_modes, []) }
+    )
+    { $1 }
+  | mktyp(
+      label = arg_label
+      mty_with_mode = with_optional_mode_expr(module_arg)
+      MINUSGREATER
+      codomain_with_modes = with_optional_mode_expr(tuple_type)
+        { let (((attrs1, id, mty), _mty_loc), arg_modes) = mty_with_mode in
+          let (codomain, codomain_loc), ret_modes = codomain_with_modes in
+          let (lid, cstrs, attrs2) = package_type_of_module_type mty in
+          let attrs = attrs1 @ attrs2 in
+          Ptyp_functor(label, id, ((lid, cstrs), attrs),
+              maybe_curry_typ codomain codomain_loc,
+              arg_modes,
+              ret_modes)
+        }
+    )
+    { $1 }
 ;
 
+%inline module_arg:
+  | LPAREN MODULE attrs = ext_attributes id = mkrhs(UIDENT) COLON
+      mty = module_type RPAREN
+      { (snd attrs, id, mty)}
+
 %inline strict_arg_label:
   | label = optlabel
       { Optional label }

ocaml/parsing/parsetree.mli

@@ -185,6 +185,8 @@ and core_type_desc =
   | Ptyp_package of package_type  (** [(module S)]. *)
   | Ptyp_open of Longident.t loc * core_type (** [M.(T)] *)
   | Ptyp_extension of extension  (** [[%id]]. *)
+  | Ptyp_functor of arg_label * string loc * (package_type * attributes) * core_type * modes * modes
+        (** [{M : S} -> ...] *)
 
 and arg_label = Asttypes.arg_label =
     Nolabel
@@ -571,6 +573,10 @@ and function_constraint =
   }
 (** See the comment on {{!expression_desc.Pexp_function}[Pexp_function]}. *)
 
+and argument =
+  | Parg_expr of expression
+  | Parg_module of module_expr
+
 (** {2 Value descriptions} *)
 
 and value_description =

ocaml/parsing/pprintast.ml

@@ -410,24 +410,26 @@ let include_kind f = function
   | Functor -> pp f "@ functor"
   | Structure -> ()
 
+let xxx_with_label printer f (label, c) =
+  match label with
+  | Nolabel    -> printer f c (* otherwise parenthesize *)
+  | Labelled s -> pp f "%a:%a" ident_of_name s printer c
+  | Optional s -> pp f "?%a:%a" ident_of_name s printer c
+
 (* c ['a,'b] *)
 let rec class_params_def ctxt f =  function
   | [] -> ()
   | l ->
       pp f "[%a] " (* space *)
         (list (type_param ctxt) ~sep:",") l
 
-and type_with_label ctxt f (label, c, mode) =
-  match label with
-  | Nolabel    ->
-    maybe_legacy_modes_type_at_modes core_type1 ctxt f (c, mode)
-    (* otherwise parenthesize *)
-  | Labelled s ->
-    pp f "%a:%a" ident_of_name s
-      (maybe_legacy_modes_type_at_modes core_type1 ctxt) (c, mode)
-  | Optional s ->
-    pp f "?%a:%a" ident_of_name s
-      (maybe_legacy_modes_type_at_modes core_type1 ctxt) (c, mode)
+and type_with_label ctxt =
+  xxx_with_label (maybe_legacy_modes_type_at_modes core_type1 ctxt)
+
+and functor_arg ctxt f (name, pck_ty) =
+  pp f "@[<hov2>(module@ %a : %a)@]" ident_of_name name.txt (package_type ctxt) pck_ty
+
+and package_with_label ctxt = xxx_with_label (functor_arg ctxt)
 
 and jkind ?(nested = false) ctxt f k = match (k : Jane_syntax.Jkind.t) with
   | Default -> pp f "_"
@@ -477,7 +479,11 @@ and core_type ctxt f x =
   else match x.ptyp_desc with
     | Ptyp_arrow (l, ct1, ct2, m1, m2) ->
         pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
-          (type_with_label ctxt) (l,ct1,m1) (return_type ctxt) (ct2,m2)
+          (type_with_label ctxt) (l,(ct1,m1)) (return_type ctxt) (ct2,m2)
+    | Ptyp_functor (label, name, (pack, _attrs), ct2, _m1, m2) ->
+      pp f "@[<2>%a@;->@;%a@]"
+          (package_with_label ctxt) (label, (name, pack))
+          (return_type ctxt) (ct2, m2)
     | Ptyp_alias (ct, s) ->
         pp f "@[<2>%a@;as@;%a@]" (core_type1 ctxt) ct tyvar s.txt
     | Ptyp_poly ([], ct) ->
@@ -566,19 +572,21 @@ and core_type1 ctxt f x =
         pp f "@[<hov2>%a@;#%a@]"
           (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l
           longident_loc li
-    | Ptyp_package (lid, cstrs) ->
-        let aux f (s, ct) =
-          pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct  in
-        (match cstrs with
-         |[] -> pp f "@[<hov2>(module@ %a)@]" longident_loc lid
-         |_ ->
-             pp f "@[<hov2>(module@ %a@ with@ %a)@]" longident_loc lid
-               (list aux  ~sep:"@ and@ ")  cstrs)
+    | Ptyp_package pck_ty ->
+        pp f "@[<hov2>(module@ %a)@]" (package_type ctxt) pck_ty
     | Ptyp_open(li, ct) ->
-       pp f "@[<hov2>%a.(%a)@]" longident_loc li (core_type ctxt) ct
+      pp f "@[<hov2>%a.(%a)@]" longident_loc li (core_type ctxt) ct
     | Ptyp_extension e -> extension ctxt f e
-    | (Ptyp_arrow _ | Ptyp_alias _ | Ptyp_poly _) ->
-       paren true (core_type ctxt) f x
+    | (Ptyp_arrow _ | Ptyp_functor _ | Ptyp_alias _ | Ptyp_poly _) ->
+      paren true (core_type ctxt) f x
+and package_type ctxt f (lid, cstrs) =
+  let aux f (s, ct) =
+    pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct  in
+  (match cstrs with
+   |[] -> pp f "%a" longident_loc lid
+   |_ ->
+       pp f "%a@ with@ %a" longident_loc lid
+         (list aux  ~sep:"@ and@ ")  cstrs)
 
 and core_type_jane_syntax ctxt attrs f (x : Jane_syntax.Core_type.t) =
   let filtered_attrs = filter_curry_attrs attrs in
@@ -1286,7 +1294,7 @@ and class_type ctxt f x =
         (attributes ctxt) x.pcty_attributes
   | Pcty_arrow (l, co, cl) ->
       pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *)
-        (type_with_label ctxt) (l,co,[])
+        (type_with_label ctxt) (l,(co,[]))
         (class_type ctxt) cl
   | Pcty_extension e ->
       extension ctxt f e;

ocaml/parsing/printast.ml

@@ -215,6 +215,15 @@ let rec core_type i ppf x =
   | Ptyp_extension (s, arg) ->
       line i ppf "Ptyp_extension \"%s\"\n" s.txt;
       payload i ppf arg
+  | Ptyp_functor (lbl, name, ((li, l), attrs), ct2, m1, m2) ->
+      line i ppf "Ptyp_functor\n";
+      arg_label i ppf lbl;
+      line i ppf "\"%s\" : %a\n" name.txt fmt_longident_loc li;
+      list i package_with ppf l;
+      attributes i ppf attrs;
+      modes i ppf m1;
+      core_type i ppf ct2;
+      modes i ppf m2
 
 and package_with i ppf (s, t) =
   line i ppf "with type %a\n" fmt_longident_loc s;