Source file subst.ml

open Component

exception Invalidated

type ('a, 'b) or_replaced = Not_replaced of 'a | Replaced of 'b

type 'a type_or_replaced = ('a, TypeExpr.t * TypeDecl.Equation.t) or_replaced

type 'a module_type_or_replaced = ('a, ModuleType.expr) or_replaced

let map_replaced f = function
  | Not_replaced p -> Not_replaced (f p)
  | Replaced _ as r -> r

open Component
open Substitution

type nonrec t = t

let identity =
  {
    module_ = ModuleMap.empty;
    module_type = ModuleTypeMap.empty;
    module_type_replacement = ModuleTypeMap.empty;
    type_ = TypeMap.empty;
    class_type = TypeMap.empty;
    type_replacement = TypeMap.empty;
    path_invalidating_modules = [];
    unresolve_opaque_paths = false;
  }

let is_identity s =
  ModuleMap.is_empty s.module_
  && ModuleTypeMap.is_empty s.module_type
  && ModuleTypeMap.is_empty s.module_type_replacement
  && TypeMap.is_empty s.type_
  && TypeMap.is_empty s.class_type
  && TypeMap.is_empty s.type_replacement
  && s.path_invalidating_modules = []
  && not s.unresolve_opaque_paths

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 =
  { t with path_invalidating_modules = id :: t.path_invalidating_modules }

let add_module id p rp t =
  { t with module_ = ModuleMap.add id (`Prefixed (p, rp)) t.module_ }

let add_module_type id p rp t =
  {
    t with
    module_type = ModuleTypeMap.add id (`Prefixed (p, rp)) t.module_type;
  }

let add_type : Ident.type_ -> Cpath.type_ -> Cpath.Resolved.type_ -> t -> t =
 fun id p rp t ->
  { t with type_ = TypeMap.add (id :> Ident.type_) (`Prefixed (p, rp)) t.type_ }

let add_class :
    Ident.type_ -> Cpath.class_type -> Cpath.Resolved.class_type -> t -> t =
 fun id p rp t ->
  {
    t with
    type_ =
      TypeMap.add
        (id :> Ident.type_)
        (`Prefixed ((p :> Cpath.type_), (rp :> Cpath.Resolved.type_)))
        t.type_;
    class_type =
      TypeMap.add (id :> Ident.type_) (`Prefixed (p, rp)) t.class_type;
  }

let add_class_type :
    Ident.type_ -> Cpath.class_type -> Cpath.Resolved.class_type -> t -> t =
 fun id p rp t ->
  {
    t with
    type_ =
      TypeMap.add
        (id :> Ident.type_)
        (`Prefixed ((p :> Cpath.type_), (rp :> Cpath.Resolved.type_)))
        t.type_;
    class_type =
      TypeMap.add (id :> Ident.type_) (`Prefixed (p, rp)) t.class_type;
  }

let add_type_replacement id texp equation t =
  {
    t with
    type_replacement = TypeMap.add id (texp, equation) t.type_replacement;
  }

let add_module_type_replacement path mty t =
  {
    t with
    module_type_replacement =
      ModuleTypeMap.add path mty t.module_type_replacement;
  }

let add_module_substitution : Ident.module_ -> t -> t =
 fun id t ->
  {
    t with
    path_invalidating_modules = id :: t.path_invalidating_modules;
    module_ = ModuleMap.add id `Substituted t.module_;
  }

let rename_module : Ident.module_ -> Ident.module_ -> t -> t =
 fun id id' t -> { t with module_ = ModuleMap.add id (`Renamed id') t.module_ }

let rename_module_type : Ident.module_type -> Ident.module_type -> t -> t =
 fun id id' t ->
  { t with module_type = ModuleTypeMap.add id (`Renamed id') t.module_type }

let rename_type : Ident.type_ -> Ident.type_ -> t -> t =
 fun id id' t -> { t with type_ = TypeMap.add id (`Renamed id') t.type_ }

let rename_class_type : Ident.type_ -> Ident.type_ -> t -> t =
 fun id id' t ->
  {
    t with
    class_type = TypeMap.add id (`Renamed id') t.class_type;
    type_ =
      TypeMap.add (id :> Ident.type_) (`Renamed (id' :> Ident.type_)) t.type_;
  }

let rec substitute_vars vars t =
  let open TypeExpr in
  match t with
  | Var (s, _jk) -> ( try List.assoc s vars with Not_found -> t)
  | Any -> Any
  | Alias (t, str) -> Alias (substitute_vars vars t, str)
  | Arrow (lbl, t1, t2, modes, ret_modes) ->
      Arrow (lbl, substitute_vars vars t1, substitute_vars vars t2, modes, ret_modes)
  | Tuple ts ->
      Tuple (List.map (fun (lbl, ty) -> (lbl, substitute_vars vars ty)) ts)
  | Unboxed_tuple ts ->
    Unboxed_tuple (List.map (fun (l, t) -> l, substitute_vars vars t) ts)
  | Constr (p, ts) -> Constr (p, List.map (substitute_vars vars) ts)
  | Polymorphic_variant v ->
      Polymorphic_variant (substitute_vars_poly_variant vars v)
  | Object o -> Object (substitute_vars_type_object vars o)
  | Class (p, ts) -> Class (p, List.map (substitute_vars vars) ts)
  | Poly (strs, ts) -> Poly (strs, substitute_vars vars ts)
  | Quote t -> Quote (substitute_vars vars t)
  | Splice t -> Splice (substitute_vars vars t)
  | Package p -> Package (substitute_vars_package vars p)

and substitute_vars_package vars p =
  let open TypeExpr.Package in
  let subst_subst (p, t) = (p, substitute_vars vars t) in
  { p with substitutions = List.map subst_subst p.substitutions }

and substitute_vars_type_object vars o =
  let open TypeExpr.Object in
  let subst_field = function
    | Method m -> Method { m with type_ = substitute_vars vars m.type_ }
    | Inherit t -> Inherit (substitute_vars vars t)
  in
  { o with fields = List.map subst_field o.fields }

and substitute_vars_poly_variant vars v =
  let open TypeExpr.Polymorphic_variant in
  let subst_element = function
    | Type t -> Type (substitute_vars vars t)
    | Constructor c ->
        let arguments =
          List.map (substitute_vars vars) c.Constructor.arguments
        in
        Constructor { c with arguments }
  in
  { v with elements = List.map subst_element v.elements }

let rec resolved_module_path :
    t -> Cpath.Resolved.module_ -> Cpath.Resolved.module_ =
 fun s p ->
  match p with
  | `LocalMod (`Na _) -> .
  | `LocalMod (#Ident.module_ as id) -> (
      if List.mem id s.path_invalidating_modules then raise Invalidated;
      match
        try Some (ModuleMap.find id s.module_)
        with _ -> None
      with
      | Some (`Renamed x) -> `LocalMod (x :> Cpath.lmod)
      | Some (`Prefixed (_p, rp)) -> rp
      | Some `Substituted -> `Substituted p
      | None -> p)
  | `Identifier _ -> p
  | `Apply (p1, p2) ->
      let p1' = resolved_module_path s p1 in
      let p2' = resolved_module_path s p2 in
      if p1' == p1 && p2' == p2 then p
      else `Apply (p1', p2')
  | `Substituted m ->
      let m' = resolved_module_path s m in
      if m' == m then p else `Substituted m'
  | `Module (parent, n) ->
      let parent' = resolved_parent_path s parent in
      if parent' == parent then p else `Module (parent', n)
  | `Alias (p1, p2, p3opt) ->
      let p1' = resolved_module_path s p1 in
      let p2' = module_path s p2 in
      let up2' = try Cpath.unresolve_module_path p2' with _ -> p2' in
      let p3opt' =
        match p3opt with
        | Some p3 -> Some (resolved_module_path s p3)
        | None -> None
      in
      if p1' == p1 && up2' == p2 && p3opt' == p3opt then p
      else `Alias (p1', up2', p3opt')
  | `Subst (p1, p2) ->
      let p1' =
        match resolved_module_type_path s p1 with
        | Replaced _ -> assert false
        | Not_replaced p1' -> p1'
      in
      let p2' = resolved_module_path s p2 in
      if p1' == p1 && p2' == p2 then p else `Subst (p1', p2')
  | `Hidden p1 ->
      let p1' = resolved_module_path s p1 in
      if p1' == p1 then p else `Hidden p1'
  | `Canonical (p1, p2) ->
      let p1' = resolved_module_path s p1 in
      if p1' == p1 then p else `Canonical (p1', p2)
  | `OpaqueModule m ->
      if s.unresolve_opaque_paths then raise Invalidated
      else
        let m' = resolved_module_path s m in
        if m' == m then p else `OpaqueModule m'

and resolved_parent_path s p =
  match p with
  | `Module m ->
      let m' = resolved_module_path s m in
      if m' == m then p else `Module m'
  | `ModuleType (m, `U) -> (
      match resolved_module_type_path s m with
      | Replaced _ -> assert false
      | Not_replaced m' ->
          if m' == m then p else `ModuleType (m', `U))
  | `FragmentRoot `U -> p
  | `ModuleType (_, `Na _) -> .
  | `FragmentRoot (`Na _) -> .

and module_path : t -> Cpath.module_ -> Cpath.module_ =
 fun s p ->
  match p with
  | `Resolved p' -> (
      try
        let p'' = resolved_module_path s p' in
        if p'' == p' then p else `Resolved p''
      with Invalidated ->
        let path' = Cpath.unresolve_resolved_module_path p' in
        module_path s path')
  | `Dot (p', str) ->
      let p'' = module_path s p' in
      if p'' == p' then p else `Dot (p'', str)
  | `Module (_, p', str) -> `Module (`U, resolved_parent_path s p', str)
  | `Apply (p1, p2) ->
      let p1' = module_path s p1 in
      let p2' = module_path s p2 in
      if p1' == p1 && p2' == p2 then p else `Apply (p1', p2')
  | `LocalMod (`Na _) -> .
  | `LocalMod (#Ident.module_ as id) -> (
      match
        try Some (ModuleMap.find id s.module_)
        with _ -> None
      with
      | Some (`Prefixed (p, _rp)) -> p
      | Some (`Renamed x) -> `LocalMod (x :> Cpath.lmod)
      | Some `Substituted -> `Substituted p
      | None -> p)
  | `Identifier _ -> p
  | `Substituted m ->
      let m' = module_path s m in
      if m' == m then p else `Substituted m'
  | `Forward _ -> p
  | `Root _ -> p

and resolved_module_type_path :
    t ->
    Cpath.Resolved.module_type ->
    (Cpath.Resolved.module_type, ModuleType.expr) or_replaced =
 fun s p ->
  match p with
  | `LocalModTy (`Na _) -> .
  | `LocalModTy (#Ident.module_type as id) -> (
      if ModuleTypeMap.mem id s.module_type_replacement then
        Replaced (ModuleTypeMap.find id s.module_type_replacement)
      else
        match ModuleTypeMap.find id s.module_type with
        | `Prefixed (_p, rp) -> Not_replaced rp
        | `Renamed x -> Not_replaced (`LocalModTy (x :> Cpath.lmodty))
        | exception Not_found -> Not_replaced (`LocalModTy (id :> Cpath.lmodty)))
  | `Identifier _ -> Not_replaced p
  | `SubstitutedMT m -> (
      match resolved_module_type_path s m with
      | Not_replaced m' ->
          if m' == m then Not_replaced p else Not_replaced (`SubstitutedMT m')
      | Replaced _ as r -> r)
  | `ModuleType (parent, n) ->
      let parent' = resolved_parent_path s parent in
      if parent' == parent then Not_replaced p
      else Not_replaced (`ModuleType (parent', n))
  | `CanonicalModuleType (mt1, mt2) -> (
      match resolved_module_type_path s mt1 with
      | Not_replaced mt1' ->
          if mt1' == mt1 then Not_replaced p
          else Not_replaced (`CanonicalModuleType (mt1', mt2))
      | x -> x)
  | `OpaqueModuleType m ->
      if s.unresolve_opaque_paths then raise Invalidated
      else (
        match resolved_module_type_path s m with
        | Not_replaced m' ->
            if m' == m then Not_replaced p
            else Not_replaced (`OpaqueModuleType m')
        | Replaced _ as r -> r)
  | `SubstT (p1, p2) -> (
      match
        (resolved_module_type_path s p1, resolved_module_type_path s p2)
      with
      | Not_replaced p1', Not_replaced p2' ->
          if p1' == p1 && p2' == p2 then Not_replaced p
          else Not_replaced (`SubstT (p1', p2'))
      | Replaced mt, _ | _, Replaced mt -> Replaced mt)
  | `AliasModuleType (p1, p2) -> (
      match
        (resolved_module_type_path s p1, resolved_module_type_path s p2)
      with
      | Not_replaced p1', Not_replaced p2' ->
          if p1' == p1 && p2' == p2 then Not_replaced p
          else Not_replaced (`AliasModuleType (p1', p2'))
      | Replaced mt, _ | _, Replaced mt -> Replaced mt)

and module_type_path :
    t -> Cpath.module_type -> Cpath.module_type module_type_or_replaced =
 fun s p ->
  match p with
  | `Resolved r -> (
      try
        match resolved_module_type_path s r with
        | Not_replaced r' ->
            if r' == r then Not_replaced p
            else Not_replaced (`Resolved r')
        | Replaced _ as x -> x
      with Invalidated ->
        let path' = Cpath.unresolve_resolved_module_type_path r in
        module_type_path s path')
  | `SubstitutedMT m -> (
      match module_type_path s m with
      | Not_replaced m' ->
          if m' == m then Not_replaced p
          else Not_replaced (`SubstitutedMT m')
      | Replaced _ as r -> r)
  | `LocalModTy (`Na _) -> .
  | `LocalModTy (#Ident.module_type as id) ->
      if ModuleTypeMap.mem id s.module_type_replacement then
        Replaced (ModuleTypeMap.find id s.module_type_replacement)
      else
        let r =
          match
            try Some (ModuleTypeMap.find id s.module_type) with _ -> None
          with
          | Some (`Prefixed (p, _rp)) -> p
          | Some (`Renamed x) -> `LocalModTy (x :> Cpath.lmodty)
          | None -> p
        in
        Not_replaced r
  | `Identifier _ -> Not_replaced p
  | `DotMT (m, n) ->
      let m' = module_path s m in
      if m' == m then Not_replaced p
      else Not_replaced (`DotMT (m', n))
  | `ModuleType (_, p', str) ->
      Not_replaced (`ModuleType (`U, resolved_parent_path s p', str))

and resolved_type_path :
    t ->
    Cpath.Resolved.type_ ->
    (Cpath.Resolved.type_, TypeExpr.t * TypeDecl.Equation.t) or_replaced =
 fun s p ->
  match p with
  | `CoreType _ -> Not_replaced p
  | `LocalTy (`Na _) -> .
  | `LocalTy (#Ident.type_ as id) -> (
      if TypeMap.mem id s.type_replacement then
        Replaced (TypeMap.find id s.type_replacement)
      else
        match try Some (TypeMap.find id s.type_) with Not_found -> None with
        | Some (`Prefixed (_p, rp)) -> Not_replaced rp
        | Some (`Renamed x) -> Not_replaced (`LocalTy (x :> Cpath.lty))
        | None -> Not_replaced (`LocalTy (id :> Cpath.lty)))
  | `CanonicalType (t1, t2) -> (
      match resolved_type_path s t1 with
      | Not_replaced t1' ->
          if t1' == t1 then Not_replaced p
          else Not_replaced (`CanonicalType (t1', t2))
      | x -> x)
  | `Identifier _ -> Not_replaced p
  | `SubstitutedT m -> (
      match resolved_type_path s m with
      | Not_replaced m' ->
          if m' == m then Not_replaced p else Not_replaced (`SubstitutedT m')
      | Replaced _ as r -> r)
  | `SubstitutedCT m ->
      let m' = resolved_class_type_path s m in
      if m' == m then Not_replaced p
      else Not_replaced (`SubstitutedCT m')
  | `Type (parent, n) ->
      let parent' = resolved_parent_path s parent in
      if parent' == parent then Not_replaced p
      else Not_replaced (`Type (parent', n))
  | `ClassType (parent, n) ->
      let parent' = resolved_parent_path s parent in
      if parent' == parent then Not_replaced p
      else Not_replaced (`ClassType (parent', n))
  | `Class (parent, n) ->
      let parent' = resolved_parent_path s parent in
      if parent' == parent then Not_replaced p
      else Not_replaced (`Class (parent', n))

and type_path : t -> Cpath.type_ -> Cpath.type_ type_or_replaced =
 fun s p ->
  match p with
  | `Resolved r -> (
      try
        match resolved_type_path s r with
        | Not_replaced r' ->
            if r' == r then Not_replaced p
            else Not_replaced (`Resolved r')
        | Replaced _ as x -> x
      with Invalidated ->
        let path' = Cpath.unresolve_resolved_type_path r in
        type_path s path')
  | `SubstitutedT m -> (
      match type_path s m with
      | Not_replaced m' ->
          if m' == m then Not_replaced p
          else Not_replaced (`SubstitutedT m')
      | Replaced _ as r -> r)
  | `SubstitutedCT m ->
      let m' = class_type_path s m in
      if m' == m then Not_replaced p
      else Not_replaced (`SubstitutedCT m')
  | `LocalTy (`Na _) -> .
  | `LocalTy (#Ident.type_ as id) -> (
      if TypeMap.mem id s.type_replacement then
        Replaced (TypeMap.find id s.type_replacement)
      else
        match try Some (TypeMap.find id s.type_) with Not_found -> None with
        | Some (`Prefixed (p, _rp)) -> Not_replaced p
        | Some (`Renamed x) -> Not_replaced (`LocalTy (x :> Cpath.lty))
        | None -> Not_replaced p)
  | `Identifier _ -> Not_replaced p
  | `DotT (m, n) ->
      let m' = module_path s m in
      if m' == m then Not_replaced p
      else Not_replaced (`DotT (m', n))
  | `Type (_, p', n) -> Not_replaced (`Type (`U, resolved_parent_path s p', n))

and resolved_class_type_path :
    t -> Cpath.Resolved.class_type -> Cpath.Resolved.class_type =
 fun s p ->
  match p with
  | `LocalTy (`Na _) -> .
  | `LocalTy (#Ident.type_ as id) -> (
      match try Some (TypeMap.find id s.class_type) with _ -> None with
      | Some (`Prefixed (_p, rp)) -> rp
      | Some (`Renamed x) -> `LocalTy (x :> Cpath.lty)
      | None -> `LocalTy (id :> Cpath.lty))
  | `Identifier _ -> p
  | `SubstitutedCT m ->
      let m' = resolved_class_type_path s m in
      if m' == m then p else `SubstitutedCT m'
  | `ClassType (parent, n) ->
      let parent' = resolved_parent_path s parent in
      if parent' == parent then p else `ClassType (parent', n)
  | `Class (parent, n) ->
      let parent' = resolved_parent_path s parent in
      if parent' == parent then p else `Class (parent', n)

and class_type_path : t -> Cpath.class_type -> Cpath.class_type =
 fun s p ->
  match p with
  | `Resolved r -> (
      try
        let r' = resolved_class_type_path s r in
        if r' == r then p else `Resolved r'
      with Invalidated ->
        let path' = Cpath.unresolve_resolved_class_type_path r in
        class_type_path s path')
  | `LocalTy (`Na _) -> .
  | `LocalTy (#Ident.type_ as id) -> (
      match try Some (TypeMap.find id s.class_type) with _ -> None with
      | Some (`Prefixed (p, _rp)) -> p
      | Some (`Renamed x) -> `LocalTy (x :> Cpath.lty)
      | None -> p)
  | `Identifier _ -> p
  | `SubstitutedCT m ->
      let m' = class_type_path s m in
      if m' == m then p else `SubstitutedCT m'
  | `DotT (m, n) ->
      let m' = module_path s m in
      if m' == m then p else `DotT (m', n)
  | `Type (_, parent, n) -> `Type (`U, resolved_parent_path s parent, n)

let rec resolved_signature_fragment :
    t -> Cfrag.resolved_signature -> Cfrag.resolved_signature =
 fun t r ->
  match r with
  | `Root (`ModuleType p) -> (
      match resolved_module_type_path t p with
      | Not_replaced p' ->
          if p' == p then r else `Root (`ModuleType p')
      | Replaced _ -> raise Invalidated)
  | `Root (`Module p) ->
      let p' = resolved_module_path t p in
      if p' == p then r else `Root (`Module p')
  | (`Subst _ | `Alias _ | `OpaqueModule _ | `Module _) as x ->
      let x' = resolved_module_fragment t x in
      if x' == x then r else (x' :> Cfrag.resolved_signature)

and resolved_module_fragment :
    t -> Cfrag.resolved_module -> Cfrag.resolved_module =
 fun t r ->
  match r with
  | `Subst (mty, f) ->
      let mty' =
        match resolved_module_type_path t mty with
        | Not_replaced p -> p
        | Replaced _ -> assert false
      in
      let f' = resolved_module_fragment t f in
      if mty' == mty && f' == f then r else `Subst (mty', f')
  | `Alias (m, f) ->
      let m' = resolved_module_path t m in
      let f' = resolved_module_fragment t f in
      if m' == m && f' == f then r else `Alias (m', f')
  | `Module (sg, n) ->
      let sg' = resolved_signature_fragment t sg in
      if sg' == sg then r else `Module (sg', n)
  | `OpaqueModule m ->
      let m' = resolved_module_fragment t m in
      if m' == m then r else `OpaqueModule m'

and resolved_module_type_fragment :
    t -> Cfrag.resolved_module_type -> Cfrag.resolved_module_type =
 fun t r ->
  match r with
  | `ModuleType (s, n) ->
      let s' = resolved_signature_fragment t s in
      if s' == s then r else `ModuleType (s', n)

and resolved_type_fragment : t -> Cfrag.resolved_type -> Cfrag.resolved_type =
 fun t r ->
  match r with
  | `Type (s, n) ->
      let s' = resolved_signature_fragment t s in
      if s' == s then r else `Type (s', n)
  | `ClassType (s, n) ->
      let s' = resolved_signature_fragment t s in
      if s' == s then r else `ClassType (s', n)
  | `Class (s, n) ->
      let s' = resolved_signature_fragment t s in
      if s' == s then r else `Class (s', n)

let rec signature_fragment : t -> Cfrag.signature -> Cfrag.signature =
 fun t r ->
  match r with
  | `Resolved f -> (
      try
        let f' = resolved_signature_fragment t f in
        if f' == f then r else `Resolved f'
      with Invalidated ->
        let frag' = Cfrag.unresolve_signature f in
        signature_fragment t frag')
  | `Dot (sg, n) ->
      let sg' = signature_fragment t sg in
      if sg' == sg then r else `Dot (sg', n)
  | `Root -> r

let rec module_fragment : t -> Cfrag.module_ -> Cfrag.module_ =
 fun t r ->
  match r with
  | `Resolved f -> (
      try
        let f' = resolved_module_fragment t f in
        if f' == f then r else `Resolved f'
      with Invalidated ->
        let frag' = Cfrag.unresolve_module f in
        module_fragment t frag')
  | `Dot (sg, n) ->
      let sg' = signature_fragment t sg in
      if sg' == sg then r else `Dot (sg', n)

let rec module_type_fragment : t -> Cfrag.module_type -> Cfrag.module_type =
 fun t r ->
  match r with
  | `Resolved f -> (
      try
        let f' = resolved_module_type_fragment t f in
        if f' == f then r else `Resolved f'
      with Invalidated ->
        let frag' = Cfrag.unresolve_module_type f in
        module_type_fragment t frag')
  | `Dot (sg, n) ->
      let sg' = signature_fragment t sg in
      if sg' == sg then r else `Dot (sg', n)

let rec type_fragment : t -> Cfrag.type_ -> Cfrag.type_ =
 fun t r ->
  match r with
  | `Resolved f -> (
      try
        let f' = resolved_type_fragment t f in
        if f' == f then r else `Resolved f'
      with Invalidated ->
        let frag' = Cfrag.unresolve_type f in
        type_fragment t frag')
  | `Dot (sg, n) ->
      let sg' = signature_fragment t sg in
      if sg' == sg then r else `Dot (sg', n)

let option_ conv s x = match x with Some x -> Some (conv s x) | None -> None

let option_sharing conv s x =
  match x with
  | None -> x
  | Some v ->
      let v' = conv s v in
      if v' == v then x else Some v'

let list_sharing conv s xs =
  let changed = ref false in
  let ys = List.map (fun x ->
    let y = conv s x in
    if y != x then changed := true;
    y
  ) xs in
  if !changed then ys else xs

let pair_sharing conv1 conv2 s ((a, b) as p) =
  let a' = conv1 s a in
  let b' = conv2 s b in
  if a' == a && b' == b then p else (a', b')

let rec type_ s t =
  let open Component.TypeDecl in
  let equation' = type_decl_equation s t.equation in
  let representation' = option_sharing type_decl_representation s t.representation in
  if equation' == t.equation && representation' == t.representation then t
  else { t with equation = equation'; representation = representation' }

and type_decl_representation s t =
  let open Component.TypeDecl.Representation in
  match t with
  | Variant cs ->
      let cs' = list_sharing type_decl_constructor s cs in
      if cs' == cs then t else Variant cs'
  | Record fs ->
      let fs' = list_sharing type_decl_field s fs in
      if fs' == fs then t else Record fs'
  | Record_unboxed_product fs ->
      let fs' = list_sharing type_decl_unboxed_field s fs in
      if fs' == fs then t else Record_unboxed_product fs'
  | Extensible -> t

and type_decl_constructor s t =
  let open Component.TypeDecl.Constructor in
  let args' = type_decl_constructor_arg s t.args in
  let res' = option_sharing type_expr s t.res in
  if args' == t.args && res' == t.res then t
  else { t with args = args'; res = res' }

and type_poly_var s v =
  let open Component.TypeExpr.Polymorphic_variant in
  let map_constr c =
    let open Constructor in
    let arguments' = list_sharing type_expr s c.arguments in
    if arguments' == c.arguments then c
    else { c with arguments = arguments' }
  in
  (* Note: poly variant substitution can flatten elements, so we can't
     always share the list. Check if any Type element expands. *)
  let changed = ref false in
  let elements' = List.flatten (List.map (function
    | Type t -> (
        match type_expr s t with
        | Polymorphic_variant v -> changed := true; v.elements
        | x ->
            if x != t then changed := true;
            [ Type x ])
    | Constructor c ->
        let c' = map_constr c in
        if c' != c then changed := true;
        [ Constructor c' ]
  ) v.elements) in
  if !changed then { kind = v.kind; elements = elements' }
  else v

and type_object s o =
  let open Component.TypeExpr.Object in
  let fields' = list_sharing (fun s f ->
    match f with
    | Method m ->
        let type_' = type_expr s m.type_ in
        if type_' == m.type_ then f
        else Method { m with type_ = type_' }
    | Inherit te ->
        let te' = type_expr s te in
        if te' == te then f else Inherit te'
  ) s o.fields in
  if fields' == o.fields then o
  else { fields = fields'; open_ = o.open_ }

and type_package s p =
  let open Component.TypeExpr.Package in
  let path' =
    match module_type_path s p.path with
    | Not_replaced p -> p
    | Replaced (Path pt) -> pt.p_path
    | Replaced _ -> assert false
  in
  let substitutions' = list_sharing (fun s ((x, y) as sub) ->
    let x' = type_fragment s x in
    let y' = type_expr s y in
    if x' == x && y' == y then sub else (x', y')
  ) s p.substitutions in
  if path' == p.path && substitutions' == p.substitutions then p
  else { path = path'; substitutions = substitutions' }

and type_expr s t =
  let open Component.TypeExpr in
  match t with
  | Var _ | Any -> t
  | Alias (te, str) ->
      let te' = type_expr s te in
      if te' == te then t else Alias (te', str)
  | Arrow (lbl, t1, t2, modes, ret_modes) ->
      let t1' = type_expr s t1 in
      let t2' = type_expr s t2 in
      if t1' == t1 && t2' == t2 then t
      else Arrow (lbl, t1', t2', modes, ret_modes)
  | Tuple ts ->
      let ts' = list_sharing (fun s (lbl, ty) ->
        let ty' = type_expr s ty in
        if ty' == ty then (lbl, ty) else (lbl, ty')
      ) s ts in
      if ts' == ts then t else Tuple ts'
  | Unboxed_tuple ts ->
      let ts' = list_sharing (fun s (l, te) ->
        let te' = type_expr s te in
        if te' == te then (l, te) else (l, te')
      ) s ts in
      if ts' == ts then t else Unboxed_tuple ts'
  | Constr (p, ts) -> (
      match type_path s p with
      | Replaced (te, eq) ->
          let mk_var acc pexpr param =
            match param.Odoc_model.Lang.TypeDecl.desc with
            | 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 te
      | Not_replaced p' ->
          let ts' = list_sharing type_expr s ts in
          if p' == p && ts' == ts then t else Constr (p', ts'))
  | Polymorphic_variant v ->
      let v' = type_poly_var s v in
      if v' == v then t else Polymorphic_variant v'
  | Object o ->
      let o' = type_object s o in
      if o' == o then t else Object o'
  | Class (p, ts) ->
      let p' = class_type_path s p in
      let ts' = list_sharing type_expr s ts in
      if p' == p && ts' == ts then t else Class (p', ts')
  | Poly (strs, te) ->
      let te' = type_expr s te in
      if te' == te then t else Poly (strs, te')
  | Quote te ->
      let te' = type_expr s te in
      if te' == te then t else Quote te'
  | Splice te ->
      let te' = type_expr s te in
      if te' == te then t else Splice te'
  | Package p ->
      let p' = type_package s p in
      if p' == p then t else Package p'

and simple_expansion :
    t ->
    Component.ModuleType.simple_expansion ->
    Component.ModuleType.simple_expansion =
 fun s t ->
  let open Component.ModuleType in
  match t with
  | Signature sg ->
      let sg' = signature s sg in
      if sg' == sg then t else Signature sg'
  | Functor (arg, sg) ->
      let arg' = functor_parameter s arg in
      let sg' = simple_expansion s sg in
      if arg' == arg && sg' == sg then t else Functor (arg', sg')

and module_type s t =
  let open Component.ModuleType in
  let expr' = option_sharing module_type_expr s t.expr in
  if expr' == t.expr then t
  else { t with expr = expr' }

and module_type_substitution s t =
  let open Component.ModuleTypeSubstitution in
  let manifest' = module_type_expr s t.manifest in
  if manifest' == t.manifest then t
  else { manifest = manifest'; doc = t.doc }

and functor_parameter s t =
  let open Component.FunctorParameter in
  match t with
  | Named arg ->
      let expr' = module_type_expr s arg.expr in
      if expr' == arg.expr then t
      else Named { arg with expr = expr' }
  | Unit -> t

and module_type_type_of_desc s t =
  let open Component.ModuleType in
  match t with
  | ModPath p ->
      let p' = module_path s p in
      if p' == p then t else ModPath p'
  | StructInclude p ->
      let p' = module_path s p in
      if p' == p then t else StructInclude p'

and u_module_type_expr s t =
  let open Component.ModuleType.U in
  match t with
  | Path p -> (
      match module_type_path s p with
      | Not_replaced p' ->
          if p' == p then t else Path p'
      | Replaced eqn -> (
          match eqn with
          | Path p -> Path p.p_path
          | Signature s -> Signature s
          | TypeOf tv -> TypeOf (tv.t_desc, tv.t_original_path)
          | With w -> With (w.w_substitutions, w.w_expr)
          | Functor _ -> assert false
          | Strengthen sv -> Strengthen (sv.s_expr, sv.s_path, sv.s_aliasable)))
  | Signature sg ->
      let sg' = signature s sg in
      if sg' == sg then t else Signature sg'
  | With (subs, e) ->
      let subs' = list_sharing with_module_type_substitution s subs in
      let e' = u_module_type_expr s e in
      if subs' == subs && e' == e then t else With (subs', e')
  | TypeOf (t_desc, t_original_path) ->
      let t_desc' = module_type_type_of_desc s t_desc in
      if t_desc' == t_desc then t else TypeOf (t_desc', t_original_path)
  | Strengthen (expr, path, aliasable) ->
      let expr' = u_module_type_expr s expr in
      let path' = module_path s path in
      if expr' == expr && path' == path then t
      else Strengthen (expr', path', aliasable)

and module_type_expr s t =
  let open Component.ModuleType in
  match t with
  | Path { p_path; p_expansion } -> (
      match module_type_path s p_path with
      | Not_replaced p_path' ->
          let p_expansion' = option_sharing simple_expansion s p_expansion in
          if p_path' == p_path && p_expansion' == p_expansion then t
          else Path { p_path = p_path'; p_expansion = p_expansion' }
      | Replaced s -> s)
  | Signature sg ->
      let sg' = signature s sg in
      if sg' == sg then t else Signature sg'
  | Functor (arg, expr) ->
      let arg' = functor_parameter s arg in
      let expr' = module_type_expr s expr in
      if arg' == arg && expr' == expr then t
      else Functor (arg', expr')
  | With { w_substitutions; w_expansion; w_expr } ->
      let w_substitutions' =
        list_sharing with_module_type_substitution s w_substitutions in
      let w_expansion' = option_sharing simple_expansion s w_expansion in
      let w_expr' = u_module_type_expr s w_expr in
      if w_substitutions' == w_substitutions
         && w_expansion' == w_expansion
         && w_expr' == w_expr then t
      else With { w_substitutions = w_substitutions';
                  w_expansion = w_expansion';
                  w_expr = w_expr' }
  | TypeOf tv ->
      let t_desc' = module_type_type_of_desc s tv.t_desc in
      let t_expansion' = option_sharing simple_expansion s tv.t_expansion in
      if t_desc' == tv.t_desc && t_expansion' == tv.t_expansion then t
      else TypeOf { tv with t_desc = t_desc'; t_expansion = t_expansion' }
  | Strengthen { s_expr; s_path; s_aliasable; s_expansion } ->
      let s_expr' = u_module_type_expr s s_expr in
      let s_path' = module_path s s_path in
      let s_expansion' = option_sharing simple_expansion s s_expansion in
      if s_expr' == s_expr && s_path' == s_path && s_expansion' == s_expansion then t
      else Strengthen { s_expr = s_expr'; s_path = s_path';
                        s_aliasable; s_expansion = s_expansion' }

and with_module_type_substitution s sub =
  let open Component.ModuleType in
  match sub with
  | ModuleEq (f, m) ->
      let f' = module_fragment s f in
      let m' = module_decl s m in
      if f' == f && m' == m then sub else ModuleEq (f', m')
  | ModuleSubst (f, p) ->
      let f' = module_fragment s f in
      let p' = module_path s p in
      if f' == f && p' == p then sub else ModuleSubst (f', p')
  | TypeEq (f, eq) ->
      let f' = type_fragment s f in
      let eq' = type_decl_equation s eq in
      if f' == f && eq' == eq then sub else TypeEq (f', eq')
  | TypeSubst (f, eq) ->
      let f' = type_fragment s f in
      let eq' = type_decl_equation s eq in
      if f' == f && eq' == eq then sub else TypeSubst (f', eq')
  | ModuleTypeEq (f, eq) ->
      let f' = module_type_fragment s f in
      let eq' = module_type_expr s eq in
      if f' == f && eq' == eq then sub else ModuleTypeEq (f', eq')
  | ModuleTypeSubst (f, eq) ->
      let f' = module_type_fragment s f in
      let eq' = module_type_expr s eq in
      if f' == f && eq' == eq then sub else ModuleTypeSubst (f', eq')

and module_decl s t =
  match t with
  | Alias (p, e) ->
      let p' = module_path s p in
      let e' = option_sharing simple_expansion s e in
      if p' == p && e' == e then t else Alias (p', e')
  | ModuleType mt ->
      let mt' = module_type_expr s mt in
      if mt' == mt then t else ModuleType mt'

and include_decl s t =
  match t with
  | Include.Alias p ->
      let p' = module_path s p in
      if p' == p then t else Include.Alias p'
  | ModuleType mt ->
      let mt' = u_module_type_expr s mt in
      if mt' == mt then t else ModuleType mt'

and module_ s t =
  let open Component.Module in
  let type_' = module_decl s t.type_ in
  if type_' == t.type_ then t
  else { t with type_ = type_' }

and module_substitution s m =
  let open Component.ModuleSubstitution in
  let manifest' = module_path s m.manifest in
  if manifest' == m.manifest then m
  else { manifest = manifest'; doc = m.doc }

and type_decl_field s f =
  let open Component.TypeDecl.Field in
  let type_' = type_expr s f.type_ in
  if type_' == f.type_ then f
  else { f with type_ = type_' }

and type_decl_unboxed_field s f =
  let open Component.TypeDecl.UnboxedField in
  let type_' = type_expr s f.type_ in
  if type_' == f.type_ then f
  else { f with type_ = type_' }

and type_decl_constructor_arg s a =
  let open Component.TypeDecl.Constructor in
  match a with
  | Tuple ts ->
      let ts' = list_sharing type_expr s ts in
      if ts' == ts then a else Tuple ts'
  | Record fs ->
      let fs' = list_sharing type_decl_field s fs in
      if fs' == fs then a else Record fs'

and type_decl_equation s t =
  let open Component.TypeDecl.Equation in
  let manifest' = option_sharing type_expr s t.manifest in
  let constraints' = list_sharing (fun s ((x, y) as p) ->
    let x' = type_expr s x in
    let y' = type_expr s y in
    if x' == x && y' == y then p else (x', y')
  ) s t.constraints in
  if manifest' == t.manifest && constraints' == t.constraints then t
  else { t with manifest = manifest'; constraints = constraints' }

and exception_ s e =
  let open Component.Exception in
  let res' = option_sharing type_expr s e.res in
  let args' = type_decl_constructor_arg s e.args in
  if res' == e.res && args' == e.args then e
  else { e with args = args'; res = res' }

and extension_constructor s c =
  let open Component.Extension.Constructor in
  let args' = type_decl_constructor_arg s c.args in
  let res' = option_sharing type_expr s c.res in
  if args' == c.args && res' == c.res then c
  else { c with args = args'; res = res' }

and extension s e =
  let open Component.Extension in
  let type_path' =
    match type_path s e.type_path with
    | Not_replaced p -> p
    | Replaced (TypeExpr.Constr (p, _), _) -> p
    | Replaced _ -> assert false
  in
  let constructors' = list_sharing extension_constructor s e.constructors in
  if type_path' == e.type_path && constructors' == e.constructors then e
  else { e with type_path = type_path'; constructors = constructors' }

and include_ s i =
  let open Component.Include in
  let decl' = include_decl s i.decl in
  let strengthened' = option_sharing module_path s i.strengthened in
  let expansion_' = apply_sig_map_sg s i.expansion_ in
  if decl' == i.decl && strengthened' == i.strengthened && expansion_' == i.expansion_
  then i
  else { i with decl = decl'; strengthened = strengthened'; expansion_ = expansion_' }

and open_ s o =
  let open Component.Open in
  let expansion' = apply_sig_map_sg s o.expansion in
  if expansion' == o.expansion then o
  else { expansion = expansion'; doc = o.doc }

and value s v =
  let open Component.Value in
  let type_' = type_expr s v.type_ in
  if type_' == v.type_ then v
  else { v with type_ = type_' }

and class_ s c =
  let open Component.Class in
  let type_' = class_decl s c.type_ in
  let expansion' = option_sharing class_signature s c.expansion in
  if type_' == c.type_ && expansion' == c.expansion then c
  else { c with type_ = type_'; expansion = expansion' }

and class_decl s t =
  let open Component.Class in
  match t with
  | ClassType e ->
      let e' = class_type_expr s e in
      if e' == e then t else ClassType e'
  | Arrow (lbl, te, d) ->
      let te' = type_expr s te in
      let d' = class_decl s d in
      if te' == te && d' == d then t else Arrow (lbl, te', d')

and class_type_expr s t =
  let open Component.ClassType in
  match t with
  | Constr (p, ts) ->
      let p' = class_type_path s p in
      let ts' = list_sharing type_expr s ts in
      if p' == p && ts' == ts then t else Constr (p', ts')
  | Signature sg ->
      let sg' = class_signature s sg in
      if sg' == sg then t else Signature sg'

and class_type s c =
  let open Component.ClassType in
  let expr' = class_type_expr s c.expr in
  let expansion' = option_sharing class_signature s c.expansion in
  if expr' == c.expr && expansion' == c.expansion then c
  else { c with expr = expr'; expansion = expansion' }

and class_signature_item s item =
  let open Component.ClassSignature in
  match item with
  | Method (id, m) ->
      let m' = method_ s m in
      if m' == m then item else Method (id, m')
  | InstanceVariable (id, i) ->
      let i' = instance_variable s i in
      if i' == i then item else InstanceVariable (id, i')
  | Constraint cst ->
      let cst' = class_constraint s cst in
      if cst' == cst then item else Constraint cst'
  | Inherit e ->
      let e' = inherit_ s e in
      if e' == e then item else Inherit e'
  | Comment _ -> item

and class_signature s sg =
  let open Component.ClassSignature in
  let self' = option_sharing type_expr s sg.self in
  let items' = list_sharing class_signature_item s sg.items in
  if self' == sg.self && items' == sg.items then sg
  else { sg with self = self'; items = items' }

and method_ s m =
  let open Component.Method in
  let type_' = type_expr s m.type_ in
  if type_' == m.type_ then m
  else { m with type_ = type_' }

and instance_variable s i =
  let open Component.InstanceVariable in
  let type_' = type_expr s i.type_ in
  if type_' == i.type_ then i
  else { i with type_ = type_' }

and class_constraint s cst =
  let open Component.ClassSignature.Constraint in
  let left' = type_expr s cst.left in
  let right' = type_expr s cst.right in
  if left' == cst.left && right' == cst.right then cst
  else { cst with left = left'; right = right' }

and inherit_ s ih =
  let open Component.ClassSignature.Inherit in
  let expr' = class_type_expr s ih.expr in
  if expr' == ih.expr then ih
  else { ih with expr = expr' }

and rename_bound_idents s sg items =
  let open Component.Signature in
  (* The closures used to look up rename targets only depend on the
     immutable substitution map, so they're hoisted to local helpers
     that don't capture per-call state. Each recursive call would
     otherwise reallocate them. *)
  let rec loop s sg = function
    | [] -> (s, List.rev sg)
    | Module (id, r, m) :: rest ->
        let id' = rbi_new_module_id s id in
        loop
          (rename_module (id :> Ident.module_) (id' :> Ident.module_) s)
          (Module (id', r, m) :: sg)
          rest
    | ModuleSubstitution (id, m) :: rest ->
        let id' = rbi_new_module_id s id in
        loop
          (rename_module (id :> Ident.module_) (id' :> Ident.module_) s)
          (ModuleSubstitution (id', m) :: sg)
          rest
    | ModuleType (id, mt) :: rest ->
        let id' = rbi_new_module_type_id s id in
        loop
          (rename_module_type id id' s)
          (ModuleType (id', mt) :: sg)
          rest
    | ModuleTypeSubstitution (id, mt) :: rest ->
        let id' = rbi_new_module_type_id s id in
        loop
          (rename_module_type id id' s)
          (ModuleTypeSubstitution (id', mt) :: sg)
          rest
    | Type (id, r, t) :: rest ->
        let id' = rbi_new_type_id s id in
        loop
          (rename_type (id :> Ident.type_) (id' :> Ident.type_) s)
          (Type (id', r, t) :: sg)
          rest
    | TypeSubstitution (id, t) :: rest ->
        let id' = rbi_new_type_id s id in
        loop
          (rename_type (id :> Ident.type_) (id' :> Ident.type_) s)
          (TypeSubstitution (id', t) :: sg)
          rest
    | Exception (id, e) :: rest ->
        let id' = Ident.Rename.exception_ id in
        loop s (Exception (id', e) :: sg) rest
    | TypExt e :: rest -> loop s (TypExt e :: sg) rest
    | Value (id, v) :: rest ->
        let id' = Ident.Rename.value id in
        loop s (Value (id', v) :: sg) rest
    | Class (id, r, c) :: rest ->
        let id' = rbi_new_class_id s id in
        loop
          (rename_class_type (id :> Ident.type_) (id' :> Ident.type_) s)
          (Class (id', r, c) :: sg)
          rest
    | ClassType (id, r, c) :: rest ->
        let id' = rbi_new_class_type_id s id in
        loop
          (rename_class_type (id :> Ident.type_) (id' :> Ident.type_) s)
          (ClassType (id', r, c) :: sg)
          rest
    | Include i :: rest ->
        loop s (Include i :: sg) rest
    | Open o :: rest ->
        loop s (Open o :: sg) rest
    | (Comment _ as item) :: rest -> loop s (item :: sg) rest
  in
  loop s sg items

(* These helpers used to be local closures inside rename_bound_idents,
   reallocated on every recursive call. They depend only on the substitution
   record so they can be defined once at module level. *)
and rbi_new_module_id s id =
  try
    match ModuleMap.find (id :> Ident.module_) s.module_ with
    | `Renamed (`LModule _ as x) -> x
    | `Prefixed (_, _) ->
        (* Unusual but can happen with TypeOf expressions. *)
        Ident.Rename.module_ id
    | _ -> failwith "Error"
  with Not_found -> Ident.Rename.module_ id

and rbi_new_module_type_id s id =
  try
    match ModuleTypeMap.find id s.module_type with
    | `Renamed x -> x
    | `Prefixed (_, _) -> Ident.Rename.module_type id
  with Not_found -> Ident.Rename.module_type id

and rbi_new_type_id s id =
  try
    match TypeMap.find (id :> Ident.type_) s.type_ with
    | `Renamed (`LType _ as x) -> x
    | `Prefixed (_, _) -> Ident.Rename.type_ id
  with Not_found -> Ident.Rename.type_ id

and rbi_new_class_id s id =
  try
    match TypeMap.find (id :> Ident.type_) s.class_type with
    | `Renamed (`LType _ as x) -> x
    | `Prefixed (_, _) -> Ident.Rename.type_ id
  with Not_found -> Ident.Rename.type_ id

and rbi_new_class_type_id s id =
  try
    match TypeMap.find (id :> Ident.type_) s.class_type with
    | `Renamed (`LType _ as x) -> x
    | `Prefixed (_, _) -> Ident.Rename.type_ id
  with Not_found -> Ident.Rename.type_ id

and removed_items s items =
  let open Component.Signature in
  list_sharing (fun s item ->
    match item with
    | RModule (id, p) ->
        let p' = module_path s p in
        if p' == p then item else RModule (id, p')
    | RType (id, exp, eqn) ->
        let exp' = type_expr s exp in
        let eqn' = type_decl_equation s eqn in
        if exp' == exp && eqn' == eqn then item else RType (id, exp', eqn')
    | RModuleType (id, mty) ->
        let mty' = module_type_expr s mty in
        if mty' == mty then item else RModuleType (id, mty')
  ) s items

and signature s sg =
  if is_identity s then sg
  else
  let s, items = rename_bound_idents s [] sg.items in
  let items, removed, dont_recompile = apply_sig_map s items sg.removed in
  { sg with items; removed; compiled = sg.compiled && dont_recompile }

and apply_sig_map_sg s (sg : Component.Signature.t) =
  if is_identity s then sg
  else
  let items, removed, dont_recompile = apply_sig_map s sg.items sg.removed in
  { sg with items; removed; compiled = sg.compiled && dont_recompile }

and apply_sig_map_item s item =
  let open Component.Signature in
  match item with
  | Module (id, r, m) ->
      Module
        ( id,
          r,
          Component.Delayed.put (fun () -> module_ s (Component.Delayed.get m))
        )
  | ModuleSubstitution (id, m) ->
      ModuleSubstitution (id, module_substitution s m)
  | ModuleType (id, mt) ->
      ModuleType
        ( id,
          Component.Delayed.put (fun () ->
              module_type s (Component.Delayed.get mt)) )
  | ModuleTypeSubstitution (id, mt) ->
      ModuleTypeSubstitution (id, module_type_substitution s mt)
  | Type (id, r, t) ->
      Type
        ( id,
          r,
          Component.Delayed.put (fun () -> type_ s (Component.Delayed.get t)) )
  | TypeSubstitution (id, t) -> TypeSubstitution (id, type_ s t)
  | Exception (id, e) -> Exception (id, exception_ s e)
  | TypExt e -> TypExt (extension s e)
  | Value (id, v) ->
      Value
        (id, Component.Delayed.put (fun () -> value s (Component.Delayed.get v)))
  | Class (id, r, c) -> Class (id, r, class_ s c)
  | ClassType (id, r, c) -> ClassType (id, r, class_type s c)
  | Include i -> Include (include_ s i)
  | Open o -> Open (open_ s o)
  | Comment c -> Comment c

and apply_sig_map_items s items =
  List.rev_map (apply_sig_map_item s) items |> List.rev

and apply_sig_map s items removed =
  if is_identity s then (items, removed, true)
  else
  let dont_recompile = List.length s.path_invalidating_modules = 0 in
  (apply_sig_map_items s items, removed_items s removed, dont_recompile)