Fix #930

CHANGES.md

@@ -1,3 +1,13 @@
+# Unreleased
+
+### Added
+- Allow persistent latex macros in HTML/KaTeX backend (@dlesbre, #1391)
+- `markdown-generate` command now accepts multiple `.odocl` files in a single
+  invocation, eliminating the need for shell scripting (@davesnx, #1387)
+
+### Fixed
+- Fix compile-time crashing bugs #930 and #1385 (@jonludlam, #1400)
+
 # 3.1.0
 
 ### Added
@@ -6,9 +16,6 @@
 - New arguments to LaTeX generator, --shorten-beyond-depth and
   --remove-functor-arg-link (@Octachron, #1337)
 - New experimental markdown generator (@davesnx, #1341)
-- `markdown-generate` command now accepts multiple `.odocl` files in a single
-  invocation, eliminating the need for shell scripting (@davesnx)
-- Allow persistent latex macros in HTML/KaTeX backend (@dlesbre, #1391)
 
 ### Changed
 - Remove cmdliner compatibility layer, no longer needed (@dbuenzli, #1328)

src/loader/cmti.ml

@@ -777,7 +777,13 @@ and read_include env parent incl =
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
   let doc, status = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_status container incl.incl_attributes in
   let content, shadowed = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature incl.incl_type) in
-  let expr = read_module_type env parent container incl.incl_mod in
+  (* Use a synthetic parent for the include's module type expression to avoid
+     identifier conflicts with items in the enclosing signature. Items inside
+     the include expression (like TypeSubstitutions) will get identifiers under
+     this synthetic parent, which won't clash with the real parent's items. *)
+  let include_parent = Identifier.fresh_include_parent parent in
+  let include_container = (include_parent :> Identifier.LabelParent.t) in
+  let expr = read_module_type env include_parent include_container incl.incl_mod in
   let umty = Odoc_model.Lang.umty_of_mty expr in 
   let expansion = { content; shadowed; } in
   match umty with

src/model/paths.ml

@@ -624,6 +624,19 @@ module Identifier = struct
           `SourceLocationInternal (p, n))
   end
 
+  (* Counter for generating unique synthetic parents for include expressions.
+     Items inside an include's module type expression need a different parent
+     to avoid identifier conflicts with items in the enclosing signature. *)
+  let include_parent_counter = ref 0
+
+  (* Create a synthetic parent identifier for items inside an include's module
+     type expression. Uses a lowercase module name (illegal in normal OCaml)
+     to ensure no clashes with real identifiers. *)
+  let fresh_include_parent (parent : Signature.t) : Signature.t =
+    incr include_parent_counter;
+    let name = Printf.sprintf "include%d_" !include_parent_counter in
+    (Mk.module_ (parent, ModuleName.make_std name) :> Signature.t)
+
   module Hashtbl = struct
     module Any = Hashtbl.Make (Any)
     module ContainerPage = Hashtbl.Make (ContainerPage)

src/model/paths.mli

@@ -345,6 +345,12 @@ module Identifier : sig
       SourcePage.t * LocalName.t ->
       [> `SourceLocationInternal of SourcePage.t * LocalName.t ] id
   end
+
+  (** Create a synthetic parent identifier for items inside an include's
+      module type expression. Uses a lowercase module name (illegal in normal
+      OCaml) to ensure no clashes with real identifiers. Each call returns a
+      fresh identifier. *)
+  val fresh_include_parent : Signature.t -> Signature.t
 end
 
 (** Normal OCaml paths (i.e. the ones present in types) *)

src/xref2/compile.ml

@@ -322,7 +322,8 @@ and signature_items : Env.t -> Id.Signature.t -> Signature.item list -> _ =
             let m' = module_type env mt in
             let ty = Component.Of_Lang.(module_type (empty ()) m') in
             let env' = Env.add_module_type mt.id ty env in
-            loop (ModuleType (module_type env mt) :: items) env' rest
+            let items' = ModuleType m' :: items in
+            loop items' env' rest
         | ModuleTypeSubstitution mt ->
             let env' = Env.open_module_type_substitution mt env in
             loop
@@ -385,7 +386,16 @@ and include_decl : Env.t -> Id.Signature.t -> Include.decl -> Include.decl =
  fun env id decl ->
   let open Include in
   match decl with
-  | ModuleType expr -> ModuleType (u_module_type_expr env id expr)
+  | ModuleType expr ->
+      let rec is_elidable_with_u : Odoc_model.Lang.ModuleType.U.expr -> bool =
+        function
+        | Path _ -> false
+        | Signature _ -> true
+        | With (_, expr) -> is_elidable_with_u expr
+        | TypeOf _ -> false
+      in
+      if is_elidable_with_u expr then ModuleType expr
+      else ModuleType (u_module_type_expr env id expr)
   | Alias p -> Alias (module_path env p)
 
 and module_type : Env.t -> ModuleType.t -> ModuleType.t =
@@ -424,8 +434,8 @@ and include_ : Env.t -> Include.t -> Include.t * Env.t =
               Strengthen.signature cp sg
           | None -> sg
         in
-        let e = Lang_of.(simple_expansion map i.parent (Signature sg')) in
-
+        let sg'' = Tools.apply_inner_substs env sg' in
+        let e = Lang_of.(simple_expansion map i.parent (Signature sg'')) in
         let expansion_sg =
           match e with
           | ModuleType.Signature sg -> sg
@@ -434,7 +444,9 @@ and include_ : Env.t -> Include.t -> Include.t * Env.t =
         in
         { i.expansion with content = expansion_sg }
   in
-  let expansion = get_expansion () in
+  let expansion =
+    if i.expansion.content.compiled then i.expansion else get_expansion ()
+  in
   let items, env' = signature_items env i.parent expansion.content.items in
   let expansion =
     {

src/xref2/component.ml

@@ -1040,11 +1040,20 @@ module Fmt = struct
     let pp_sep ppf () = Format.fprintf ppf ", " in
     Format.fprintf ppf "(%a)" (Format.pp_print_list ~pp_sep type_param) ts
 
-  and type_equation c ppf t =
+  and type_equation_manifest c ppf t =
     match t.TypeDecl.Equation.manifest with
     | None -> ()
     | Some m -> Format.fprintf ppf " = %a" (type_expr c) m
 
+  and type_equation_params _c ppf t =
+    match t.TypeDecl.Equation.params with
+    | [] -> ()
+    | ps -> Format.fprintf ppf "%a" type_params ps
+
+  and type_equation c ppf t =
+    Format.fprintf ppf "(params %a)%a" (type_equation_params c) t
+      (type_equation_manifest c) t
+
   and exception_ _c _ppf _e = ()
 
   and extension c ppf e =

src/xref2/expand_tools.ml

@@ -50,9 +50,10 @@ let rec type_expr map t =
   match t with
   | Var v -> (
       try List.assoc v map
-      with _ ->
-        Format.eprintf "Failed to list assoc %s\n%!" v;
-        failwith "bah")
+      with Not_found ->
+        Format.eprintf "Type variable '%s' not found in map [%s]@." v
+          (String.concat ", " (List.map fst map));
+        assert false)
   | Any -> Any
   | Alias (t, s) ->
       if List.mem_assoc s map then raise Clash else Alias (type_expr map t, s)

src/xref2/lang_of.ml

@@ -649,7 +649,9 @@ and include_decl :
   (* Don't start shadowing within any signatures *)
   match d with
   | Alias p -> Alias (Path.module_ map p)
-  | ModuleType mty -> ModuleType (u_module_type_expr map identifier mty)
+  | ModuleType mty ->
+      let include_parent = Identifier.fresh_include_parent identifier in
+      ModuleType (u_module_type_expr map include_parent mty)
 
 and include_ parent map i =
   let open Component.Include in

src/xref2/link.ml

@@ -690,7 +690,15 @@ and module_decl : Env.t -> Id.Signature.t -> Module.decl -> Module.decl =
 and include_decl : Env.t -> Id.Signature.t -> Include.decl -> Include.decl =
  fun env id decl ->
   let open Include in
+  let rec is_elidable_with_u : Odoc_model.Lang.ModuleType.U.expr -> bool =
+    function
+    | Path _ -> false
+    | Signature _ -> true
+    | With (_, expr) -> is_elidable_with_u expr
+    | TypeOf _ -> false
+  in
   match decl with
+  | ModuleType expr when is_elidable_with_u expr -> ModuleType expr
   | ModuleType expr -> ModuleType (u_module_type_expr env id expr)
   | Alias p -> Alias (module_path env p)
 
@@ -1143,8 +1151,7 @@ and type_expression : Env.t -> Id.Signature.t -> _ -> _ =
                   | e ->
                       Format.eprintf
                         "Caught unexpected exception when expanding type \
-                         declaration (%s)\n\
-                         %!"
+                         declaration (%s)@."
                         (Printexc.to_string e);
                       Constr (`Resolved p, ts))
               | _ -> Constr (`Resolved p, ts)

src/xref2/subst.ml

@@ -29,6 +29,49 @@ let identity =
     unresolve_opaque_paths = false;
   }
 
+let pp fmt s =
+  let pp_map pp_binding b fmt map =
+    let pp_b fmt (id, v) =
+      Format.fprintf fmt "%a -> %a" Ident.fmt id pp_binding v
+    in
+    Format.fprintf fmt "@[<hov 1>{%a}@]" (Format.pp_print_list pp_b) (b map)
+  in
+  let pp_subst ppp fmt v =
+    Format.fprintf fmt "%s"
+      (match v with
+      | `Prefixed (p, _) -> Format.asprintf "%a" ppp p
+      | `Renamed id' -> Format.asprintf "%a" Ident.fmt id'
+      | `Substituted -> "<substituted>")
+  in
+  let pp_type_replacement fmt (te, eq) =
+    Format.fprintf fmt "(%a,%a)"
+      Component.Fmt.(type_expr default)
+      te
+      Component.Fmt.(type_equation default)
+      eq
+  in
+
+  Format.fprintf fmt
+    "{ module_ = %a;@ module_type = %a;@ type_ = %a;@ class_type = %a;@ \
+     type_replacement = %a;@ module_type_replacement = %a;@ \
+     path_invalidating_modules = [%a];@ unresolve_opaque_paths = %b }"
+    (pp_map (pp_subst Component.Fmt.(module_path default)) ModuleMap.bindings)
+    s.module_
+    (pp_map
+       (pp_subst Component.Fmt.(module_type_path default))
+       ModuleTypeMap.bindings)
+    s.module_type
+    (pp_map (pp_subst Component.Fmt.(type_path default)) TypeMap.bindings)
+    s.type_
+    (pp_map (pp_subst Component.Fmt.(class_type_path default)) TypeMap.bindings)
+    s.class_type
+    (pp_map pp_type_replacement TypeMap.bindings)
+    s.type_replacement
+    (pp_map Component.Fmt.(module_type_expr default) ModuleTypeMap.bindings)
+    s.module_type_replacement
+    (Format.pp_print_list Ident.fmt)
+    s.path_invalidating_modules s.unresolve_opaque_paths
+
 let unresolve_opaque_paths s = { s with unresolve_opaque_paths = true }
 
 let path_invalidate_module id t =
@@ -556,6 +599,11 @@ and type_expr s t =
             | Any -> acc
             | Var n -> (n, type_expr s pexpr) :: acc
           in
+          if List.length ts <> List.length eq.params then (
+            Format.eprintf
+              "Type substitution error: eq.params length=%d ts length=%d@."
+              (List.length eq.params) (List.length ts);
+            assert false);
           let vars = List.fold_left2 mk_var [] ts eq.params in
           substitute_vars vars t
       | Not_replaced p -> Constr (p, List.map (type_expr s) ts))

src/xref2/subst.mli

@@ -3,6 +3,8 @@ open Component
 
 type t = Component.Substitution.t
 
+val pp : Format.formatter -> t -> unit
+
 val identity : t
 
 val unresolve_opaque_paths : t -> t

src/xref2/test.md

@@ -975,7 +975,7 @@ now we can ask for the signature of this module:
 val sg : Tools.expansion =
   Odoc_xref2.Tools.Signature
    {Odoc_xref2.Component.Signature.items =
-     [Odoc_xref2.Component.Signature.Module (`LModule (M, 32),
+     [Odoc_xref2.Component.Signature.Module (`LModule (M, 31),
        Odoc_model.Lang.Signature.Ordinary,
        {Odoc_xref2.Component.Delayed.v =
          Some
@@ -1001,7 +1001,7 @@ val sg : Tools.expansion =
              None);
            canonical = None; hidden = false};
         get = None});
-      Odoc_xref2.Component.Signature.Module (`LModule (N, 33),
+      Odoc_xref2.Component.Signature.Module (`LModule (N, 32),
        Odoc_model.Lang.Signature.Ordinary,
        {Odoc_xref2.Component.Delayed.v =
          Some
@@ -1014,7 +1014,7 @@ val sg : Tools.expansion =
              (Odoc_xref2.Component.ModuleType.Path
                {Odoc_xref2.Component.ModuleType.p_expansion = None;
                 p_path =
-                 `DotMT (`Substituted (`Local (`LModule (M, 32), false)), S)});
+                 `DotMT (`Substituted (`Local (`LModule (M, 31), false)), S)});
            canonical = None; hidden = false};
         get = None})];
     compiled = false; removed = [];
@@ -1064,7 +1064,7 @@ val m : Component.Module.t Component.Delayed.t =
 - : Tools.expansion =
 Odoc_xref2.Tools.Signature
  {Odoc_xref2.Component.Signature.items =
-   [Odoc_xref2.Component.Signature.Type (`LType (t, 42),
+   [Odoc_xref2.Component.Signature.Type (`LType (t, 41),
      Odoc_model.Lang.Signature.Ordinary,
      {Odoc_xref2.Component.Delayed.v =
        Some

src/xref2/tools.ml

@@ -2341,3 +2341,68 @@ let resolve_value_path env p = resolve_value env p >>= fun (p, _) -> Ok p
 
 let resolve_class_type_path env p =
   resolve_class_type env p >>= fun (p, _) -> Ok p
+
+let apply_inner_substs env (sg : Component.Signature.t) : Component.Signature.t
+    =
+  let rec inner (items : Component.Signature.item list) :
+      Component.Signature.item list =
+    match items with
+    | Component.Signature.TypeSubstitution (id, typedecl) :: rest -> (
+        let subst =
+          Component.ModuleType.TypeSubst
+            (`Dot (`Root, Ident.Name.type_ id), typedecl.equation)
+        in
+        let rest =
+          Component.Signature.Type
+            (id, Ordinary, Component.Delayed.put (fun () -> typedecl))
+          :: inner rest
+        in
+        match fragmap env subst { sg with items = rest } with
+        | Ok sg' -> sg'.items
+        | Error _ -> failwith "error")
+    | Component.Signature.ModuleSubstitution (id, modsubst) :: rest -> (
+        let subst =
+          Component.ModuleType.ModuleSubst
+            (`Dot (`Root, Ident.Name.module_ id), modsubst.manifest)
+        in
+        let rest =
+          Component.Signature.Module
+            ( id,
+              Ordinary,
+              Component.Delayed.put (fun () ->
+                  {
+                    Component.Module.source_loc = None;
+                    doc = modsubst.doc;
+                    type_ = Alias (modsubst.manifest, None);
+                    canonical = None;
+                    hidden = false;
+                  }) )
+          :: inner rest
+        in
+        match fragmap env subst { sg with items = rest } with
+        | Ok sg' -> sg'.items
+        | Error _ -> failwith "error")
+    | Component.Signature.ModuleTypeSubstitution (id, modtypesubst) :: rest -> (
+        let subst =
+          Component.ModuleType.ModuleTypeSubst
+            (`Dot (`Root, Ident.Name.module_type id), modtypesubst.manifest)
+        in
+        let rest =
+          Component.Signature.ModuleType
+            ( id,
+              Component.Delayed.put (fun () ->
+                  {
+                    Component.ModuleType.source_loc = None;
+                    doc = modtypesubst.doc;
+                    expr = Some modtypesubst.manifest;
+                    canonical = None;
+                  }) )
+          :: inner rest
+        in
+        match fragmap env subst { sg with items = rest } with
+        | Ok sg' -> sg'.items
+        | Error _ -> failwith "error")
+    | x :: rest -> x :: inner rest
+    | [] -> []
+  in
+  { sg with items = inner sg.items }

src/xref2/tools.mli

@@ -337,3 +337,5 @@ val reset_caches : unit -> unit
 
 val disable_all_caches : unit -> unit
 (** Disable the caches completely *)
+
+val apply_inner_substs : Env.t -> Component.Signature.t -> Component.Signature.t

test/sources/functor.t/run.t

@@ -60,9 +60,8 @@ In this test, the functor expansion contains the right link.
        <a href="../../src/a.ml.html#module-F.val-y" class="source_link">Source
        </a>
 
-  $ cat html/root/source/a.ml.html | grep L3
-  cat: html/root/source/a.ml.html: No such file or directory
-  [1]
+  $ cat html/src/a.ml.html | grep L3
+  <a id="L3" class="source_line" href="#L3">3</a>
 
 However, on functor results, there is a link to source in the file: