Parsing error on path-reference with empty components

Also improve the path parsing to be more readable.
Julow · Jul 10, 2024 · e66ecbd · e66ecbd
1 parent 4b2c293
commit e66ecbd
Show file tree

Hide file tree

Showing 2 changed files with 47 additions and 18 deletions.
diff --git a/src/model/reference.ml b/src/model/reference.ml
@@ -234,27 +234,31 @@ let parse whole_reference_location s :
   let open Paths.Reference in
   let open Names in
   let rec path components next_token tokens : Hierarchy.t =
-    match (next_token.kind, tokens) with
-    | `End_in_slash, [] when next_token.identifier = "" ->
-        (* {!/identifier} *)
-        (`TAbsolutePath, components)
-    | `End_in_slash, [] when next_token.identifier = "." ->
-        (* {!./identifier} *)
-        (`TRelativePath, components)
-    | `End_in_slash, [ { kind = `End_in_slash; identifier = ""; _ } ]
-      when next_token.identifier = "" ->
+    match (next_token, tokens) with
+    | { kind = `End_in_slash; identifier; _ }, [] -> (
+        match identifier with
+        | "" ->
+            (* {!/identifier} *)
+            (`TAbsolutePath, components)
+        | "." ->
+            (* {!./identifier} *)
+            (`TRelativePath, components)
+        | c ->
+            (* {!identifier'/identifier} *)
+            (`TRelativePath, c :: components))
+    | ( { kind = `End_in_slash; identifier = ""; _ },
+        [ { kind = `End_in_slash; identifier = ""; _ } ] ) ->
         (* {!//identifier} *)
         (`TCurrentPackage, components)
-    | `End_in_slash, [] ->
-        (* {!identifier'/identifier} *)
-        (`TRelativePath, next_token.identifier :: components)
-    | `End_in_slash, next_token' :: tokens' ->
+    | { kind = `End_in_slash; identifier; location }, next_token' :: tokens' ->
+        if identifier = "" then
+          should_not_be_empty ~what:"Identifier in path reference" location
+          |> Error.raise_exception;
         (* {!path/identifier} *)
-        path (next_token.identifier :: components) next_token' tokens'
-    | (`None | `Prefixed _), _ ->
-        (* This is not really expected *)
-        expected ~expect_paths:true [] next_token.location
-        |> Error.raise_exception
+        path (identifier :: components) next_token' tokens'
+    | { kind = `None | `Prefixed _; _ }, _ ->
+        (* Cannot be outputed by the lexer. *)
+        assert false
   in
 
   let ends_in_slash next_token =

diff --git a/test/model/semantics/test.ml b/test/model/semantics/test.ml
@@ -2855,6 +2855,31 @@ let%expect_test _ =
       [%expect
         {| {"value":[{"`Paragraph":[{"`Code_span":"foo/type-bar"}]}],"warnings":["File \"f.ml\", line 1, characters 6-14:\nExpected 'module-', 'page-', a path, or an unqualified reference."]} |}]
 
+    let err_relative_empty_component =
+      test "{!foo//bar}";
+      [%expect
+        {| {"value":[{"`Paragraph":[{"`Code_span":"foo//bar"}]}],"warnings":["File \"f.ml\", line 1, characters 6-6:\nIdentifier in path reference should not be empty."]} |}]
+
+    let err_current_package_empty_component =
+      test "{!///bar}";
+      [%expect
+        {| {"value":[{"`Paragraph":[{"`Code_span":"///bar"}]}],"warnings":["File \"f.ml\", line 1, characters 4-4:\nIdentifier in path reference should not be empty."]} |}]
+
+    let err_last_empty_component =
+      test "{!foo/}";
+      [%expect
+        {| {"value":[{"`Paragraph":[{"`Code_span":"foo/"}]}],"warnings":["File \"f.ml\", line 1, characters 6-6:\nIdentifier in reference should not be empty."]} |}]
+
+    let err_first_empty_component =
+      test "{!/}";
+      [%expect
+        {| {"value":[{"`Paragraph":[{"`Code_span":"/"}]}],"warnings":["File \"f.ml\", line 1, characters 3-3:\nIdentifier in reference should not be empty."]} |}]
+
+    let err_current_package_empty_component =
+      test "{!//}";
+      [%expect
+        {| {"value":[{"`Paragraph":[{"`Code_span":"//"}]}],"warnings":["File \"f.ml\", line 1, characters 4-4:\nIdentifier in reference should not be empty."]} |}]
+
     (* Old kind compatibility *)
 
     let oldkind_abs_page =