Simpler parser ast

src/parser/ast.ml

@@ -1,32 +1,36 @@
-module Path = Odoc_model.Paths.Path
-module Reference = Odoc_model.Paths.Reference
-module Identifier = Odoc_model.Paths.Identifier
-module Comment = Odoc_model.Comment
-
 type 'a with_location = 'a Odoc_model.Location_.with_location
 
 
 
+type style = [
+  | `Bold
+  | `Italic
+  | `Emphasis
+  | `Superscript
+  | `Subscript
+]
+
 type reference_kind = [ `Simple | `With_text ]
 
 type inline_element = [
-  | `Space
+  | `Space of string
   | `Word of string
   | `Code_span of string
-  | `Raw_markup of Comment.raw_markup_target * string
-  | `Styled of Comment.style * (inline_element with_location) list
+  | `Raw_markup of string option * string
+  | `Styled of style * (inline_element with_location) list
   | `Reference of
-      reference_kind * Reference.t * (inline_element with_location) list
+      reference_kind * string with_location * (inline_element with_location) list
   | `Link of string * (inline_element with_location) list
 ]
 
 type nestable_block_element = [
   | `Paragraph of (inline_element with_location) list
   | `Code_block of string
   | `Verbatim of string
-  | `Modules of Reference.Module.t list
+  | `Modules of string with_location list
   | `List of
     [ `Unordered | `Ordered ] *
+    [ `Light | `Heavy ] *
     ((nestable_block_element with_location) list) list
 ]
 
@@ -43,7 +47,7 @@ type tag = [
   | `Since of string
   | `Before of string * (nestable_block_element with_location) list
   | `Version of string
-  | `Canonical of Path.Module.t * Reference.Module.t
+  | `Canonical of string with_location
   | `Inline
   | `Open
   | `Closed

src/parser/lexer.mll

@@ -76,7 +76,7 @@ let trim_leading_whitespace : string -> string = fun s ->
       match line.[index] with
       | ' ' | '\t' -> count_leading_whitespace' (index + 1)
       | _ -> `Leading_whitespace index
-      | exception Invalid_argument _ -> `Blank_line
+      | exception Invalid_argument _ -> `Blank_line "\n"
     in
     count_leading_whitespace' 0
   in
@@ -251,15 +251,15 @@ rule token input = parse
   | horizontal_space* eof
     { emit input `End }
 
-  | (horizontal_space* newline as prefix)
-    horizontal_space* ((newline horizontal_space*)+ as suffix)
-    { emit input `Blank_line ~adjust_start_by:prefix ~adjust_end_by:suffix }
+  | ((horizontal_space* newline as prefix)
+    horizontal_space* ((newline horizontal_space*)+ as suffix) as ws)
+    { emit input (`Blank_line ws) ~adjust_start_by:prefix ~adjust_end_by:suffix }
 
-  | horizontal_space* newline horizontal_space*
-    { emit input `Single_newline }
+  | (horizontal_space* newline horizontal_space* as ws)
+    { emit input (`Single_newline ws) }
 
-  | horizontal_space+
-    { emit input `Space }
+  | (horizontal_space+ as ws)
+    { emit input (`Space ws) }
 
   | (horizontal_space* (newline horizontal_space*)? as p) '}'
     { emit input `Right_brace ~adjust_start_by:p }
@@ -308,27 +308,15 @@ rule token input = parse
 
   | "{%" ((raw_markup_target as target) ':')? (raw_markup as s)
     ("%}" | eof as e)
-    { if e <> "%}" then
+    { let token = `Raw_markup (target, s) in
+      if e <> "%}" then
         warning
           input
           ~start_offset:(Lexing.lexeme_end lexbuf)
           (Parse_error.not_allowed
             ~what:(Token.describe `End)
-            ~in_what:(Token.describe (`Raw_markup (`Html, ""))));
-      let target_is_valid =
-        match target with
-        | Some "html" -> true
-        | Some invalid_target ->
-          warning input (Parse_error.invalid_raw_markup_target invalid_target);
-          false
-        | None ->
-          warning input Parse_error.default_raw_markup_target_not_supported;
-          false
-      in
-      if target_is_valid then
-        emit input (`Raw_markup (`Html, s))
-      else
-        emit input (`Code_span s) }
+            ~in_what:(Token.describe token));
+      emit input token }
 
   | "{ul"
     { emit input (`Begin_list `Unordered) }
@@ -487,7 +475,7 @@ and code_span buffer nesting_level start_offset input = parse
     { warning
         input
         (Parse_error.not_allowed
-          ~what:(Token.describe `Blank_line)
+          ~what:(Token.describe (`Blank_line "\n\n"))
           ~in_what:(Token.describe (`Code_span "")));
       Buffer.add_char buffer '\n';
       code_span buffer nesting_level start_offset input lexbuf }

src/parser/parse_error.ml

@@ -91,15 +91,15 @@ let unpaired_right_bracket : Location.span -> Error.t =
 let invalid_raw_markup_target : string -> Location.span -> Error.t =
   Error.make
     ~suggestion:
-      (Printf.sprintf "try %s." (Token.print (`Raw_markup (`Html, ""))))
+      (Printf.sprintf "try %s." (Token.print (`Raw_markup (Some "html", ""))))
       "'{%%%s:': bad raw markup target."
 
 let default_raw_markup_target_not_supported : Location.span -> Error.t =
   Error.make
     ~suggestion:
-      (Printf.sprintf "try %s." (Token.print (`Raw_markup (`Html, ""))))
+      (Printf.sprintf "try %s." (Token.print (`Raw_markup (Some "html", ""))))
     "%s needs a target language."
-    (Token.describe (`Raw_markup (`Html, "")))
+    (Token.describe (`Raw_markup (None, "")))
 
 let expected : string -> Location.span -> Error.t =
   Error.make "Expected %s."

src/parser/semantics.ml

@@ -8,6 +8,15 @@ type 'a with_location = 'a Location.with_location
 
 
 
+type ast_leaf_inline_element = [
+  | `Space of string
+  | `Word of string
+  | `Code_span of string
+  | `Raw_markup of string option * string
+]
+
+
+
 type status = {
   warnings : Error.warning_accumulator;
   sections_allowed : Ast.sections_allowed;
@@ -29,14 +38,43 @@ let describe_element = function
 
 
 
+let leaf_inline_element
+    : status -> ast_leaf_inline_element with_location ->
+        Comment.leaf_inline_element with_location =
+    fun status element ->
+
+  match element with
+  | { value = (`Word _ | `Code_span _); _ } as element ->
+    element
+
+  | { value = `Space _; _ } ->
+    Location.same element `Space
+
+  | { value = `Raw_markup (Some "html", s); _ } ->
+    Location.same element (`Raw_markup (`Html, s))
+
+  | { value = `Raw_markup (target, s); location } ->
+    let error =
+      match target with
+      | Some invalid_target ->
+        Parse_error.invalid_raw_markup_target invalid_target location
+      | None ->
+        Parse_error.default_raw_markup_target_not_supported location
+    in
+    Error.warning status.warnings error;
+    Location.same element (`Code_span s)
+
+
+
 let rec non_link_inline_element
     : status -> surrounding:_ -> Ast.inline_element with_location ->
         Comment.non_link_inline_element with_location =
     fun status ~surrounding element ->
 
   match element with
-  | {value = #Comment.leaf_inline_element; _} as element ->
-    element
+  | {value = #ast_leaf_inline_element; _} as element ->
+    (leaf_inline_element status element
+     :> Comment.non_link_inline_element with_location)
 
   | {value = `Styled (style, content); _} ->
     `Styled (style, non_link_inline_elements status ~surrounding content)
@@ -64,17 +102,30 @@ let rec inline_element
     fun status element ->
 
   match element with
-  | {value = #Comment.leaf_inline_element; _} as element ->
-    element
+  | {value = #ast_leaf_inline_element; _} as element ->
+    (leaf_inline_element status element
+     :> Comment.inline_element with_location)
 
   | {value = `Styled (style, content); location} ->
     `Styled (style, inline_elements status content)
     |> Location.at location
 
-  | {value = `Reference (_, target, content) as value; location} ->
-    `Reference
-      (target, non_link_inline_elements status ~surrounding:value content)
-    |> Location.at location
+  | {value = `Reference (kind, target, content) as value; location} ->
+    let {Location.value = target; location = target_location} = target in
+    begin match Reference.parse status.warnings target_location target with
+      | Result.Ok target ->
+        let content = non_link_inline_elements status ~surrounding:value content in
+        Location.at location (`Reference (target, content))
+
+      | Result.Error error ->
+        Error.warning status.warnings error;
+        let placeholder =
+          match kind with
+          | `Simple -> `Code_span target
+          | `With_text -> `Styled (`Emphasis, content)
+        in
+        inline_element status (Location.at location placeholder)
+    end
 
   | {value = `Link (target, content) as value; location} ->
     `Link (target, non_link_inline_elements status ~surrounding:value content)
@@ -95,11 +146,24 @@ let rec nestable_block_element
     Location.at location (`Paragraph (inline_elements status content))
 
   | {value = `Code_block _; _}
-  | {value = `Verbatim _; _}
-  | {value = `Modules _; _} as element ->
+  | {value = `Verbatim _; _} as element ->
     element
 
-  | {value = `List (kind, items); location} ->
+  | {value = `Modules modules; location} ->
+    let modules =
+      List.fold_left (fun acc {Location.value; location} ->
+          match Reference.read_mod_longident status.warnings location value with
+          | Result.Ok r ->
+            r :: acc
+          | Result.Error error ->
+            Error.warning status.warnings error;
+            acc
+        ) [] modules
+      |> List.rev
+    in
+    Location.at location (`Modules modules)
+
+  | {value = `List (kind, _syntax, items); location} ->
     `List (kind, List.map (nestable_block_elements status) items)
     |> Location.at location
 
@@ -108,34 +172,51 @@ and nestable_block_elements status elements =
 
 
 
-let tag : status -> Ast.tag -> Comment.tag = fun status tag ->
+let tag
+    : location:Location.span -> status -> Ast.tag ->
+        (Comment.block_element with_location, Ast.block_element with_location) Result.result =
+    fun ~location status tag ->
+  let ok t = Result.Ok (Location.at location (`Tag t)) in
   match tag with
   | `Author _
   | `Since _
   | `Version _
-  | `Canonical _
   | `Inline
   | `Open
   | `Closed as tag ->
-    tag
+    ok tag
+
+  | `Canonical {value = s; location = r_location} ->
+    let path = Reference.read_path_longident r_location s in
+    let module_ = Reference.read_mod_longident status.warnings r_location s in
+    begin match path, module_ with
+    | Result.Ok path, Result.Ok module_ ->
+      ok (`Canonical (path, module_))
+    | Result.Error e, _
+    | Result.Ok _, Result.Error e ->
+      Error.warning status.warnings e;
+      let placeholder = [`Word "@canonical"; `Space " "; `Code_span s] in
+      let placeholder = List.map (Location.at location) placeholder in
+      Error (Location.at location (`Paragraph placeholder))
+    end
 
   | `Deprecated content ->
-    `Deprecated (nestable_block_elements status content)
+    ok (`Deprecated (nestable_block_elements status content))
 
   | `Param (name, content) ->
-    `Param (name, nestable_block_elements status content)
+    ok (`Param (name, nestable_block_elements status content))
 
   | `Raise (name, content) ->
-    `Raise (name, nestable_block_elements status content)
+    ok (`Raise (name, nestable_block_elements status content))
 
   | `Return content ->
-    `Return (nestable_block_elements status content)
+    ok (`Return (nestable_block_elements status content))
 
   | `See (kind, target, content) ->
-    `See (kind, target, nestable_block_elements status content)
+    ok (`See (kind, target, nestable_block_elements status content))
 
   | `Before (version, content) ->
-    `Before (version, nestable_block_elements status content)
+    ok (`Before (version, nestable_block_elements status content))
 
 
 
@@ -304,9 +385,13 @@ let top_level_block_elements
         let element = (element :> Comment.block_element with_location) in
         traverse ~top_heading_level (element::comment_elements_acc) ast_elements
 
-      | {value = `Tag the_tag; _} ->
-        let element = Location.same ast_element (`Tag (tag status the_tag)) in
-        traverse ~top_heading_level (element::comment_elements_acc) ast_elements
+      | {value = `Tag the_tag; location} ->
+        begin match tag ~location status the_tag with
+          | Result.Ok element ->
+            traverse ~top_heading_level (element::comment_elements_acc) ast_elements
+          | Result.Error placeholder ->
+            traverse ~top_heading_level comment_elements_acc (placeholder::ast_elements)
+        end
 
       | {value = `Heading _ as heading; _} ->
         let top_heading_level, element =