Represent the fragment root as a fixed local module

The root of the signature that a with constraint changes is now a local
module identifier with a fixed number, so the parent type no longer needs
a FragmentRoot constructor that only component paths can hold.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>

Author: jonludlam

src/model/paths.ml

@@ -635,7 +635,6 @@ module Path = struct
       (global_parent, na, canon) Paths_types.Resolved_path.module_ = function
     | `Module m -> m
     | `ModuleType (_, `Na _) -> .
-    | `FragmentRoot (`Na _) -> .
 
   type ra = (global_parent, na, canon) Paths_types.Resolved_path.any
 
@@ -728,7 +727,6 @@ module Path = struct
     | `ModuleType (mt, _) ->
         is_resolved_hidden_gen ~weak_canonical_test
           (mt :> (local_parent, 'pty) gra)
-    | `FragmentRoot _ -> false
 
   and is_path_hidden_gen : 'pty. (local_parent, 'pty) gpa -> bool = function
     | `Resolved r -> is_resolved_hidden_gen ~weak_canonical_test:false r

src/model/paths_types.ml

@@ -325,8 +325,7 @@ end =
 and Resolved_path : sig
   type ('p, 'pty, 'canon) parent =
     [ `Module of ('p, 'pty, 'canon) module_
-    | `ModuleType of ('p, 'pty, 'canon) module_type * 'pty
-    | `FragmentRoot of 'pty ]
+    | `ModuleType of ('p, 'pty, 'canon) module_type * 'pty ]
     constraint 'canon = < m : 'cm ; mt : 'cmt ; t : 'ct >
 
   and ('p, 'pty, 'canon) module_ =

src/xref2/component.ml

@@ -1370,7 +1370,6 @@ module Fmt = struct
     | `ModuleType (m, _) ->
         if c.short_paths then resolved_module_type_path c ppf m
         else Format.fprintf ppf ">>%a<<" (resolved_module_type_path c) m
-    | `FragmentRoot _ -> Format.fprintf ppf "FragmentRoot"
 
   and type_path : config -> Format.formatter -> Cpath.type_ -> unit =
    fun c ppf p ->

src/xref2/cpath.ml

@@ -85,6 +85,17 @@ end
 
 include Cpath
 
+(* The parent that stands for the root of the signature a [with] constraint
+   changes, while its fragments are resolved. *)
+let fragment_root : Resolved.parent =
+  `Module (`Identifier (Ident.fragment_root :> Id.module_))
+
+let is_fragment_root : Resolved.parent -> bool = function
+  | `Module (`Identifier (`Module (`Local i, _))) ->
+      let (`Module (`Local j, _)) = Ident.fragment_root in
+      i = j
+  | _ -> false
+
 let rec is_resolved_module_substituted : Resolved.module_ -> bool = function
   | `Substituted _ -> true
   | `Identifier _ -> false
@@ -97,7 +108,6 @@ let rec is_resolved_module_substituted : Resolved.module_ -> bool = function
 and is_resolved_parent_substituted = function
   | `Module m -> is_resolved_module_substituted m
   | `ModuleType (m, _) -> is_resolved_module_type_substituted m
-  | `FragmentRoot _ -> false
 
 and is_resolved_module_type_substituted : Resolved.module_type -> bool =
   function
@@ -265,8 +275,9 @@ and unresolve_resolved_module_type_path : Resolved.module_type -> module_type =
   | `OpaqueModuleType m -> unresolve_resolved_module_type_path m
 
 and unresolve_resolved_parent_path : Resolved.parent -> module_ = function
+  | p when is_fragment_root p -> assert false
   | `Module m -> unresolve_resolved_module_path m
-  | `FragmentRoot _ | `ModuleType _ -> assert false
+  | `ModuleType _ -> assert false
 
 and unresolve_resolved_type_path : Resolved.type_ -> type_ = function
   | (`Identifier _ | `CoreType _) as p -> `Resolved p

src/xref2/ident.ml

@@ -54,6 +54,11 @@ let class_of_type : type_ -> [ `Class of [ `Local of int ] * TypeName.t ] =
   function
   | `Type (l, n) -> `Class (l, n)
 
+(* The root of the signature that a [with] constraint changes. It is a fixed
+   local, as fresh locals start from 0. *)
+let fragment_root : module_ =
+  `Module (`Local (-1), ModuleName.make_std "FragmentRoot")
+
 let fresh_int () =
   let n = !counter in
   incr counter;

src/xref2/lang_of.ml

@@ -151,6 +151,11 @@ module Path = struct
   and resolved_module_inner map (p : Cpath.Resolved.module_) :
       Odoc_model.Paths.Path.Resolved.Module.t =
     match p with
+    | `Identifier _ when Cpath.is_fragment_root (`Module p) -> (
+        (* A module type root fails as a module type parent did before. *)
+        match map.fragment_root with
+        | Some (`Module m) -> resolved_module map m
+        | Some (`ModuleType _) | None -> failwith "Invalid")
     | `Identifier id -> (
         match Cpath.Id.module_ id with
         | Global g -> `Identifier g
@@ -173,11 +178,6 @@ module Path = struct
     match p with
     | `Module m -> resolved_module map m
     | `ModuleType _ -> failwith "Invalid"
-    | `FragmentRoot _ -> (
-        match map.fragment_root with
-        | Some (`Module m) -> resolved_parent map (`Module m)
-        | Some (`ModuleType mt) -> resolved_parent map (`ModuleType (mt, `U))
-        | None -> failwith "Invalid")
 
   and resolved_module_type map (p : Cpath.Resolved.module_type) :
       Odoc_model.Paths.Path.Resolved.ModuleType.t =

src/xref2/subst.ml

@@ -263,7 +263,6 @@ and resolved_parent_path s = function
         | Not_replaced p1 -> p1
       in
       `ModuleType (p, pty)
-  | `FragmentRoot _ as x -> x
 
 and module_path : t -> Cpath.module_ -> Cpath.module_ =
  fun s p ->

src/xref2/tools.ml

@@ -634,6 +634,10 @@ and lookup_parent :
  fun env' parent' ->
   let lookup env parent =
     match parent with
+    | p when Cpath.is_fragment_root p ->
+        Env.lookup_fragment_root env
+        |> of_option ~error:(`Parent `Fragment_root)
+        >>= fun (_, sg) -> Ok (sg, prefix_substitution parent sg)
     | `Module p ->
         lookup_module env p |> map_error (fun e -> `Parent (`Parent_module e))
         >>= fun m ->
@@ -650,10 +654,6 @@ and lookup_parent :
         |> map_error (fun e -> `Parent (`Parent_sig e))
         >>= assert_not_functor
         >>= fun sg -> Ok (sg, prefix_substitution parent sg)
-    | `FragmentRoot _ ->
-        Env.lookup_fragment_root env
-        |> of_option ~error:(`Parent `Fragment_root)
-        >>= fun (_, sg) -> Ok (sg, prefix_substitution parent sg)
   in
   LookupParentMemo.memoize lookup env' parent'
 
@@ -1292,7 +1292,6 @@ and reresolve_parent : Env.t -> Cpath.Resolved.parent -> Cpath.Resolved.parent =
   match path with
   | `Module m -> `Module (reresolve_module env m)
   | `ModuleType (mty, x) -> `ModuleType (reresolve_module_type env mty, x)
-  | `FragmentRoot _ -> path
 
 (* *)
 and module_type_expr_of_module_decl :
@@ -1854,10 +1853,10 @@ and find_external_parent_path :
  fun p ->
   let open Odoc_utils.OptionMonad in
   match p with
+  | p when Cpath.is_fragment_root p -> None
   | `Module m -> find_external_module_path m >>= fun m -> Some (`Module m)
   | `ModuleType (m, x) ->
       find_external_module_type_path m >>= fun m -> Some (`ModuleType (m, x))
-  | `FragmentRoot _ -> None
 
 and fixup_module_cfrag (f : Cfrag.resolved_module) : Cfrag.resolved_module =
   match f with
@@ -1925,8 +1924,8 @@ and resolve_signature_fragment :
  fun env (p, sg) frag ->
   match frag with
   | `Root ->
-      let sg = prefix_signature (`FragmentRoot `U, sg) in
-      Some (`Root p, `FragmentRoot `U, sg)
+      let sg = prefix_signature (Cpath.fragment_root, sg) in
+      Some (`Root p, Cpath.fragment_root, sg)
   | `Resolved _r -> None
   | `Dot (parent, name) ->
       let open Odoc_utils.OptionMonad in
@@ -1946,7 +1945,7 @@ and resolve_signature_fragment :
             (`Alias (p', `Resolved new_path, None), `Alias (p', new_frag))
         | Some (`SubstMT p') -> (`Subst (p', new_path), `Subst (p', new_frag))
       in
-      (* Don't use the cached one - `FragmentRoot` is not unique *)
+      (* Don't use the cached one - the fragment root is not unique *)
       of_result
         Odoc_utils.ResultMonad.(
           expansion_of_module env m' >>= assert_not_functor)