Skip to content

Commit

Permalink
fix compatibility
Browse files Browse the repository at this point in the history
Signed-off-by: Paul-Elliot <[email protected]>
  • Loading branch information
panglesd committed Jul 13, 2023
1 parent 4ded6db commit 5c158d1
Show file tree
Hide file tree
Showing 6 changed files with 43 additions and 19 deletions.
2 changes: 1 addition & 1 deletion src/document/generator.ml
Original file line number Diff line number Diff line change
Expand Up @@ -1763,7 +1763,7 @@ module Make (Syntax : SYNTAX) = struct
| None -> None
in
let search_assets =
List.filter_map
Utils.filter_map
(function
| `Resolved (`Identifier id) ->
Some Url.(from_path @@ Path.from_identifier id)
Expand Down
8 changes: 8 additions & 0 deletions src/document/utils.ml
Original file line number Diff line number Diff line change
@@ -1,5 +1,13 @@
let option_of_result = function Result.Ok x -> Some x | Result.Error _ -> None

let filter_map f =
let rec aux accu = function
| [] -> List.rev accu
| x :: l -> (
match f x with None -> aux accu l | Some v -> aux (v :: accu) l)
in
aux []

let rec flatmap ?sep ~f = function
| [] -> []
| [ x ] -> f x
Expand Down
1 change: 1 addition & 0 deletions src/document/utils.mli
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
val filter_map : ('a -> 'b option) -> 'a list -> 'b list
val option_of_result : ('a, 'b) Result.result -> 'a option
val flatmap : ?sep:'a list -> f:('b -> 'a list) -> 'b list -> 'a list
val skip_until : p:('a -> bool) -> 'a list -> 'a list
Expand Down
4 changes: 3 additions & 1 deletion src/odoc/indexing.ml
Original file line number Diff line number Diff line change
@@ -1,9 +1,11 @@
open Odoc_search
open Or_error

let map_result f = function Ok v -> Ok (f v) | Error _ as e -> e

let handle_file file ~unit ~page =
Odoc_file.load file
|> Result.map @@ fun unit' ->
|> map_result @@ fun unit' ->
match unit' with
| { Odoc_file.content = Unit_content (unit', _); _ } when not unit'.hidden
->
Expand Down
18 changes: 14 additions & 4 deletions src/search/entry.ml
Original file line number Diff line number Diff line change
@@ -1,6 +1,15 @@
open Odoc_model.Lang
open Odoc_model.Paths

let list_concat_map f l =
let rec aux f acc = function
| [] -> List.rev acc
| x :: l ->
let xs = f x in
aux f (List.rev_append xs acc) l
in
aux f [] l

type type_decl_entry = {
canonical : Path.Type.t option;
equation : TypeDecl.Equation.t;
Expand Down Expand Up @@ -118,14 +127,14 @@ let entry_of_field id_parent params (field : TypeDecl.Field.t) =
entry ~id:field.id ~doc:field.doc ~kind

let rec entries_of_docs id (d : Odoc_model.Comment.docs) =
List.concat_map (entries_of_doc id) d
list_concat_map (entries_of_doc id) d

and entries_of_doc id d =
match d.value with
| `Paragraph _ -> [ entry ~id ~doc:[ d ] ~kind:(Doc Paragraph) ]
| `Tag _ -> []
| `List (_, ds) ->
List.concat_map (entries_of_docs id) (ds :> Odoc_model.Comment.docs list)
list_concat_map (entries_of_docs id) (ds :> Odoc_model.Comment.docs list)
| `Heading (_, lbl, _) -> [ entry ~id:lbl ~doc:[ d ] ~kind:(Doc Heading) ]
| `Modules _ -> []
| `Code_block (_, _, o) ->
Expand Down Expand Up @@ -171,8 +180,9 @@ let entries_of_item id (x : Odoc_model.Fold.item) =
[ entry ~id:v.id ~doc:v.doc ~kind ]
| Exception exc ->
let res =
Option.value exc.res
~default:(TypeExpr.Constr (Odoc_model.Predefined.exn_path, []))
match exc.res with
| None -> TypeExpr.Constr (Odoc_model.Predefined.exn_path, [])
| Some x -> x
in
let kind = Exception { args = exc.args; res } in
[ entry ~id:exc.id ~doc:exc.doc ~kind ]
Expand Down
29 changes: 16 additions & 13 deletions src/search/generator.ml
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,8 @@ open Odoc_model
open Lang
open Printf

let map_option f = function Some x -> Some (f x) | None -> None

let type_from_path : Paths.Path.Type.t -> string =
fun path ->
match path with
Expand Down Expand Up @@ -79,19 +81,19 @@ let display_constructor_args args =
| _ :: _ :: _ -> Some TypeExpr.(Tuple args)
| [ arg ] -> Some arg
| _ -> None)
|> Option.map type_expr
|> map_option type_expr
| TypeDecl.Constructor.Record fields -> Some (Render.text_of_record fields)

let constructor_rhs ~args ~res =
let args = display_constructor_args args in
let res = Option.map type_expr res in
let res = map_option type_expr res in
match (args, res) with
| None, None -> ""
| None, Some res -> " : " ^ res
| Some args, None -> " of " ^ args
| Some args, Some res -> " : " ^ args ^ " -> " ^ res

let field_rhs Entry.{ mutable_ = _; type_; parent_type = _ } =
let field_rhs ({ mutable_ = _; type_; parent_type = _ } : Entry.field_entry) =
" : " ^ type_expr type_

let typedecl_params ?(delim = `parens) params =
Expand Down Expand Up @@ -121,7 +123,7 @@ let typedecl_params ?(delim = `parens) params =
let type_decl_constraint (typ, typ') =
"constraint" ^ " " ^ type_expr typ ^ " = " ^ type_expr typ'

let typedecl_params_of_entry Entry.{ kind; _ } =
let typedecl_params_of_entry ({ kind; _ } : Entry.t) =
match kind with
| Entry.TypeDecl { canonical = _; equation; representation = _ } ->
typedecl_params equation.params
Expand All @@ -139,17 +141,17 @@ let typedecl_repr ~private_ (repr : TypeDecl.Representation.t) =
| Extensible -> ".."
| Variant constructors ->
constructors
|> List.map (fun TypeDecl.Constructor.{ id; args; res; _ } ->
|> List.map (fun ({ id; args; res; _ } : TypeDecl.Constructor.t) ->
constructor ~id ~args ~res)
|> String.concat " | "
| Record record -> Render.text_of_record record

let typedecl_rhs Entry.{ equation; representation; _ } =
let TypeDecl.Equation.{ private_; manifest; constraints; _ } = equation in
let typedecl_rhs ({ equation; representation; _ } : Entry.type_decl_entry) =
let ({ private_; manifest; constraints; _ } : TypeDecl.Equation.t) =
equation
in
let repr =
representation
|> Option.map (typedecl_repr ~private_)
|> Option.value ~default:""
match representation with Some r -> typedecl_repr ~private_ r | None -> ""
in
let manifest =
match manifest with None -> "" | Some typ -> " = " ^ type_expr typ
Expand All @@ -162,7 +164,8 @@ let typedecl_rhs Entry.{ equation; representation; _ } =
in
match repr ^ manifest ^ constraints with "" -> None | r -> Some r

let constructor_rhs Entry.{ args; res } = constructor_rhs ~args ~res:(Some res)
let constructor_rhs ({ args; res } : Entry.constructor_entry) =
constructor_rhs ~args ~res:(Some res)

(** Kinds *)

Expand Down Expand Up @@ -264,12 +267,12 @@ let html_of_doc doc =
let html_string_of_doc doc =
doc |> html_of_doc |> Format.asprintf "%a" (Html.pp_elt ())
let html_of_entry (entry : Entry.t) =
let Entry.{ id; doc; kind } = entry in
let ({ id; doc; kind } : Entry.t) = entry in
let rhs = rhs_of_kind kind in
let prefix_name, name = title_of_id id in
let doc = html_string_of_doc doc in
let kind = string_of_kind kind in
let typedecl_params = typedecl_params_of_entry entry in
html_of_strings ~kind ~prefix_name ~name ~rhs ~doc ~typedecl_params

let with_html entry = Entry.{ entry; html = html_of_entry entry }
let with_html entry : Entry.with_html = { entry; html = html_of_entry entry }

0 comments on commit 5c158d1

Please sign in to comment.