Add exception to [uid_to_loc] table

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

Author: panglesd

src/loader/ident_env.cppo.ml

@@ -62,6 +62,9 @@ type item = [
   | `Value of Ident.t * bool * Warnings.loc option
   | `Class of Ident.t * Ident.t * Ident.t * Ident.t option * bool * Warnings.loc option
   | `ClassType of Ident.t * Ident.t * Ident.t option * bool * Warnings.loc option
+  | `Exception of Ident.t * Warnings.loc option
+  (* Exceptions are never hidden, but we need to add it to the [loc_to_ident]
+     table. *)
 ]
 
 type items =
@@ -305,6 +308,12 @@ let rec extract_structure_tree_items : bool -> Typedtree.structure_item list ->
         List.map (fun decl -> `Type (decl.typ_id, hide_item, Some str_loc))
           decls @ extract_structure_tree_items hide_item rest
 
+#if OCAML_VERSION < (4,14,0)
+    | { str_desc = Tstr_exception _; _ } :: rest -> extract_structure_tree_items hide_item rest
+#else
+    | { str_desc = Tstr_exception { tyexn_constructor; tyexn_loc = _; _ }; _ } :: rest ->
+       `Exception (tyexn_constructor.ext_id, Some tyexn_constructor.ext_loc) :: extract_structure_tree_items hide_item rest
+#endif
 
 #if OCAML_VERSION < (4,3,0)
     | { str_desc = Tstr_value (_, vbs ); _} :: rest ->
@@ -379,8 +388,7 @@ let rec extract_structure_tree_items : bool -> Typedtree.structure_item list ->
     | { str_desc = Tstr_primitive {val_id; _}; str_loc; _ } :: rest ->
       [`Value (val_id, false, Some str_loc)] @ extract_structure_tree_items hide_item rest
     | { str_desc = Tstr_eval _; _} :: rest 
-    | { str_desc = Tstr_typext _; _} :: rest
-    | {str_desc = Tstr_exception _; _ } :: rest -> extract_structure_tree_items hide_item rest
+    | { str_desc = Tstr_typext _; _} :: rest -> extract_structure_tree_items hide_item rest
     | [] -> []
 
 
@@ -391,6 +399,7 @@ let flatten_extracted : items list -> item list = fun items ->
     | `ModuleType _
     | `Value _
     | `Class _
+    | `Exception _
     | `ClassType _ as x -> [x]
     | `Include xs -> xs) items |> List.flatten
 
@@ -428,6 +437,12 @@ let env_of_items : Id.Signature.t -> item list -> t -> t = fun parent items env
       (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ());
       inner rest { env with types; hidden }
 
+    | `Exception (t, loc) :: rest ->
+      let name = Ident.name t in
+      let identifier = Mk.exception_(parent, ExceptionName.make_std name) in
+      (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ());
+      inner rest env
+
     | `Value (t, is_hidden_item, loc) :: rest ->
       let name = Ident.name t in
       let is_hidden = is_hidden_item || value_name_exists name rest in

src/loader/ident_env.cppo.mli

@@ -25,6 +25,7 @@ type item =
   | `Value of Ident.t * bool * Warnings.loc option
   | `Class of
     Ident.t * Ident.t * Ident.t * Ident.t option * bool * Warnings.loc option
+  | `Exception of Ident.t * Warnings.loc option
   | `ClassType of
     Ident.t * Ident.t * Ident.t option * bool * Warnings.loc option ]
 

test/sources/lookup_def.t/run.t

@@ -20,7 +20,7 @@ Show the locations:
   [{"`Value":[{"`Module":[{"`Module":[{"`Root":["None","A"]},"N"]},"T"]},"x"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"def_3"]}}]
   [{"`Type":[{"`Root":["None","A"]},"t"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"type-t"]}}]
   [{"`Value":[{"`Root":["None","A"]},"a"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"value-a"]}}]
-  [{"`Exception":[{"`Root":["None","A"]},"Exn"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"def_9"]}}]
+  [{"`Exception":[{"`Root":["None","A"]},"Exn"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"exception-Exn"]}}]
   [{"`Type":[{"`Root":["None","A"]},"ext"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"type-ext"]}}]
   [{"`Extension":[{"`Root":["None","A"]},"Ext"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"def_11"]}}]
   [{"`Class":[{"`Root":["None","A"]},"cls"]},{"Some":{"`SourceLocation":[{"`SourcePage":[{"`Page":[{"Some":{"`Page":["None","root"]}},"source"]},"a.ml"]},"class-cls"]}}]

test/sources/source.t/a.ml

@@ -18,3 +18,6 @@ exception Exn
 class cls = object end
 class cls' = cls
 class type ct = object end
+
+
+let x _ = raise Exn

test/sources/source.t/run.t

@@ -21,6 +21,9 @@ Files containing some values:
   class cls = object end
   class cls' = cls
   class type ct = object end
+  
+  
+  let x _ = raise Exn
 
 Source pages require a parent:
 
@@ -47,7 +50,12 @@ Now, compile the pages with the --source option:
 
   $ odoc compile -I . --source-name a.ml --source-parent-file src-source.odoc a.cmt
   $ odoc link -I . a.odoc
+  $ odoc link -I . page-root.odoc
+  $ odoc link -I . src-source.odoc
+  $ odoc html-generate --indent -o html src-source.odocl
+  $ odoc html-generate --indent -o html page-root.odocl
   $ odoc html-generate --source a.ml --indent -o html a.odocl
+  $ odoc support-files -o html
 
 Source links generated in the documentation:
 
@@ -59,10 +67,6 @@ Source links generated in the documentation:
       <div class="spec type anchored" id="type-t">
        <a href="#type-t" class="anchor"></a>
        <a href="../root/source/a.ml.html#type-t" class="source_link">Source</a>
-  --
-      <div class="spec value anchored" id="val-x">
-       <a href="#val-x" class="anchor"></a>
-       <a href="../root/source/a.ml.html#value-x" class="source_link">Source
   --
       <div class="spec value anchored" id="val-y">
        <a href="#val-y" class="anchor"></a>
@@ -98,7 +102,7 @@ Source links generated in the documentation:
   --
       <div class="spec exception anchored" id="exception-Exn">
        <a href="#exception-Exn" class="anchor"></a>
-       <a href="../root/source/a.ml.html#def_11" class="source_link">Source</a>
+       <a href="../root/source/a.ml.html#exception-Exn" class="source_link">
   --
       <div class="spec class anchored" id="class-cls">
        <a href="#class-cls" class="anchor"></a>
@@ -111,6 +115,10 @@ Source links generated in the documentation:
       <div class="spec class-type anchored" id="class-type-ct">
        <a href="#class-type-ct" class="anchor"></a>
        <a href="../root/source/a.ml.html#class_type-ct" class="source_link">
+  --
+      <div class="spec value anchored" id="val-x">
+       <a href="#val-x" class="anchor"></a>
+       <a href="../root/source/a.ml.html#value-x" class="source_link">Source
 
 Ids generated in the source code:
 
@@ -135,42 +143,26 @@ Ids generated in the source code:
   id="L18"
   id="L19"
   id="L20"
+  id="L21"
+  id="L22"
+  id="L23"
   id="type-t"
-  id="value-x"
+  id="value-{x}2"
   id="value-y"
   id="value-z"
   id="local_a_47"
-  id="def-5"
-  id="def-6"
-  id="def-7"
-  id="def-8"
-  id="def-9"
-  id="def-10"
-  id="def-11"
-  id="def-12"
-  id="def-14"
-  id="def-15"
-
-Another example, with a cmti file:
-
-  $ printf "b.ml\n" > source_tree.map
-  $ odoc source-tree -I . --parent page-root -o src-source2.odoc source_tree.map
-
-  $ ocamlc -bin-annot b.mli
-  $ ocamlc -bin-annot b.ml
-
-When giving a .cmti with the source-name and source-parent option, the cmt file
-has to be given explicitely with the --cmt argument:
-
-  $ odoc compile -I . --source-name b.ml --source-parent-file src-source2.odoc b.cmti
-  --cmt has to be passed when --source-parent-file and --source-name are passed and the input file is not a cmt file.
-  [2]
-
-  $ odoc compile -I . --cmt b.cmt --source-name b.ml --source-parent-file src-source2.odoc b.cmti
-
-The --cmt argument has to be compatible with a cmt file given as input:
+  id="module-A"
+  id="module-B"
+  id="module_type-T"
+  id="module_type-U"
+  id="type-ext"
+  id="def_10"
+  id="exception-Exn"
+  id="class-cls"
+  id="class-cls'"
+  id="class_type-ct"
+  id="value-x"
 
-  $ cp b.cmt other.cmt
-  $ odoc compile -I . --cmt other.cmt --source-name b.ml --source-parent-file src-source2.odoc b.cmt
-  --cmt has to be equal to the input file when this one has .cmt extension.
-  [2]
+  $ firefox html/root/source/a.ml.html
+  Gtk-Message: 12:16:26.688: Failed to load module "xapp-gtk3-module"
+  Gtk-Message: 12:16:26.689: Not loading module "atk-bridge": The functionality is provided by GTK natively. Please try to not load it.