Frontmatter syntax

odoc-parser.opam

@@ -18,6 +18,7 @@ depends: [
   "astring"
   "result"
   "camlp-streams"
+  "sexplib"
   "ppx_expect" {with-test}
   ("ocaml" {< "4.04.1" & with-test} | "sexplib0" {with-test})
 ]

src/driver/test/config_file/test_odoc_driver/test_odoc_driver.opam

@@ -1,14 +1,5 @@
 # This file is generated by dune, edit dune-project instead
 opam-version: "2.0"
-synopsis: "A short synopsis"
-description: "A longer description"
-maintainer: ["Maintainer Name"]
-authors: ["Author Name"]
-license: "LICENSE"
-tags: ["topics" "to describe" "your" "project"]
-homepage: "https://github.com/username/reponame"
-doc: "https://url/to/documentation"
-bug-reports: "https://github.com/username/reponame/issues"
 depends: [
   "ocaml"
   "dune" {>= "3.16"}
@@ -28,4 +19,3 @@ build: [
     "@doc" {with-doc}
   ]
 ]
-dev-repo: "git+https://github.com/username/reponame.git"

src/loader/cmti.ml

@@ -572,10 +572,10 @@ and read_module_type env parent label_parent mty =
                 let p = Env.Path.read_module env p in
                 TypeOf {t_desc=StructInclude p; t_original_path = p; t_expansion = None}
             | None ->
-              !read_module_expr env parent label_parent mexpr 
+              !read_module_expr env parent label_parent mexpr
             end
           | _  ->
-            !read_module_expr env parent label_parent mexpr 
+            !read_module_expr env parent label_parent mexpr
           in
         decl
     | Tmty_alias _ -> assert false
@@ -760,7 +760,7 @@ and read_include env parent incl =
   let doc, status = Doc_attr.attached Odoc_model.Semantics.Expect_status container incl.incl_attributes in
   let content, shadowed = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature incl.incl_type) in
   let expr = read_module_type env parent container incl.incl_mod in
-  let umty = Odoc_model.Lang.umty_of_mty expr in 
+  let umty = Odoc_model.Lang.umty_of_mty expr in
   let expansion = { content; shadowed; } in
   match umty with
   | Some uexpr ->

src/loader/doc_attr.ml

@@ -133,6 +133,8 @@ let attached internal_tags parent attrs =
               Odoc_parser.parse_comment ~location:(pad_loc loc) ~text:str
               |> Error.raise_parser_warnings
             in
+            let Odoc_parser.Ast.{front_matter;content=ast_docs} = ast_docs in
+            (match front_matter with None -> () | Some _ -> assert false );
             loop (List.rev_append ast_docs acc_docs) acc_alerts rest
         | Some (`Alert (name, p, loc)) ->
             let elt = mk_alert_payload ~loc name p in
@@ -141,7 +143,8 @@ let attached internal_tags parent attrs =
     | [] -> (List.rev acc_docs, List.rev acc_alerts)
   in
   let ast_docs, alerts = loop [] [] attrs in
-  ast_to_comment ~internal_tags parent ast_docs alerts
+  let ast_docs = {Odoc_parser.Ast.content=ast_docs; front_matter=None} in
+  let d,_frontmatter,a = ast_to_comment ~internal_tags parent ast_docs alerts in d,a
 
 let attached_no_tag parent attrs =
   let x, () = attached Semantics.Expect_none parent attrs in
@@ -161,19 +164,20 @@ let read_string_comment internal_tags parent loc str =
   read_string ~tags_allowed:true internal_tags parent (pad_loc loc) str
 
 let page parent loc str =
-  let doc, () =
+  let doc, frontmatter, () =
     read_string ~tags_allowed:false Odoc_model.Semantics.Expect_none parent loc.Location.loc_start
       str
   in
-  `Docs doc
+  `Docs (doc,frontmatter)
 
 let standalone parent (attr : Parsetree.attribute) :
     Odoc_model.Comment.docs_or_stop option =
   match parse_attribute attr with
   | Some (`Stop _loc) -> Some `Stop
   | Some (`Text (str, loc)) ->
-      let doc, () = read_string_comment Semantics.Expect_none parent loc str in
-      Some (`Docs doc)
+      (* TODO : Here we need an error if the frontmatter is not empty *)
+      let doc, _frontmatter, () = read_string_comment Semantics.Expect_none parent loc str in
+      Some (`Docs (doc))
   | Some (`Doc _) -> None
   | Some (`Alert (name, _, attr_loc)) ->
       let w =
@@ -246,11 +250,11 @@ let extract_top_comment internal_tags ~classify parent items =
         | `Skip ->
             let items, ast_docs, alerts = extract tl in
             (hd :: items, ast_docs, alerts)
-        | `Return -> (items, [], []))
-    | [] -> ([], [], [])
+        | `Return -> (items, Odoc_parser.Ast.empty, []))
+    | [] -> ([], Odoc_parser.Ast.empty, [])
   in
   let items, ast_docs, alerts = extract items in
-  let docs, tags =
+  let docs, _frontmatter, tags =
     ast_to_comment ~internal_tags
       (parent : Paths.Identifier.Signature.t :> Paths.Identifier.LabelParent.t)
       ast_docs alerts
@@ -259,7 +263,7 @@ let extract_top_comment internal_tags ~classify parent items =
 
 let extract_top_comment_class items =
   match items with
-  | Lang.ClassSignature.Comment (`Docs doc) :: tl -> (tl, split_docs doc)
+  | Lang.ClassSignature.Comment (`Docs (doc)) :: tl -> (tl, split_docs doc)
   | _ -> items, (empty,empty)
 
 let rec conv_canonical_module : Odoc_model.Reference.path -> Paths.Path.Module.t = function

src/loader/doc_attr.mli

@@ -37,7 +37,7 @@ val page :
   Paths.Identifier.LabelParent.t ->
   Location.t ->
   string ->
-  Odoc_model.Comment.docs_or_stop
+  Odoc_model.Comment.docs_and_frontmatter_or_stop
 (** The parent identifier is used to define labels in the given string (i.e.
     for things like [{1:some_section Some title}]) and the location is used for
     error messages.

src/loader/odoc_loader.mli

@@ -11,7 +11,7 @@ val read_string :
   Paths.Identifier.LabelParent.t ->
   string ->
   string ->
-  (Comment.docs_or_stop, Error.t) result Error.with_warnings
+  (Comment.docs_and_frontmatter_or_stop, Error.t) result Error.with_warnings
 
 val read_cmti :
   make_root:make_root ->

src/model/comment.ml

@@ -117,6 +117,8 @@ type docs = block_element with_location list
 
 type docs_or_stop = [ `Docs of docs | `Stop ]
 
+type docs_and_frontmatter_or_stop = [ `Docs of docs * Frontmatter.t | `Stop ]
+
 (** The synopsis is the first element of a comment if it is a paragraph.
     Otherwise, there is no synopsis. *)
 let synopsis = function
@@ -145,15 +147,3 @@ let find_zero_heading docs : link_content option =
           Some (link_content_of_inline_elements h_content)
       | _ -> None)
     docs
-
-let extract_frontmatter docs : _ =
-  let fm, rev_content =
-    List.fold_left
-      (fun (fm_acc, content_acc) doc ->
-        match doc.Location_.value with
-        | `Code_block (Some "meta", content, None) ->
-            (Frontmatter.parse content, content_acc)
-        | _ -> (fm_acc, doc :: content_acc))
-      (Frontmatter.empty, []) docs
-  in
-  (fm, List.rev rev_content)

src/model/frontmatter.ml

@@ -46,3 +46,88 @@ let parse s =
            Location_.same s v)
   in
   List.fold_left apply empty entries
+
+module Sexp_pattern = struct
+  open Sexplib
+  open Sexp.Annotated
+
+  let point ({ line; col; offset = _ } : pos) : Location_.point =
+    { line; column = col }
+
+  let span ~file { start_pos; end_pos } =
+    Location_.{ file; start = point start_pos; end_ = point end_pos }
+
+  let span_of_sexp ~file sexp =
+    match sexp with
+    | List (range, _, _) -> span ~file range
+    | Atom (range, _) -> span ~file range
+
+  let ( let* ) = Result.bind
+
+  let str expected f Location_.{ value = real; location } =
+    if expected = real then f ()
+    else Error (Error.make "Expected %S got %S" expected real location)
+
+  (* let ( ||| ) pat1 pat2 sexp =
+     match pat1 sexp with Error _msg -> pat2 sexp | Ok v -> Ok v *)
+
+  let atom ~file f sexp =
+    match sexp with
+    | Atom (range, Sexp.Atom str) ->
+        let span = span ~file range in
+        f (Location_.at span str)
+    | _ -> Error (Error.make "Expected list" (span_of_sexp ~file sexp))
+
+  let list ~file f sexp =
+    match sexp with
+    | List (range, li, _) ->
+        let span = span ~file range in
+        f (Location_.at span li)
+    | _ -> Error (Error.make "Expected list" (span_of_sexp ~file sexp))
+
+  let rec result_list_map f li =
+    match li with
+    | [] -> Ok []
+    | elt :: li ->
+        let* elt = f elt in
+        let* li = result_list_map f li in
+        Ok (elt :: li)
+
+  let accept = Result.ok
+
+  let accept_map f a = Result.ok (f a)
+end
+
+(*
+(children (a b c d))
+*)
+
+let of_ast_frontmatter frontmatter =
+  match frontmatter with
+  | None -> Ok empty
+  | Some { Odoc_parser.Ast.sexp; filename = file } ->
+      let open Sexp_pattern in
+      list ~file
+        (function
+          | { value = [ sexp1; sexp2 ]; location } ->
+              let* () = atom ~file (str "children" accept) sexp1 in
+              let* children =
+                list ~file
+                  (fun { value = li; location = _ } ->
+                    result_list_map
+                      (atom ~file
+                         (accept_map (fun Location_.{ value = str; location } ->
+                              Location_.at location
+                                (if str.[String.length str - 1] = '/' then
+                                   Dir
+                                     (String.sub str 0 (String.length str - 1))
+                                 else Page str))))
+                      li)
+                  sexp2
+              in
+              Ok { children_order = Some (Location_.at location children) }
+          | _ ->
+              Error
+                (Error.make "Expected two elements in list"
+                   (span_of_sexp ~file sexp)))
+        sexp

src/model/frontmatter.mli

@@ -7,3 +7,6 @@ type t = { children_order : children_order option }
 val empty : t
 
 val parse : string Location_.with_location -> t
+
+val of_ast_frontmatter :
+  Odoc_parser.Ast.frontmatter option -> (t, Error.t) result

src/model/semantics.ml

@@ -561,12 +561,22 @@ let append_alerts_to_comment alerts
 let ast_to_comment ~internal_tags ~sections_allowed ~tags_allowed
     ~parent_of_sections ast alerts =
   Error.catch_warnings (fun () ->
+      let front_matter = ast.Ast.front_matter in
+      let front_matter = Frontmatter.of_ast_frontmatter front_matter in
+      let front_matter =
+        match front_matter with
+        | Error err ->
+            Error.raise_warning err;
+            Frontmatter.empty
+        | Ok front_matter -> front_matter
+      in
+      let ast = ast.content in
       let status = { sections_allowed; tags_allowed; parent_of_sections } in
       let ast, tags = strip_internal_tags ast in
       let elts =
         top_level_block_elements status ast |> append_alerts_to_comment alerts
       in
-      (elts, handle_internal_tags tags internal_tags))
+      (elts, front_matter, handle_internal_tags tags internal_tags))
 
 let parse_comment ~internal_tags ~sections_allowed ~tags_allowed
     ~containing_definition ~location ~text =

src/model/semantics.mli

@@ -17,7 +17,7 @@ val ast_to_comment :
   parent_of_sections:Paths.Identifier.LabelParent.t ->
   Odoc_parser.Ast.t ->
   alerts ->
-  (Comment.docs * 'tags) Error.with_warnings
+  (Comment.docs * Frontmatter.t * 'tags) Error.with_warnings
 
 val parse_comment :
   internal_tags:'tags handle_internal_tags ->
@@ -26,6 +26,6 @@ val parse_comment :
   containing_definition:Paths.Identifier.LabelParent.t ->
   location:Lexing.position ->
   text:string ->
-  (Comment.docs * 'tags) Error.with_warnings
+  (Comment.docs * Frontmatter.t * 'tags) Error.with_warnings
 
 val parse_reference : string -> Paths.Reference.t Error.with_errors_and_warnings

src/odoc/compile.ml

@@ -245,9 +245,8 @@ let mld ~parent_id ~parents_children ~output ~children ~warnings_options input =
      | None -> Ok (Paths.Identifier.Mk.page (parent_id, page_name)))
      >>= fun id -> Ok (id :> Paths.Identifier.Page.t))
   >>= fun name ->
-  let resolve content =
+  let resolve content frontmatter =
     let zero_heading = Comment.find_zero_heading content in
-    let frontmatter, content = Comment.extract_frontmatter content in
     if (not (is_index_page name)) && has_children_order frontmatter then
       Error.raise_warning
         (Error.filename_only
@@ -273,8 +272,8 @@ let mld ~parent_id ~parents_children ~output ~children ~warnings_options input =
   Odoc_loader.read_string (name :> Paths.Identifier.LabelParent.t) input_s str
   |> Error.raise_errors_and_warnings
   |> function
-  | `Stop -> resolve [] (* TODO: Error? *)
-  | `Docs content -> resolve content
+  | `Stop -> resolve [] Frontmatter.empty (* TODO: Error? *)
+  | `Docs (content, frontmatter) -> resolve content frontmatter
 
 let handle_file_ext ext =
   match ext with

src/odoc/html_fragment.ml

@@ -9,9 +9,8 @@ let from_mld ~xref_base_uri ~resolver ~output ~warnings_options input =
   in
   let input_s = Fs.File.to_string input in
   let digest = Digest.file input_s in
-  let to_html content =
+  let to_html content frontmatter =
     (* This is a mess. *)
-    let frontmatter, content = Odoc_model.Comment.extract_frontmatter content in
     let root =
       let file =
         Odoc_model.Root.Odoc_file.create_page page_name None frontmatter
@@ -53,7 +52,7 @@ let from_mld ~xref_base_uri ~resolver ~output ~warnings_options input =
       Odoc_loader.read_string id input_s str
       |> Odoc_model.Error.handle_errors_and_warnings ~warnings_options
       >>= function
-      | `Docs content -> to_html content
-      | `Stop -> to_html [])
+      | `Docs (content, frontmatter) -> to_html content frontmatter
+      | `Stop -> to_html [] Odoc_model.Frontmatter.empty)
 
 (* TODO: Error? *)

src/parser/ast.ml

@@ -97,4 +97,10 @@ type heading = int * string option * inline_element with_location list
 type block_element =
   [ nestable_block_element | `Heading of heading | `Tag of tag ]
 
-type t = block_element with_location list
+type body = block_element with_location list
+
+type frontmatter = { sexp : Sexplib.Sexp.Annotated.t; filename : string }
+
+type t = { front_matter : frontmatter option; content : body }
+
+let empty = { front_matter = None; content = [] }

src/parser/dune

@@ -1,4 +1,4 @@
-(ocamllex lexer)
+(ocamllex lexer frontmatter_lexer)
 
 (library
  (name odoc_parser)
@@ -9,4 +9,4 @@
   (backend bisect_ppx))
  (flags
   (:standard -w -50))
- (libraries astring result camlp-streams))
+ (libraries astring result camlp-streams sexplib))

src/parser/frontmatter_lexer.mll

@@ -0,0 +1,10 @@
+{
+type token = ()
+}
+
+
+rule parser buffer =
+parse
+| "\n---" { Some (Buffer.contents buffer) }
+| eof { None}
+| _ {Buffer.add_string buffer (Lexing.lexeme lexbuf); parser buffer lexbuf}

src/parser/loc.ml

@@ -8,6 +8,9 @@ let value { value; _ } = value
 let map f annotated = { annotated with value = f annotated.value }
 let same annotated value = { annotated with value }
 
+let point_of_position Lexing.{ pos_fname = _; pos_lnum; pos_bol; pos_cnum } =
+  { line = pos_lnum; column = pos_cnum - pos_bol }
+
 let span spans =
   match spans with
   | [] ->

src/parser/loc.mli

@@ -47,3 +47,5 @@ val same : _ with_location -> 'b -> 'b with_location
 val spans_multiple_lines : _ with_location -> bool
 (** [spans_multiple_lines x] checks to see whether [x] is located
     on a single line or whether it covers more than one. *)
+
+val point_of_position : Lexing.position -> point