Occurrence: refactor typedtree traverse and source_info type

An occurrence contains information for its documentation and its implementation.

The manual traverse is made only to compute the environment, the compiler
traverse is used to find occurrences.

Signed-off-by: Paul-Elliot <[email protected]>

Author: panglesd

src/document/generator.ml

@@ -252,52 +252,43 @@ module Make (Syntax : SYNTAX) = struct
     let path id = Url.Path.from_identifier id
     let url id = Url.from_path (path id)
 
+    let to_link documentation implementation =
+      let documentation =
+        let open Paths.Path.Resolved in
+        match documentation with
+        | Some (`Resolved p) when not (is_hidden (p :> t)) -> (
+            let id = identifier (p :> t) in
+            match Url.from_identifier ~stop_before:false id with
+            | Ok link -> Some link
+            | _ -> None)
+        | _ -> None
+      in
+      let implementation =
+        match implementation with
+        | None -> None
+        | Some id -> (
+            match Url.Anchor.from_identifier (id :> Paths.Identifier.t) with
+            | Ok url -> Some url
+            | Error _ -> None)
+      in
+      Some (Source_page.Link { implementation; documentation })
+
     let info_of_info : Lang.Source_info.annotation -> Source_page.info option =
       function
-      | Value id -> (
-          match Url.Anchor.from_identifier (id :> Paths.Identifier.t) with
-          | Ok url -> Some (Link url)
-          | Error _ -> None)
       | Definition id -> (
           match id.iv with
           | `SourceLocation (_, def) -> Some (Anchor (DefName.to_string def))
           | `SourceLocationInternal (_, local) ->
               Some (Anchor (LocalName.to_string local))
           | _ -> None)
-      | ModulePath (`Resolved p)
-        when not (Paths.Path.Resolved.is_hidden (p :> Paths.Path.Resolved.t))
-        -> (
-          let id = Paths.Path.Resolved.(identifier (p :> t)) in
-          match Url.from_identifier ~stop_before:false id with
-          | Ok link -> Some (Link link)
-          | _ -> None)
-      | TypePath (`Resolved p)
-        when not (Paths.Path.Resolved.is_hidden (p :> Paths.Path.Resolved.t))
-        -> (
-          let id = Paths.Path.Resolved.(identifier (p :> t)) in
-          match Url.from_identifier ~stop_before:false id with
-          | Ok link -> Some (Link link)
-          | _ -> None)
-      | ValuePath (`Resolved p)
-        when not (Paths.Path.Resolved.is_hidden (p :> Paths.Path.Resolved.t))
-        -> (
-          let id = Paths.Path.Resolved.(identifier (p :> t)) in
-          match Url.from_identifier ~stop_before:false id with
-          | Ok link -> Some (Link link)
-          | _ -> None)
-      | ConstructorPath (`Resolved p)
-        when not (Paths.Path.Resolved.is_hidden (p :> Paths.Path.Resolved.t))
-        -> (
-          let id = Paths.Path.Resolved.(identifier (p :> t)) in
-          match Url.from_identifier ~stop_before:false id with
-          | Ok link -> Some (Link link)
-          | _ -> None)
-      | ModulePath _ -> None
-      | ClassPath _ -> None
-      | TypePath _ -> None
-      | MtyPath _ -> None
-      | ValuePath _ -> None
-      | ConstructorPath _ -> None
+      | Module { documentation; _ } -> to_link documentation None
+      | ModuleType { documentation; _ } -> to_link documentation None
+      | Type { documentation; _ } -> to_link documentation None
+      | Class { documentation; _ } -> to_link documentation None
+      | Value { documentation; implementation } ->
+          to_link documentation implementation
+      | Constructor { documentation; _ } -> to_link documentation None
+
 
     let source id syntax_info infos source_code =
       let url = path id in

src/document/types.ml

@@ -183,7 +183,9 @@ end =
   Page
 
 and Source_page : sig
-  type info = Syntax of string | Anchor of string | Link of Url.Anchor.t
+
+  type target = { documentation : Url.Anchor.t option ; implementation : Url.Anchor.t option}
+  type info = Syntax of string | Anchor of string | Link of target
 
   type code = span list
   and span = Tagged_code of info * code | Plain_code of string

src/html/html_source.ml

@@ -24,9 +24,24 @@ let html_of_doc ~config ~resolve docs =
         let children = List.concat @@ List.map (doc_to_html ~is_in_a) docs in
         match info with
         | Syntax tok -> [ span ~a:[ a_class [ tok ] ] children ]
-        | Link anchor ->
-            let href = Link.href ~config ~resolve anchor in
-            [ a ~a:[ a_href href ] children ]
+        | Link { documentation; implementation } -> (
+            let href_implementation =
+              Option.map (Link.href ~config ~resolve) implementation
+            in
+            let href_documentation =
+              Option.map (Link.href ~config ~resolve) documentation
+            in
+            let body =
+              match href_implementation with
+              | Some href -> [ a ~a:[ a_href href ] children ]
+              | None -> children
+            in
+            match href_documentation with
+            | None -> body
+            | Some href ->
+                [
+                  span ~a:[] [ span ~a:[] body; a ~a:[ a_href href ] [txt "Jump to documentation"] ];
+                ])
         | Anchor lbl -> [ span ~a:[ a_id lbl ] children ])
   in
   span ~a:[] @@ List.concat @@ List.map (doc_to_html ~is_in_a:false) docs