Better errors and more permissive parser

Author: EmileTrotignon

src/lexer.mll

@@ -279,76 +279,60 @@ let language_tag_char =
 let delim_char =
   ['a'-'z' 'A'-'Z' '0'-'9' '_' ]
 
-rule reference_paren_content input start depth_paren depth_curly buffer = parse
+rule reference_paren_content input start ref_offset start_offset depth_paren
+  buffer =
+  parse
   | '('
     {
       buffer_add_lexeme buffer lexbuf ;
-      reference_paren_content input start (depth_paren + 1) depth_curly buffer
-        lexbuf }
-  | '{'
-    {
-      buffer_add_lexeme buffer lexbuf ;
-       reference_paren_content input start depth_paren (depth_curly + 1) buffer
-        lexbuf }
+      reference_paren_content input start ref_offset start_offset
+        (depth_paren + 1) buffer lexbuf }
   | ')'
     {
       buffer_add_lexeme buffer lexbuf ;
       if depth_paren = 0 then
-        reference_content input start buffer lexbuf
-      else
-        reference_paren_content input start (depth_paren - 1) depth_curly
-            buffer lexbuf }
-  | '}'
-    {
-      if depth_curly = 0 then (
-        warning
-          input
-          ~start_offset:(Lexing.lexeme_end lexbuf)
-          (Parse_error.not_allowed
-            ~what:"'}' (end of reference)"
-            ~in_what:(
-              Printf.sprintf "'%s' (custom operator)"
-                (Buffer.contents buffer ))) ;
-        Buffer.contents buffer )
+        reference_content input start ref_offset buffer lexbuf
       else
-        (
-          buffer_add_lexeme buffer lexbuf ;
-          reference_paren_content input start depth_paren (depth_curly - 1)
-            buffer lexbuf ) }
+        reference_paren_content input start ref_offset start_offset
+          (depth_paren - 1) buffer lexbuf }
   | eof
-    { reference_content input start buffer lexbuf }
+    { warning
+        input
+        ~start_offset
+        (Parse_error.unclosed_bracket ~bracket:"(") ;
+      Buffer.contents buffer }
   | _
     {
       buffer_add_lexeme buffer lexbuf ;
-      reference_paren_content input start depth_paren depth_curly buffer lexbuf }
+      reference_paren_content input start ref_offset start_offset depth_paren
+        buffer lexbuf }
 
-and reference_content input start buffer = parse
+and reference_content input start start_offset buffer = parse
   | '}'
     {
       Buffer.contents buffer
     }
   | '('
     {
       buffer_add_lexeme buffer lexbuf ;
-      reference_paren_content input start 0 0 buffer lexbuf
+      reference_paren_content input start start_offset
+        (Lexing.lexeme_start lexbuf) 0 buffer lexbuf
     }
   | '"' [^ '"']* '"'
     {
       buffer_add_lexeme buffer lexbuf ;
-      reference_content input start buffer lexbuf
+      reference_content input start start_offset buffer lexbuf
     }
   | eof
     { warning
         input
-        ~start_offset:(Lexing.lexeme_end lexbuf)
-        (Parse_error.not_allowed
-          ~what:(Token.describe `End)
-          ~in_what:(Token.describe (reference_token start "")));
-        Buffer.contents buffer }
+        ~start_offset
+        (Parse_error.unclosed_bracket ~bracket:start) ;
+      Buffer.contents buffer }
   | _
     {
       buffer_add_lexeme buffer lexbuf ;
-      reference_content input start buffer lexbuf }
+      reference_content input start start_offset buffer lexbuf }
 
 and token input = parse
   | horizontal_space* eof
@@ -421,7 +405,9 @@ and token input = parse
   | (reference_start as start)
     {
       let start_offset = Lexing.lexeme_start lexbuf in
-      let target = reference_content input start (Buffer.create 16) lexbuf in
+      let target =
+        reference_content input start start_offset (Buffer.create 16) lexbuf
+      in
       let token = (reference_token start target) in
       emit ~start_offset input token }
 

src/parse_error.ml

@@ -30,6 +30,11 @@ let not_allowed :
   Warning.make ?suggestion "%s is not allowed in %s." (capitalize_ascii what)
     in_what
 
+let unclosed_bracket :
+    ?suggestion:string -> bracket:string -> Loc.span -> Warning.t =
+ fun ?suggestion ~bracket ->
+  Warning.make ?suggestion "Open bracket '%s' is never closed." bracket
+
 let no_leading_whitespace_in_verbatim : Loc.span -> Warning.t =
   Warning.make "'{v' should be followed by whitespace."
 

test/test.ml

@@ -1537,8 +1537,8 @@ let%expect_test _ =
           (((f.ml (1 0) (1 5))
             (paragraph (((f.ml (1 0) (1 5)) (simple ((f.ml (1 2) (1 5)) foo) ())))))))
          (warnings
-          ( "File \"f.ml\", line 1, characters 5-5:\
-           \nEnd of text is not allowed in '{!...}' (cross-reference)."))) |}]
+          ( "File \"f.ml\", line 1, characters 0-5:\
+           \nOpen bracket '{!' is never closed."))) |}]
 
     let empty_kind =
       test "{!:foo}";
@@ -1647,8 +1647,8 @@ let%expect_test _ =
             (paragraph
              (((f.ml (1 0) (1 9)) (simple ((f.ml (1 2) (1 9)) val:foo) ())))))))
          (warnings
-          ( "File \"f.ml\", line 1, characters 9-9:\
-           \nEnd of text is not allowed in '{!...}' (cross-reference)."))) |}]
+          ( "File \"f.ml\", line 1, characters 0-9:\
+           \nOpen bracket '{!' is never closed."))) |}]
 
     let operator =
       test "{!(>>=)}";
@@ -1720,17 +1720,27 @@ let%expect_test _ =
                 (((f.ml (1 0) (1 6)) (simple ((f.ml (1 2) (1 6)) "\"}\"") ())))))))
             (warnings ())) |}]
 
+    let operator_with_curly_braces =
+      test "{!( } )}";
+      [%expect
+        {|
+          ((output
+            (((f.ml (1 0) (1 8))
+              (paragraph
+               (((f.ml (1 0) (1 8)) (simple ((f.ml (1 2) (1 8)) "( } )") ())))))))
+           (warnings ())) |}]
+
     let operator_unbalanced =
       test "{!(.*()}";
       [%expect
         {|
         ((output
           (((f.ml (1 0) (1 8))
             (paragraph
-             (((f.ml (1 0) (1 8)) (simple ((f.ml (1 2) (1 8)) "(.*()") ())))))))
+             (((f.ml (1 0) (1 8)) (simple ((f.ml (1 2) (1 8)) "(.*()}") ())))))))
          (warnings
-          ( "File \"f.ml\", line 1, characters 8-8:\
-           \n'}' (end of reference) is not allowed in '(.*()' (custom operator)."))) |}]
+          ( "File \"f.ml\", line 1, characters 2-8:\
+           \nOpen bracket '(' is never closed."))) |}]
 
     let operator_eof =
       test "{!(.*()";
@@ -1741,8 +1751,8 @@ let%expect_test _ =
               (paragraph
                (((f.ml (1 0) (1 7)) (simple ((f.ml (1 2) (1 7)) "(.*()") ())))))))
            (warnings
-            ( "File \"f.ml\", line 1, characters 7-7:\
-             \nEnd of text is not allowed in '{!...}' (cross-reference)."))) |}]
+            ( "File \"f.ml\", line 1, characters 2-7:\
+             \nOpen bracket '(' is never closed."))) |}]
   end in
   ()
 
@@ -1933,8 +1943,8 @@ let%expect_test _ =
             (paragraph
              (((f.ml (1 0) (1 6)) (with_text ((f.ml (1 3) (1 6)) foo) ())))))))
          (warnings
-          ( "File \"f.ml\", line 1, characters 6-6:\
-           \nEnd of text is not allowed in '{{!...} ...}' (cross-reference)."
+          ( "File \"f.ml\", line 1, characters 0-6:\
+           \nOpen bracket '{{!' is never closed."
             "File \"f.ml\", line 1, characters 6-6:\
            \nEnd of text is not allowed in '{{!...} ...}' (cross-reference)."
             "File \"f.ml\", line 1, characters 0-6:\
@@ -2102,8 +2112,8 @@ let%expect_test _ =
         {|
         ((output (((f.ml (1 0) (1 6)) (paragraph (((f.ml (1 0) (1 6)) (foo ())))))))
          (warnings
-          ( "File \"f.ml\", line 1, characters 6-6:\
-           \nEnd of text is not allowed in '{{:...} ...}' (external link)."
+          ( "File \"f.ml\", line 1, characters 0-6:\
+           \nOpen bracket '{{:' is never closed."
             "File \"f.ml\", line 1, characters 6-6:\
            \nEnd of text is not allowed in '{{:...} ...}' (external link)."))) |}]
 
@@ -2120,8 +2130,8 @@ let%expect_test _ =
         {|
         ((output (((f.ml (1 0) (1 5)) (paragraph (((f.ml (1 0) (1 5)) (foo ())))))))
          (warnings
-          ( "File \"f.ml\", line 1, characters 5-5:\
-           \nEnd of text is not allowed in '{:...} (external link)'."))) |}]
+          ( "File \"f.ml\", line 1, characters 0-5:\
+           \nOpen bracket '{:' is never closed."))) |}]
 
     let empty_single_braces =
       test "{:}";