diff --git a/.ocamlformat b/.ocamlformat index 17e03264..1db190a1 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,17 +1,9 @@ -version = 0.25.1 +version = 0.26.1 +profile = janestreet let-binding-spacing = compact sequence-style = separator doc-comments = after-when-possible exp-grouping = preserve break-cases = toplevel -break-separators = before cases-exp-indent = 4 cases-matching-exp-indent = normal -if-then-else = keyword-first -parens-tuple = multi-line-only -type-decl = sparse -field-space = loose -space-around-arrays = true -space-around-lists = true -space-around-records = true -dock-collection-brackets = false diff --git a/cli/main.ml b/cli/main.ml index d6e78405..7ce46b3d 100644 --- a/cli/main.ml +++ b/cli/main.ml @@ -20,22 +20,17 @@ let string_of_kind = | Field _ -> "field" | Val _ -> "val" -let print_result ~print_cost ~no_rhs - Db.Entry. - { name - ; rhs - ; url = _ - ; kind - ; cost - ; doc_html = _ - ; pkg = _ - ; is_from_module_type = _ - } = +let print_result + ~print_cost + ~no_rhs + Db.Entry. + { name; rhs; url = _; kind; cost; doc_html = _; pkg = _; is_from_module_type = _ } + = let cost = if print_cost then string_of_int cost ^ " " else "" in let typedecl_params = (match kind with - | Db.Entry.Kind.TypeDecl args -> args - | _ -> None) + | Db.Entry.Kind.TypeDecl args -> args + | _ -> None) |> Option.map (fun str -> str ^ " ") |> Option.value ~default:"" in @@ -54,31 +49,30 @@ let search ~print_cost ~static_sort ~limit ~db ~no_rhs ~pretty_query query = match Query.(search ~shards:db ~dynamic_sort:(not static_sort) query) with | [] -> print_endline "[No results]" | _ :: _ as results -> - List.iter (print_result ~print_cost ~no_rhs) results ; - flush stdout + List.iter (print_result ~print_cost ~no_rhs) results ; + flush stdout let rec search_loop ~print_cost ~no_rhs ~pretty_query ~static_sort ~limit ~db = match In_channel.input_line stdin with | Some query -> - search ~print_cost ~static_sort ~limit ~db ~no_rhs ~pretty_query query ; - search_loop ~print_cost ~no_rhs ~pretty_query ~static_sort ~limit ~db + search ~print_cost ~static_sort ~limit ~db ~no_rhs ~pretty_query query ; + search_loop ~print_cost ~no_rhs ~pretty_query ~static_sort ~limit ~db | None -> print_endline "[Search session ended]" let main db query print_cost no_rhs static_sort limit pretty_query = match db with | None -> - output_string stderr - "No database provided. Provide one by exporting the SHERLODOC_DB \ - variable, or using the --db option\n" ; - exit 1 - | Some db -> ( - let db = Storage_marshal.load db in - match query with - | None -> - search_loop ~print_cost ~no_rhs ~pretty_query ~static_sort ~limit ~db - | Some query -> - search ~print_cost ~no_rhs ~pretty_query ~static_sort ~limit ~db query - ) + output_string + stderr + "No database provided. Provide one by exporting the SHERLODOC_DB variable, or \ + using the --db option\n" ; + exit 1 + | Some db -> + let db = Storage_marshal.load db in + (match query with + | None -> search_loop ~print_cost ~no_rhs ~pretty_query ~static_sort ~limit ~db + | Some query -> + search ~print_cost ~no_rhs ~pretty_query ~static_sort ~limit ~db query) open Cmdliner @@ -94,9 +88,7 @@ let limit = Arg.(value & opt int 50 & info [ "limit"; "n" ] ~docv:"N" ~doc) let query = - let doc = - "The query. If absent, sherlodoc will read queries in the standard input." - in + let doc = "The query. If absent, sherlodoc will read queries in the standard input." in Arg.(value & pos 0 (some string) None & info [] ~docv:"QUERY" ~doc) let print_cost = @@ -121,7 +113,13 @@ let pretty_query = let main = Term.( - const main $ db_filename $ query $ print_cost $ no_rhs $ static_sort $ limit + const main + $ db_filename + $ query + $ print_cost + $ no_rhs + $ static_sort + $ limit $ pretty_query) let cmd = diff --git a/db/db.ml b/db/db.ml index cb8400a2..a9d39eb4 100644 --- a/db/db.ml +++ b/db/db.ml @@ -30,5 +30,4 @@ let store db name elt ~count = let store_type_polarities db elt polarities = List.iter (fun (word, count) -> store db ~count word elt) polarities -let store_word db word elt = - Suffix_tree.With_elts.add_suffixes db.writer_names word elt +let store_word db word elt = Suffix_tree.With_elts.add_suffixes db.writer_names word elt diff --git a/db/db.mli b/db/db.mli index 0f6bfaf7..7f2ea301 100644 --- a/db/db.mli +++ b/db/db.mli @@ -11,16 +11,15 @@ type t = Db_typedef.t = } (** The type of a search database. -[db_names] is for text-based part of the query and [db_types] for the -type-based part. + [db_names] is for text-based part of the query and [db_types] for the + type-based part. -[db_types] has [Entry.t array Int_map.t] ([Occ.t]) as a payload because we want -the query [blabla : int -> int -> _] to return only entries that take at -least two ints as arguments, an entry of type [int -> string] is invalid. -The [Int_map.t] maps a number of occurences to a set of entries. See {!Occ}. -[db_types] still is a suffix tree, so you can search in it only for text. The -way we transform types into searchable text is in {!Type_polarity}. -*) + [db_types] has [Entry.t array Int_map.t] ([Occ.t]) as a payload because we want + the query [blabla : int -> int -> _] to return only entries that take at + least two ints as arguments, an entry of type [int -> string] is invalid. + The [Int_map.t] maps a number of occurences to a set of entries. See {!Occ}. + [db_types] still is a suffix tree, so you can search in it only for text. The + way we transform types into searchable text is in {!Type_polarity}. *) type writer (** The type that builds a database. You can use it to add things to it, but diff --git a/db/entry.ml b/db/entry.ml index 9da9340d..b0252eab 100644 --- a/db/entry.ml +++ b/db/entry.ml @@ -60,27 +60,27 @@ module T = struct begin match Int.compare (String.length a.name) (String.length b.name) with | 0 -> begin - match String.compare a.name b.name with + match String.compare a.name b.name with + | 0 -> begin + match Option.compare compare_pkg a.pkg b.pkg with | 0 -> begin - match Option.compare compare_pkg a.pkg b.pkg with - | 0 -> begin - match Stdlib.compare a.kind b.kind with - | 0 -> Stdlib.compare a.url b.url - | c -> c - end - | c -> c - end + match Stdlib.compare a.kind b.kind with + | 0 -> Stdlib.compare a.url b.url + | c -> c + end | c -> c end + | c -> c + end | c -> c end let compare a b = if a == b then 0 - else + else ( let cmp = Int.compare a.cost b.cost in - if cmp = 0 then structural_compare a b else cmp + if cmp = 0 then structural_compare a b else cmp) end include T @@ -108,19 +108,18 @@ let pkg_link { pkg; _ } = match pkg with | None -> None | Some { name; version } -> - Some (Printf.sprintf "https://ocaml.org/p/%s/%s" name version) + Some (Printf.sprintf "https://ocaml.org/p/%s/%s" name version) let link t = match pkg_link t with | None -> None | Some pkg_link -> - let name, path = - match List.rev (String.split_on_char '.' t.name) with - | name :: path -> name, String.concat "/" (List.rev path) - | _ -> "", "" - in - Some (pkg_link ^ "/doc/" ^ path ^ "/index.html#val-" ^ name) - -let v ~name ~kind ~cost ~rhs ~doc_html ~url ~is_from_module_type ?(pkg = None) - () = + let name, path = + match List.rev (String.split_on_char '.' t.name) with + | name :: path -> name, String.concat "/" (List.rev path) + | _ -> "", "" + in + Some (pkg_link ^ "/doc/" ^ path ^ "/index.html#val-" ^ name) + +let v ~name ~kind ~cost ~rhs ~doc_html ~url ~is_from_module_type ?(pkg = None) () = { name; kind; url; cost; doc_html; pkg; rhs; is_from_module_type } diff --git a/db/entry.mli b/db/entry.mli index 38fdaa4a..c87777b3 100644 --- a/db/entry.mli +++ b/db/entry.mli @@ -69,8 +69,8 @@ end val pkg_link : t -> string option val link : t -> string option -val v : - name:string +val v + : name:string -> kind:Kind.t -> cost:int -> rhs:string option diff --git a/db/occ.ml b/db/occ.ml index bb9db288..70932fca 100644 --- a/db/occ.ml +++ b/db/occ.ml @@ -9,13 +9,13 @@ let is_empty = Int_map.is_empty let equal_elt (a_count, a) (b_count, b) = a_count = b_count && Entry.equal a b (* -let of_list li = - List.fold_left - (fun acc (count, elt) -> - let elts = try Int_map.find count acc with Not_found -> [] in - Int_map.add count (elt :: elts) acc) - Int_map.empty li - |> Int_map.map Entry.Array.of_list + let of_list li = + List.fold_left + (fun acc (count, elt) -> + let elts = try Int_map.find count acc with Not_found -> [] in + Int_map.add count (elt :: elts) acc) + Int_map.empty li + |> Int_map.map Entry.Array.of_list *) let of_list li = @@ -24,5 +24,6 @@ let of_list li = match Int_map.find_opt count acc with | None -> Int_map.add count (Entry.Set.singleton elt) acc | Some set -> Int_map.add count (Entry.Set.add elt set) acc) - Int_map.empty li + Int_map.empty + li |> Int_map.map (fun set -> set |> Entry.Set.to_seq |> Array.of_seq) diff --git a/db/occ.mli b/db/occ.mli index 7b4f2d0f..512f1b6e 100644 --- a/db/occ.mli +++ b/db/occ.mli @@ -1,60 +1,57 @@ (** [Occ] stands for occurences. It associate sets of elements to the number of - time members of the set occurs. - -The list [[a, a, b, b, c]] would correspond to [[(2, [a; b]); (1, [c]) ]]. It is -used or type search : you want to be able to return every function that takes -two ints as an argument. Without this datastrucure, we would only be able to -search for functions that take ints, without specifying the amount. - -This datastructure is used at the leafs of the suffix tree : so when doing type -search, we first perform a type search ignoring occurences, and afterwards -filter the results according to them. - -I will give an example bellow, it is probably better to read {!Type_polarities} -first to understand it completely. - -If you have the following entries : - -{[ -val a : string -> int -val b : string -> string -> int -val c : string -> string -> (int * int) -val d : (string * string) -> float -> (int * int) - -]} - -Their polarities will be : - -{[ -val a : {(-string, 1); (+int, 1)} -val b : {(-string, 2); (+int, 1)} -val c : {(-string, 2); (+int, 2)} -val d : {(-string, 2); (+int, 2); (-float, 1)} -]} - -We can combine them into a database that will look like this : - -{[ -+int -> - { 1 -> {a; b} - 2 -> {c; d} - } --string -> - { 1 -> {a} - 2 -> {b; c; d} - } --float -> - { 1 -> {d} - } -]} - -If there is a query for type [string -> string -> (int * int)], the polarities -of the query are [(-string, 2)], [(+int, 2)]. - -The entries of [(-string, 2)] are [{b; c; d}], and the entries of [(+int, 2)] -are [{c; d}]. The intersection of the two is [{c; d}]. - -*) + time members of the set occurs. + + The list [[a, a, b, b, c]] would correspond to [[(2, [a; b]); (1, [c]) ]]. It is + used or type search : you want to be able to return every function that takes + two ints as an argument. Without this datastrucure, we would only be able to + search for functions that take ints, without specifying the amount. + + This datastructure is used at the leafs of the suffix tree : so when doing type + search, we first perform a type search ignoring occurences, and afterwards + filter the results according to them. + + I will give an example bellow, it is probably better to read {!Type_polarities} + first to understand it completely. + + If you have the following entries : + + {[ + val a : string -> int + val b : string -> string -> int + val c : string -> string -> int * int + val d : string * string -> float -> int * int + ]} + + Their polarities will be : + + {[ + val a : {(-string, 1); (+int, 1)} + val b : {(-string, 2); (+int, 1)} + val c : {(-string, 2); (+int, 2)} + val d : {(-string, 2); (+int, 2); (-float, 1)} + ]} + + We can combine them into a database that will look like this : + + {[ + +int -> + { 1 -> {a; b} + 2 -> {c; d} + } + -string -> + { 1 -> {a} + 2 -> {b; c; d} + } + -float -> + { 1 -> {d} + } + ]} + + If there is a query for type [string -> string -> (int * int)], the polarities + of the query are [(-string, 2)], [(+int, 2)]. + + The entries of [(-string, 2)] are [{b; c; d}], and the entries of [(+int, 2)] + are [{c; d}]. The intersection of the two is [{c; d}]. *) type t type elt = int * Entry.t diff --git a/db/suffix_tree.ml b/db/suffix_tree.ml index 6493e3b5..89a0b3a4 100644 --- a/db/suffix_tree.ml +++ b/db/suffix_tree.ml @@ -19,9 +19,7 @@ module Doc = struct | Terminal of 'a | Char of char - let get t i = - if i >= String.length t.text then Terminal t.uid else Char t.text.[i] - + let get t i = if i >= String.length t.text then Terminal t.uid else Char t.text.[i] let sub { text; _ } i = String.sub text i (String.length text - i) end @@ -30,11 +28,11 @@ module Buf = struct string twice, the second addition is not performed. *) module String_hashtbl = Hashtbl.Make (struct - type t = string + type t = string - let equal = String.equal - let hash = Hashtbl.hash - end) + let equal = String.equal + let hash = Hashtbl.hash + end) type t = { buffer : Buffer.t @@ -49,16 +47,17 @@ module Buf = struct match String_hashtbl.find_opt cache substr with | Some start -> start | None -> - let start = Buffer.length buffer in - Buffer.add_string buffer substr ; - let stop = Buffer.length buffer in - assert (stop - start = String.length substr) ; - for idx = 1 to String.length substr - 1 do - String_hashtbl.add cache - (String.sub substr idx (String.length substr - idx)) - (start + idx) - done ; - start + let start = Buffer.length buffer in + Buffer.add_string buffer substr ; + let stop = Buffer.length buffer in + assert (stop - start = String.length substr) ; + for idx = 1 to String.length substr - 1 do + String_hashtbl.add + cache + (String.sub substr idx (String.length substr - idx)) + (start + idx) + done ; + start end module Make (S : SET) = struct @@ -83,11 +82,11 @@ module Make (S : SET) = struct | _ -> false module Hashtbl = Hashtbl.Make (struct - type nonrec t = t + type nonrec t = t - let hash = hash - let equal = equal - end) + let hash = hash + let equal = equal + end) end module Char_map = Map.Make (Char) @@ -134,9 +133,9 @@ module Make (S : SET) = struct let rec go_lcp i j = if i >= String.length i_str || j >= j_stop then i - else + else ( let i_chr, j_chr = i_str.[i], Buf.get j_str j in - if i_chr <> j_chr then i else go_lcp (i + 1) (j + 1) + if i_chr <> j_chr then i else go_lcp (i + 1) (j + 1)) in let i' = go_lcp i j in i' - i @@ -145,12 +144,12 @@ module Make (S : SET) = struct let start = match prev_leaf with | None -> - let substr = Doc.sub doc (str_start - 1) in - let start = Buf.add buffer substr in - start + 1 + let substr = Doc.sub doc (str_start - 1) in + let start = Buf.add buffer substr in + start + 1 | Some (prev_leaf, _depth, _) -> - let doc_len = Doc.length doc in - prev_leaf.start + prev_leaf.len - (doc_len - str_start) + 1 + let doc_len = Doc.length doc in + prev_leaf.start + prev_leaf.len - (doc_len - str_start) + 1 in let len = Doc.length doc - str_start - 1 in assert (start > 0) ; @@ -164,12 +163,12 @@ module Make (S : SET) = struct let set_suffix_link ~prev ~depth node = match prev with | Some (prev, prev_depth) when depth = prev_depth -> - begin - match prev.suffix_link with - | None -> prev.suffix_link <- Some node - | Some node' -> assert (node == node') - end ; - None + begin + match prev.suffix_link with + | None -> prev.suffix_link <- Some node + | Some node' -> assert (node == node') + end ; + None | _ -> prev let add_document trie doc = @@ -182,12 +181,12 @@ module Make (S : SET) = struct match prev_leaf with | None -> () | Some (prev_leaf, prev_depth, _) -> - assert (prev_depth = depth) ; - begin - match prev_leaf.suffix_link with - | None -> prev_leaf.suffix_link <- Some node - | Some node' -> assert (node' == node) - end + assert (prev_depth = depth) ; + begin + match prev_leaf.suffix_link with + | None -> prev_leaf.suffix_link <- Some node + | Some node' -> assert (node' == node) + end end ; Some (node, depth - 1) end @@ -196,123 +195,113 @@ module Make (S : SET) = struct let prev = set_suffix_link ~prev ~depth node in if i >= Doc.length doc then assert (depth = 0) - else + else ( let chr = Doc.get doc i in let i, depth = i + 1, depth + 1 in match chr with | Terminal doc_uid -> - if not (Terminals.mem doc_uid node.terminals) - then begin - let hint = - Option.map - (fun (t, _, prev_terminals) -> prev_terminals, t.terminals) - prev_leaf - in - let prev_terminals = node.terminals in - node.terminals <- Terminals.add ~hint doc_uid node.terminals ; - let prev_leaf = - match set_leaf ~debug:"0" ~prev_leaf ~depth node with - | None -> None - | Some (t, depth) -> Some (t, depth, prev_terminals) - in - follow_suffix ~prev ~prev_leaf ~parent:node ~depth ~i - end - | Char chr -> begin - match Char_map.find chr node.children with - | child -> - assert (depth >= 0) ; - assert (i - depth >= 0) ; - assert (i < Doc.length doc) ; - let len = - lcp doc.Doc.text i trie.buffer child.start child.len - in - let i, depth = i + len, depth + len in - assert (i < Doc.length doc) ; - if len = child.len - then - if not (Char_map.is_empty child.children) - then go ~prev ~prev_leaf ~depth child i - else add_leaf ~prev_leaf ~node ~child ~depth ~i ~len - else begin - let new_child = split_at ~str:trie.buffer child len in - node.children <- Char_map.add chr new_child node.children ; - let prev = set_suffix_link ~prev ~depth new_child in - assert (prev = None) ; - add_leaf ~prev_leaf ~node ~child:new_child ~depth ~i ~len - end - | exception Not_found -> - let new_leaf = - make_leaf ~prev_leaf ~buffer:trie.buffer ~doc i - in - node.children <- Char_map.add chr new_leaf node.children ; - let prev_leaf = - set_leaf ~debug:"1" ~prev_leaf - ~depth:(depth + Doc.length doc - i) - new_leaf - in - let prev_leaf = - match prev_leaf with - | None -> None - | Some (t, depth) -> Some (t, depth, Terminals.empty) - in - follow_suffix ~prev ~prev_leaf ~parent:node ~depth ~i - end - and add_leaf ~prev_leaf ~node ~child ~depth ~i ~len = - match Doc.get doc i with - | Terminal doc_uid -> - if not (Terminals.mem doc_uid child.terminals) + if not (Terminals.mem doc_uid node.terminals) then begin let hint = Option.map (fun (t, _, prev_terminals) -> prev_terminals, t.terminals) prev_leaf in - let prev_terminals = child.terminals in - child.terminals <- Terminals.add ~hint doc_uid child.terminals ; + let prev_terminals = node.terminals in + node.terminals <- Terminals.add ~hint doc_uid node.terminals ; let prev_leaf = - match set_leaf ~debug:"2" ~prev_leaf ~depth:(depth + 1) child with + match set_leaf ~debug:"0" ~prev_leaf ~depth node with | None -> None | Some (t, depth) -> Some (t, depth, prev_terminals) in - assert (Doc.length doc - i = 1) ; - begin - match child.suffix_link with - | None -> - let i, depth = i - len, depth - len in - follow_suffix ~prev:None ~prev_leaf ~parent:node ~depth ~i - | Some next_child -> - let depth = depth - 1 in - go ~prev:None ~prev_leaf:None ~depth next_child i - end + follow_suffix ~prev ~prev_leaf ~parent:node ~depth ~i end - | Char new_chr -> - let new_leaf = - make_leaf ~prev_leaf ~buffer:trie.buffer ~doc (i + 1) - in - let prev_leaf = - set_leaf ~debug:"3" ~prev_leaf - ~depth:(depth + Doc.length doc - i) - new_leaf + | Char chr -> begin + match Char_map.find chr node.children with + | child -> + assert (depth >= 0) ; + assert (i - depth >= 0) ; + assert (i < Doc.length doc) ; + let len = lcp doc.Doc.text i trie.buffer child.start child.len in + let i, depth = i + len, depth + len in + assert (i < Doc.length doc) ; + if len = child.len + then + if not (Char_map.is_empty child.children) + then go ~prev ~prev_leaf ~depth child i + else add_leaf ~prev_leaf ~node ~child ~depth ~i ~len + else begin + let new_child = split_at ~str:trie.buffer child len in + node.children <- Char_map.add chr new_child node.children ; + let prev = set_suffix_link ~prev ~depth new_child in + assert (prev = None) ; + add_leaf ~prev_leaf ~node ~child:new_child ~depth ~i ~len + end + | exception Not_found -> + let new_leaf = make_leaf ~prev_leaf ~buffer:trie.buffer ~doc i in + node.children <- Char_map.add chr new_leaf node.children ; + let prev_leaf = + set_leaf ~debug:"1" ~prev_leaf ~depth:(depth + Doc.length doc - i) new_leaf + in + let prev_leaf = + match prev_leaf with + | None -> None + | Some (t, depth) -> Some (t, depth, Terminals.empty) + in + follow_suffix ~prev ~prev_leaf ~parent:node ~depth ~i + end) + and add_leaf ~prev_leaf ~node ~child ~depth ~i ~len = + match Doc.get doc i with + | Terminal doc_uid -> + if not (Terminals.mem doc_uid child.terminals) + then begin + let hint = + Option.map + (fun (t, _, prev_terminals) -> prev_terminals, t.terminals) + prev_leaf in + let prev_terminals = child.terminals in + child.terminals <- Terminals.add ~hint doc_uid child.terminals ; let prev_leaf = - match prev_leaf with + match set_leaf ~debug:"2" ~prev_leaf ~depth:(depth + 1) child with | None -> None - | Some (t, depth) -> Some (t, depth, Terminals.empty) + | Some (t, depth) -> Some (t, depth, prev_terminals) in - child.children <- Char_map.add new_chr new_leaf child.children ; - let prev = Some (child, depth - 1) in - let i, depth = i - len, depth - len in - follow_suffix ~prev ~prev_leaf ~parent:node ~depth ~i + assert (Doc.length doc - i = 1) ; + begin + match child.suffix_link with + | None -> + let i, depth = i - len, depth - len in + follow_suffix ~prev:None ~prev_leaf ~parent:node ~depth ~i + | Some next_child -> + let depth = depth - 1 in + go ~prev:None ~prev_leaf:None ~depth next_child i + end + end + | Char new_chr -> + let new_leaf = make_leaf ~prev_leaf ~buffer:trie.buffer ~doc (i + 1) in + let prev_leaf = + set_leaf ~debug:"3" ~prev_leaf ~depth:(depth + Doc.length doc - i) new_leaf + in + let prev_leaf = + match prev_leaf with + | None -> None + | Some (t, depth) -> Some (t, depth, Terminals.empty) + in + child.children <- Char_map.add new_chr new_leaf child.children ; + let prev = Some (child, depth - 1) in + let i, depth = i - len, depth - len in + follow_suffix ~prev ~prev_leaf ~parent:node ~depth ~i and follow_suffix ~prev ~prev_leaf ~parent ~depth ~i = match parent.suffix_link with | None -> begin - let i = i - depth + 1 in - go ~prev:None ~prev_leaf ~depth:0 root i - end + let i = i - depth + 1 in + go ~prev:None ~prev_leaf ~depth:0 root i + end | Some next -> - assert (depth >= 2) ; - assert (next != root) ; - go ~prev ~prev_leaf ~depth:(depth - 2) next (i - 1) + assert (depth >= 2) ; + assert (next != root) ; + go ~prev ~prev_leaf ~depth:(depth - 2) next (i - 1) in go ~prev:None ~prev_leaf:None ~depth:0 root 0 @@ -349,9 +338,9 @@ module Make (S : SET) = struct let rec go i = if i >= Array.length arr then raise Not_found - else + else ( let node = arr.(i) in - if chr = str.[node.start - 1] then node else go (i + 1) + if chr = str.[node.start - 1] then node else go (i + 1)) in go 0 @@ -360,9 +349,9 @@ module Make (S : SET) = struct let rec go_lcp i j = if i >= String.length i_str || j >= j_stop then i - else + else ( let i_chr, j_chr = i_str.[i], j_str.[j] in - if i_chr <> j_chr then i else go_lcp (i + 1) (j + 1) + if i_chr <> j_chr then i else go_lcp (i + 1) (j + 1)) in let i' = go_lcp i j in i' - i @@ -370,10 +359,10 @@ module Make (S : SET) = struct let rec find ~str node pattern i = if i >= String.length pattern then node - else + else ( let chr = pattern.[i] in let child = array_find ~str chr node.children in - find_lcp ~str child pattern (i + 1) + find_lcp ~str child pattern (i + 1)) and find_lcp ~str child pattern i = let n = lcp pattern i str child.start child.len in @@ -387,7 +376,9 @@ module Make (S : SET) = struct let child = find ~str:t.str t.t pattern 0 in { str = t.str; t = child } - let find t pattern = try Some (find t pattern) with Not_found -> None + let find t pattern = + try Some (find t pattern) with + | Not_found -> None let rec collapse acc t = let acc = if S.is_empty t.terminals then acc else t.terminals :: acc in @@ -396,7 +387,8 @@ module Make (S : SET) = struct let collapse t = collapse [] t.t let rec sets_tree ~union ~terminal ~union_of_array t = - union (terminal t.terminals) + union + (terminal t.terminals) (union_of_array (Array.map (sets_tree ~union ~terminal ~union_of_array) t.children)) @@ -405,30 +397,25 @@ module Make (S : SET) = struct end let export_terminals ~cache_term ts = - try Terminals.Hashtbl.find cache_term ts - with Not_found -> + try Terminals.Hashtbl.find cache_term ts with + | Not_found -> let result = Uid.make (), S.of_list ts in Terminals.Hashtbl.add cache_term ts result ; result let rec export ~cache ~cache_term node = - let terminals_uid, terminals = - export_terminals ~cache_term node.terminals - in + let terminals_uid, terminals = export_terminals ~cache_term node.terminals in let children = - Char_map.bindings - @@ Char_map.map (export ~cache ~cache_term) node.children + Char_map.bindings @@ Char_map.map (export ~cache ~cache_term) node.children in let children_uids = List.map (fun (chr, (uid, _)) -> chr, uid) children in let key = node.start, node.len, terminals_uid, children_uids in - try Hashtbl.find cache key - with Not_found -> + try Hashtbl.find cache key with + | Not_found -> let children = Array.of_list @@ List.map (fun (_, (_, child)) -> child) children in - let node = - { T.start = node.start; len = node.len; terminals; children } - in + let node = { T.start = node.start; len = node.len; terminals; children } in let result = Uid.make (), node in Hashtbl.add cache key result ; result diff --git a/db/suffix_tree.mli b/db/suffix_tree.mli index ca1cf54e..d5017bab 100644 --- a/db/suffix_tree.mli +++ b/db/suffix_tree.mli @@ -1,8 +1,8 @@ (** The suffix tree datastructure. This datastructure allows to efficiently - search for strings suffixes. + search for strings suffixes. -You need to provide a datastructure for the sets of elements at the leafs of the -tree. *) + You need to provide a datastructure for the sets of elements at the leafs of the + tree. *) module type SET = sig type t @@ -29,8 +29,8 @@ module Make (S : SET) : sig val find : reader -> string -> reader option val to_sets : reader -> S.t list - val sets_tree : - union:('a -> 'a -> 'a) + val sets_tree + : union:('a -> 'a -> 'a) -> terminal:(S.t -> 'a) -> union_of_array:('a array -> 'a) -> reader @@ -39,8 +39,8 @@ end module With_elts : module type of Make (Entry.Array) (** [With_elts] is a suffix tree with array of entries at the leafs. It is used - for the text-based part of the database. *) + for the text-based part of the database. *) module With_occ : module type of Make (Occ) (** [With_occ] is a suffix tree with occurence annotated arrays of entries at - the leafs. It is used for the type-based part of the database. *) + the leafs. It is used for the type-based part of the database. *) diff --git a/db/type_polarity.ml b/db/type_polarity.ml index 55a22717..7bfc307d 100644 --- a/db/type_polarity.ml +++ b/db/type_polarity.ml @@ -4,9 +4,13 @@ let regroup lst = String_map.bindings @@ List.fold_left (fun acc s -> - let count = try String_map.find s acc with Not_found -> 0 in + let count = + try String_map.find s acc with + | Not_found -> 0 + in String_map.add s (count + 1) acc) - String_map.empty lst + String_map.empty + lst module Sign = struct type t = @@ -22,8 +26,7 @@ module Sign = struct | Neg -> Pos end -let rev_concat lst = - List.fold_left (fun acc xs -> List.rev_append xs acc) [] lst +let rev_concat lst = List.fold_left (fun acc xs -> List.rev_append xs acc) [] lst let rec tails = function | [] -> [] @@ -37,34 +40,32 @@ let all_type_names name = let rec of_typ ~any_is_poly ~all_names ~prefix ~sgn = function | Poly _ -> [ Sign.to_string sgn :: "POLY" :: prefix ] | Any -> - if any_is_poly - then [ Sign.to_string sgn :: "POLY" :: prefix ] - else [ Sign.to_string sgn :: prefix ] + if any_is_poly + then [ Sign.to_string sgn :: "POLY" :: prefix ] + else [ Sign.to_string sgn :: prefix ] | Arrow (a, b) -> - List.rev_append - (of_typ ~any_is_poly ~all_names ~prefix ~sgn:(Sign.not sgn) a) - (of_typ ~any_is_poly ~all_names ~prefix ~sgn b) + List.rev_append + (of_typ ~any_is_poly ~all_names ~prefix ~sgn:(Sign.not sgn) a) + (of_typ ~any_is_poly ~all_names ~prefix ~sgn b) | Constr (name, args) -> - name - |> (if all_names then all_type_names else fun name -> [ name ]) - |> List.map (fun name -> - let prefix = Sign.to_string sgn :: name :: prefix in - begin - match args with - | [] -> [ prefix ] - | _ -> - rev_concat - @@ List.mapi - (fun i arg -> - let prefix = string_of_int i :: prefix in - of_typ ~any_is_poly ~all_names ~prefix ~sgn arg) - args - end) - |> rev_concat + name + |> (if all_names then all_type_names else fun name -> [ name ]) + |> List.map (fun name -> + let prefix = Sign.to_string sgn :: name :: prefix in + begin + match args with + | [] -> [ prefix ] + | _ -> + rev_concat + @@ List.mapi + (fun i arg -> + let prefix = string_of_int i :: prefix in + of_typ ~any_is_poly ~all_names ~prefix ~sgn arg) + args + end) + |> rev_concat | Tuple args -> - rev_concat - @@ List.map (of_typ ~any_is_poly ~all_names ~prefix ~sgn) - @@ args + rev_concat @@ List.map (of_typ ~any_is_poly ~all_names ~prefix ~sgn) @@ args | Unhandled -> [] let of_typ ~any_is_poly ~all_names t = diff --git a/db/type_polarity.mli b/db/type_polarity.mli index 3f46d9c9..e22c0058 100644 --- a/db/type_polarity.mli +++ b/db/type_polarity.mli @@ -61,28 +61,26 @@ type t = string * int {!Suffix_tree}. It is a solely text-based datastructure. Therefore, we need a text represention for the polarities. - The polarity [+t] is represented by ["+t"], and the polarity [-t] is - represented by ["-t"]. + The polarity [+t] is represented by ["+t"], and the polarity [-t] is + represented by ["-t"]. - The fact that the sign is in the front is important : ["+flo"] is a prefix of - ["+float"], but ["flo+"] is not a prefix nor a suffix of ["float+"]. This - allows to answer incomplete queries. + The fact that the sign is in the front is important : ["+flo"] is a prefix of + ["+float"], but ["flo+"] is not a prefix nor a suffix of ["float+"]. This + allows to answer incomplete queries. - The integer represents the occurences of the polarity, as explained in the - toplevel documentation of the module. -*) + The integer represents the occurences of the polarity, as explained in the + toplevel documentation of the module. *) val of_typ : any_is_poly:bool -> all_names:bool -> Typexpr.t -> t list (** [of_typ ~ignore_any ~all_names typ] is the list of polarised types corresponding to [typ]. - - If [any_is_poly] is true, the type [_] will be treated like a type variable - ['a], other it will be represented solely by its sign ("+" or "-"). + - If [any_is_poly] is true, the type [_] will be treated like a type variable + ['a], other it will be represented solely by its sign ("+" or "-"). - - If [all_names] is true, extra polarities are added for every "possible name" - of each type constructor. For instance the possible names of - [Stdlib.Int64.t] are ["t"], ["Int64.t"] and ["Stdlib.Int64.t"]. This allows - for the user to use any of the possible name. It is important to set this - when registering entries in the database, but you not need it when computing - the polarities of a query. - *) + - If [all_names] is true, extra polarities are added for every "possible name" + of each type constructor. For instance the possible names of + [Stdlib.Int64.t] are ["t"], ["Int64.t"] and ["Stdlib.Int64.t"]. This allows + for the user to use any of the possible name. It is important to set this + when registering entries in the database, but you not need it when computing + the polarities of a query. *) diff --git a/db/typexpr.ml b/db/typexpr.ml index e02c9a63..c9249e02 100644 --- a/db/typexpr.ml +++ b/db/typexpr.ml @@ -12,8 +12,8 @@ let cache t = match Hashtbl.find_opt table t with | Some t -> t | None -> - Hashtbl.add table t t ; - t + Hashtbl.add table t t ; + t let arrow a b = cache (Arrow (a, b)) let constr name args = cache (Constr (name, args)) diff --git a/index/index.ml b/index/index.ml index d1e6b281..508aeb3b 100644 --- a/index/index.ml +++ b/index/index.ml @@ -1,25 +1,23 @@ let index_file register filename = match Fpath.of_string filename with | Error (`Msg msg) -> Format.printf "FILE ERROR %s: %s@." filename msg - | Ok file -> ( - let open Odoc_model in - let page p = - let id = p.Lang.Page.name in - Fold.page ~f:(register (id :> Paths.Identifier.t)) () p - in - let unit u = - let id = u.Lang.Compilation_unit.id in - Fold.unit ~f:(register (id :> Paths.Identifier.t)) () u - in - match Odoc_odoc.Indexing.handle_file ~page ~unit file with - | Ok result -> result - | Error (`Msg msg) -> - Format.printf "Odoc warning or error %s: %s@." filename msg) + | Ok file -> + let open Odoc_model in + let page p = + let id = p.Lang.Page.name in + Fold.page ~f:(register (id :> Paths.Identifier.t)) () p + in + let unit u = + let id = u.Lang.Compilation_unit.id in + Fold.unit ~f:(register (id :> Paths.Identifier.t)) () u + in + (match Odoc_odoc.Indexing.handle_file ~page ~unit file with + | Ok result -> result + | Error (`Msg msg) -> Format.printf "Odoc warning or error %s: %s@." filename msg) let storage_module = Ancient.storage_module -let main files file_list index_docstring index_name type_search db_filename - db_format = +let main files file_list index_docstring index_name type_search db_filename db_format = let module Storage = (val storage_module db_format) in let db = Db.make () in let register id () item = @@ -32,8 +30,8 @@ let main files file_list index_docstring index_name type_search db_filename match file_list with | None -> files | Some file_list -> - let file_list = open_in file_list in - files @ (file_list |> In_channel.input_all |> String.split_on_char '\n') + let file_list = open_in file_list in + files @ (file_list |> In_channel.input_all |> String.split_on_char '\n') in List.iter (index_file register) files ; let t = Db.export db in @@ -57,21 +55,16 @@ let type_search = let db_format = let doc = "Database format" in let kind = Arg.enum (Ancient.arg_enum @ [ "marshal", `marshal; "js", `js ]) in - Arg.( - required & opt (some kind) None & info [ "format" ] ~docv:"DB_FORMAT" ~doc) + Arg.(required & opt (some kind) None & info [ "format" ] ~docv:"DB_FORMAT" ~doc) let db_filename = let doc = "Output filename" in - Arg.( - required - & opt (some string) None - & info [ "db"; "output"; "o" ] ~docv:"DB" ~doc) + Arg.(required & opt (some string) None & info [ "db"; "output"; "o" ] ~docv:"DB" ~doc) let file_list = let doc = "File containing a list of .odocl files.\n\ - Useful for system where there is a limit on the number of arguments to a \ - command." + Useful for system where there is a limit on the number of arguments to a command." in Arg.(value & opt (some file) None & info [ "file-list" ] ~doc) @@ -81,8 +74,14 @@ let odoc_files = let index = Term.( - const main $ odoc_files $ file_list $ index_docstring $ index_name - $ type_search $ db_filename $ db_format) + const main + $ odoc_files + $ file_list + $ index_docstring + $ index_name + $ type_search + $ db_filename + $ db_format) let cmd = let doc = "Index odocl files" in diff --git a/index/load_doc.ml b/index/load_doc.ml index 12f5fab4..c5af61f9 100644 --- a/index/load_doc.ml +++ b/index/load_doc.ml @@ -30,19 +30,18 @@ let cost ~name ~kind ~doc_html = generic_cost ~ignore_no_doc name has_doc + kind_cost kind (* - - todo : check usefulness - let rec type_size = function - | Odoc_model.Lang.TypeExpr.Var _ -> 1 - | Any -> 1 - | Arrow (lbl, a, b) -> - (match lbl with - | None -> 0 - | Some _ -> 1) - + type_size a + type_size b - | Constr (_, args) -> List.fold_left (fun acc t -> acc + type_size t) 1 args - | Tuple args -> List.fold_left (fun acc t -> acc + type_size t) 1 args - | _ -> 100 + todo : check usefulness + let rec type_size = function + | Odoc_model.Lang.TypeExpr.Var _ -> 1 + | Any -> 1 + | Arrow (lbl, a, b) -> + (match lbl with + | None -> 0 + | Some _ -> 1) + + type_size a + type_size b + | Constr (_, args) -> List.fold_left (fun acc t -> acc + type_size t) 1 args + | Tuple args -> List.fold_left (fun acc t -> acc + type_size t) 1 args + | _ -> 100 *) let string_of_html = Format.asprintf "%a" (Tyxml.Html.pp_elt ()) @@ -52,10 +51,9 @@ let rec typ_of_odoc_typ otyp = match otyp with | Odoc_model.Lang.TypeExpr.Var str -> poly str | Any -> any - | Arrow (_lbl, left, right) -> - arrow (typ_of_odoc_typ left) (typ_of_odoc_typ right) + | Arrow (_lbl, left, right) -> arrow (typ_of_odoc_typ left) (typ_of_odoc_typ right) | Constr (name, args) -> - constr (Typename.to_string name) (List.map typ_of_odoc_typ args) + constr (Typename.to_string name) (List.map typ_of_odoc_typ args) | Tuple li -> tuple (List.map typ_of_odoc_typ li) | _ -> unhandled @@ -70,14 +68,15 @@ let with_tokenizer str fn = let rec go i = if i >= String.length str then flush () - else + else ( let chr = str.[i] in if (chr >= 'a' && chr <= 'z') || (chr >= '0' && chr <= '9') - || chr = '_' || chr = '@' + || chr = '_' + || chr = '@' then Buffer.add_char buf chr else flush () ; - go (i + 1) + go (i + 1)) in go 0 @@ -91,18 +90,19 @@ let register_full_name ~db name elt = let searchable_type_of_constructor args res = let open Odoc_model.Lang in match args with - | TypeDecl.Constructor.Tuple args -> ( - match args with - | _ :: _ :: _ -> TypeExpr.(Arrow (None, Tuple args, res)) - | [ arg ] -> TypeExpr.(Arrow (None, arg, res)) - | _ -> res) + | TypeDecl.Constructor.Tuple args -> + (match args with + | _ :: _ :: _ -> TypeExpr.(Arrow (None, Tuple args, res)) + | [ arg ] -> TypeExpr.(Arrow (None, arg, res)) + | _ -> res) | TypeDecl.Constructor.Record fields -> - List.fold_left - (fun res field -> - let open TypeDecl.Field in - let field_name = Odoc_model.Paths.Identifier.name field.id in - TypeExpr.Arrow (Some (Label field_name), field.type_, res)) - res fields + List.fold_left + (fun res field -> + let open TypeDecl.Field in + let field_name = Odoc_model.Paths.Identifier.name field.id in + TypeExpr.Arrow (Some (Label field_name), field.type_, res)) + res + fields let searchable_type_of_record parent_type type_ = let open Odoc_model.Lang in @@ -111,40 +111,36 @@ let searchable_type_of_record parent_type type_ = let convert_kind (Odoc_search.Entry.{ kind; _ } as entry) = let open Odoc_search.Entry in match kind with - | TypeDecl _ -> - Entry.Kind.TypeDecl (Odoc_search.Html.typedecl_params_of_entry entry) + | TypeDecl _ -> Entry.Kind.TypeDecl (Odoc_search.Html.typedecl_params_of_entry entry) | Module -> Entry.Kind.Module | Value { value = _; type_ } -> - let typ = typ_of_odoc_typ type_ in - Entry.Kind.val_ typ + let typ = typ_of_odoc_typ type_ in + Entry.Kind.val_ typ | Constructor { args; res } -> - let searchable_type = searchable_type_of_constructor args res in - let typ = typ_of_odoc_typ searchable_type in - Entry.Kind.constructor typ + let searchable_type = searchable_type_of_constructor args res in + let typ = typ_of_odoc_typ searchable_type in + Entry.Kind.constructor typ | Field { mutable_ = _; parent_type; type_ } -> - let typ = - type_ |> searchable_type_of_record parent_type |> typ_of_odoc_typ - in - Entry.Kind.field typ + let typ = type_ |> searchable_type_of_record parent_type |> typ_of_odoc_typ in + Entry.Kind.field typ | Doc _ -> Doc | Exception { args; res } -> - let searchable_type = searchable_type_of_constructor args res in - let typ = typ_of_odoc_typ searchable_type in - Entry.Kind.exception_ typ + let searchable_type = searchable_type_of_constructor args res in + let typ = typ_of_odoc_typ searchable_type in + Entry.Kind.exception_ typ | Class_type _ -> Class_type | Method _ -> Method | Class _ -> Class | TypeExtension _ -> TypeExtension | ExtensionConstructor { args; res } -> - let searchable_type = searchable_type_of_constructor args res in - let typ = typ_of_odoc_typ searchable_type in - Entry.Kind.extension_constructor typ + let searchable_type = searchable_type_of_constructor args res in + let typ = typ_of_odoc_typ searchable_type in + Entry.Kind.extension_constructor typ | ModuleType -> ModuleType let register_type_expr ~db elt type_ = let type_polarities = - type_ |> typ_of_odoc_typ - |> Db.Type_polarity.of_typ ~any_is_poly:true ~all_names:true + type_ |> typ_of_odoc_typ |> Db.Type_polarity.of_typ ~any_is_poly:true ~all_names:true in Db.store_type_polarities db elt type_polarities @@ -152,7 +148,7 @@ let register_kind ~db ~type_search elt (kind : Odoc_search.Entry.kind) = let open Odoc_search.Entry in let open Odoc_model.Lang in if type_search - then + then ( match kind with | TypeDecl _ -> () | Module -> () @@ -166,11 +162,11 @@ let register_kind ~db ~type_search elt (kind : Odoc_search.Entry.kind) = | ExtensionConstructor { args; res } | Constructor { args; res } | Exception { args; res } -> - let type_ = searchable_type_of_constructor args res in - register_type_expr ~db elt type_ + let type_ = searchable_type_of_constructor args res in + register_type_expr ~db elt type_ | Field { mutable_ = _; parent_type; type_ } -> - let type_ = TypeExpr.Arrow (None, parent_type, type_) in - register_type_expr ~db elt type_ + let type_ = TypeExpr.Arrow (None, parent_type, type_) in + register_type_expr ~db elt type_) let rec is_from_module_type (id : Odoc_model.Paths.Identifier.Any.t) = let open Odoc_model.Paths in @@ -178,28 +174,34 @@ let rec is_from_module_type (id : Odoc_model.Paths.Identifier.Any.t) = | `CoreType _ | `CoreException _ | `Root _ | `Page _ | `LeafPage _ -> false | `ModuleType _ -> true | #Identifier.NonSrc.t_pv as x -> - let parent = Identifier.label_parent { id with iv = x } in - is_from_module_type (parent :> Identifier.Any.t) + let parent = Identifier.label_parent { id with iv = x } in + is_from_module_type (parent :> Identifier.Any.t) | _ -> false let is_from_module_type Odoc_search.Entry.{ id; _ } = match id.iv with | `ModuleType (parent, _) -> - (* A module type itself is not *from* a module type, but it might be if one - of its parents is a module type. *) - is_from_module_type (parent :> Odoc_model.Paths.Identifier.Any.t) + (* A module type itself is not *from* a module type, but it might be if one + of its parents is a module type. *) + is_from_module_type (parent :> Odoc_model.Paths.Identifier.Any.t) | _ -> is_from_module_type id let prefixname n = match (n :> Odoc_model.Paths.Identifier.t) - |> Odoc_model.Paths.Identifier.fullname |> List.rev + |> Odoc_model.Paths.Identifier.fullname + |> List.rev with | [] -> "" | _ :: q -> q |> List.rev |> String.concat "." -let register_entry ~db ~index_name ~type_search ~index_docstring - (Odoc_search.Entry.{ id; doc; kind } as entry) = +let register_entry + ~db + ~index_name + ~type_search + ~index_docstring + (Odoc_search.Entry.{ id; doc; kind } as entry) + = let module Sherlodoc_entry = Entry in let open Odoc_search in let open Odoc_search.Entry in @@ -210,10 +212,8 @@ let register_entry ~db ~index_name ~type_search ~index_docstring in if Odoc_model.Paths.Identifier.is_internal id || is_type_extension then () - else - let full_name = - id |> Odoc_model.Paths.Identifier.fullname |> String.concat "." - in + else ( + let full_name = id |> Odoc_model.Paths.Identifier.fullname |> String.concat "." in let doc_txt = Text.of_doc doc in let doc_html = match doc_txt with @@ -232,13 +232,20 @@ let register_entry ~db ~index_name ~type_search ~index_docstring let url = Result.get_ok url in let is_from_module_type = is_from_module_type entry in let elt = - Sherlodoc_entry.v ~name ~kind:kind' ~rhs ~doc_html ~cost ~url - ~is_from_module_type () + Sherlodoc_entry.v + ~name + ~kind:kind' + ~rhs + ~doc_html + ~cost + ~url + ~is_from_module_type + () in if index_docstring then register_doc ~db elt doc_txt ; - (if index_name - then - match kind with - | Doc _ -> () - | _ -> register_full_name ~db full_name elt) ; - register_kind ~db ~type_search elt kind + if index_name + then ( + match kind with + | Doc _ -> () + | _ -> register_full_name ~db full_name elt) ; + register_kind ~db ~type_search elt kind) diff --git a/index/load_doc.mli b/index/load_doc.mli index f7f5ad89..f9c855d4 100644 --- a/index/load_doc.mli +++ b/index/load_doc.mli @@ -1,9 +1,9 @@ -val register_entry : - db:Db.writer +val register_entry + : db:Db.writer -> index_name:bool -> type_search:bool -> index_docstring:bool -> Odoc_search.Entry.t -> unit (** [register_entry ~db ~index_name ~type_search ~index_docstring e] register - the entry [e] in [db]. *) + the entry [e] in [db]. *) diff --git a/index/typename.ml b/index/typename.ml index cd5fcb06..d2c4c1be 100644 --- a/index/typename.ml +++ b/index/typename.ml @@ -11,37 +11,33 @@ let rec show_ident_long h (r : Paths.Identifier.t_pv Paths.Identifier.id) = match r.Paths.Identifier.iv with | `CoreType n -> Format.fprintf h "Stdlib.%s" (Names.TypeName.to_string n) | `Type (md, n) -> - Format.fprintf h "%a.%s" show_signature md (Names.TypeName.to_string n) - | _ -> - Format.fprintf h "%S" (r |> Paths.Identifier.fullname |> String.concat ".") + Format.fprintf h "%a.%s" show_signature md (Names.TypeName.to_string n) + | _ -> Format.fprintf h "%S" (r |> Paths.Identifier.fullname |> String.concat ".") and show_module_t h p = - Format.fprintf h "%s" + Format.fprintf + h + "%s" (Odoc_document.Url.render_path (p : Paths.Path.Module.t :> Paths.Path.t)) and show_signature h sig_ = match sig_.iv with - | `Root (_, name) -> - Format.fprintf h "%s" (Odoc_model.Names.ModuleName.to_string name) - | `Module (pt, mdl) -> - Format.fprintf h "%a.%a" show_signature pt show_module_name mdl - | `Parameter (_, p) -> - Format.fprintf h "%s" (Odoc_model.Names.ModuleName.to_string p) + | `Root (_, name) -> Format.fprintf h "%s" (Odoc_model.Names.ModuleName.to_string name) + | `Module (pt, mdl) -> Format.fprintf h "%a.%a" show_signature pt show_module_name mdl + | `Parameter (_, p) -> Format.fprintf h "%s" (Odoc_model.Names.ModuleName.to_string p) | `Result t -> Format.fprintf h "%a" show_signature t | `ModuleType (_, p) -> - Format.fprintf h "%s" (Odoc_model.Names.ModuleTypeName.to_string p) + Format.fprintf h "%s" (Odoc_model.Names.ModuleTypeName.to_string p) let show_type_name_verbose h : Paths.Path.Type.t -> _ = function | `Resolved t -> - let open Paths.Path in - Format.fprintf h "%a" show_ident_long - (Resolved.identifier (t :> Resolved.t)) + let open Paths.Path in + Format.fprintf h "%a" show_ident_long (Resolved.identifier (t :> Resolved.t)) | `Identifier (path, _hidden) -> - let name = - (path :> Paths.Identifier.t) - |> Paths.Identifier.fullname |> String.concat "." - in - Format.fprintf h "%s" name + let name = + (path :> Paths.Identifier.t) |> Paths.Identifier.fullname |> String.concat "." + in + Format.fprintf h "%s" name | `Dot (mdl, x) -> Format.fprintf h "%a.%s" show_module_t mdl x let to_string t = Format.asprintf "%a" show_type_name_verbose t diff --git a/jsoo/dune b/jsoo/dune index 28529937..1b1dc9fd 100644 --- a/jsoo/dune +++ b/jsoo/dune @@ -13,8 +13,8 @@ (install (files sherlodoc.js) -; (section share) -; This ought to be in share, but for now I can only make it work in bin : I did -; not manage to fetch sherlodoc.js from share in the dune rules. -(section bin) + ; (section share) + ; This ought to be in share, but for now I can only make it work in bin : I did + ; not manage to fetch sherlodoc.js from share in the dune rules. + (section bin) (package sherlodoc)) diff --git a/jsoo/main.ml b/jsoo/main.ml index 63a4abc8..810de706 100644 --- a/jsoo/main.ml +++ b/jsoo/main.ml @@ -1,6 +1,7 @@ let print_error e = let open Jv.Error in - Printf.eprintf "Error : %s %s\n%s%!" + Printf.eprintf + "Error : %s %s\n%s%!" (Jstr.to_string @@ name e) (Jstr.to_string @@ message e) (Jstr.to_string @@ stack e) @@ -8,18 +9,17 @@ let print_error e = let new_ cl = Jv.(new' (get global cl)) let stream_of_string str = - let str = - str |> Brr.Tarray.of_binary_jstr |> Result.get_ok |> Brr.Tarray.to_jv - in + let str = str |> Brr.Tarray.of_binary_jstr |> Result.get_ok |> Brr.Tarray.to_jv in let stream = - new_ "ReadableStream" + new_ + "ReadableStream" Jv. [| obj [| ( "start" , callback ~arity:1 (fun controller -> - let _ = call controller "enqueue" [| str |] in - let _ = call controller "close" [||] in - ()) ) + let _ = call controller "enqueue" [| str |] in + let _ = call controller "close" [||] in + ()) ) |] |] in @@ -39,7 +39,6 @@ module Decompress_browser = struct in let open Jv in let reader = call stream "getReader" [||] in - let open Fut.Syntax in let rec read_step obj = let done_ = get obj "done" |> to_bool in @@ -55,18 +54,16 @@ module Decompress_browser = struct Fut.bind promise (function | Ok v -> read_step v | Error e -> - print_endline "error in string_of_stream" ; - print_error e ; - Fut.return ()) + print_endline "error in string_of_stream" ; + print_error e ; + Fut.return ()) in let+ () = read () in let r = Buffer.contents buffer in r let inflate str = - let dekompressor = - Jv.(new_ "DecompressionStream" [| of_string "deflate" |]) - in + let dekompressor = Jv.(new_ "DecompressionStream" [| of_string "deflate" |]) in let str = Jv.(call global "atob" [| str |]) |> Jv.to_jstr in let stream = stream_of_string str in let decompressed_stream = Jv.call stream "pipeThrough" [| dekompressor |] in @@ -98,9 +95,7 @@ let string_of_kind = let search message db = let query = Jv.get message "data" in let query = query |> Jv.to_jstr |> Jstr.to_string in - let results = - Query.(search ~shards:db { query; packages = []; limit = 50 }) - in + let results = Query.(search ~shards:db { query; packages = []; limit = 50 }) in let _ = Jv.(apply (get global "postMessage")) [| Jv.of_list @@ -114,18 +109,19 @@ let search message db = match kind with | Db.Entry.Kind.Doc -> None, None | _ -> - let rev_name = - name |> String.split_on_char '.' |> List.rev - in - ( rev_name |> List.tl |> List.rev |> String.concat "." - |> Option.some - , rev_name |> List.hd |> Option.some ) + let rev_name = name |> String.split_on_char '.' |> List.rev in + ( rev_name |> List.tl |> List.rev |> String.concat "." |> Option.some + , rev_name |> List.hd |> Option.some ) in let kind = string_of_kind kind in - let html = - Odoc_html_frontend.of_strings ~kind ~prefix_name ~name - ~typedecl_params ~rhs ~doc:doc_html + Odoc_html_frontend.of_strings + ~kind + ~prefix_name + ~name + ~typedecl_params + ~rhs + ~doc:doc_html |> List.map (Format.asprintf "%a" (Tyxml.Html.pp_elt ())) |> String.concat "\n" in @@ -142,7 +138,8 @@ let search message = let+ db = db in (* Here we catch any exception and print it. This allows us to keep running and answer requests that do not trigger exceptions. *) - try Printexc.print (search message) db with _ -> () + try Printexc.print (search message) db with + | _ -> () let main () = let module J' = Jstr in diff --git a/query/array_succ.ml b/query/array_succ.ml index 8f2cab26..a0eb3106 100644 --- a/query/array_succ.ml +++ b/query/array_succ.ml @@ -16,7 +16,7 @@ let rec succ_ge ~compare elt arr lo hi = let elt_hi = get arr hi in assert (compare elt_hi elt >= 0) ; elt_hi) - else + else ( let mid = (lo + hi) / 2 in let elt' = get arr mid in let comp = compare elt' elt in @@ -24,16 +24,17 @@ let rec succ_ge ~compare elt arr lo hi = then elt' else if comp > 0 then succ_ge ~compare elt arr lo mid - else succ_ge ~compare elt arr mid hi + else succ_ge ~compare elt arr mid hi) let succ_ge ~compare elt arr = if Array.length arr = 0 then None - else - let lo = 0 and hi = Array.length arr in + else ( + let lo = 0 + and hi = Array.length arr in if not (compare (get arr (hi - 1)) elt >= 0) then None - else Some (succ_ge ~compare elt arr lo hi) + else Some (succ_ge ~compare elt arr lo hi)) let rec succ_gt ~compare elt arr lo hi = let elt_lo = get arr lo in @@ -48,7 +49,7 @@ let rec succ_gt ~compare elt arr lo hi = let elt_hi = get arr hi in assert (compare elt_hi elt > 0) ; elt_hi) - else + else ( let mid = (lo + hi) / 2 in let elt' = get arr mid in let comp = compare elt' elt in @@ -56,16 +57,17 @@ let rec succ_gt ~compare elt arr lo hi = then get arr (mid + 1) else if comp > 0 then succ_gt ~compare elt arr lo mid - else succ_gt ~compare elt arr mid hi + else succ_gt ~compare elt arr mid hi) let succ_gt ~compare elt arr = if Array.length arr = 0 then None - else - let lo = 0 and hi = Array.length arr in + else ( + let lo = 0 + and hi = Array.length arr in if not (compare (get arr (hi - 1)) elt > 0) then None - else Some (succ_gt ~compare elt arr lo hi) + else Some (succ_gt ~compare elt arr lo hi)) let succ_gt_exn ~compare elt arr = match succ_gt ~compare elt arr with diff --git a/query/dynamic_cost.ml b/query/dynamic_cost.ml index 20e396cc..691c8725 100644 --- a/query/dynamic_cost.ml +++ b/query/dynamic_cost.ml @@ -25,8 +25,7 @@ module Reasoning = struct let low_query_word = String.lowercase_ascii query_word in let has_case = low_query_word <> query_word in let name = if not has_case then String.lowercase_ascii name else name in - if String.equal query_word name - || String.ends_with ~suffix:("." ^ query_word) name + if String.equal query_word name || String.ends_with ~suffix:("." ^ query_word) name then DotSuffix else if String.starts_with ~prefix:query_word name || String.ends_with ~suffix:query_word name @@ -42,8 +41,7 @@ module Reasoning = struct then SubUnderscore else if is_substring ~sub:query_word name then Sub - else if has_case - && is_substring ~sub:low_query_word (String.lowercase_ascii name) + else if has_case && is_substring ~sub:low_query_word (String.lowercase_ascii name) then Lowercase else (* Matches only in the docstring are always worse *) Doc @@ -92,22 +90,21 @@ module Reasoning = struct | Field entry_type | Val entry_type | Exception entry_type )) ) -> - Some (Type_distance.v ~query:query_type ~entry:entry_type) + Some (Type_distance.v ~query:query_type ~entry:entry_type) | ( _ - , ( Doc | TypeDecl _ | Module | Class_type | Method | Class - | TypeExtension | ModuleType ) ) -> - None + , ( Doc | TypeDecl _ | Module | Class_type | Method | Class | TypeExtension + | ModuleType ) ) -> + None let type_in_query query_type = Result.is_ok query_type let type_in_entry entry = let open Entry in match entry.kind with - | ExtensionConstructor _ | Constructor _ | Field _ | Val _ | Exception _ -> - true - | Doc | TypeDecl _ | Module | Class_type | Method | Class | TypeExtension - | ModuleType -> - false + | ExtensionConstructor _ | Constructor _ | Field _ | Val _ | Exception _ -> true + | Doc | TypeDecl _ | Module | Class_type | Method | Class | TypeExtension | ModuleType + -> + false let is_stdlib entry = let open Entry in @@ -149,17 +146,18 @@ end (** [cost_of_reasoning r] is the cost of a entry according to the reasons contained in [r]. *) let cost_of_reasoning - Reasoning. - { is_stdlib - ; has_doc - ; name_matches - ; type_distance - ; type_in_entry - ; type_in_query - ; kind - ; name_length - ; is_from_module_type - } = + Reasoning. + { is_stdlib + ; has_doc + ; name_matches + ; type_distance + ; type_in_entry + ; type_in_query + ; kind + ; name_length + ; is_from_module_type + } + = let ignore_no_doc = match kind with | Module | ModuleType -> true @@ -176,13 +174,13 @@ let cost_of_reasoning let open Reasoning.Name_match in name_matches |> List.map (function - | DotSuffix -> 0 - | PrefixSuffix -> 103 - | SubDot -> 104 - | SubUnderscore -> 105 - | Sub -> 106 - | Lowercase -> 107 - | Doc -> 1000) + | DotSuffix -> 0 + | PrefixSuffix -> 103 + | SubDot -> 104 + | SubUnderscore -> 105 + | Sub -> 106 + | Lowercase -> 107 + | Doc -> 1000) |> List.fold_left ( + ) 0 in let type_cost = @@ -200,12 +198,16 @@ let cost_of_reasoning let is_from_module_type_cost = if is_from_module_type then 400 else 0 in (if is_stdlib then 0 else 100) + (if has_doc || ignore_no_doc then 0 else 100) - + name_matches + type_cost + kind + name_length + is_from_module_type_cost + + name_matches + + type_cost + + kind + + name_length + + is_from_module_type_cost let cost_of_entry ~query_name ~query_type entry = cost_of_reasoning (Reasoning.v query_name query_type entry) (** [update_entry ~query_name ~query_type e] updates [e.cost] to take into - account the query described by [query_name] and [query_type]. *) + account the query described by [query_name] and [query_type]. *) let update_entry ~query_name ~query_type entry = Entry.{ entry with cost = cost_of_entry ~query_name ~query_type entry } diff --git a/query/query.ml b/query/query.ml index 7a54e4b2..5282e9e5 100644 --- a/query/query.ml +++ b/query/query.ml @@ -19,14 +19,13 @@ end let collapse_occ ~count occs = Occ.fold (fun k x acc -> if k < count then acc else Succ.union (Succ.of_array x) acc) - occs Succ.empty + occs + Succ.empty let collapse_trie_occ ~count t = - Succ.( - Tree_occ.sets_tree ~union ~terminal:(collapse_occ ~count) ~union_of_array t) + Succ.(Tree_occ.sets_tree ~union ~terminal:(collapse_occ ~count) ~union_of_array t) -let collapse_trie t = - Succ.(Tree.sets_tree ~union ~terminal:of_array ~union_of_array t) +let collapse_trie t = Succ.(Tree.sets_tree ~union ~terminal:of_array ~union_of_array t) let polarities typ = List.filter @@ -35,8 +34,7 @@ let polarities typ = let find_types ~shards typ = let polarities = polarities typ in - if polarities = [] - then failwith "Query.find_types : type with empty polarities" ; + if polarities = [] then failwith "Query.find_types : type with empty polarities" ; List.fold_left (fun acc shard -> let db = Db.(shard.db_types) in @@ -50,7 +48,8 @@ let find_types ~shards typ = polarities in Succ.union acc r) - Succ.empty shards + Succ.empty + shards let find_names ~(shards : Db.t list) names = let names = List.map String.lowercase_ascii names in @@ -67,7 +66,8 @@ let find_names ~(shards : Db.t list) names = in let candidates = Succ.inter_of_list candidates in Succ.union acc candidates) - Succ.empty shards + Succ.empty + shards type t = { query : string @@ -81,9 +81,9 @@ let search ~(shards : Db.t list) query_name query_typ = | _ :: _, Error _ -> find_names ~shards query_name | [], Ok query_typ -> find_types ~shards query_typ | _ :: _, Ok query_typ -> - let results_name = find_names ~shards query_name in - let results_typ = find_types ~shards query_typ in - Succ.inter results_name results_typ + let results_name = find_names ~shards query_name in + let results_typ = find_types ~shards query_typ in + Succ.inter results_name results_typ let match_packages ~packages { Db.Entry.pkg; _ } = match pkg with @@ -103,10 +103,7 @@ let search ~(shards : Db.t list) ?(dynamic_sort = true) params = let results = List.of_seq @@ Seq.take params.limit results in let results = if dynamic_sort - then - List.map - (Dynamic_cost.update_entry ~query_name:words ~query_type:typ) - results + then List.map (Dynamic_cost.update_entry ~query_name:words ~query_type:typ) results else results in let results = List.sort Db.Entry.compare results in diff --git a/query/query.mli b/query/query.mli index 468a4567..f81141e0 100644 --- a/query/query.mli +++ b/query/query.mli @@ -7,8 +7,8 @@ type t = val search : shards:Db.t list -> ?dynamic_sort:bool -> t -> Db.Entry.t list (** [search ~shard ~dynamic_sort {query; packages; limit}] returns [(pretty_query, results)] where [pretty_query] is a re-printed version of [query] and - [results] is the list of results corresponding to the query and the - various parameters. + [results] is the list of results corresponding to the query and the + various parameters. - [shards] is a list of databases. [results] is the union of the results of each database of the list [shards]. If [shards] is a very long list, [api] diff --git a/query/query_parser.ml b/query/query_parser.ml index e9ba7072..4570bae6 100644 --- a/query/query_parser.ml +++ b/query/query_parser.ml @@ -1,7 +1,7 @@ let type_of_string str = let lexbuf = Lexing.from_string str in - try Ok (Type_parser.main Type_lexer.token lexbuf) - with Type_parser.Error -> Error "parse error" + try Ok (Type_parser.main Type_lexer.token lexbuf) with + | Type_parser.Error -> Error "parse error" let naive_of_string str = List.filter (fun s -> String.length s > 0) (String.split_on_char ' ' str) @@ -18,13 +18,12 @@ let of_string str = | _ when guess_type_search str -> "", Ok str | _ -> str, Error `empty in - let typ = Result.bind str_typ (fun str_typ -> - match type_of_string str_typ with - | Ok Any -> Error `any - | Ok typ -> Ok typ - | Error _ -> Error `parse) + match type_of_string str_typ with + | Ok Any -> Error `any + | Ok typ -> Ok typ + | Error _ -> Error `parse) in let words = naive_of_string str_name in words, typ diff --git a/query/query_parser.mli b/query/query_parser.mli index 9d53e92e..c4acfa5a 100644 --- a/query/query_parser.mli +++ b/query/query_parser.mli @@ -1,2 +1 @@ -val of_string : - string -> string list * (Db.Typexpr.t, [> `any | `parse | `empty ]) result +val of_string : string -> string list * (Db.Typexpr.t, [> `any | `parse | `empty ]) result diff --git a/query/succ.ml b/query/succ.ml index e43bbea6..8312b81d 100644 --- a/query/succ.ml +++ b/query/succ.ml @@ -10,21 +10,21 @@ let rec print_node a ~depth s = match s with | Empty -> print_endline "Empty" | Inter (l, r) -> - print_endline "Inter" ; - print_node a ~depth l ; - print_node a ~depth r + print_endline "Inter" ; + print_node a ~depth l ; + print_node a ~depth r | Union (l, r) -> - print_endline "Union" ; - print_node a ~depth l ; - print_node a ~depth r + print_endline "Union" ; + print_node a ~depth l ; + print_node a ~depth r | Array arr -> - print_string "{ " ; - Array.iter - (fun elt -> - a elt ; - print_string " ") - arr ; - print_endline "}" + print_string "{ " ; + Array.iter + (fun elt -> + a elt ; + print_string " ") + arr ; + print_endline "}" let print_node a s = print_node a ~depth:0 s @@ -56,30 +56,30 @@ let rec succ ~compare ~strictness t elt = | Empty -> None | Array arr -> array_succ ~strictness ~compare elt arr | Union (l, r) -> - let elt_r = succ ~compare ~strictness r elt in - let elt_l = succ ~compare ~strictness l elt in - best_opt ~compare elt_l elt_r + let elt_r = succ ~compare ~strictness r elt in + let elt_l = succ ~compare ~strictness l elt in + best_opt ~compare elt_l elt_r | Inter (l, r) -> - let rec loop elt_r = - let* elt_l = succ ~compare ~strictness:Ge l elt_r in - let* elt_r = succ ~compare ~strictness:Ge r elt_l in - if compare elt_l elt_r = 0 then Some elt_l else loop elt_r - in - let* elt_l = succ ~compare ~strictness l elt in - loop elt_l + let rec loop elt_r = + let* elt_l = succ ~compare ~strictness:Ge l elt_r in + let* elt_r = succ ~compare ~strictness:Ge r elt_l in + if compare elt_l elt_r = 0 then Some elt_l else loop elt_r + in + let* elt_l = succ ~compare ~strictness l elt in + loop elt_l let rec first ~compare t = match t with | Empty -> None | Array s -> Some s.(0) | Inter (l, _) -> - let* elt = first ~compare l in - succ ~strictness:Ge ~compare t elt + let* elt = first ~compare l in + succ ~strictness:Ge ~compare t elt | Union (l, r) -> begin - let elt_l = first ~compare l in - let elt_r = first ~compare r in - best_opt ~compare elt_l elt_r - end + let elt_l = first ~compare l in + let elt_r = first ~compare r in + best_opt ~compare elt_l elt_r + end type 'a t = { cardinal : int @@ -104,17 +104,15 @@ let to_seq ~compare { s; _ } = let empty = { cardinal = 0; s = Empty } let of_array arr = - if Array.length arr = 0 - then empty - else { cardinal = Array.length arr; s = Array arr } + if Array.length arr = 0 then empty else { cardinal = Array.length arr; s = Array arr } let inter a b = match a.s, b.s with | Empty, _ | _, Empty -> empty | x, y when x == y -> a | x, y -> - let x, y = if a.cardinal < b.cardinal then x, y else y, x in - { cardinal = min a.cardinal b.cardinal; s = Inter (x, y) } + let x, y = if a.cardinal < b.cardinal then x, y else y, x in + { cardinal = min a.cardinal b.cardinal; s = Inter (x, y) } let union a b = match a.s, b.s with @@ -122,8 +120,8 @@ let union a b = | _, Empty -> a | x, y when x == y -> a | x, y -> - let x, y = if a.cardinal < b.cardinal then x, y else y, x in - { cardinal = a.cardinal + b.cardinal; s = Union (x, y) } + let x, y = if a.cardinal < b.cardinal then x, y else y, x in + { cardinal = a.cardinal + b.cardinal; s = Union (x, y) } (** This does a dychotomy to avoid building a comb, which would have poor performance. *) @@ -133,10 +131,10 @@ let union_of_array arr = | 0 -> empty | 1 -> arr.(lo) | dist -> - let mid = lo + (dist / 2) in - let left = loop lo mid in - let right = loop mid hi in - union left right + let mid = lo + (dist / 2) in + let left = loop lo mid in + let right = loop mid hi in + union left right in loop 0 (Array.length arr) diff --git a/query/test/test.ml b/query/test/test.ml index 374859a2..8a45d3e7 100644 --- a/query/test/test.ml +++ b/query/test/test.ml @@ -1,6 +1,7 @@ let () = let open Alcotest in - run "Query" + run + "Query" [ "Array_succ", Test_array.tests_succ_ge @ Test_array.tests_succ_gt ; "Succ", Test_succ.tests_to_seq ; "Type_parser", Test_type_parser.tests diff --git a/query/test/test_array.ml b/query/test/test_array.ml index 64a7d720..280dfdf5 100644 --- a/query/test/test_array.ml +++ b/query/test/test_array.ml @@ -37,27 +37,27 @@ let () = Random.init 123 let random_array size = let r = List.init size (fun _ -> Random.full_int (size * 2)) - |> List.sort_uniq Int.compare |> Array.of_list + |> List.sort_uniq Int.compare + |> Array.of_list in - r let tests_arr name test = List.init 50 (fun i -> - let elt = Random.full_int ((i * 2) + 1) in - let arr = random_array i in - let arr_string = - if i <= 5 - then - "[|" - ^ (arr |> Array.to_list |> List.map string_of_int - |> String.concat "; ") - ^ "|]" - else "[|...|]" - in - Alcotest.test_case - (Printf.sprintf "%s %i %s " name elt arr_string) - `Quick (test elt arr)) + let elt = Random.full_int ((i * 2) + 1) in + let arr = random_array i in + let arr_string = + if i <= 5 + then + "[|" + ^ (arr |> Array.to_list |> List.map string_of_int |> String.concat "; ") + ^ "|]" + else "[|...|]" + in + Alcotest.test_case + (Printf.sprintf "%s %i %s " name elt arr_string) + `Quick + (test elt arr)) let tests_succ_ge = tests_arr "succ_ge" test_succ_ge let tests_succ_gt = tests_arr "succ_gt" test_succ_gt diff --git a/query/test/test_succ.ml b/query/test/test_succ.ml index 9341f7f9..be71c318 100644 --- a/query/test/test_succ.ml +++ b/query/test/test_succ.ml @@ -1,7 +1,7 @@ open Query.Private (** This module does the same thing as Succ, but its correctness is obvious - and its performance terrible. *) + and its performance terrible. *) module Reference = struct include Set.Make (Int) @@ -10,7 +10,7 @@ module Reference = struct end (** This module is used to construct a pair of a "set array" using [Reference] - and a Succ that are exactly the same. *) + and a Succ that are exactly the same. *) module Both = struct let empty = Reference.empty, Succ.empty let union (l, l') (r, r') = Reference.union l r, Succ.union l' r' @@ -19,7 +19,7 @@ module Both = struct end (** This is a problematic exemple that was found randomly. It is saved here - to check for regressions. *) + to check for regressions. *) let extra_succ = Both.( union @@ -30,15 +30,15 @@ let rec random_set ~empty ~union ~inter ~of_array size = let random_set = random_set ~empty ~union ~inter ~of_array in if size = 0 then empty - else + else ( match Random.int 3 with | 0 -> - let arr = Test_array.random_array size in - Array.sort Int.compare arr ; - of_array arr + let arr = Test_array.random_array size in + Array.sort Int.compare arr ; + of_array arr | 1 -> inter (random_set (size / 2)) (random_set (size / 2)) | 2 -> union (random_set (size / 2)) (random_set (size / 2)) - | _ -> assert false + | _ -> assert false) let test_to_seq tree () = let ref = fst tree |> Reference.to_seq ~compare:Int.compare |> List.of_seq in @@ -48,8 +48,6 @@ let test_to_seq tree () = let tests_to_seq = [ Alcotest.test_case "Succ.to_seq extra" `Quick (test_to_seq extra_succ) ] @ List.init 50 (fun i -> - let i = i * 7 in - let succ = i |> Both.(random_set ~empty ~union ~inter ~of_array) in - Alcotest.test_case - (Printf.sprintf "Succ.to_seq size %i" i) - `Quick (test_to_seq succ)) + let i = i * 7 in + let succ = i |> Both.(random_set ~empty ~union ~inter ~of_array) in + Alcotest.test_case (Printf.sprintf "Succ.to_seq size %i" i) `Quick (test_to_seq succ)) diff --git a/query/test/test_type_parser.ml b/query/test/test_type_parser.ml index 4bdf1034..02b62fcc 100644 --- a/query/test/test_type_parser.ml +++ b/query/test/test_type_parser.ml @@ -11,12 +11,12 @@ let rec random_type size = | 0 | 1 -> random_elt [| random_poly; random_constr; (fun () -> any) |] () | (2 | 3 | 4) when Random.bool () -> random_constr_params size | _ when Random.int 100 < 20 -> - let n = 2 + Random.int 3 in - tuple (List.init n (fun _i -> random_type (size / n))) + let n = 2 + Random.int 3 in + tuple (List.init n (fun _i -> random_type (size / n))) | _ when Random.int 100 < 5 -> random_constr_params size | _ -> - let size = size / 2 in - arrow (random_type size) (random_type size) + let size = size / 2 in + arrow (random_type size) (random_type size) and random_constr_params size = let n_params = 1 + Random.int 3 in @@ -34,8 +34,6 @@ let test_parser typ () = let tests = List.init 50 (fun i -> - let i = i * 5 in - let typ = random_type i in - Alcotest.test_case - (Printf.sprintf "Type_parser size %i" i) - `Quick (test_parser typ)) + let i = i * 5 in + let typ = random_type i in + Alcotest.test_case (Printf.sprintf "Type_parser size %i" i) `Quick (test_parser typ)) diff --git a/query/type_distance.ml b/query/type_distance.ml index 0175ef08..06b7e906 100644 --- a/query/type_distance.ml +++ b/query/type_distance.ml @@ -1,30 +1,32 @@ module Type_path : sig (** This module contains the transformation that make it possible to compute the - distance between types.. - -A type can viewed as a tree. [a -> b -> c * d] is the following tree : -{[ -> - |- a - |- -> - |- b - |- * - |- c - |- d -]} -We consider the list of paths from root to leaf in the tree of the type. - -Here the paths would be : [ [[-> a]; [-> -> b]; [-> -> * c ]; [-> -> * d]] ] - -We encode slightly more information than that. In the above, it not possible by -looking at a type path to know the child position relative to its parent : In -the path [[-> a]]; [a] is the first child of [->], and in [[-> -> b]]; [[-> b]] -is the second child of [->]. This information is not possible to recover without -the whole tree, so we add it in the list, ass a number after the arrow. - -This makes the type path of the example type look like this : - -{[ [[-> 1 a]; [-> 2 -> 1 b]; [-> 2 -> 2 * 1 c ]; [-> 2 -> 2 * 2 d]] ]} -*) + distance between types.. + + A type can viewed as a tree. [a -> b -> c * d] is the following tree : + {[ + -> + |- a + |- -> + |- b + |- * + |- c + |- d + ]} + We consider the list of paths from root to leaf in the tree of the type. + + Here the paths would be : [ [[-> a]; [-> -> b]; [-> -> * c ]; [-> -> * d]] ] + + We encode slightly more information than that. In the above, it not possible by + looking at a type path to know the child position relative to its parent : In + the path [[-> a]]; [a] is the first child of [->], and in [[-> -> b]]; [[-> b]] + is the second child of [->]. This information is not possible to recover without + the whole tree, so we add it in the list, ass a number after the arrow. + + This makes the type path of the example type look like this : + + {[ + [[-> 1 a]; [-> 2 -> 1 b]; [-> 2 -> 2 * 1 c ]; [-> 2 -> 2 * 2 d]] + ]} *) type t = string list list @@ -37,45 +39,44 @@ end = struct type t = string list list - let rev_concat lst = - List.fold_left (fun acc xs -> List.rev_append xs acc) [] lst + let rev_concat lst = List.fold_left (fun acc xs -> List.rev_append xs acc) [] lst let rec of_typ ~ignore_any ~prefix ~sgn t = match t with | Db.Typexpr.Poly _ -> - let poly = "POLY" in - [ poly :: Sign.to_string sgn :: prefix ] + let poly = "POLY" in + [ poly :: Sign.to_string sgn :: prefix ] | Any -> - if ignore_any - then [ prefix ] - else - let poly = "POLY" in - [ poly :: Sign.to_string sgn :: prefix ] + if ignore_any + then [ prefix ] + else ( + let poly = "POLY" in + [ poly :: Sign.to_string sgn :: prefix ]) | Arrow (a, b) -> - let prefix_left = "->0" :: prefix in - let prefix_right = "->1" :: prefix in - List.rev_append - (of_typ ~ignore_any ~prefix:prefix_left ~sgn:(Sign.not sgn) a) - (of_typ ~ignore_any ~prefix:prefix_right ~sgn b) + let prefix_left = "->0" :: prefix in + let prefix_right = "->1" :: prefix in + List.rev_append + (of_typ ~ignore_any ~prefix:prefix_left ~sgn:(Sign.not sgn) a) + (of_typ ~ignore_any ~prefix:prefix_right ~sgn b) | Constr (name, args) -> - let prefix = name :: Sign.to_string sgn :: prefix in - begin - match args with - | [] -> [ prefix ] - | _ -> - rev_concat - @@ List.mapi - (fun i arg -> - let prefix = string_of_int i :: prefix in - of_typ ~ignore_any ~prefix ~sgn arg) - args - end + let prefix = name :: Sign.to_string sgn :: prefix in + begin + match args with + | [] -> [ prefix ] + | _ -> + rev_concat + @@ List.mapi + (fun i arg -> + let prefix = string_of_int i :: prefix in + of_typ ~ignore_any ~prefix ~sgn arg) + args + end | Tuple args -> - rev_concat - @@ List.mapi (fun i arg -> - let prefix = (string_of_int i ^ "*") :: prefix in - of_typ ~ignore_any ~prefix ~sgn arg) - @@ args + rev_concat + @@ List.mapi (fun i arg -> + let prefix = (string_of_int i ^ "*") :: prefix in + of_typ ~ignore_any ~prefix ~sgn arg) + @@ args | Unhandled -> [] let hcons_tbl = Hashtbl.create 16 @@ -83,20 +84,20 @@ end = struct let rec hcons = function | [] -> -1, [] - | x :: xs -> ( - let uid_xs, xs = hcons xs in - match Hashtbl.find hcons_tbl (uid_xs, x) with - | xxs -> xxs - | exception Not_found -> - let uid = !uid_generator in - uid_generator := uid + 1 ; - let result = uid, x :: xs in - Hashtbl.add hcons_tbl (uid_xs, x) result ; - result) + | x :: xs -> + let uid_xs, xs = hcons xs in + (match Hashtbl.find hcons_tbl (uid_xs, x) with + | xxs -> xxs + | exception Not_found -> + let uid = !uid_generator in + uid_generator := uid + 1 ; + let result = uid, x :: xs in + Hashtbl.add hcons_tbl (uid_xs, x) result ; + result) (** [of_typ t] is a [string list list] representing - the type [t]. It allows to compute the distance between two types. It is - stored in the database to sort results once they are obtained. *) + the type [t]. It allows to compute the distance between two types. It is + stored in the database to sort results once they are obtained. *) let of_typ ~ignore_any typ = List.map (fun xs -> @@ -123,80 +124,76 @@ let distance xs ys = | [], _ -> 0 | [ "_" ], _ -> 0 | _, [] -> List.length xs - | x :: xs, y :: ys when String.ends_with ~suffix:x y -> - memo (i + 1) (j + 1) xs ys + | x :: xs, y :: ys when String.ends_with ~suffix:x y -> memo (i + 1) (j + 1) xs ys | _, "->1" :: ys -> memo i (j + 1) xs ys | "->1" :: xs, _ -> 1 + memo (i + 1) j xs ys | _ :: xs', _ :: ys' -> - 7 - + min - (memo (i + 1) (j + 1) xs' ys') - (min (memo (i + 1) j xs' ys) (memo i (j + 1) xs ys')) + 7 + + min + (memo (i + 1) (j + 1) xs' ys') + (min (memo (i + 1) j xs' ys) (memo i (j + 1) xs ys')) in go 0 0 xs ys let minimize = function | [] -> 0 | arr -> - let used = Array.make (List.length (List.hd arr)) false in - let arr = - Array.map (fun lst -> - let lst = (1, None) :: List.mapi (fun i x -> x, Some i) lst in - List.sort Stdlib.compare lst) - @@ Array.of_list arr - in - Array.sort (fun xs ys -> Stdlib.compare xs ys) arr ; - let heuristics = Array.make (Array.length arr + 1) 0 in - for i = Array.length heuristics - 2 downto 0 do - let best = fst (List.hd arr.(i)) in - heuristics.(i) <- heuristics.(i + 1) + best - done ; - let best = ref 1000 in - let limit = ref 0 in - let rec go rem acc i = - incr limit ; - if !limit > 10_000 - then false - else if rem <= 0 - then begin - let score = acc + (1 * (Array.length arr - i)) in - best := min score !best ; - true - end - else if i >= Array.length arr - then begin - best := min !best (acc + (100 * rem)) ; - true - end - else if acc + heuristics.(i) >= !best - then true - else - let rec find = function - | [] -> true - | (cost, j) :: rest -> - let ok = - match j with - | None -> - go rem - (acc + cost - + if rem > Array.length arr - i then 100 else 0) - (i + 1) - | Some j -> - if used.(j) - then true - else begin - used.(j) <- true ; - let ok = go (rem - 1) (acc + cost) (i + 1) in - used.(j) <- false ; - ok - end - in - if ok then find rest else false - in - find arr.(i) - in - let _ = go (Array.length used) 0 0 in - !best + let used = Array.make (List.length (List.hd arr)) false in + let arr = + Array.map (fun lst -> + let lst = (1, None) :: List.mapi (fun i x -> x, Some i) lst in + List.sort Stdlib.compare lst) + @@ Array.of_list arr + in + Array.sort (fun xs ys -> Stdlib.compare xs ys) arr ; + let heuristics = Array.make (Array.length arr + 1) 0 in + for i = Array.length heuristics - 2 downto 0 do + let best = fst (List.hd arr.(i)) in + heuristics.(i) <- heuristics.(i + 1) + best + done ; + let best = ref 1000 in + let limit = ref 0 in + let rec go rem acc i = + incr limit ; + if !limit > 10_000 + then false + else if rem <= 0 + then begin + let score = acc + (1 * (Array.length arr - i)) in + best := min score !best ; + true + end + else if i >= Array.length arr + then begin + best := min !best (acc + (100 * rem)) ; + true + end + else if acc + heuristics.(i) >= !best + then true + else ( + let rec find = function + | [] -> true + | (cost, j) :: rest -> + let ok = + match j with + | None -> + go rem (acc + cost + if rem > Array.length arr - i then 100 else 0) (i + 1) + | Some j -> + if used.(j) + then true + else begin + used.(j) <- true ; + let ok = go (rem - 1) (acc + cost) (i + 1) in + used.(j) <- false ; + ok + end + in + if ok then find rest else false + in + find arr.(i)) + in + let _ = go (Array.length used) 0 0 in + !best let v ~query ~entry = let query_paths = Type_path.of_typ ~ignore_any:false query in @@ -204,11 +201,11 @@ let v ~query ~entry = match entry_paths, query_paths with | _, [] | [], _ -> 0 | _ -> - let arr = - List.map - (fun p -> - let p = List.rev p in - List.map (fun q -> distance (List.rev q) p) query_paths) - entry_paths - in - minimize arr + let arr = + List.map + (fun p -> + let p = List.rev p in + List.map (fun q -> distance (List.rev q) p) query_paths) + entry_paths + in + minimize arr diff --git a/www/packages.ml b/www/packages.ml index 8b2b97cb..fcff8b0d 100644 --- a/www/packages.ml +++ b/www/packages.ml @@ -7,13 +7,11 @@ type package = module M = Map.Make (String) module S = Set.Make (struct - type t = package + type t = package - let compare a b = - String.compare - (String.lowercase_ascii a.name) - (String.lowercase_ascii b.name) -end) + let compare a b = + String.compare (String.lowercase_ascii a.name) (String.lowercase_ascii b.name) + end) let pretty = function | "ai" -> "Sciences" @@ -95,8 +93,8 @@ let pretty = function | "xml" -> "Formats: Xml" | "" -> "--- TODO ---" | other -> - Format.printf "TODO: missing category name %S@." other ; - other + Format.printf "TODO: missing category name %S@." other ; + other let unescape str = let str = String.trim str in @@ -113,21 +111,21 @@ let load filename = match input_line h with | exception End_of_file -> acc | line -> - let package = - match String.split_on_char '\t' line with - | [ category; name; description ] -> - { category = pretty category - ; name - ; description = unescape description - } - | [ name; description ] -> - { category = pretty ""; name; description = unescape description } - | _ -> failwith (Printf.sprintf "invalid package: %S" line) - in - let set = try M.find package.category acc with Not_found -> S.empty in - let set = S.add package set in - let acc = M.add package.category set acc in - go acc + let package = + match String.split_on_char '\t' line with + | [ category; name; description ] -> + { category = pretty category; name; description = unescape description } + | [ name; description ] -> + { category = pretty ""; name; description = unescape description } + | _ -> failwith (Printf.sprintf "invalid package: %S" line) + in + let set = + try M.find package.category acc with + | Not_found -> S.empty + in + let set = S.add package set in + let acc = M.add package.category set acc in + go acc in let result = go M.empty in close_in h ; @@ -145,18 +143,18 @@ let html = div ~a:[ a_class [ "categories" ] ] (M.bindings packages - |> List.map (fun (category, packages) -> - div - ~a:[ a_class [ "category" ] ] - [ h3 [ txt (if category = "" then "Not classified" else category) ] - ; div - ~a:[ a_class [ "packages" ] ] - (S.elements packages - |> List.map (fun package -> - a - ~a: - [ a_href ("https://ocaml.org/p/" ^ package.name) - ; a_title package.description - ] - [ txt package.name ])) - ])) + |> List.map (fun (category, packages) -> + div + ~a:[ a_class [ "category" ] ] + [ h3 [ txt (if category = "" then "Not classified" else category) ] + ; div + ~a:[ a_class [ "packages" ] ] + (S.elements packages + |> List.map (fun package -> + a + ~a: + [ a_href ("https://ocaml.org/p/" ^ package.name) + ; a_title package.description + ] + [ txt package.name ])) + ])) diff --git a/www/ui.ml b/www/ui.ml index 7753e9e1..b9403715 100644 --- a/www/ui.ml +++ b/www/ui.ml @@ -43,17 +43,14 @@ let render_pkg elt = let open Db.Entry in match elt.pkg with | Some { name; version } -> - let link = elt |> pkg_link |> Option.get in - [ div - ~a:[ a_class [ "pkg" ] ] - [ a - ~a:[ a_href link ] - [ txt name - ; txt " " - ; span ~a:[ a_class [ "version" ] ] [ txt version ] - ] - ] - ] + let link = elt |> pkg_link |> Option.get in + [ div + ~a:[ a_class [ "pkg" ] ] + [ a + ~a:[ a_href link ] + [ txt name; txt " "; span ~a:[ a_class [ "version" ] ] [ txt version ] ] + ] + ] | None -> [] let render_result elt = @@ -62,16 +59,12 @@ let render_result elt = let render ~pretty results = match results with - | [] -> - div ~a:[ a_class [ "query" ] ] [ txt "No results! "; code [ txt pretty ] ] + | [] -> div ~a:[ a_class [ "query" ] ] [ txt "No results! "; code [ txt pretty ] ] | _ -> - div - [ div - ~a:[ a_class [ "query" ] ] - [ txt "Results for "; code [ txt pretty ] ] - ; ul ~a:[ a_class [ "found" ] ] - @@ List.map (fun r -> li (render_result r)) results - ] + div + [ div ~a:[ a_class [ "query" ] ] [ txt "Results for "; code [ txt pretty ] ] + ; ul ~a:[ a_class [ "found" ] ] @@ List.map (fun r -> li (render_result r)) results + ] let ajax_reload = {js| @@ -122,12 +115,7 @@ let template query contents = (head (title (txt "Sherlodoc")) [ meta ~a:[ a_charset "UTF-8" ] () - ; meta - ~a: - [ a_name "viewport" - ; a_content "width=device-width, initial-scale=1" - ] - () + ; meta ~a:[ a_name "viewport"; a_content "width=device-width, initial-scale=1" ] () ; link ~rel:[ `Stylesheet ] ~href:"/s.css" () ]) @@ body [ search_form query; div ~a:[ a_id "results" ] [ contents ] ] @@ -135,25 +123,19 @@ let template query contents = let github_icon = let open Tyxml.Svg in Tyxml.Html.svg - ~a: - [ a_width (16., None) - ; a_height (16.0, None) - ; a_viewBox (0., 0., 16., 16.) - ] + ~a:[ a_width (16., None); a_height (16.0, None); a_viewBox (0., 0., 16., 16.) ] [ path ~a: [ a_d - "M8 0C3.58 0 0 3.58 0 8c0 3.54 2.29 6.53 5.47 \ - 7.59.4.07.55-.17.55-.38 \ + "M8 0C3.58 0 0 3.58 0 8c0 3.54 2.29 6.53 5.47 7.59.4.07.55-.17.55-.38 \ 0-.19-.01-.82-.01-1.49-2.01.37-2.53-.49-2.69-.94-.09-.23-.48-.94-.82-1.13-.28-.15-.68-.52-.01-.53.63-.01 \ 1.08.58 1.23.82.72 1.21 1.87.87 \ 2.33.66.07-.52.28-.87.51-1.07-1.78-.2-3.64-.89-3.64-3.95 \ - 0-.87.31-1.59.82-2.15-.08-.2-.36-1.02.08-2.12 0 0 .67-.21 \ - 2.2.82.64-.18 1.32-.27 2-.27.68 0 1.36.09 2 .27 1.53-1.04 \ - 2.2-.82 2.2-.82.44 1.1.16 1.92.08 2.12.51.56.82 1.27.82 2.15 0 \ - 3.07-1.87 3.75-3.65 3.95.29.25.54.73.54 1.48 0 1.07-.01 \ - 1.93-.01 2.2 0 .21.15.46.55.38A8.012 8.012 0 0 0 16 \ - 8c0-4.42-3.58-8-8-8z" + 0-.87.31-1.59.82-2.15-.08-.2-.36-1.02.08-2.12 0 0 .67-.21 2.2.82.64-.18 \ + 1.32-.27 2-.27.68 0 1.36.09 2 .27 1.53-1.04 2.2-.82 2.2-.82.44 1.1.16 \ + 1.92.08 2.12.51.56.82 1.27.82 2.15 0 3.07-1.87 3.75-3.65 \ + 3.95.29.25.54.73.54 1.48 0 1.07-.01 1.93-.01 2.2 0 .21.15.46.55.38A8.012 \ + 8.012 0 0 0 16 8c0-4.42-3.58-8-8-8z" ] [] ] @@ -176,18 +158,10 @@ let explain = [ h1 [ txt "Sherlodoc" ] ; p ~a:[ a_class [ "doc" ] ] - [ txt - "Fuzzy search in OCaml's documentation for almost all opam \ - packages." - ] + [ txt "Fuzzy search in OCaml's documentation for almost all opam packages." ] ; ul ~a:[ a_class [ "doc" ] ] - [ li - [ txt "Search by name: " - ; link "concat map" - ; txt " and " - ; link "Lwt pool" - ] + [ li [ txt "Search by name: "; link "concat map"; txt " and "; link "Lwt pool" ] ; li [ txt "Search by type with a colon: "; link ": list list -> list" ] ; li [ txt "Search on name and type with a colon separator: " diff --git a/www/www.ml b/www/www.ml index 1c8ce825..eec10f6c 100644 --- a/www/www.ml +++ b/www/www.ml @@ -24,8 +24,9 @@ let get_limit params = let default = 100 in match Dream.query params "limit" with | None -> default - | Some str -> ( - try max 1 (min default (int_of_string str)) with _ -> default) + | Some str -> + (try max 1 (min default (int_of_string str)) with + | _ -> default) let get_params params = { Query.query = get_query params @@ -42,24 +43,26 @@ let string_of_tyxml' html = Format.asprintf "%a" (Tyxml.Html.pp_elt ()) html let root fn params = let params = get_params params in - try root fn params - with err -> + try root fn params with + | err -> Format.printf "ERROR: %S@." (Printexc.to_string err) ; Dream.html (string_of_tyxml @@ Ui.template params.query Ui.explain) let root fn params = - try root fn params - with _ -> Dream.html (string_of_tyxml @@ Ui.template "" Ui.explain) + try root fn params with + | _ -> Dream.html (string_of_tyxml @@ Ui.template "" Ui.explain) let cache_header : int option -> Dream.middleware = - fun max_age f req -> + fun max_age f req -> let+ response = f req in begin match max_age with | None -> () | Some max_age -> - Dream.add_header response "Cache-Control" - ("public, max-age=" ^ string_of_int max_age) + Dream.add_header + response + "Cache-Control" + ("public, max-age=" ^ string_of_int max_age) end ; response @@ -70,10 +73,10 @@ let cors_header f req = let cors_options = Dream.options "**" (fun _ -> - let+ response = Dream.empty `No_Content in - Dream.add_header response "Access-Control-Allow-Methods" "GET, OPTIONS" ; - Dream.add_header response "Access-Control-Allow-Headers" "*" ; - response) + let+ response = Dream.empty `No_Content in + Dream.add_header response "Access-Control-Allow-Methods" "GET, OPTIONS" ; + Dream.add_header response "Access-Control-Allow-Headers" "*" ; + response) let main db_format db_filename cache_max_age = let storage = @@ -84,16 +87,20 @@ let main db_format db_filename cache_max_age = let module Storage = (val storage) in let shards = Storage.load db_filename in Dream.run ~interface:"127.0.0.1" ~port:1234 - @@ Dream.logger @@ cache_header cache_max_age @@ cors_header + @@ Dream.logger + @@ cache_header cache_max_age + @@ cors_header @@ Dream.router - [ Dream.get "/" + [ Dream.get + "/" (root (fun params -> - let+ result = api ~shards params in - string_of_tyxml @@ Ui.template params.query result)) - ; Dream.get "/api" + let+ result = api ~shards params in + string_of_tyxml @@ Ui.template params.query result)) + ; Dream.get + "/api" (root (fun params -> - let+ result = api ~shards params in - string_of_tyxml' result)) + let+ result = api ~shards params in + string_of_tyxml' result)) ; Dream.get "/s.css" (Dream.from_filesystem "static" "style.css") ; Dream.get "/robots.txt" (Dream.from_filesystem "static" "robots.txt") ; Dream.get "/favicon.ico" (Dream.from_filesystem "static" "favicon.ico") @@ -106,8 +113,7 @@ open Cmdliner let db_format = let doc = "Database format" in let kind = Arg.enum [ "ancient", `ancient; "marshal", `marshal ] in - Arg.( - required & opt (some kind) None & info [ "format" ] ~docv:"DB_FORMAT" ~doc) + Arg.(required & opt (some kind) None & info [ "format" ] ~docv:"DB_FORMAT" ~doc) let db_path = let doc = "Database filename" in