Handle @canonical tags in the top-comment of signatures

Previously, @canonical tags were allowed to be attached to module,
module type and type declarations and in the top-comment of compilation
units.

This handles @canonical tags in the top-comment of signatures and
structures.

Author: Julow

src/loader/cmt.ml

@@ -387,6 +387,17 @@ and unwrap_module_expr_desc = function
       unwrap_module_expr_desc mexpr.mod_desc
   | desc -> desc
 
+(** Like [read_module_expr] but handle the canonical tag in the top-comment. *)
+and read_module_expr_maybe_canonical env parent container ~canonical mexpr =
+  let open ModuleType in
+  match (canonical, mexpr.mod_desc) with
+  | None, Tmod_structure str ->
+      let sg, canonical =
+        read_structure Odoc_model.Semantics.Expect_canonical env parent str
+      in
+      (Signature sg, canonical)
+  | _ -> (read_module_expr env parent container mexpr, canonical)
+
 and read_module_binding env parent mb =
   let open Module in
 #if OCAML_MAJOR = 4 && OCAML_MINOR >= 10
@@ -400,12 +411,17 @@ and read_module_binding env parent mb =
   let id = (id :> Identifier.Module.t) in
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
   let doc, canonical = Doc_attr.attached Odoc_model.Semantics.Expect_canonical container mb.mb_attributes in
-  let canonical = (canonical :> Path.Module.t option) in
-  let type_ =
+  let type_, canonical =
     match unwrap_module_expr_desc mb.mb_expr.mod_desc with
-    | Tmod_ident(p, _) -> Alias (Env.Path.read_module env p, None)
-    | _ -> ModuleType (read_module_expr env (id :> Identifier.Signature.t) container mb.mb_expr)
+    | Tmod_ident (p, _) -> (Alias (Env.Path.read_module env p, None), canonical)
+    | _ ->
+        let id = (id :> Identifier.Signature.t) in
+        let expr, canonical =
+          read_module_expr_maybe_canonical env id container ~canonical mb.mb_expr
+        in
+        (ModuleType expr, canonical)
   in
+  let canonical = (canonical :> Path.Module.t option) in
   let hidden =
 #if OCAML_MAJOR = 4 && OCAML_MINOR >= 10
     match canonical, mb.mb_id with

src/loader/cmti.ml

@@ -536,14 +536,35 @@ and read_module_type env parent label_parent mty =
         decl
     | Tmty_alias _ -> assert false
 
+(** Like [read_module_type] but handle the canonical tag in the top-comment. If
+    [canonical] is [Some _], no tag is expected in the top-comment. *)
+and read_module_type_maybe_canonical env parent container ~canonical mty =
+  match (canonical, mty.mty_desc) with
+  | None, Tmty_signature sg ->
+      let sg, canonical =
+        read_signature Odoc_model.Semantics.Expect_canonical env parent sg
+      in
+      (ModuleType.Signature sg, canonical)
+  | _, _ -> (read_module_type env parent container mty, canonical)
+
 and read_module_type_declaration env parent mtd =
   let open ModuleType in
   let id = Env.find_module_type env mtd.mtd_id in
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
   let doc, canonical = Doc_attr.attached Odoc_model.Semantics.Expect_canonical container mtd.mtd_attributes in
+  let expr, canonical =
+    match mtd.mtd_type with
+    | Some mty ->
+        let expr, canonical =
+          read_module_type_maybe_canonical env
+            (id :> Identifier.Signature.t)
+            container ~canonical mty
+        in
+        (Some expr, canonical)
+    | None -> (None, canonical)
+  in
   let canonical = (canonical :> Path.ModuleType.t option) in
-  let expr = opt_map (read_module_type env (id :> Identifier.Signature.t) container) mtd.mtd_type in
-    {id; doc; canonical; expr;}
+  { id; doc; canonical; expr }
 
 and read_module_declaration env parent md =
   let open Module in
@@ -556,15 +577,20 @@ and read_module_declaration env parent md =
   let id = Env.find_module_identifier env md.md_id in
 #endif
   let id = (id :> Identifier.Module.t) in
-
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
   let doc, canonical = Doc_attr.attached Odoc_model.Semantics.Expect_canonical container md.md_attributes in
-  let canonical = (canonical :> Path.Module.t option) in
-  let type_ =
+  let type_, canonical =
     match md.md_type.mty_desc with
-    | Tmty_alias(p, _) -> Alias (Env.Path.read_module env p, None)
-    | _ -> ModuleType (read_module_type env (id :> Identifier.Signature.t) container md.md_type)
+    | Tmty_alias (p, _) -> (Alias (Env.Path.read_module env p, None), canonical)
+    | _ ->
+        let expr, canonical =
+          read_module_type_maybe_canonical env
+            (id :> Identifier.Signature.t)
+            container ~canonical md.md_type
+        in
+        (ModuleType expr, canonical)
   in
+  let canonical = (canonical :> Path.Module.t option) in
   let hidden =
 #if OCAML_MAJOR=4 && OCAML_MINOR >= 10
     match canonical, md.md_id with
@@ -576,7 +602,6 @@ and read_module_declaration env parent md =
     | _ -> false
 #endif
   in
-  
   Some {id; doc; type_; canonical; hidden}
 
 and read_module_declarations env parent mds =

test/xref2/canonical_module_type.t/run.t

@@ -23,13 +23,11 @@ constructor where the second element of the tuple is Resolved.
 
   $ ocamlc -c -bin-annot test.mli
   $ odoc compile --package x test.cmti
-  File "test.mli", line 8, characters 6-24:
-  Unexpected tag '@canonical' at this location.
   $ odoc link test.odoc
 
 Every module type aliases and the path they link to:
 
   $ odoc_print test.odocl | jq -c '.content.Module.items | .[] | select(.ModuleType.expr.Some.Path) | .ModuleType | { "from": .id, "to": .expr.Some.Path.p_path }'
-  {"from":{"`ModuleType":[{"`Root":[{"`RootPage":"x"},"Test"]},"X"]},"to":{"`Resolved":{"`Identifier":{"`ModuleType":[{"`Root":[{"`RootPage":"x"},"Test"]},"B"]}}}}
+  {"from":{"`ModuleType":[{"`Root":[{"`RootPage":"x"},"Test"]},"X"]},"to":{"`Resolved":{"`CanonicalModuleType":[{"`Identifier":{"`ModuleType":[{"`Root":[{"`RootPage":"x"},"Test"]},"B"]}},{"`Resolved":{"`Identifier":{"`ModuleType":[{"`Root":[{"`RootPage":"x"},"Test"]},"X"]}}}]}}}
   {"from":{"`ModuleType":[{"`Root":[{"`RootPage":"x"},"Test"]},"Y"]},"to":{"`Resolved":{"`CanonicalModuleType":[{"`Identifier":{"`ModuleType":[{"`Root":[{"`RootPage":"x"},"Test"]},"A"]}},{"`Resolved":{"`Identifier":{"`ModuleType":[{"`Root":[{"`RootPage":"x"},"Test"]},"Y"]}}}]}}}
   {"from":{"`ModuleType":[{"`Root":[{"`RootPage":"x"},"Test"]},"Z"]},"to":{"`Resolved":{"`CanonicalModuleType":[{"`Identifier":{"`ModuleType":[{"`Root":[{"`RootPage":"x"},"Test"]},"A"]}},{"`Resolved":{"`Identifier":{"`ModuleType":[{"`Root":[{"`RootPage":"x"},"Test"]},"Y"]}}}]}}}

test/xref2/canonical_unit.t/run.t

@@ -5,12 +5,6 @@ The module Test_x is expected to be referenced as Test.X.
 Test_w is similar but defined as a .ml file.
 
   $ compile test_x.mli test_w.ml test.ml
-  File "test_x.mli", line 13, characters 6-26:
-  Unexpected tag '@canonical' at this location.
-  File "test_w.ml", line 13, characters 6-26:
-  Unexpected tag '@canonical' at this location.
-  File "test.ml", line 18, characters 6-24:
-  Unexpected tag '@canonical' at this location.
 
 Test_x has a 'canonical' field:
 
@@ -22,14 +16,14 @@ The first two type declarations should have resolved canonical constructors, the
   $ odoc_print test.odocl | jq -c ".content.Module.items | .[] | .Type[1] | select(.) | .equation.manifest.Some.Constr"
   [{"`Resolved":{"`Type":[{"`Canonical":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_x"]}},{"`Resolved":{"`Alias":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_x"]}},{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"X"]}}]}}]},"t"]}},[]]
   [{"`Resolved":{"`Type":[{"`Canonical":[{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"Test_y"]}},{"`Resolved":{"`Alias":[{"`Canonical":[{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"Test_y"]}},{"`Dot":[{"`Root":"Test"},"Y"]}]},{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"Y"]}}]}}]},"t"]}},[]]
-  [{"`Resolved":{"`Type":[{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"Test_z"]}},"t"]}},[]]
+  [{"`Resolved":{"`Type":[{"`Canonical":[{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"Test_z"]}},{"`Resolved":{"`Alias":[{"`Canonical":[{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"Test_z"]}},{"`Dot":[{"`Root":"Test"},"Z"]}]},{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"Z"]}}]}}]},"t"]}},[]]
 
   $ odoc_print test.odocl | jq -c ".content.Module.items | .[] | .Module[1].type_.Alias[0] | select(.)"
   {"`Resolved":{"`Canonical":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_x"]}},{"`Resolved":{"`Alias":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_x"]}},{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"X"]}}]}}]}}
   {"`Resolved":{"`Canonical":[{"`Module":[{"`Canonical":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_x"]}},{"`Resolved":{"`Alias":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_x"]}},{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"X"]}}]}}]},"M"]},{"`Resolved":{"`Alias":[{"`Module":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_x"]}},"M"]},{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"X_m"]}}]}}]}}
-  {"`Resolved":{"`Module":[{"`Canonical":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_x"]}},{"`Resolved":{"`Alias":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_x"]}},{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"X"]}}]}}]},"N"]}}
+  {"`Resolved":{"`Canonical":[{"`Module":[{"`Canonical":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_x"]}},{"`Resolved":{"`Alias":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_x"]}},{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"X"]}}]}}]},"N"]},{"`Resolved":{"`Alias":[{"`Module":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_x"]}},"N"]},{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"X_n"]}}]}}]}}
   {"`Resolved":{"`Canonical":[{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"Test_y"]}},{"`Resolved":{"`Alias":[{"`Canonical":[{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"Test_y"]}},{"`Dot":[{"`Root":"Test"},"Y"]}]},{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"Y"]}}]}}]}}
   {"`Resolved":{"`Canonical":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_w"]}},{"`Resolved":{"`Alias":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_w"]}},{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"W"]}}]}}]}}
   {"`Resolved":{"`Canonical":[{"`Module":[{"`Canonical":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_w"]}},{"`Resolved":{"`Alias":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_w"]}},{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"W"]}}]}}]},"M"]},{"`Resolved":{"`Alias":[{"`Module":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_w"]}},"M"]},{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"W_m"]}}]}}]}}
-  {"`Resolved":{"`Module":[{"`Canonical":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_w"]}},{"`Resolved":{"`Alias":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_w"]}},{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"W"]}}]}}]},"N"]}}
-  {"`Resolved":{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"Test_z"]}}}
+  {"`Resolved":{"`Canonical":[{"`Module":[{"`Canonical":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_w"]}},{"`Resolved":{"`Alias":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_w"]}},{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"W"]}}]}}]},"N"]},{"`Resolved":{"`Alias":[{"`Module":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Test_w"]}},"N"]},{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"W_n"]}}]}}]}}
+  {"`Resolved":{"`Canonical":[{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"Test_z"]}},{"`Resolved":{"`Alias":[{"`Canonical":[{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"Test_z"]}},{"`Dot":[{"`Root":"Test"},"Z"]}]},{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"Test"]},"Z"]}}]}}]}}