Skip to content

Commit 4a12848

Browse files
jonludlamjonludlam
committed
Don't allow links to hidden pages
A while back we changed the type of `Path.Resolved.identifier` so we could return `None` for the case where there is genuinely no identifier that can be used. This was initially for to allow paths to core types to be resolved, even though there's no destination for them. This commit extends this idea so that attempting to generate an identifier for a hidden path will result in `None`. Whilst we would prefer not to generate these paths at all, it can happen as a consequence of incorrect canonical paths. Partial fix for #1369
1 parent a65f359 commit 4a12848

File tree

5 files changed

+176
-107
lines changed

5 files changed

+176
-107
lines changed

‎src/document/comment.ml‎

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -122,8 +122,13 @@ module Reference = struct
122122
| None -> None
123123
| Some _ -> Some rendered
124124
in
125-
let url = Url.from_identifier ~stop_before:false id in
126-
let target = Target.Internal (Resolved url) in
125+
let target =
126+
match id with
127+
| Some id ->
128+
let url = Url.from_identifier ~stop_before:false id in
129+
Target.Internal (Resolved url)
130+
| None -> Internal Unresolved
131+
in
127132
let link = { Link.target; content; tooltip } in
128133
[ inline @@ Inline.Link link ]
129134
| _ -> (

‎src/document/generator.ml‎

Lines changed: 5 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -188,8 +188,11 @@ module Make (Syntax : SYNTAX) = struct
188188
let open Fragment in
189189
let id = Resolved.identifier (fragment :> Resolved.t) in
190190
let txt = render_resolved_fragment (fragment :> Resolved.t) in
191-
let href = Url.from_identifier ~stop_before:false id in
192-
resolved href [ inline @@ Text txt ]
191+
match id with
192+
| Some id ->
193+
let href = Url.from_identifier ~stop_before:false id in
194+
resolved href [ inline @@ Text txt ]
195+
| None -> unresolved [ inline @@ Text txt ]
193196

194197
let from_fragment : Fragment.leaf -> text = function
195198
| `Resolved r

‎src/model/paths.ml‎

Lines changed: 150 additions & 92 deletions
Original file line numberDiff line numberDiff line change
@@ -715,11 +715,13 @@ module Path = struct
715715
type t = Paths_types.Resolved_path.any
716716

717717
let rec parent_module_type_identifier :
718-
Paths_types.Resolved_path.module_type -> Identifier.ModuleType.t =
719-
function
720-
| `Identifier id -> (id : Identifier.ModuleType.t)
721-
| `ModuleType (m, n) ->
722-
Identifier.Mk.module_type (parent_module_identifier m, n)
718+
Paths_types.Resolved_path.module_type -> Identifier.ModuleType.t option
719+
= function
720+
| `Identifier id -> Some (id : Identifier.ModuleType.t)
721+
| `ModuleType (m, n) -> (
722+
match parent_module_identifier m with
723+
| None -> None
724+
| Some p -> Some (Identifier.Mk.module_type (p, n)))
723725
| `SubstT (m, _n) -> parent_module_type_identifier m
724726
| `CanonicalModuleType (_, `Resolved p) -> parent_module_type_identifier p
725727
| `CanonicalModuleType (p, _) -> parent_module_type_identifier p
@@ -731,13 +733,17 @@ module Path = struct
731733
else parent_module_type_identifier sub
732734

733735
and parent_module_identifier :
734-
Paths_types.Resolved_path.module_ -> Identifier.Signature.t = function
736+
Paths_types.Resolved_path.module_ -> Identifier.Signature.t option =
737+
function
735738
| `Identifier id ->
736-
(id : Identifier.Path.Module.t :> Identifier.Signature.t)
739+
Some (id : Identifier.Path.Module.t :> Identifier.Signature.t)
737740
| `Subst (sub, _) ->
738-
(parent_module_type_identifier sub :> Identifier.Signature.t)
739-
| `Hidden p -> parent_module_identifier p
740-
| `Module (m, n) -> Identifier.Mk.module_ (parent_module_identifier m, n)
741+
(parent_module_type_identifier sub :> Identifier.Signature.t option)
742+
| `Hidden _ -> None
743+
| `Module (m, n) -> (
744+
match parent_module_identifier m with
745+
| None -> None
746+
| Some p -> Some (Identifier.Mk.module_ (p, n)))
741747
| `Canonical (_, `Resolved p) -> parent_module_identifier p
742748
| `Canonical (p, _) -> parent_module_identifier p
743749
| `Apply (m, _) -> parent_module_identifier m
@@ -759,7 +765,7 @@ module Path = struct
759765
module ModuleType = struct
760766
type t = Paths_types.Resolved_path.module_type
761767

762-
let identifier : t -> Identifier.ModuleType.t =
768+
let identifier : t -> Identifier.ModuleType.t option =
763769
parent_module_type_identifier
764770
end
765771

@@ -775,26 +781,27 @@ module Path = struct
775781
type t = Paths_types.Resolved_path.class_type
776782
end
777783

778-
let rec identifier : t -> Identifier.t option = function
784+
let rec identifier : t -> Identifier.t option =
785+
let parent p f =
786+
match parent_module_identifier p with
787+
| None -> None
788+
| Some id -> Some (f id :> Identifier.t)
789+
in
790+
function
779791
| `Identifier id -> Some id
780792
| `CoreType _ -> None
781793
| `Subst (sub, _) -> identifier (sub :> t)
782-
| `Hidden p -> identifier (p :> t)
783-
| `Module (m, n) ->
784-
Some (Identifier.Mk.module_ (parent_module_identifier m, n))
794+
| `Hidden _p -> None
795+
| `Module (m, n) -> parent m (fun p -> Identifier.Mk.module_ (p, n))
785796
| `Canonical (_, `Resolved p) -> identifier (p :> t)
786797
| `Canonical (p, _) -> identifier (p :> t)
787798
| `Apply (m, _) -> identifier (m :> t)
788-
| `Type (m, n) ->
789-
Some (Identifier.Mk.type_ (parent_module_identifier m, n))
790-
| `Value (m, n) ->
791-
Some (Identifier.Mk.value (parent_module_identifier m, n))
799+
| `Type (m, n) -> parent m (fun p -> Identifier.Mk.type_ (p, n))
800+
| `Value (m, n) -> parent m (fun p -> Identifier.Mk.value (p, n))
792801
| `ModuleType (m, n) ->
793-
Some (Identifier.Mk.module_type (parent_module_identifier m, n))
794-
| `Class (m, n) ->
795-
Some (Identifier.Mk.class_ (parent_module_identifier m, n))
796-
| `ClassType (m, n) ->
797-
Some (Identifier.Mk.class_type (parent_module_identifier m, n))
802+
parent m (fun p -> Identifier.Mk.module_type (p, n))
803+
| `Class (m, n) -> parent m (fun p -> Identifier.Mk.class_ (p, n))
804+
| `ClassType (m, n) -> parent m (fun p -> Identifier.Mk.class_type (p, n))
798805
| `Alias (dest, `Resolved src) ->
799806
if is_resolved_hidden ~weak_canonical_test:false (dest :> t) then
800807
identifier (src :> t)
@@ -851,16 +858,19 @@ module Fragment = struct
851858
module Signature = struct
852859
type t = Paths_types.Resolved_fragment.signature
853860

854-
let rec sgidentifier : t -> Identifier.Signature.t = function
861+
let rec sgidentifier : t -> Identifier.Signature.t option = function
855862
| `Root (`ModuleType i) ->
856863
(Path.Resolved.parent_module_type_identifier i
857-
:> Identifier.Signature.t)
864+
:> Identifier.Signature.t option)
858865
| `Root (`Module i) -> Path.Resolved.parent_module_identifier i
859866
| `Subst (s, _) ->
860867
(Path.Resolved.parent_module_type_identifier s
861-
:> Identifier.Signature.t)
868+
:> Identifier.Signature.t option)
862869
| `Alias (i, _) -> Path.Resolved.parent_module_identifier i
863-
| `Module (m, n) -> Identifier.Mk.module_ (sgidentifier m, n)
870+
| `Module (m, n) -> (
871+
match sgidentifier m with
872+
| None -> None
873+
| Some p -> Some (Identifier.Mk.module_ (p, n)))
864874
| `OpaqueModule m -> sgidentifier (m :> t)
865875
end
866876

@@ -878,19 +888,33 @@ module Fragment = struct
878888

879889
type leaf = Paths_types.Resolved_fragment.leaf
880890

881-
let rec identifier : t -> Identifier.t = function
891+
let rec identifier : t -> Identifier.t option = function
882892
| `Root (`ModuleType _r) -> assert false
883893
| `Root (`Module _r) -> assert false
884-
| `Subst (s, _) -> (Path.Resolved.ModuleType.identifier s :> Identifier.t)
894+
| `Subst (s, _) ->
895+
(Path.Resolved.ModuleType.identifier s :> Identifier.t option)
885896
| `Alias (p, _) ->
886-
(Path.Resolved.parent_module_identifier p :> Identifier.t)
887-
| `Module (m, n) -> Identifier.Mk.module_ (Signature.sgidentifier m, n)
888-
| `Module_type (m, n) ->
889-
Identifier.Mk.module_type (Signature.sgidentifier m, n)
890-
| `Type (m, n) -> Identifier.Mk.type_ (Signature.sgidentifier m, n)
891-
| `Class (m, n) -> Identifier.Mk.class_ (Signature.sgidentifier m, n)
892-
| `ClassType (m, n) ->
893-
Identifier.Mk.class_type (Signature.sgidentifier m, n)
897+
(Path.Resolved.parent_module_identifier p :> Identifier.t option)
898+
| `Module (m, n) -> (
899+
match Signature.sgidentifier m with
900+
| None -> None
901+
| Some p -> Some (Identifier.Mk.module_ (p, n)))
902+
| `Module_type (m, n) -> (
903+
match Signature.sgidentifier m with
904+
| None -> None
905+
| Some p -> Some (Identifier.Mk.module_type (p, n)))
906+
| `Type (m, n) -> (
907+
match Signature.sgidentifier m with
908+
| None -> None
909+
| Some p -> Some (Identifier.Mk.type_ (p, n)))
910+
| `Class (m, n) -> (
911+
match Signature.sgidentifier m with
912+
| None -> None
913+
| Some p -> Some (Identifier.Mk.class_ (p, n)))
914+
| `ClassType (m, n) -> (
915+
match Signature.sgidentifier m with
916+
| None -> None
917+
| Some p -> Some (Identifier.Mk.class_type (p, n)))
894918
| `OpaqueModule m -> identifier (m :> t)
895919

896920
let rec is_hidden : t -> bool = function
@@ -934,83 +958,117 @@ module Reference = struct
934958

935959
type t = Paths_types.Resolved_reference.any
936960

937-
let rec parent_signature_identifier : signature -> Identifier.Signature.t =
938-
function
939-
| `Identifier id -> id
940-
| `Hidden s -> parent_signature_identifier (s :> signature)
961+
let rec parent_signature_identifier :
962+
signature -> Identifier.Signature.t option = function
963+
| `Identifier id -> Some id
964+
| `Hidden _s -> None
941965
| `Alias (sub, orig) ->
942966
if Path.Resolved.(is_hidden (sub :> t)) then
943967
parent_signature_identifier (orig :> signature)
944968
else
945969
(Path.Resolved.parent_module_identifier sub
946-
:> Identifier.Signature.t)
970+
:> Identifier.Signature.t option)
947971
| `AliasModuleType (sub, orig) ->
948972
if Path.Resolved.(is_hidden (sub :> t)) then
949973
parent_signature_identifier (orig :> signature)
950974
else
951975
(Path.Resolved.parent_module_type_identifier sub
952-
:> Identifier.Signature.t)
953-
| `Module (m, n) ->
954-
Identifier.Mk.module_ (parent_signature_identifier m, n)
955-
| `ModuleType (m, s) ->
956-
Identifier.Mk.module_type (parent_signature_identifier m, s)
957-
958-
and parent_type_identifier : datatype -> Identifier.DataType.t = function
959-
| `Identifier id -> id
960-
| `Type (sg, s) -> Identifier.Mk.type_ (parent_signature_identifier sg, s)
976+
:> Identifier.Signature.t option)
977+
| `Module (m, n) -> (
978+
match parent_signature_identifier m with
979+
| None -> None
980+
| Some p -> Some (Identifier.Mk.module_ (p, n)))
981+
| `ModuleType (m, n) -> (
982+
match parent_signature_identifier m with
983+
| None -> None
984+
| Some p -> Some (Identifier.Mk.module_type (p, n)))
985+
986+
and parent_type_identifier : datatype -> Identifier.DataType.t option =
987+
function
988+
| `Identifier id -> Some id
989+
| `Type (sg, s) -> (
990+
match parent_signature_identifier sg with
991+
| None -> None
992+
| Some p -> Some (Identifier.Mk.type_ (p, s)))
961993

962994
and parent_class_signature_identifier :
963-
class_signature -> Identifier.ClassSignature.t = function
964-
| `Identifier id -> id
965-
| `Class (sg, s) ->
966-
Identifier.Mk.class_ (parent_signature_identifier sg, s)
967-
| `ClassType (sg, s) ->
968-
Identifier.Mk.class_type (parent_signature_identifier sg, s)
969-
970-
and field_parent_identifier : field_parent -> Identifier.FieldParent.t =
971-
function
972-
| `Identifier id -> id
995+
class_signature -> Identifier.ClassSignature.t option = function
996+
| `Identifier id -> Some id
997+
| `Class (sg, s) -> (
998+
match parent_signature_identifier sg with
999+
| None -> None
1000+
| Some p -> Some (Identifier.Mk.class_ (p, s)))
1001+
| `ClassType (sg, s) -> (
1002+
match parent_signature_identifier sg with
1003+
| None -> None
1004+
| Some p -> Some (Identifier.Mk.class_type (p, s)))
1005+
1006+
and field_parent_identifier :
1007+
field_parent -> Identifier.FieldParent.t option = function
1008+
| `Identifier id -> Some id
9731009
| (`Hidden _ | `Alias _ | `AliasModuleType _ | `Module _ | `ModuleType _)
9741010
as sg ->
975-
(parent_signature_identifier sg :> Identifier.FieldParent.t)
976-
| `Type _ as t -> (parent_type_identifier t :> Identifier.FieldParent.t)
1011+
(parent_signature_identifier sg :> Identifier.FieldParent.t option)
1012+
| `Type _ as t ->
1013+
(parent_type_identifier t :> Identifier.FieldParent.t option)
9771014

978-
and label_parent_identifier : label_parent -> Identifier.LabelParent.t =
979-
function
980-
| `Identifier id -> id
1015+
and label_parent_identifier :
1016+
label_parent -> Identifier.LabelParent.t option = function
1017+
| `Identifier id -> Some id
9811018
| (`Class _ | `ClassType _) as c ->
982-
(parent_class_signature_identifier c :> Identifier.LabelParent.t)
1019+
(parent_class_signature_identifier c
1020+
:> Identifier.LabelParent.t option)
9831021
| ( `Hidden _ | `Alias _ | `AliasModuleType _ | `Module _ | `ModuleType _
9841022
| `Type _ ) as r ->
985-
(field_parent_identifier r :> Identifier.LabelParent.t)
1023+
(field_parent_identifier r :> Identifier.LabelParent.t option)
9861024

987-
and identifier : t -> Identifier.t = function
988-
| `Identifier id -> id
1025+
and identifier : t -> Identifier.t option = function
1026+
| `Identifier id -> Some id
9891027
| ( `Alias _ | `AliasModuleType _ | `Module _ | `Hidden _ | `Type _
9901028
| `Class _ | `ClassType _ | `ModuleType _ ) as r ->
991-
(label_parent_identifier r :> Identifier.t)
992-
| `Field (p, n) -> Identifier.Mk.field (field_parent_identifier p, n)
993-
| `PolyConstructor (s, n) ->
1029+
(label_parent_identifier r :> Identifier.t option)
1030+
| `Field (p, n) -> (
1031+
match field_parent_identifier p with
1032+
| None -> None
1033+
| Some p -> Some (Identifier.Mk.field (p, n)))
1034+
| `PolyConstructor (s, n) -> (
9941035
(* Uses an identifier for constructor even though it is not
9951036
one. Document must make the links correspond. *)
996-
Identifier.Mk.constructor
997-
((parent_type_identifier s :> Identifier.DataType.t), n)
998-
| `Constructor (s, n) ->
999-
Identifier.Mk.constructor
1000-
((parent_type_identifier s :> Identifier.DataType.t), n)
1001-
| `Extension (p, q) ->
1002-
Identifier.Mk.extension (parent_signature_identifier p, q)
1003-
| `ExtensionDecl (p, q, r) ->
1004-
Identifier.Mk.extension_decl (parent_signature_identifier p, (q, r))
1005-
| `Exception (p, q) ->
1006-
Identifier.Mk.exception_ (parent_signature_identifier p, q)
1007-
| `Value (p, q) -> Identifier.Mk.value (parent_signature_identifier p, q)
1008-
| `Method (p, q) ->
1009-
Identifier.Mk.method_ (parent_class_signature_identifier p, q)
1010-
| `InstanceVariable (p, q) ->
1011-
Identifier.Mk.instance_variable
1012-
(parent_class_signature_identifier p, q)
1013-
| `Label (p, q) -> Identifier.Mk.label (label_parent_identifier p, q)
1037+
match parent_type_identifier s with
1038+
| None -> None
1039+
| Some p -> Some (Identifier.Mk.constructor (p, n)))
1040+
| `Constructor (s, n) -> (
1041+
match parent_type_identifier s with
1042+
| None -> None
1043+
| Some p -> Some (Identifier.Mk.constructor (p, n)))
1044+
| `Extension (p, q) -> (
1045+
match parent_signature_identifier p with
1046+
| None -> None
1047+
| Some p -> Some (Identifier.Mk.extension (p, q)))
1048+
| `ExtensionDecl (p, q, r) -> (
1049+
match parent_signature_identifier p with
1050+
| None -> None
1051+
| Some p -> Some (Identifier.Mk.extension_decl (p, (q, r))))
1052+
| `Exception (p, q) -> (
1053+
match parent_signature_identifier p with
1054+
| None -> None
1055+
| Some p -> Some (Identifier.Mk.exception_ (p, q)))
1056+
| `Value (p, q) -> (
1057+
match parent_signature_identifier p with
1058+
| None -> None
1059+
| Some p -> Some (Identifier.Mk.value (p, q)))
1060+
| `Method (p, q) -> (
1061+
match parent_class_signature_identifier p with
1062+
| None -> None
1063+
| Some p -> Some (Identifier.Mk.method_ (p, q)))
1064+
| `InstanceVariable (p, q) -> (
1065+
match parent_class_signature_identifier p with
1066+
| None -> None
1067+
| Some p -> Some (Identifier.Mk.instance_variable (p, q)))
1068+
| `Label (p, q) -> (
1069+
match label_parent_identifier p with
1070+
| None -> None
1071+
| Some p -> Some (Identifier.Mk.label (p, q)))
10141072

10151073
module Signature = struct
10161074
type t = Paths_types.Resolved_reference.signature

‎src/model/paths.mli‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -450,7 +450,7 @@ module Fragment : sig
450450

451451
type t = Paths_types.Resolved_fragment.any
452452

453-
val identifier : t -> Identifier.t
453+
val identifier : t -> Identifier.t option
454454

455455
val is_hidden : t -> bool
456456
end
@@ -567,7 +567,7 @@ module rec Reference : sig
567567

568568
type t = Paths_types.Resolved_reference.any
569569

570-
val identifier : t -> Identifier.t
570+
val identifier : t -> Identifier.t option
571571
end
572572

573573
module Signature : sig

0 commit comments

Comments
 (0)