├── .gitignore ├── .ocamlformat ├── .vscode └── settings.json ├── LICENSE ├── README.md ├── cli ├── dune ├── main.ml ├── search.ml ├── search.mli ├── serve.available.ml ├── serve.mli ├── serve.unavailable.ml └── unescape.mll ├── db ├── db.ml ├── db.mli ├── dune ├── entry.ml ├── entry.mli ├── storage.ml ├── string_automata.ml ├── string_automata.mli ├── type_polarity.ml ├── type_polarity.mli ├── typexpr.ml └── typexpr.mli ├── dune-project ├── dune-workspace ├── index ├── db_writer.ml ├── db_writer.mli ├── dune ├── index.ml ├── index.mli ├── load_doc.ml ├── load_doc.mli ├── suffix_tree.ml ├── suffix_tree.mli ├── type_cache.ml ├── type_cache.mli ├── typename.ml └── typename.mli ├── jsoo ├── dune ├── main.ml ├── odoc_html_frontend.ml ├── tyxml.ml └── tyxml.mli ├── query ├── dune ├── dynamic_cost.ml ├── io.ml ├── name_cost.ml ├── priority_queue.ml ├── priority_queue.mli ├── query.ml ├── query.mli ├── query_parser.ml ├── query_parser.mli ├── succ.ml ├── succ.mli ├── test │ ├── dune │ ├── test.ml │ ├── test_succ.ml │ └── test_type_parser.ml ├── top_results.ml ├── top_results.mli ├── type_distance.ml ├── type_distance.mli ├── type_lexer.mll └── type_parser.mly ├── sherlodoc.opam ├── store ├── db_store.default.ml ├── db_store.with_ancient.ml ├── dune ├── storage_ancient.ml ├── storage_ancient.mli ├── storage_js.ml ├── storage_js.mli ├── storage_marshal.ml └── storage_marshal.mli ├── test ├── cram │ ├── base_benchmark.t │ ├── base_cli.t │ ├── base_odocls.t │ ├── base_web.t │ ├── cli.t │ │ ├── main.mli │ │ ├── page.mld │ │ └── run.t │ ├── cli_poly.t │ │ ├── main.mli │ │ ├── page.mld │ │ └── run.t │ ├── cli_small.t │ │ ├── main.mli │ │ └── run.t │ ├── dune │ ├── empty.t │ │ ├── dune │ │ ├── dune-project │ │ ├── foo.ml │ │ └── run.t │ ├── link_in_docstring.t │ │ ├── a.mli │ │ └── run.t │ ├── module_type_cost.t │ │ ├── main.mli │ │ └── run.t │ ├── multi_package.t │ ├── odocl_favouritism.t │ │ ├── a.mli │ │ ├── b.mli │ │ └── run.t │ ├── prefix_favouritism.t │ ├── query_syntax.t │ ├── simple.t │ │ ├── main.ml │ │ ├── page.mld │ │ └── run.t │ ├── size_bound.t │ └── version.t ├── cram_ancient │ ├── cli_small.t │ │ ├── main.mli │ │ └── run.t │ ├── dune │ └── empty.t ├── cram_static │ ├── base_web.t │ ├── dune │ └── js_static_size.t ├── dune └── whole_switch │ ├── .gitignore │ ├── readme.md │ ├── setup_big_switch.sh │ └── test.sh └── www ├── dune ├── packages.ml ├── static ├── bg.jpg ├── favicon.ico ├── packages.csv ├── robots.txt └── style.css ├── ui.ml ├── www.ml └── www.mli /.gitignore: -------------------------------------------------------------------------------- 1 | *.annot 2 | *.cmo 3 | *.cma 4 | *.cmi 5 | *.a 6 | *.o 7 | *.cmx 8 | *.cmxs 9 | *.cmxa 10 | 11 | .merlin 12 | *.install 13 | *.coverage 14 | *.sw[lmnop] 15 | 16 | _build/ 17 | _doc/ 18 | _coverage/ 19 | _opam/ 20 | **/perf.data 21 | **/perf.data.old 22 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.26.1 2 | profile = janestreet 3 | let-binding-spacing = compact 4 | sequence-style = separator 5 | doc-comments = after-when-possible 6 | exp-grouping = preserve 7 | break-cases = toplevel 8 | cases-exp-indent = 4 9 | cases-matching-exp-indent = normal 10 | -------------------------------------------------------------------------------- /.vscode/settings.json: -------------------------------------------------------------------------------- 1 | { 2 | "ocaml.sandbox": { 3 | "kind": "opam", 4 | "switch": "sherlodoc" 5 | } 6 | } -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 Arthur Wendling, Tarides 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | **Try it online at [doc.sherlocode.com](https://doc.sherlocode.com) !** 2 | 3 | Sherlodoc is a search engine for OCaml documentation (inspired by [Hoogle](https://hoogle.haskell.org/)), which allows you to search through OCaml libraries by names and approximate type signatures: 4 | 5 | - Search by name: [`list map`](https://doc.sherlocode.com/?q=list%20map) 6 | - Search inside documentation comments: [`raise Not_found`](https://doc.sherlocode.com/?q=raise%20Not_found) 7 | - Fuzzy type search is introduced with a colon, e.g. [`: map -> list`](https://doc.sherlocode.com/?q=%3A%20map%20-%3E%20list) 8 | - Search by name and type with a colon separator [`Bogue : Button.t`](https://doc.sherlocode.com/?q=Bogue%20%3A%20Button.t) 9 | - An underscore `_` can be used as a wildcard in type queries: [`(int -> _) -> list -> _`](https://doc.sherlocode.com/?q=(int%20-%3E%20_)%20-%3E%20list%20-%3E%20_) 10 | - Type search supports products and reordering of function arguments: [`array -> ('a * int -> bool) -> array`](https://doc.sherlocode.com/?q=%3A%20array%20-%3E%20(%27a%20*%20int%20-%3E%20bool)%20-%3E%20array) 11 | 12 | ## Local usage 13 | 14 | First, install sherlodoc and odig: 15 | 16 | ```bash 17 | $ opam pin add 'https://github.com/art-w/sherlodoc.git' # optional 18 | 19 | $ opam install sherlodoc odig 20 | ``` 21 | 22 | [Odig](https://erratique.ch/software/odig) can generate the odoc documentation of your current switch with: 23 | 24 | ```bash 25 | $ odig odoc # followed by `odig doc` to browse your switch documentation 26 | ``` 27 | 28 | Which sherlodoc can then index to create a search database: 29 | 30 | ```bash 31 | # name your sherlodoc database 32 | $ export SHERLODOC_DB=/tmp/sherlodoc.marshal 33 | 34 | # if you are using OCaml 4, we recommend the `ancient` database format: 35 | $ opam install ancient 36 | $ export SHERLODOC_DB=/tmp/sherlodoc.ancient 37 | 38 | # index all odoc files generated by odig for your current switch: 39 | $ sherlodoc index $(find $OPAM_SWITCH_PREFIX/var/cache/odig/odoc -name '*.odocl' | grep -v __) 40 | ``` 41 | 42 | Enjoy searching from the command-line or run the webserver: 43 | 44 | ```bash 45 | $ sherlodoc search "map : list" 46 | $ sherlodoc search # interactice cli 47 | 48 | $ opam install dream 49 | $ sherlodoc serve # webserver at http://localhost:1234 50 | ``` 51 | 52 | The different commands support a `--help` argument for more details/options. 53 | 54 | In particular, sherlodoc supports three different file formats for its database, which can be specified either in the filename extension or through the `--db-format=` flag: 55 | - `ancient` for fast database loading using mmap, but is only compatible with OCaml 4. 56 | - `marshal` for when ancient is unavailable, with slower database opening. 57 | - `js` for integration with odoc static html documentation for client-side search without a server. 58 | 59 | ## Integration with Odoc 60 | 61 | Odoc 2.4.0 adds a search bar inside the statically generated html documentation. [Integration with dune is in progress](https://github.com/ocaml/dune/pull/9772), you can try it inside a fresh opam switch with: (warning! this will recompile any installed package that depends on dune!) 62 | 63 | ```bash 64 | $ opam pin https://github.com/emileTrotignon/dune.git#search-odoc-new 65 | 66 | $ dune build @doc # in your favorite project 67 | ``` 68 | 69 | Otherwise, manual integration with odoc requires to add to every call of `odoc html-generate` the flags `--search-uri sherlodoc.js --search-uri db.js` to activate the search bar. You'll also need to generate a search database `db.js` and provide the `sherlodoc.js` dependency (a version of the sherlodoc search engine with odoc support, compiled to javascript): 70 | 71 | ```bash 72 | $ sherlodoc index --db=_build/default/_doc/_html/YOUR_LIB/db.js \ 73 | $(find _build/default/_doc/_odocls/YOUR_LIB -name '*.odocl' | grep -v __) 74 | 75 | $ sherlodoc js > _build/default/_doc/_html/sherlodoc.js 76 | ``` 77 | 78 | ## How it works 79 | 80 | The sherlodoc database uses [Suffix Trees](https://en.wikipedia.org/wiki/Suffix_tree) to search for substrings in value names, documentation and types. During indexation, the suffix trees are compressed to state machine automatas. The children of every node are also sorted, such that a sub-tree can be used as a priority queue during search enumeration. 81 | 82 | To rank the search results, sherlodoc computes a static evaluation of each candidate during indexation. This static scoring biases the search to favor short names, short types, the presence of documentation, etc. When searching, a dynamic evaluation dependent on the user query is used to adjust the static ordering of the results: 83 | 84 | - How similar is the result name to the search query? (to e.g. prefer results which respect the case: [`map`](https://doc.sherlocode.com/?q=map) vs [`Map`](https://doc.sherlocode.com/?q=Map)) 85 | - How similar are the types? (using a tree diff algorithm, as for example [`('a -> 'b -> 'a) -> 'a -> 'b list -> 'a`](https://doc.sherlocode.com/?q=(%27a%20-%3E%20%27b%20-%3E%20%27a)%20-%3E%20%27a%20-%3E%20%27b%20list%20-%3E%20%27a) and [`('a -> 'b -> 'b) -> 'a list -> 'b -> 'b`](https://doc.sherlocode.com/?q=(%27a%20-%3E%20%27b%20-%3E%20%27b)%20-%3E%20%27a%20list%20-%3E%20%27b%20-%3E%20%27b) are isomorphic yet point to `fold_left` and `fold_right` respectively) 86 | 87 | For fuzzy type search, sherlodoc aims to provide good results without requiring a precise search query, on the basis that the user doesn't know the exact type of the things they are looking for (e.g. [`string -> file_descr`](https://doc.sherlocode.com/?q=string%20-%3E%20file_descr) is incomplete but should still point in the right direction). In particular when exploring a package documentation, the common question "how do I produce a value of type `foo`" can be answered with the query `: foo` (and "which functions consume a value of type `bar`" with `: bar -> _`). This should also work when the type can only be produced indirectly through a callback (for example [`: Eio.Switch.t`](https://doc.sherlocode.com/?q=%3A%20Eio.Switch.t) has no direct constructor). To achieve this, sherlodoc performs a type decomposition based on the polarity of each term: A value produced by a function is said to be positive, while an argument consumed by a function is negative. This simplifies away the tree shape of types, allowing their indexation in the suffix trees. The cardinality of each value type is also indexed, to e.g. differentiate between [`list -> list`](https://doc.sherlocode.com/?q=list%20-%3E%20list) and [`list -> list -> list`](https://doc.sherlocode.com/?q=list%20-%3E%20list%20-%3E%20list). 88 | 89 | While the polarity search results are satisfying, sherlodoc offers very limited support for polymorphic variables, type aliases and true type isomorphisms. You should check out the extraordinary [Dowsing](https://github.com/Drup/dowsing) project for this! 90 | 91 | And if you speak French, a more detailed [presentation of Sherlodoc](https://www.irill.org/videos/OUPS/2023-03/wendling.html) (and [Sherlocode](https://sherlocode.com)) was given at the [OCaml Users in PariS (OUPS)](https://oups.frama.io/) in March 2023. 92 | -------------------------------------------------------------------------------- /cli/dune: -------------------------------------------------------------------------------- 1 | (ocamllex unescape) 2 | 3 | (executable 4 | (name main) 5 | (public_name sherlodoc) 6 | (package sherlodoc) 7 | (libraries 8 | cmdliner 9 | index 10 | query 11 | db_store 12 | unix 13 | (select 14 | serve.ml 15 | from 16 | (www -> serve.available.ml) 17 | (!www -> serve.unavailable.ml))) 18 | (preprocess 19 | (pps ppx_blob)) 20 | (preprocessor_deps ../jsoo/sherlodoc.js)) 21 | -------------------------------------------------------------------------------- /cli/main.ml: -------------------------------------------------------------------------------- 1 | let guess_db_format db_format db_filename = 2 | match db_format with 3 | | Some db_format -> db_format 4 | | None -> begin 5 | let ext = Filename.extension db_filename in 6 | let ext_len = String.length ext in 7 | let ext = if ext_len = 0 then ext else String.sub ext 1 (ext_len - 1) in 8 | try List.assoc ext Db_store.available_backends with 9 | | Not_found -> 10 | Format.fprintf 11 | Format.err_formatter 12 | "Unknown db format extension %S (expected: %s)@." 13 | ext 14 | (String.concat ", " @@ List.map fst Db_store.available_backends) ; 15 | exit 1 16 | end 17 | 18 | open Cmdliner 19 | 20 | let db_format = 21 | let env = 22 | let doc = "Database format" in 23 | Cmd.Env.info "SHERLODOC_FORMAT" ~doc 24 | in 25 | let kind = Arg.enum Db_store.available_backends in 26 | Arg.(value & opt (some kind) None & info [ "format" ] ~docv:"DB_FORMAT" ~env) 27 | 28 | let db_filename = 29 | let env = 30 | let doc = "The database to query" in 31 | Cmd.Env.info "SHERLODOC_DB" ~doc 32 | in 33 | Arg.(required & opt (some string) None & info [ "db"; "o" ] ~docv:"DB" ~env) 34 | 35 | let db_path = 36 | let env = 37 | let doc = "The database to query" in 38 | Cmd.Env.info "SHERLODOC_DB" ~doc 39 | in 40 | Arg.(required & opt (some file) None & info [ "db" ] ~docv:"DB" ~env) 41 | 42 | let with_db fn db_path = 43 | let apply fn db_format db_filename = 44 | let db_format = guess_db_format db_format db_filename in 45 | fn db_format db_filename 46 | in 47 | Term.(const apply $ fn $ db_format $ db_path) 48 | 49 | let cmd_search = 50 | let info = Cmd.info "search" ~doc:"Command-line search" in 51 | Cmd.v info (with_db Search.term db_path) 52 | 53 | let cmd_index = 54 | let doc = "Index odocl files to create a Sherlodoc database" in 55 | let info = Cmd.info "index" ~doc in 56 | Cmd.v info (with_db Index.term db_filename) 57 | 58 | let cmd_serve = 59 | let doc = "Webserver interface" in 60 | let info = Cmd.info "serve" ~doc in 61 | Cmd.v info (with_db Serve.term db_path) 62 | 63 | let cmd_jsoo = 64 | let doc = "For dune/odoc integration, sherlodoc compiled as javascript" in 65 | let info = Cmd.info "js" ~doc in 66 | let target = 67 | let doc = "Name of the file to create" in 68 | Arg.(value & pos 0 string "" & info [] ~docv:"QUERY" ~doc) 69 | in 70 | let emit_js_dep filename = 71 | let close, h = if filename = "" then false, stdout else true, open_out filename in 72 | output_string h [%blob "jsoo/sherlodoc.js"] ; 73 | if close then close_out h 74 | in 75 | Cmd.v info Term.(const emit_js_dep $ target) 76 | 77 | let cmd = 78 | let doc = "Sherlodoc" in 79 | let version = "0.2" in 80 | let info = Cmd.info "sherlodoc" ~version ~doc in 81 | Cmd.group info [ cmd_search; cmd_index; cmd_serve; cmd_jsoo ] 82 | 83 | let () = exit (Cmd.eval cmd) 84 | -------------------------------------------------------------------------------- /cli/search.ml: -------------------------------------------------------------------------------- 1 | let header = 2 | {|Sherlodoc v0.2 -- search OCaml documentation by name and type (use CTRL-D to exit)|} 3 | 4 | let string_of_kind = 5 | let open Db.Entry.Kind in 6 | function 7 | | Doc -> "doc" 8 | | Type_decl _ -> "type" 9 | | Module -> "mod" 10 | | Exception _ -> "exn" 11 | | Class_type -> "class" 12 | | Method -> "meth" 13 | | Class -> "class" 14 | | Type_extension -> "type" 15 | | Extension_constructor _ -> "cons" 16 | | Module_type -> "sig" 17 | | Constructor _ -> "cons" 18 | | Field _ -> "field" 19 | | Val _ -> "val" 20 | 21 | let print_result ~print_cost ~print_docstring ~no_rhs (elt : Db.Entry.t) = 22 | let cost = if print_cost then string_of_int elt.cost ^ " " else "" in 23 | let typedecl_params = 24 | (match elt.kind with 25 | | Type_decl args -> args 26 | | _ -> None) 27 | |> Option.map (fun str -> str ^ " ") 28 | |> Option.value ~default:"" 29 | in 30 | let kind = elt.kind |> string_of_kind |> Unescape.string in 31 | let name = Unescape.string elt.name in 32 | let pp_rhs h = function 33 | | None -> () 34 | | Some _ when no_rhs -> () 35 | | Some rhs -> Format.fprintf h "%s" (Unescape.string rhs) 36 | in 37 | let docstring = if print_docstring then "\n" ^ elt.doc_html else "" in 38 | Format.printf "%s%s %s%s%a%s@." cost kind typedecl_params name pp_rhs elt.rhs docstring 39 | 40 | let search 41 | ~print_cost 42 | ~static_sort 43 | ~limit 44 | ~db 45 | ~no_rhs 46 | ~pretty_query 47 | ~time 48 | ~print_docstring 49 | query 50 | = 51 | let query = Query.{ query; packages = []; limit } in 52 | if pretty_query then print_endline (Query.pretty query) ; 53 | let t0 = Unix.gettimeofday () in 54 | let r = Query.Blocking.search ~shards:db ~dynamic_sort:(not static_sort) query in 55 | let t1 = Unix.gettimeofday () in 56 | match r with 57 | | [] -> print_endline "[No results]" 58 | | _ :: _ as results -> 59 | List.iter (print_result ~print_cost ~print_docstring ~no_rhs) results ; 60 | flush stdout ; 61 | if time then Format.printf "Search in %f@." (t1 -. t0) 62 | 63 | let rec search_loop 64 | ~print_cost 65 | ~no_rhs 66 | ~pretty_query 67 | ~static_sort 68 | ~limit 69 | ~time 70 | ~print_docstring 71 | ~db 72 | = 73 | Printf.printf "%ssearch>%s %!" "\027[0;36m" "\027[0;0m" ; 74 | match Stdlib.input_line stdin with 75 | | query -> 76 | search 77 | ~print_cost 78 | ~static_sort 79 | ~limit 80 | ~db 81 | ~no_rhs 82 | ~pretty_query 83 | ~time 84 | ~print_docstring 85 | query ; 86 | search_loop 87 | ~print_cost 88 | ~no_rhs 89 | ~pretty_query 90 | ~static_sort 91 | ~limit 92 | ~time 93 | ~print_docstring 94 | ~db 95 | | exception End_of_file -> Printf.printf "\n%!" 96 | 97 | let search 98 | query 99 | print_cost 100 | no_rhs 101 | static_sort 102 | limit 103 | pretty_query 104 | time 105 | print_docstring 106 | db_format 107 | db_filename 108 | = 109 | let module Storage = (val Db_store.storage_module db_format) in 110 | let db = Storage.load db_filename in 111 | match query with 112 | | None -> 113 | print_endline header ; 114 | search_loop 115 | ~print_cost 116 | ~no_rhs 117 | ~pretty_query 118 | ~static_sort 119 | ~limit 120 | ~time 121 | ~print_docstring 122 | ~db 123 | | Some query -> 124 | search 125 | ~print_cost 126 | ~no_rhs 127 | ~pretty_query 128 | ~static_sort 129 | ~limit 130 | ~time 131 | ~print_docstring 132 | ~db 133 | query 134 | 135 | open Cmdliner 136 | 137 | let limit = 138 | let doc = "The maximum number of results per query" in 139 | Arg.(value & opt int 25 & info [ "limit"; "n" ] ~docv:"N" ~doc) 140 | 141 | let query = 142 | let doc = "The query. If absent, queries will be read interactively." in 143 | Arg.(value & pos 0 (some string) None & info [] ~docv:"QUERY" ~doc) 144 | 145 | let print_cost = 146 | let doc = "For debugging purposes: prints the cost of each result" in 147 | Arg.(value & flag & info [ "print-cost" ] ~doc) 148 | 149 | let print_time = 150 | let doc = "For debugging purposes: prints the search time" in 151 | Arg.(value & flag & info [ "print-time" ] ~doc) 152 | 153 | let static_sort = 154 | let doc = 155 | "Sort the results without looking at the query.\n\ 156 | Enabling it allows to look at the static costs of elements.\n\ 157 | Mainly for testing purposes." 158 | in 159 | Arg.(value & flag & info [ "static-sort" ] ~doc) 160 | 161 | let no_rhs = 162 | let doc = "Do not print the right-hand side of results." in 163 | Arg.(value & flag & info [ "no-rhs"; "no-right-hand-side" ] ~doc) 164 | 165 | let pretty_query = 166 | let doc = "Prints the query itself as it was parsed" in 167 | Arg.(value & flag & info [ "pretty-query" ] ~doc) 168 | 169 | let print_docstring = 170 | let doc = "Print the HTML of the docstring of the results" in 171 | Arg.(value & flag & info [ "print-docstring-html" ] ~doc) 172 | 173 | let term = 174 | Term.( 175 | const search 176 | $ query 177 | $ print_cost 178 | $ no_rhs 179 | $ static_sort 180 | $ limit 181 | $ pretty_query 182 | $ print_time 183 | $ print_docstring) 184 | -------------------------------------------------------------------------------- /cli/search.mli: -------------------------------------------------------------------------------- 1 | val term : (Db_store.db_format -> string -> unit) Cmdliner.Term.t 2 | -------------------------------------------------------------------------------- /cli/serve.available.ml: -------------------------------------------------------------------------------- 1 | let term = Www.term 2 | -------------------------------------------------------------------------------- /cli/serve.mli: -------------------------------------------------------------------------------- 1 | val term : (Db_store.db_format -> string -> unit) Cmdliner.Term.t 2 | -------------------------------------------------------------------------------- /cli/serve.unavailable.ml: -------------------------------------------------------------------------------- 1 | let main _ _ = 2 | Format.fprintf 3 | Format.err_formatter 4 | "Webserver unavailable: please install dream and retry.@." 5 | 6 | let term = Cmdliner.Term.const main 7 | -------------------------------------------------------------------------------- /cli/unescape.mll: -------------------------------------------------------------------------------- 1 | (* The goal of this lexer is to remove html encoding from strings, so that 2 | they display nicely on the command-line. The only encodings included are the 3 | one actually used. Because this executable is mainly used for testing, this 4 | is fine. *) 5 | rule buffer b = parse 6 | | "&" { Buffer.add_char b '&'; buffer b lexbuf } 7 | | "<" { Buffer.add_char b '<'; buffer b lexbuf } 8 | | ">" { Buffer.add_char b '>'; buffer b lexbuf } 9 | | ">" { Buffer.add_char b '>'; buffer b lexbuf } 10 | | ">" { Buffer.add_char b '>'; buffer b lexbuf } 11 | | """ { Buffer.add_char b '>'; buffer b lexbuf } 12 | | "'" { Buffer.add_char b '\''; buffer b lexbuf } 13 | | "-" { Buffer.add_char b '-'; buffer b lexbuf } 14 | 15 | | eof { () } 16 | | _ { Buffer.add_string b (Lexing.lexeme lexbuf) ; buffer b lexbuf } 17 | 18 | { 19 | let string str = 20 | let lexbuf = Lexing.from_string str in 21 | let b = Buffer.create (String.length str) in 22 | buffer b lexbuf ; 23 | Buffer.contents b 24 | } 25 | -------------------------------------------------------------------------------- /db/db.ml: -------------------------------------------------------------------------------- 1 | module Entry = Entry 2 | module Storage = Storage 3 | module Type_polarity = Type_polarity 4 | module Typexpr = Typexpr 5 | module Occurences = Storage.Occurences 6 | module String_automata = String_automata 7 | 8 | type t = Storage.db = 9 | { db_names : String_automata.t 10 | ; db_pos_types : String_automata.t Occurences.t 11 | ; db_neg_types : String_automata.t Occurences.t 12 | } 13 | -------------------------------------------------------------------------------- /db/db.mli: -------------------------------------------------------------------------------- 1 | module Entry = Entry 2 | module Storage = Storage 3 | module Type_polarity = Type_polarity 4 | module Typexpr = Typexpr 5 | module Occurences = Storage.Occurences 6 | module String_automata = String_automata 7 | 8 | type t = Storage.db = 9 | { db_names : String_automata.t 10 | ; db_pos_types : String_automata.t Occurences.t 11 | ; db_neg_types : String_automata.t Occurences.t 12 | } 13 | (** The type of a search database. 14 | 15 | [db_names] is for text-based part of the query and [db_types] for the 16 | type-based part. 17 | 18 | [db_types] has [Entry.t array Int_map.t] ([Occ.t]) as a payload because we want 19 | the query [blabla : int -> int -> _] to return only entries that take at 20 | least two ints as arguments, an entry of type [int -> string] is invalid. 21 | The [Int_map.t] maps a number of occurences to a set of entries. See {!Occ}. 22 | [db_types] still is a suffix tree, so you can search in it only for text. The 23 | way we transform types into searchable text is in {!Type_polarity}. *) 24 | -------------------------------------------------------------------------------- /db/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name db)) 3 | -------------------------------------------------------------------------------- /db/entry.ml: -------------------------------------------------------------------------------- 1 | let empty_string = String.make 0 '_' 2 | 3 | let non_empty_string s = 4 | (* to protect against `ancient` segfaulting on statically allocated values *) 5 | if s = "" then empty_string else s 6 | 7 | module Kind = struct 8 | type t = 9 | | Doc 10 | | Module 11 | | Module_type 12 | | Class 13 | | Class_type 14 | | Method 15 | | Val of Typexpr.t 16 | | Type_decl of string option 17 | | Type_extension 18 | | Extension_constructor of Typexpr.t 19 | | Exception of Typexpr.t 20 | | Constructor of Typexpr.t 21 | | Field of Typexpr.t 22 | 23 | let equal = ( = ) 24 | 25 | let get_type t = 26 | match t with 27 | | Val typ | Extension_constructor typ | Exception typ | Constructor typ | Field typ -> 28 | Some typ 29 | | Doc | Module | Module_type | Class | Class_type | Method | Type_decl _ 30 | | Type_extension -> 31 | None 32 | end 33 | 34 | module Package = struct 35 | type t = 36 | { name : string 37 | ; version : string 38 | } 39 | 40 | let v ~name ~version = 41 | { name = non_empty_string name; version = non_empty_string version } 42 | 43 | let compare a b = String.compare a.name b.name 44 | let link { name; version } = "https://ocaml.org/p/" ^ name ^ "/" ^ version 45 | end 46 | 47 | type t = 48 | { name : string 49 | ; rhs : string option 50 | ; url : string 51 | ; kind : Kind.t 52 | ; cost : int 53 | ; doc_html : string 54 | ; pkg : Package.t 55 | } 56 | 57 | let string_compare_shorter a b = 58 | match Int.compare (String.length a) (String.length b) with 59 | | 0 -> String.compare a b 60 | | c -> c 61 | 62 | let structural_compare a b = 63 | match string_compare_shorter a.name b.name with 64 | | 0 -> begin 65 | match Package.compare a.pkg b.pkg with 66 | | 0 -> begin 67 | match Stdlib.compare a.kind b.kind with 68 | | 0 -> begin 69 | match string_compare_shorter a.doc_html b.doc_html with 70 | | 0 -> String.compare a.url b.url 71 | | c -> c 72 | end 73 | | c -> c 74 | end 75 | | c -> c 76 | end 77 | | c -> c 78 | 79 | let compare a b = 80 | if a == b 81 | then 0 82 | else begin 83 | match Int.compare a.cost b.cost with 84 | | 0 -> structural_compare a b 85 | | cmp -> cmp 86 | end 87 | 88 | let equal a b = compare a b = 0 89 | 90 | let stdlib_link ~name t = 91 | let path, hashref = 92 | match List.rev name, String.index_opt t.url '#' with 93 | | _ :: path, Some idx -> 94 | let idx = idx + 1 in 95 | let tgt = 96 | match String.index_from_opt t.url idx '-' with 97 | | None -> String.sub t.url idx (String.length t.url - idx) 98 | | Some jdx -> 99 | let kind = String.sub t.url idx (jdx - idx) in 100 | let jdx = jdx + 1 in 101 | let target = String.sub t.url jdx (String.length t.url - jdx) in 102 | String.uppercase_ascii kind ^ target 103 | in 104 | path, "#" ^ tgt 105 | | path, _ -> path, "" 106 | in 107 | let path = String.concat "." (List.rev path) in 108 | "https://v2.ocaml.org/releases/5.1/api/" ^ path ^ ".html" ^ hashref 109 | 110 | let link t = 111 | let fullname = String.split_on_char '.' t.name in 112 | match fullname with 113 | | "Stdlib" :: name -> stdlib_link ~name t 114 | | _ -> 115 | let pkg_link = Package.link t.pkg in 116 | let rec align n ys = 117 | match ys with 118 | | _ when n = 0 -> [] 119 | | [] -> [] 120 | | y :: ys -> y :: align (n - 1) ys 121 | in 122 | let length = List.length fullname in 123 | let length = 124 | match String.index_opt t.url '#' with 125 | | None -> length + 1 126 | | Some idx -> 127 | let tgt = String.sub t.url idx (String.length t.url - idx) in 128 | let count = ref 0 in 129 | String.iter 130 | (function 131 | | '.' -> incr count 132 | | _ -> ()) 133 | tgt ; 134 | length - !count 135 | in 136 | let path = align length (List.rev (String.split_on_char '/' t.url)) in 137 | let path = String.concat "/" (List.rev path) in 138 | pkg_link ^ "/doc/" ^ path 139 | 140 | let v ~name ~kind ~cost ~rhs ~doc_html ~url ~pkg () = 141 | { name = non_empty_string name 142 | ; kind 143 | ; url = non_empty_string url 144 | ; cost 145 | ; doc_html = non_empty_string doc_html 146 | ; pkg 147 | ; rhs = Option.map non_empty_string rhs 148 | } 149 | -------------------------------------------------------------------------------- /db/entry.mli: -------------------------------------------------------------------------------- 1 | module Kind : sig 2 | type t = 3 | | Doc 4 | | Module 5 | | Module_type 6 | | Class 7 | | Class_type 8 | | Method 9 | | Val of Typexpr.t 10 | | Type_decl of string option 11 | | Type_extension 12 | | Extension_constructor of Typexpr.t 13 | | Exception of Typexpr.t 14 | | Constructor of Typexpr.t 15 | | Field of Typexpr.t 16 | 17 | val equal : t -> t -> bool 18 | val get_type : t -> Typexpr.t option 19 | end 20 | 21 | module Package : sig 22 | type t = private 23 | { name : string 24 | ; version : string 25 | } 26 | 27 | val v : name:string -> version:string -> t 28 | val link : t -> string 29 | end 30 | 31 | type t = 32 | { name : string 33 | ; rhs : string option 34 | ; url : string 35 | ; kind : Kind.t 36 | ; cost : int 37 | ; doc_html : string 38 | ; pkg : Package.t 39 | } 40 | 41 | val v 42 | : name:string 43 | -> kind:Kind.t 44 | -> cost:int 45 | -> rhs:string option 46 | -> doc_html:string 47 | -> url:string 48 | -> pkg:Package.t 49 | -> unit 50 | -> t 51 | 52 | val link : t -> string 53 | val compare : t -> t -> int 54 | val equal : t -> t -> bool 55 | -------------------------------------------------------------------------------- /db/storage.ml: -------------------------------------------------------------------------------- 1 | module Occurences = Map.Make (Int) 2 | 3 | type db = 4 | { db_names : String_automata.t 5 | ; db_pos_types : String_automata.t Occurences.t 6 | ; db_neg_types : String_automata.t Occurences.t 7 | } 8 | 9 | module type S = sig 10 | type writer 11 | 12 | val open_out : string -> writer 13 | val save : db:writer -> db -> unit 14 | val close_out : writer -> unit 15 | val load : string -> db list 16 | end 17 | -------------------------------------------------------------------------------- /db/string_automata.ml: -------------------------------------------------------------------------------- 1 | type terminals = 2 | | Empty 3 | | Terminals of Entry.t array 4 | | Summary of Entry.t array 5 | 6 | type node = 7 | { start : int 8 | ; len : int 9 | ; size : int 10 | ; terminals : terminals 11 | ; children : node array option 12 | } 13 | 14 | type t = 15 | { str : string 16 | ; t : node 17 | } 18 | 19 | let empty = { start = 0; len = 0; size = 0; children = None; terminals = Empty } 20 | 21 | let empty () = 22 | (* avoid ancient segfaulting on statically allocated values *) 23 | Obj.obj @@ Obj.dup @@ Obj.repr empty 24 | 25 | let size t = t.t.size 26 | 27 | let minimum { t; _ } = 28 | match t.terminals with 29 | | Empty -> assert false 30 | | Terminals arr | Summary arr -> arr.(0) 31 | 32 | let array_find ~str chr arr = 33 | let rec go i = 34 | if i >= Array.length arr 35 | then None 36 | else begin 37 | let node = arr.(i) in 38 | if chr = str.[node.start - 1] then Some node else go (i + 1) 39 | end 40 | in 41 | go 0 42 | 43 | let array_find ~str chr = function 44 | | None -> None 45 | | Some arr -> array_find ~str chr arr 46 | 47 | let lcp i_str i j_str j j_len = 48 | let j_stop = j + j_len in 49 | let rec go_lcp i j = 50 | if i >= String.length i_str || j >= j_stop 51 | then i 52 | else begin 53 | let i_chr, j_chr = i_str.[i], j_str.[j] in 54 | if i_chr <> j_chr then i else go_lcp (i + 1) (j + 1) 55 | end 56 | in 57 | let i' = go_lcp i j in 58 | i' - i 59 | 60 | let rec find ~str node pattern i = 61 | if i >= String.length pattern 62 | then Some node 63 | else begin 64 | match array_find ~str pattern.[i] node.children with 65 | | None -> None 66 | | Some child -> find_lcp ~str child pattern (i + 1) 67 | end 68 | 69 | and find_lcp ~str child pattern i = 70 | let n = lcp pattern i str child.start child.len in 71 | if i + n = String.length pattern 72 | then Some { child with start = child.start + n; len = child.len - n } 73 | else if n = child.len 74 | then find ~str child pattern (i + n) 75 | else None 76 | 77 | let find t pattern = 78 | match find_lcp ~str:t.str t.t pattern 0 with 79 | | None -> None 80 | | Some child -> Some { str = t.str; t = child } 81 | 82 | let advance node = 83 | assert (node.len >= 1) ; 84 | { node with start = node.start + 1; len = node.len - 1 } 85 | 86 | let stepback node = 87 | assert (node.len >= 0) ; 88 | { node with start = node.start - 1; len = node.len + 1 } 89 | 90 | let rec find_skip ~spaces t pattern yield = 91 | let skip () = 92 | let node = t.t in 93 | if node.len >= 1 94 | then begin 95 | let spaces = spaces + if t.str.[node.start] = ' ' then 1 else 0 in 96 | if spaces > 1 97 | then () 98 | else find_skip ~spaces { t with t = advance t.t } pattern yield 99 | end 100 | else begin 101 | match node.children with 102 | | None -> () 103 | | Some children -> 104 | Array.iter 105 | (fun child -> find_skip ~spaces { t with t = stepback child } pattern yield) 106 | children 107 | end 108 | in 109 | if spaces = 0 110 | then skip () 111 | else if spaces = 1 && pattern = Type_polarity.poly 112 | then begin 113 | match find t pattern with 114 | | None -> () 115 | | Some here -> yield here 116 | end 117 | else begin 118 | skip () ; 119 | match find t pattern with 120 | | None -> () 121 | | Some here -> yield here 122 | end 123 | 124 | let find_star t pattern yield = 125 | let rec go t = function 126 | | [] -> yield t 127 | | p :: ps -> find_skip ~spaces:0 t p @@ fun t -> go t ps 128 | in 129 | match String.split_on_char ' ' pattern with 130 | | [] -> () 131 | | p :: ps -> begin 132 | match find t p with 133 | | None -> () 134 | | Some t -> go t ps 135 | end 136 | 137 | let find_star t pattern = 138 | let found = ref [] in 139 | find_star t pattern (fun t -> found := t :: !found) ; 140 | !found 141 | -------------------------------------------------------------------------------- /db/string_automata.mli: -------------------------------------------------------------------------------- 1 | (* A string automata, constructed from a suffix tree and optimized 2 | for fast queries and small serialization. *) 3 | 4 | type terminals = 5 | | Empty 6 | | Terminals of Entry.t array 7 | | Summary of Entry.t array 8 | 9 | type node = 10 | { start : int 11 | ; len : int 12 | ; size : int 13 | ; terminals : terminals 14 | ; children : node array option 15 | } 16 | 17 | type t = 18 | { str : string 19 | ; t : node 20 | } 21 | 22 | val empty : unit -> node 23 | val find : t -> string -> t option 24 | val find_star : t -> string -> t list 25 | val minimum : t -> Entry.t 26 | val size : t -> int 27 | -------------------------------------------------------------------------------- /db/type_polarity.ml: -------------------------------------------------------------------------------- 1 | open Typexpr 2 | 3 | module Sign = struct 4 | type t = 5 | | Pos 6 | | Neg 7 | 8 | let to_string = function 9 | | Pos -> "+" 10 | | Neg -> "-" 11 | 12 | let not = function 13 | | Pos -> Neg 14 | | Neg -> Pos 15 | end 16 | 17 | let rev_concat lst = List.fold_left (fun acc xs -> List.rev_append xs acc) [] lst 18 | 19 | type t = string * int * Sign.t 20 | 21 | let poly = "@" 22 | 23 | let rec of_typ ~any_is_poly ~prefix ~sgn = function 24 | | Poly _ -> [ sgn, poly :: prefix ] 25 | | Any -> if any_is_poly then [ sgn, poly :: prefix ] else [ sgn, prefix ] 26 | | Arrow (a, b) -> 27 | List.rev_append 28 | (of_typ ~any_is_poly ~prefix ~sgn:(Sign.not sgn) a) 29 | (of_typ ~any_is_poly ~prefix ~sgn b) 30 | | Constr (name, args) -> begin 31 | let prefix = String.lowercase_ascii name :: prefix in 32 | match args with 33 | | [] -> [ sgn, prefix ] 34 | | _ -> 35 | rev_concat 36 | @@ List.mapi 37 | (fun i arg -> 38 | let prefix = string_of_int i :: prefix in 39 | of_typ ~any_is_poly ~prefix ~sgn arg) 40 | args 41 | end 42 | | Tuple args -> rev_concat @@ List.map (of_typ ~any_is_poly ~prefix ~sgn) @@ args 43 | | Unhandled -> [] 44 | 45 | let regroup lst = 46 | let h = Hashtbl.create 16 in 47 | List.iter 48 | (fun v -> 49 | let count = 50 | try Hashtbl.find h v with 51 | | Not_found -> 0 52 | in 53 | Hashtbl.replace h v (count + 1)) 54 | lst ; 55 | Hashtbl.to_seq h 56 | 57 | let of_typ ~any_is_poly t = 58 | t 59 | |> of_typ ~any_is_poly ~prefix:[] ~sgn:Pos 60 | |> List.map (fun (polarity, path) -> polarity, String.concat " " (List.rev path)) 61 | |> regroup 62 | |> Seq.map (fun ((polarity, path), count) -> path, count, polarity) 63 | -------------------------------------------------------------------------------- /db/type_polarity.mli: -------------------------------------------------------------------------------- 1 | (** This module provide a way to transform a type into strings, in such a way 2 | that the strings can be used for type search. 3 | 4 | The chosen representation is polarity : we do not represent the [->] or the [*] 5 | constructors, but instead compute the "polarity" of every type name/constructor 6 | like [int] or ['a] that is part of the whole type expression. 7 | 8 | The polarity of a component of a type indicates if it is produced or consumed by 9 | the type. In the type [int -> string], [int] has negative polarity because it is 10 | being consumed, and [string] has positive polarity because it is being produced. 11 | We say that the polarities of [int -> string] are [-int] and [+string]. 12 | 13 | Once you have computed the polarities of the type of an entry [e], you can 14 | register each polarity as corresponding to [e] in the search database. 15 | 16 | Then, when the user queries for a type, we compute the polarities of the query 17 | type, and search for the entries. 18 | 19 | We then return the result corresponding to intersection of each polarity: if the 20 | user queries for [int -> string], we want to have every entry which consumes an 21 | [int] and produces a [string], that is the intersection of the entries 22 | associated to [-int] with the entries associated to [+string]. 23 | 24 | How is polarity computed exactly ? When you have [t -> u], the polarity of [t] 25 | is inversed, and the polarity of [u] stays the same. A good example of this is 26 | the type of {!Stdlib.Out_channel.with_open_gen} : 27 | 28 | {[ 29 | val with_open_gen : open_flag list -> int -> string -> (t -> 'a) -> 'a 30 | ]} 31 | 32 | Here the polarities are [-open_flag list], [-int], [-string], [+Out_channel.t], 33 | [-'a] and [+'a]. The fact that we have [+Out_channel.t] might be puzzling at 34 | first, because an [Out_channel.t] is not returned by the function, but 35 | {!Stdlib.Out_channel.with_open_gen} is indeed one of the possible ways to create 36 | an [Out_channel.t]. 37 | 38 | There is however a complication. If the user queries for [int -> int -> string], 39 | then the polarities will be [-int], [-int] and [+string]. An entry of type [int 40 | tring] would be included in the intersection of these polarities. But the 41 | user explicitely asked for two integers to be consumed. To fix this issue, we 42 | track the number of occurences of each polarity. 43 | 44 | The polarities for [int -> int -> string], become [(-int, 2)] and [(+string, 1)] 45 | and allows us to filter entries according to this information. 46 | 47 | There is a mechanism for types with parameters like ['a list]. I might explain 48 | it in the future. 49 | TODO : Give an example even if not the full explanation. *) 50 | 51 | module Sign : sig 52 | type t = 53 | | Pos 54 | | Neg 55 | 56 | val to_string : t -> string 57 | val not : t -> t 58 | end 59 | 60 | type t = string * int * Sign.t 61 | (** The search database is a suffix tree structure, implemented in 62 | {!Suffix_tree}. It is a solely text-based datastructure. Therefore, we need 63 | a text represention for the polarities. 64 | 65 | The polarity [+t] is represented by ["+t"], and the polarity [-t] is 66 | represented by ["-t"]. 67 | 68 | The fact that the sign is in the front is important : ["+flo"] is a prefix of 69 | ["+float"], but ["flo+"] is not a prefix nor a suffix of ["float+"]. This 70 | allows to answer incomplete queries. 71 | 72 | The integer represents the occurences of the polarity, as explained in the 73 | toplevel documentation of the module. *) 74 | 75 | val of_typ : any_is_poly:bool -> Typexpr.t -> t Seq.t 76 | (** [of_typ ~ignore_any ~all_names typ] is the list of polarised types 77 | corresponding to [typ]. 78 | 79 | - If [any_is_poly] is true, the type [_] will be treated like a type variable 80 | ['a], otherwise it will be represented solely by its sign ("+" or "-"). *) 81 | 82 | val poly : string 83 | -------------------------------------------------------------------------------- /db/typexpr.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Arrow of t * t 3 | | Constr of string * t list 4 | | Tuple of t list 5 | | Poly of string 6 | | Any 7 | | Unhandled 8 | 9 | let tuple = function 10 | | [] -> Any 11 | | [ x ] -> x 12 | | xs -> Tuple xs 13 | 14 | let rec show = function 15 | | Arrow (a, b) -> show_parens a ^ " -> " ^ show b 16 | | Constr (t, []) -> t 17 | | Constr (t, [ x ]) -> show_parens x ^ " " ^ t 18 | | Constr (t, xs) -> "(" ^ show_list xs ^ ") " ^ t 19 | | Tuple xs -> show_tuple xs 20 | | Poly "" -> "'_" 21 | | Poly name -> "'" ^ name 22 | | Any -> "_" 23 | | Unhandled -> "???" 24 | 25 | and show_parens t = 26 | match t with 27 | | Arrow _ | Tuple _ -> "(" ^ show t ^ ")" 28 | | _ -> show t 29 | 30 | and show_list = function 31 | | [] -> failwith "show_list: empty" 32 | | [ x ] -> show x 33 | | x :: xs -> show x ^ ", " ^ show_list xs 34 | 35 | and show_tuple = function 36 | | [] -> failwith "show_tuple: empty" 37 | | [ x ] -> show_parens x 38 | | x :: xs -> show_parens x ^ " * " ^ show_tuple xs 39 | 40 | let size typ = typ |> show |> String.length 41 | let equal = Stdlib.( = ) 42 | let hash = Hashtbl.hash 43 | -------------------------------------------------------------------------------- /db/typexpr.mli: -------------------------------------------------------------------------------- 1 | type t = 2 | | Arrow of t * t 3 | | Constr of string * t list 4 | | Tuple of t list 5 | | Poly of string 6 | | Any 7 | | Unhandled 8 | 9 | val tuple : t list -> t 10 | val size : t -> int 11 | val show : t -> string 12 | val equal : t -> t -> bool 13 | val hash : t -> int 14 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.5) 2 | 3 | (cram enable) 4 | 5 | (using menhir 2.1) 6 | 7 | (generate_opam_files true) 8 | 9 | (name sherlodoc) 10 | 11 | (version 0.2) 12 | 13 | (source (github art-w/sherlodoc)) 14 | 15 | (authors "Arthur Wendling" "Emile Trotignon") 16 | 17 | (maintainers "art.wendling@gmail.com") 18 | 19 | (license MIT) 20 | 21 | (using directory-targets 0.1) 22 | 23 | (package 24 | (name sherlodoc) 25 | (synopsis "Search engine for OCaml documentation") 26 | (depends 27 | (ocaml (>= 4.0.8)) 28 | (odoc (>= 2.4.0)) 29 | (base64 (>= 3.5.1)) 30 | (bigstringaf (>= 0.9.1)) 31 | (js_of_ocaml (>= 5.6.0)) 32 | (brr (>= 0.0.6)) 33 | (cmdliner (>= 1.2.0)) 34 | (decompress (>= 1.5.3)) 35 | (fpath (>= 0.7.3)) 36 | (lwt (>= 5.7.0)) 37 | (menhir (>= 20230608)) 38 | (ppx_blob (>= 0.7.2)) 39 | (tyxml (>= 4.6.0)) 40 | (result (>= 1.5)) 41 | (odig :with-test) 42 | (base (and :with-test (= v0.16.3))) 43 | (alcotest :with-test)) 44 | (depopts 45 | (dream (>= 1.0.0~alpha5)) 46 | (ancient (>= 0.9.1)))) 47 | -------------------------------------------------------------------------------- /dune-workspace: -------------------------------------------------------------------------------- 1 | (lang dune 3.5) 2 | 3 | (profile release) 4 | -------------------------------------------------------------------------------- /index/db_writer.ml: -------------------------------------------------------------------------------- 1 | open Db 2 | 3 | type s = 4 | { mutable load : int 5 | ; writer_names : Suffix_tree.t 6 | ; buffer_types : Suffix_tree.Buf.t 7 | ; mutable writer_pos_types : Suffix_tree.t Occurences.t 8 | ; mutable writer_neg_types : Suffix_tree.t Occurences.t 9 | ; type_cache : Type_cache.t 10 | } 11 | 12 | type t = s ref 13 | 14 | let load t = !t.load 15 | 16 | let make_empty () = 17 | let buffer_names = Suffix_tree.Buf.make () in 18 | let buffer_types = Suffix_tree.Buf.make () in 19 | { load = 0 20 | ; writer_names = Suffix_tree.make buffer_names 21 | ; buffer_types 22 | ; writer_pos_types = Occurences.empty 23 | ; writer_neg_types = Occurences.empty 24 | ; type_cache = Type_cache.make () 25 | } 26 | 27 | let make () = ref (make_empty ()) 28 | 29 | let export ~summarize db = 30 | let shard = 31 | let db = !db in 32 | let db_names = Suffix_tree.export ~summarize db.writer_names in 33 | let db_pos_types = 34 | Occurences.map (Suffix_tree.export ~summarize) db.writer_pos_types 35 | in 36 | let db_neg_types = 37 | Occurences.map (Suffix_tree.export ~summarize) db.writer_neg_types 38 | in 39 | { Storage.db_names; db_pos_types; db_neg_types } 40 | in 41 | db := make_empty () ; 42 | shard 43 | 44 | let store db name elt ~count ~polarity = 45 | db.load <- db.load + 1 ; 46 | let st = 47 | match polarity with 48 | | Type_polarity.Sign.Pos -> begin 49 | try Occurences.find count db.writer_pos_types with 50 | | Not_found -> 51 | let st = Suffix_tree.make db.buffer_types in 52 | db.writer_pos_types <- Occurences.add count st db.writer_pos_types ; 53 | st 54 | end 55 | | Type_polarity.Sign.Neg -> begin 56 | try Occurences.find count db.writer_neg_types with 57 | | Not_found -> 58 | let st = Suffix_tree.make db.buffer_types in 59 | db.writer_neg_types <- Occurences.add count st db.writer_neg_types ; 60 | st 61 | end 62 | in 63 | Suffix_tree.add_suffixes st name elt 64 | 65 | let store_type_polarities db elt polarities = 66 | let db = !db in 67 | Seq.iter (fun (path, count, polarity) -> store db ~count ~polarity path elt) polarities 68 | 69 | let store_word db word elt = 70 | let db = !db in 71 | db.load <- db.load + 1 ; 72 | Suffix_tree.add_suffixes db.writer_names word elt 73 | 74 | let type_of_odoc ~db ty = 75 | let db = !db in 76 | Type_cache.of_odoc ~cache:db.type_cache ty 77 | -------------------------------------------------------------------------------- /index/db_writer.mli: -------------------------------------------------------------------------------- 1 | type t 2 | (** The type that builds a database. You can use it to add things to it, but 3 | you cannot make queries on it. *) 4 | 5 | val export : summarize:bool -> t -> Db.t 6 | 7 | val make : unit -> t 8 | (** [make ()] returns an empty search database. *) 9 | 10 | val load : t -> int 11 | val type_of_odoc : db:t -> Odoc_model.Lang.TypeExpr.t -> Db.Typexpr.t 12 | val store_type_polarities : t -> Db.Entry.t -> Db.Type_polarity.t Seq.t -> unit 13 | val store_word : t -> string -> Db.Entry.t -> unit 14 | -------------------------------------------------------------------------------- /index/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name index) 3 | (libraries 4 | db 5 | db_store 6 | fpath 7 | tyxml 8 | odoc.search 9 | odoc.model 10 | odoc.odoc 11 | cmdliner)) 12 | -------------------------------------------------------------------------------- /index/index.ml: -------------------------------------------------------------------------------- 1 | let index_file register filename = 2 | match Fpath.of_string filename with 3 | | Error (`Msg msg) -> Format.printf "FILE ERROR %s: %s@." filename msg 4 | | Ok file -> 5 | let open Odoc_model in 6 | let page p = 7 | let id = p.Lang.Page.name in 8 | Fold.page ~f:(register (id :> Paths.Identifier.t)) () p 9 | in 10 | let unit u = 11 | let id = u.Lang.Compilation_unit.id in 12 | Fold.unit ~f:(register (id :> Paths.Identifier.t)) () u 13 | in 14 | (match Odoc_odoc.Indexing.handle_file ~page ~unit file with 15 | | Ok result -> result 16 | | Error (`Msg msg) -> Format.printf "Odoc warning or error %s: %s@." filename msg) 17 | 18 | let main 19 | files 20 | favourite_files 21 | file_list 22 | index_docstring 23 | index_name 24 | type_search 25 | favoured_prefixes 26 | db_format 27 | db_filename 28 | = 29 | let module Storage = (val Db_store.storage_module db_format) in 30 | let db = Db_writer.make () in 31 | let no_pkg = Db.Entry.Package.v ~name:"" ~version:"" in 32 | let register ~pkg ~favourite id () item = 33 | List.iter 34 | (Load_doc.register_entry 35 | ~db 36 | ~index_docstring 37 | ~index_name 38 | ~type_search 39 | ~favourite 40 | ~favoured_prefixes 41 | ~pkg) 42 | (Odoc_search.Entry.entries_of_item id item) 43 | in 44 | let files = 45 | match file_list with 46 | | None -> files 47 | | Some file_list -> 48 | let h = open_in file_list in 49 | let rec read_all acc = 50 | match Stdlib.input_line h with 51 | | exception End_of_file -> List.rev acc 52 | | line -> read_all (line :: acc) 53 | in 54 | let other_files = read_all [] in 55 | close_in h ; 56 | files @ other_files 57 | in 58 | let h = Storage.open_out db_filename in 59 | let flush () = 60 | let t = Db_writer.export ~summarize:(db_format = `ancient) db in 61 | Storage.save ~db:h t 62 | in 63 | let loop ~favourite odoc = 64 | let pkg, odoc = 65 | match String.split_on_char '\t' odoc with 66 | | [ filename ] -> no_pkg, filename 67 | | [ name; filename ] -> Db.Entry.Package.v ~name ~version:"", filename 68 | | [ name; version; filename ] -> Db.Entry.Package.v ~name ~version, filename 69 | | _ -> failwith ("invalid line: " ^ odoc) 70 | in 71 | index_file (register ~pkg ~favourite) odoc ; 72 | if db_format = `ancient && Db_writer.load db > 1_000_000 then flush () 73 | in 74 | List.iter (loop ~favourite:false) files ; 75 | List.iter (loop ~favourite:true) favourite_files ; 76 | flush () ; 77 | Storage.close_out h 78 | 79 | open Cmdliner 80 | 81 | let index_docstring = 82 | let doc = "Use the docstring to index the results." in 83 | Arg.(value & opt bool true & info ~doc [ "index-docstring" ]) 84 | 85 | let index_name = 86 | let doc = "Use the name to index the results." in 87 | Arg.(value & opt bool true & info ~doc [ "index-name" ]) 88 | 89 | let type_search = 90 | let doc = "Enable type based search." in 91 | Arg.(value & opt bool true & info ~doc [ "type-search" ]) 92 | 93 | let favoured_prefixes = 94 | let doc = 95 | "The list of favoured prefixes. Entries that start with a favoured prefix are ranked \ 96 | higher." 97 | in 98 | Arg.(value & opt (list string) [ "Stdlib." ] & info ~doc [ "favoured-prefixes" ]) 99 | 100 | let file_list = 101 | let doc = 102 | "File containing a list of .odocl files.\n\ 103 | Useful for system where there is a limit on the number of arguments to a command." 104 | in 105 | Arg.(value & opt (some file) None & info [ "file-list" ] ~doc) 106 | 107 | let odoc_favourite_file = 108 | let doc = "Path to a .odocl file whose entries will be ranked higher." in 109 | Arg.(value & opt_all file [] & info [ "favoured" ] ~doc) 110 | 111 | let odoc_files = 112 | let doc = "Path to a .odocl file" in 113 | Arg.(value & (pos_all file [] @@ info ~doc ~docv:"ODOCL_FILE" [])) 114 | 115 | let term = 116 | Term.( 117 | const main 118 | $ odoc_files 119 | $ odoc_favourite_file 120 | $ file_list 121 | $ index_docstring 122 | $ index_name 123 | $ type_search 124 | $ favoured_prefixes) 125 | -------------------------------------------------------------------------------- /index/index.mli: -------------------------------------------------------------------------------- 1 | val term : (Db_store.db_format -> string -> unit) Cmdliner.Term.t 2 | -------------------------------------------------------------------------------- /index/load_doc.ml: -------------------------------------------------------------------------------- 1 | module Entry = Db.Entry 2 | module Db_common = Db 3 | module ModuleName = Odoc_model.Names.ModuleName 4 | 5 | let string_starts_with ~prefix str = 6 | let rec go i = 7 | if i >= String.length prefix then true else prefix.[i] = str.[i] && go (i + 1) 8 | in 9 | String.length prefix <= String.length str && go 0 10 | 11 | let path_length str = 12 | let rec go i acc = 13 | if i >= String.length str 14 | then acc 15 | else go (i + 1) (if str.[i] = '.' then acc + 1 else acc) 16 | in 17 | go 0 0 18 | 19 | let kind_cost = function 20 | | Entry.Kind.Constructor _ | Entry.Kind.Exception _ | Entry.Kind.Extension_constructor _ 21 | | Entry.Kind.Field _ | Entry.Kind.Module | Entry.Kind.Type_decl _ 22 | | Entry.Kind.Type_extension | Entry.Kind.Val _ -> 23 | 0 24 | | _ -> 50 25 | 26 | let rhs_cost = function 27 | | Some str -> String.length str 28 | | None -> 20 29 | 30 | let cost_doc = function 31 | | Entry.Kind.Constructor _ | Entry.Kind.Exception _ | Entry.Kind.Extension_constructor _ 32 | | Entry.Kind.Field _ | Entry.Kind.Module | Entry.Kind.Module_type 33 | | Entry.Kind.Type_decl _ | Entry.Kind.Type_extension -> 34 | 0 35 | | _ -> 100 36 | 37 | let cost ~name ~kind ~doc_html ~rhs ~cat ~favourite ~favoured_prefixes = 38 | String.length name 39 | + (5 * path_length name) 40 | + (if List.exists (fun prefix -> string_starts_with ~prefix name) favoured_prefixes 41 | then 0 42 | else 50) 43 | + (if favourite then 0 else 50) 44 | + rhs_cost rhs 45 | + kind_cost kind 46 | + (if cat = `definition then 0 else 100) 47 | + if doc_html <> "" then 0 else cost_doc kind 48 | 49 | let string_of_html = Format.asprintf "%a" (Tyxml.Html.pp_elt ()) 50 | 51 | let with_tokenizer str fn = 52 | let str = String.lowercase_ascii str in 53 | let buf = Buffer.create 16 in 54 | let flush () = 55 | let word = Buffer.contents buf in 56 | if word <> "" then fn word ; 57 | Buffer.clear buf 58 | in 59 | let rec go i = 60 | if i >= String.length str 61 | then flush () 62 | else ( 63 | let chr = str.[i] in 64 | if (chr >= 'a' && chr <= 'z') 65 | || (chr >= '0' && chr <= '9') 66 | || chr = '_' 67 | || chr = '@' 68 | then Buffer.add_char buf chr 69 | else flush () ; 70 | go (i + 1)) 71 | in 72 | go 0 73 | 74 | let register_doc ~db elt doc_txt = 75 | with_tokenizer doc_txt @@ fun word -> Db_writer.store_word db word elt 76 | 77 | let register_full_name ~db (elt : Db.Entry.t) = 78 | let name = String.lowercase_ascii elt.name in 79 | Db_writer.store_word db name elt 80 | 81 | let searchable_type_of_constructor args res = 82 | let open Odoc_model.Lang in 83 | match args with 84 | | TypeDecl.Constructor.Tuple args -> begin 85 | match args with 86 | | _ :: _ :: _ -> TypeExpr.(Arrow (None, Tuple args, res)) 87 | | [ arg ] -> TypeExpr.(Arrow (None, arg, res)) 88 | | _ -> res 89 | end 90 | | TypeDecl.Constructor.Record fields -> 91 | List.fold_left 92 | (fun res field -> 93 | let open TypeDecl.Field in 94 | let field_name = Odoc_model.Paths.Identifier.name field.id in 95 | TypeExpr.Arrow (Some (Label field_name), field.type_, res)) 96 | res 97 | fields 98 | 99 | let searchable_type_of_record parent_type type_ = 100 | Odoc_model.Lang.TypeExpr.Arrow (None, parent_type, type_) 101 | 102 | let convert_kind ~db (Odoc_search.Entry.{ kind; _ } as entry) = 103 | match kind with 104 | | TypeDecl _ -> Entry.Kind.Type_decl (Odoc_search.Html.typedecl_params_of_entry entry) 105 | | Value { value = _; type_ } -> 106 | let typ = Db_writer.type_of_odoc ~db type_ in 107 | Entry.Kind.Val typ 108 | | Constructor { args; res } -> 109 | let typ = searchable_type_of_constructor args res in 110 | let typ = Db_writer.type_of_odoc ~db typ in 111 | Entry.Kind.Constructor typ 112 | | ExtensionConstructor { args; res } -> 113 | let typ = searchable_type_of_constructor args res in 114 | let typ = Db_writer.type_of_odoc ~db typ in 115 | Entry.Kind.Extension_constructor typ 116 | | Exception { args; res } -> 117 | let typ = searchable_type_of_constructor args res in 118 | let typ = Db_writer.type_of_odoc ~db typ in 119 | Entry.Kind.Exception typ 120 | | Field { mutable_ = _; parent_type; type_ } -> 121 | let typ = searchable_type_of_record parent_type type_ in 122 | let typ = Db_writer.type_of_odoc ~db typ in 123 | Entry.Kind.Field typ 124 | | Doc _ -> Doc 125 | | Class_type _ -> Class_type 126 | | Method _ -> Method 127 | | Class _ -> Class 128 | | TypeExtension _ -> Type_extension 129 | | Module -> Entry.Kind.Module 130 | | ModuleType -> Module_type 131 | 132 | let register_type_expr ~db elt typ = 133 | let type_polarities = Db.Type_polarity.of_typ ~any_is_poly:true typ in 134 | Db_writer.store_type_polarities db elt type_polarities 135 | 136 | let register_kind ~db elt = 137 | let open Db.Entry in 138 | match Kind.get_type elt.kind with 139 | | None -> () 140 | | Some typ -> register_type_expr ~db elt typ 141 | 142 | let rec categorize id = 143 | let open Odoc_model.Paths in 144 | match id.Identifier.iv with 145 | | `CoreType _ | `CoreException _ | `Root _ | `Page _ | `LeafPage _ -> `definition 146 | | `ModuleType _ -> `declaration 147 | | `Parameter _ -> `ignore (* redundant with indexed signature *) 148 | | ( `InstanceVariable _ | `Method _ | `Field _ | `Result _ | `Label _ | `Type _ 149 | | `Exception _ | `Class _ | `ClassType _ | `Value _ | `Constructor _ | `Extension _ 150 | | `ExtensionDecl _ | `Module _ ) as x -> 151 | let parent = Identifier.label_parent { id with iv = x } in 152 | categorize (parent :> Identifier.Any.t) 153 | | `AssetFile _ | `SourceDir _ | `SourceLocationMod _ | `SourceLocation _ | `SourcePage _ 154 | | `SourceLocationInternal _ -> 155 | `ignore (* unclear what to do with those *) 156 | 157 | let categorize Odoc_search.Entry.{ id; _ } = 158 | match id.iv with 159 | | `ModuleType (parent, _) -> 160 | (* A module type itself is not *from* a module type, but it might be if one 161 | of its parents is a module type. *) 162 | categorize (parent :> Odoc_model.Paths.Identifier.Any.t) 163 | | _ -> categorize id 164 | 165 | let register_entry 166 | ~db 167 | ~index_name 168 | ~type_search 169 | ~index_docstring 170 | ~favourite 171 | ~favoured_prefixes 172 | ~pkg 173 | ~cat 174 | (Odoc_search.Entry.{ id; doc; kind } as entry) 175 | = 176 | let module Sherlodoc_entry = Entry in 177 | let open Odoc_search in 178 | let name = String.concat "." (Odoc_model.Paths.Identifier.fullname id) in 179 | let doc_txt = Text.of_doc doc in 180 | let doc_html = 181 | match doc_txt with 182 | | "" -> "" 183 | | _ -> string_of_html (Html.of_doc doc) 184 | in 185 | let rhs = Html.rhs_of_kind kind in 186 | let kind = convert_kind ~db entry in 187 | let cost = cost ~name ~kind ~doc_html ~rhs ~cat ~favourite ~favoured_prefixes in 188 | let url = Result.get_ok (Html.url id) in 189 | let elt = Sherlodoc_entry.v ~name ~kind ~rhs ~doc_html ~cost ~url ~pkg () in 190 | if index_docstring then register_doc ~db elt doc_txt ; 191 | if index_name && kind <> Doc then register_full_name ~db elt ; 192 | if type_search then register_kind ~db elt 193 | 194 | let register_entry 195 | ~db 196 | ~index_name 197 | ~type_search 198 | ~index_docstring 199 | ~favourite 200 | ~favoured_prefixes 201 | ~pkg 202 | (Odoc_search.Entry.{ id; kind; _ } as entry) 203 | = 204 | let cat = categorize entry in 205 | let is_pure_documentation = 206 | match kind with 207 | | Doc _ -> true 208 | | _ -> false 209 | in 210 | if is_pure_documentation || cat = `ignore || Odoc_model.Paths.Identifier.is_internal id 211 | then () 212 | else 213 | register_entry 214 | ~db 215 | ~index_name 216 | ~type_search 217 | ~index_docstring 218 | ~favourite 219 | ~favoured_prefixes 220 | ~pkg 221 | ~cat 222 | entry 223 | -------------------------------------------------------------------------------- /index/load_doc.mli: -------------------------------------------------------------------------------- 1 | val register_entry 2 | : db:Db_writer.t 3 | -> index_name:bool 4 | -> type_search:bool 5 | -> index_docstring:bool 6 | -> favourite:bool 7 | -> favoured_prefixes:string list 8 | -> pkg:Db.Entry.Package.t 9 | -> Odoc_search.Entry.t 10 | -> unit 11 | (** [register_entry ~db ~index_name ~type_search ~index_docstring e] register 12 | the entry [e] in [db]. *) 13 | -------------------------------------------------------------------------------- /index/suffix_tree.ml: -------------------------------------------------------------------------------- 1 | module Doc = struct 2 | type 'a t = 3 | { uid : 'a 4 | ; text : string 5 | } 6 | 7 | let length t = String.length t.text + 1 8 | 9 | type 'a v = 10 | | Terminal of 'a 11 | | Char of char 12 | 13 | let get t i = if i >= String.length t.text then Terminal t.uid else Char t.text.[i] 14 | let sub { text; _ } i = String.sub text i (String.length text - i) 15 | end 16 | 17 | module Buf = struct 18 | (* Cache small strings as slices in one bigstring. *) 19 | 20 | module String_hashtbl = Hashtbl.Make (struct 21 | type t = string 22 | 23 | let equal = String.equal 24 | let hash = Hashtbl.hash 25 | end) 26 | 27 | type t = 28 | { buffer : Buffer.t 29 | ; cache : int String_hashtbl.t 30 | ; mutable contents : string option 31 | } 32 | 33 | let make () = 34 | { buffer = Buffer.create 16; cache = String_hashtbl.create 16; contents = None } 35 | 36 | let contents t = 37 | match t.contents with 38 | | Some contents -> contents 39 | | None -> 40 | let contents = Buffer.contents t.buffer in 41 | t.contents <- Some contents ; 42 | contents 43 | 44 | let get t i = Buffer.nth t.buffer i 45 | 46 | let add { buffer; cache; contents } substr = 47 | assert (contents = None) ; 48 | match String_hashtbl.find_opt cache substr with 49 | | Some start -> start 50 | | None -> 51 | let start = Buffer.length buffer in 52 | Buffer.add_string buffer substr ; 53 | let stop = Buffer.length buffer in 54 | assert (stop - start = String.length substr) ; 55 | for idx = 1 to String.length substr - 1 do 56 | String_hashtbl.add 57 | cache 58 | (String.sub substr idx (String.length substr - idx)) 59 | (start + idx) 60 | done ; 61 | start 62 | end 63 | 64 | module Entry = Db.Entry 65 | 66 | module Uid = struct 67 | type t = int 68 | 69 | let gen = ref 0 70 | 71 | let make () = 72 | let u = !gen in 73 | gen := u + 1 ; 74 | u 75 | end 76 | 77 | module Terminals = struct 78 | type t = Entry.t list 79 | 80 | let empty = [] 81 | let singleton x = [ x ] 82 | 83 | let add ~hint x xs = 84 | match hint with 85 | | Some (prev_xs, xxs) when prev_xs == xs -> xxs 86 | | _ -> x :: xs 87 | 88 | let hash = Hashtbl.hash 89 | 90 | let rec equal xs ys = 91 | match xs, ys with 92 | | [], [] -> true 93 | | x :: xs, y :: ys when x == y -> equal xs ys 94 | | _ -> false 95 | 96 | let equal xs ys = xs == ys || equal xs ys 97 | 98 | let mem x = function 99 | | y :: _ -> Entry.equal x y 100 | | _ -> false 101 | end 102 | 103 | module Char_map = Map.Make (Char) 104 | 105 | type node = 106 | { mutable start : int 107 | ; mutable len : int 108 | ; mutable suffix_link : node option 109 | ; mutable terminals : Terminals.t 110 | ; mutable children : node Char_map.t 111 | } 112 | 113 | type t = 114 | { buffer : Buf.t 115 | ; root : node 116 | } 117 | 118 | let make_root () = 119 | { start = 0 120 | ; len = 0 121 | ; suffix_link = None 122 | ; terminals = Terminals.empty 123 | ; children = Char_map.empty 124 | } 125 | 126 | let make buffer = { root = make_root (); buffer } 127 | 128 | let split_at ~str node len = 129 | let split_chr = Buf.get str (node.start + len) in 130 | let new_node = 131 | { start = node.start 132 | ; len 133 | ; suffix_link = None 134 | ; terminals = Terminals.empty 135 | ; children = Char_map.singleton split_chr node 136 | } 137 | in 138 | node.start <- node.start + len + 1 ; 139 | node.len <- node.len - 1 - len ; 140 | new_node 141 | 142 | let lcp i_str i j_str j j_len = 143 | let j_stop = j + j_len in 144 | let rec go_lcp i j = 145 | if i >= String.length i_str || j >= j_stop 146 | then i 147 | else ( 148 | let i_chr, j_chr = i_str.[i], Buf.get j_str j in 149 | if i_chr <> j_chr then i else go_lcp (i + 1) (j + 1)) 150 | in 151 | let i' = go_lcp i j in 152 | i' - i 153 | 154 | let make_leaf ~prev_leaf ~buffer ~doc str_start = 155 | let start = 156 | match prev_leaf with 157 | | None -> 158 | let substr = Doc.sub doc (str_start - 1) in 159 | let start = Buf.add buffer substr in 160 | start + 1 161 | | Some (prev_leaf, _depth, _) -> 162 | let doc_len = Doc.length doc in 163 | prev_leaf.start + prev_leaf.len - (doc_len - str_start) + 1 164 | in 165 | let len = Doc.length doc - str_start - 1 in 166 | assert (start > 0) ; 167 | { start 168 | ; len 169 | ; suffix_link = None 170 | ; terminals = Terminals.singleton doc.Doc.uid 171 | ; children = Char_map.empty 172 | } 173 | 174 | let set_suffix_link ~prev ~depth node = 175 | match prev with 176 | | Some (prev, prev_depth) when depth = prev_depth -> 177 | begin 178 | match prev.suffix_link with 179 | | None -> prev.suffix_link <- Some node 180 | | Some node' -> assert (node == node') 181 | end ; 182 | None 183 | | _ -> prev 184 | 185 | let add_document trie doc = 186 | let root = trie.root in 187 | let set_leaf ?debug:_ ~prev_leaf ~depth node = 188 | if node == root 189 | then None 190 | else begin 191 | begin 192 | match prev_leaf with 193 | | None -> () 194 | | Some (prev_leaf, prev_depth, _) -> 195 | assert (prev_depth = depth) ; 196 | begin 197 | match prev_leaf.suffix_link with 198 | | None -> prev_leaf.suffix_link <- Some node 199 | | Some node' -> assert (node' == node) 200 | end 201 | end ; 202 | Some (node, depth - 1) 203 | end 204 | in 205 | let rec go ~prev ~prev_leaf ~depth node i = 206 | let prev = set_suffix_link ~prev ~depth node in 207 | if i >= Doc.length doc 208 | then assert (depth = 0) 209 | else ( 210 | let chr = Doc.get doc i in 211 | let i, depth = i + 1, depth + 1 in 212 | match chr with 213 | | Terminal doc_uid -> 214 | if not (Terminals.mem doc_uid node.terminals) 215 | then begin 216 | let hint = 217 | Option.map 218 | (fun (t, _, prev_terminals) -> prev_terminals, t.terminals) 219 | prev_leaf 220 | in 221 | let prev_terminals = node.terminals in 222 | node.terminals <- Terminals.add ~hint doc_uid node.terminals ; 223 | let prev_leaf = 224 | match set_leaf ~debug:"0" ~prev_leaf ~depth node with 225 | | None -> None 226 | | Some (t, depth) -> Some (t, depth, prev_terminals) 227 | in 228 | follow_suffix ~prev ~prev_leaf ~parent:node ~depth ~i 229 | end 230 | | Char chr -> begin 231 | match Char_map.find chr node.children with 232 | | child -> 233 | assert (depth >= 0) ; 234 | assert (i - depth >= 0) ; 235 | assert (i < Doc.length doc) ; 236 | let len = lcp doc.Doc.text i trie.buffer child.start child.len in 237 | let i, depth = i + len, depth + len in 238 | assert (i < Doc.length doc) ; 239 | if len = child.len 240 | then 241 | if not (Char_map.is_empty child.children) 242 | then go ~prev ~prev_leaf ~depth child i 243 | else add_leaf ~prev_leaf ~node ~child ~depth ~i ~len 244 | else begin 245 | let new_child = split_at ~str:trie.buffer child len in 246 | node.children <- Char_map.add chr new_child node.children ; 247 | let prev = set_suffix_link ~prev ~depth new_child in 248 | assert (prev = None) ; 249 | add_leaf ~prev_leaf ~node ~child:new_child ~depth ~i ~len 250 | end 251 | | exception Not_found -> 252 | let new_leaf = make_leaf ~prev_leaf ~buffer:trie.buffer ~doc i in 253 | node.children <- Char_map.add chr new_leaf node.children ; 254 | let prev_leaf = 255 | set_leaf ~debug:"1" ~prev_leaf ~depth:(depth + Doc.length doc - i) new_leaf 256 | in 257 | let prev_leaf = 258 | match prev_leaf with 259 | | None -> None 260 | | Some (t, depth) -> Some (t, depth, Terminals.empty) 261 | in 262 | follow_suffix ~prev ~prev_leaf ~parent:node ~depth ~i 263 | end) 264 | and add_leaf ~prev_leaf ~node ~child ~depth ~i ~len = 265 | match Doc.get doc i with 266 | | Terminal doc_uid -> 267 | if not (Terminals.mem doc_uid child.terminals) 268 | then begin 269 | let hint = 270 | Option.map (fun (t, _, prev_terminals) -> prev_terminals, t.terminals) prev_leaf 271 | in 272 | let prev_terminals = child.terminals in 273 | child.terminals <- Terminals.add ~hint doc_uid child.terminals ; 274 | let prev_leaf = 275 | match set_leaf ~debug:"2" ~prev_leaf ~depth:(depth + 1) child with 276 | | None -> None 277 | | Some (t, depth) -> Some (t, depth, prev_terminals) 278 | in 279 | assert (Doc.length doc - i = 1) ; 280 | begin 281 | match child.suffix_link with 282 | | None -> 283 | let i, depth = i - len, depth - len in 284 | follow_suffix ~prev:None ~prev_leaf ~parent:node ~depth ~i 285 | | Some next_child -> 286 | let depth = depth - 1 in 287 | go ~prev:None ~prev_leaf:None ~depth next_child i 288 | end 289 | end 290 | | Char new_chr -> 291 | let new_leaf = make_leaf ~prev_leaf ~buffer:trie.buffer ~doc (i + 1) in 292 | let prev_leaf = 293 | set_leaf ~debug:"3" ~prev_leaf ~depth:(depth + Doc.length doc - i) new_leaf 294 | in 295 | let prev_leaf = 296 | match prev_leaf with 297 | | None -> None 298 | | Some (t, depth) -> Some (t, depth, Terminals.empty) 299 | in 300 | child.children <- Char_map.add new_chr new_leaf child.children ; 301 | let prev = Some (child, depth - 1) in 302 | let i, depth = i - len, depth - len in 303 | follow_suffix ~prev ~prev_leaf ~parent:node ~depth ~i 304 | and follow_suffix ~prev ~prev_leaf ~parent ~depth ~i = 305 | match parent.suffix_link with 306 | | None -> begin 307 | let i = i - depth + 1 in 308 | go ~prev:None ~prev_leaf ~depth:0 root i 309 | end 310 | | Some next -> 311 | assert (depth >= 2) ; 312 | assert (next != root) ; 313 | go ~prev ~prev_leaf ~depth:(depth - 2) next (i - 1) 314 | in 315 | go ~prev:None ~prev_leaf:None ~depth:0 root 0 316 | 317 | let add_suffixes t text elt = add_document t { Doc.text; uid = elt } 318 | 319 | module Terminals_cache = Hashtbl.Make (Terminals) 320 | module Seen = Set.Make (Db.Entry) 321 | 322 | let export_terminals ~cache_term ~is_summary ts = 323 | try Terminals_cache.find cache_term ts with 324 | | Not_found -> 325 | let terminals = 326 | if ts = [] 327 | then Db.String_automata.Empty 328 | else if is_summary 329 | then Db.String_automata.Summary (Array.of_list ts) 330 | else Db.String_automata.Terminals (Array.of_list ts) 331 | in 332 | let result = Uid.make (), terminals in 333 | Terminals_cache.add cache_term ts result ; 334 | result 335 | 336 | type result = 337 | { uid : Uid.t 338 | ; t : Db.String_automata.node 339 | ; min : Entry.t 340 | ; seen : Seen.t 341 | } 342 | 343 | let size_of_terminals = function 344 | | Db.String_automata.Empty -> 1 345 | | Summary arr | Terminals arr -> Array.length arr 346 | 347 | let rec export ~cache ~cache_term ~summarize ~is_root node = 348 | let is_summary = summarize && not is_root in 349 | let children = 350 | Char_map.bindings 351 | @@ Char_map.map (export ~cache ~cache_term ~summarize ~is_root:false) node.children 352 | in 353 | let children = 354 | List.sort 355 | (fun (a_chr, { min = a; _ }) (b_chr, { min = b; _ }) -> 356 | match Entry.compare a b with 357 | | 0 -> Char.compare a_chr b_chr 358 | | c -> c) 359 | children 360 | in 361 | let children_seen = 362 | List.fold_left (fun acc (_, child) -> Seen.union acc child.seen) Seen.empty children 363 | in 364 | let seen = List.fold_left (fun acc e -> Seen.add e acc) children_seen node.terminals in 365 | let terminals = 366 | if is_summary 367 | then List.of_seq (Seen.to_seq seen) 368 | else 369 | List.sort Entry.compare 370 | @@ List.filter (fun e -> not (Seen.mem e children_seen)) node.terminals 371 | in 372 | let min_child = 373 | match children with 374 | | [] -> None 375 | | (_, { min = elt; _ }) :: _ -> Some elt 376 | in 377 | let min_terminal = 378 | match terminals with 379 | | [] -> None 380 | | hd :: _ -> Some hd 381 | in 382 | let min_child, terminals = 383 | match min_child, min_terminal with 384 | | None, None -> failwith "suffix_tree: empty node" 385 | | None, Some min_terminal -> min_terminal, terminals 386 | | Some min_child, None -> min_child, min_child :: terminals 387 | | Some min_child, Some min_terminal -> 388 | if Db.Entry.compare min_child min_terminal < 0 389 | then min_child, min_child :: terminals 390 | else min_terminal, terminals 391 | in 392 | assert (min_child == Seen.min_elt seen) ; 393 | assert (terminals <> []) ; 394 | let terminals_uid, terminals = export_terminals ~cache_term ~is_summary terminals in 395 | let children_uids = List.map (fun (chr, { uid; _ }) -> chr, uid) children in 396 | let key = node.start, node.len, terminals_uid, children_uids in 397 | try Hashtbl.find cache key with 398 | | Not_found -> 399 | let children = 400 | Array.of_list @@ List.map (fun (_, { t = child; _ }) -> child) children 401 | in 402 | let size = size_of_terminals terminals in 403 | let size = 404 | if is_summary 405 | then size 406 | else 407 | Array.fold_left 408 | (fun acc child -> acc + child.Db.String_automata.size) 409 | size 410 | children 411 | in 412 | let children = if Array.length children = 0 then None else Some children in 413 | let node = 414 | { Db.String_automata.start = node.start; len = node.len; size; terminals; children } 415 | in 416 | let result = { uid = Uid.make (); t = node; min = min_child; seen } in 417 | Hashtbl.add cache key result ; 418 | result 419 | 420 | let export ~summarize { buffer; root = t } = 421 | let str = Buf.contents buffer in 422 | if String.length str = 0 423 | then { Db.String_automata.str; t = Db.String_automata.empty () } 424 | else begin 425 | let cache = Hashtbl.create 16 in 426 | let cache_term = Terminals_cache.create 16 in 427 | let { t; _ } = export ~cache ~cache_term ~summarize ~is_root:true t in 428 | { Db.String_automata.str; t } 429 | end 430 | -------------------------------------------------------------------------------- /index/suffix_tree.mli: -------------------------------------------------------------------------------- 1 | module Buf : sig 2 | type t 3 | 4 | val make : unit -> t 5 | end 6 | 7 | type t 8 | 9 | val make : Buf.t -> t 10 | val add_suffixes : t -> string -> Db.Entry.t -> unit 11 | val export : summarize:bool -> t -> Db.String_automata.t 12 | -------------------------------------------------------------------------------- /index/type_cache.ml: -------------------------------------------------------------------------------- 1 | open Db.Typexpr 2 | module H = Hashtbl.Make (Db.Typexpr) 3 | 4 | type t = Db.Typexpr.t -> Db.Typexpr.t 5 | 6 | let make () = 7 | let table = H.create 256 in 8 | fun t -> 9 | match H.find_opt table t with 10 | | Some t -> t 11 | | None -> 12 | H.add table t t ; 13 | t 14 | 15 | let rec of_odoc ~cache otyp = 16 | match otyp with 17 | | Odoc_model.Lang.TypeExpr.Var _str -> Any 18 | | Any -> Any 19 | | Arrow (_lbl, left, right) -> cache (Arrow (of_odoc ~cache left, of_odoc ~cache right)) 20 | | Constr (name, args) -> 21 | cache (Constr (Typename.to_string name, List.map (of_odoc ~cache) args)) 22 | | Tuple li -> cache (Tuple (List.map (of_odoc ~cache) li)) 23 | | _ -> Unhandled 24 | -------------------------------------------------------------------------------- /index/type_cache.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val make : unit -> t 4 | val of_odoc : cache:t -> Odoc_model.Lang.TypeExpr.t -> Db.Typexpr.t 5 | -------------------------------------------------------------------------------- /index/typename.ml: -------------------------------------------------------------------------------- 1 | module Path = Odoc_model.Paths.Path 2 | module Identifier = Odoc_model.Paths.Identifier 3 | module TypeName = Odoc_model.Names.TypeName 4 | module ModuleName = Odoc_model.Names.ModuleName 5 | 6 | let rec show_ident_long h (r : Identifier.t_pv Identifier.id) = 7 | match r.iv with 8 | | `CoreType n -> Format.fprintf h "Stdlib.%s" (TypeName.to_string n) 9 | | `Type (md, n) -> Format.fprintf h "%a.%s" show_signature md (TypeName.to_string n) 10 | | _ -> Format.fprintf h "%S" (r |> Identifier.fullname |> String.concat ".") 11 | 12 | and show_signature h sig_ = 13 | match sig_.iv with 14 | | `Root (_, name) -> Format.fprintf h "%s" (ModuleName.to_string name) 15 | | `Module (pt, mdl) -> 16 | Format.fprintf h "%a.%s" show_signature pt (ModuleName.to_string mdl) 17 | | `Parameter (_, p) -> Format.fprintf h "%s" (ModuleName.to_string p) 18 | | `Result t -> Format.fprintf h "%a" show_signature t 19 | | `ModuleType (_, p) -> 20 | Format.fprintf h "%s" (Odoc_model.Names.ModuleTypeName.to_string p) 21 | 22 | let show_type_name_verbose h : Path.Type.t -> _ = function 23 | | `Resolved t -> 24 | Format.fprintf h "%a" show_ident_long Path.Resolved.(identifier (t :> t)) 25 | | `Identifier (path, _hidden) -> 26 | let name = String.concat "." @@ Identifier.fullname path in 27 | Format.fprintf h "%s" name 28 | | `Dot (mdl, x) -> 29 | Format.fprintf h "%s.%s" (Odoc_document.Url.render_path (mdl :> Path.t)) x 30 | 31 | let to_string t = Format.asprintf "%a" show_type_name_verbose t 32 | -------------------------------------------------------------------------------- /index/typename.mli: -------------------------------------------------------------------------------- 1 | val to_string : Odoc_model.Paths.Path.Type.t -> string 2 | (** [Typename.string tn] is a string representing the type name of [tn] as a string. 3 | Such a function could be provided by Odoc but we do two things differently : 4 | - Core types like [int] and [string] are represented as [Stdlib.int] or [Stdlib.string] 5 | - We do not use any parenthesis on functors. *) 6 | -------------------------------------------------------------------------------- /jsoo/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (modes js) 4 | (libraries brr query)) 5 | 6 | (rule 7 | (alias all) 8 | (action 9 | (copy main.bc.js sherlodoc.js))) 10 | -------------------------------------------------------------------------------- /jsoo/main.ml: -------------------------------------------------------------------------------- 1 | let print_error e = 2 | print_string 3 | @@ String.concat 4 | "" 5 | [ "Error : " 6 | ; Jstr.to_string @@ Jv.Error.name e 7 | ; " " 8 | ; Jstr.to_string @@ Jv.Error.message e 9 | ; "\n" 10 | ; Jstr.to_string @@ Jv.Error.stack e 11 | ] 12 | 13 | let new_ cl = Jv.(new' (get global cl)) 14 | 15 | let stream_of_string str = 16 | let str = str |> Brr.Tarray.of_binary_jstr |> Result.get_ok |> Brr.Tarray.to_jv in 17 | let stream = 18 | new_ 19 | "ReadableStream" 20 | Jv. 21 | [| obj 22 | [| ( "start" 23 | , callback ~arity:1 (fun controller -> 24 | let _ = call controller "enqueue" [| str |] in 25 | let _ = call controller "close" [||] in 26 | ()) ) 27 | |] 28 | |] 29 | in 30 | stream 31 | 32 | module Decompress_browser = struct 33 | (** This module contains binding to the browser string compression api. It is 34 | much faster than using an OCaml library, and does not require sending code 35 | over the network. *) 36 | 37 | let string_of_stream stream = 38 | let buffer = Buffer.create 128 in 39 | let append str = 40 | Buffer.add_string buffer (str |> Brr.Tarray.of_jv |> Brr.Tarray.to_string) 41 | in 42 | let open Jv in 43 | let reader = call stream "getReader" [||] in 44 | let open Fut.Syntax in 45 | let rec read_step obj = 46 | let done_ = get obj "done" |> to_bool in 47 | let str = get obj "value" in 48 | if not done_ 49 | then ( 50 | append str ; 51 | read ()) 52 | else Fut.return () 53 | and read () : unit Fut.t = 54 | let read = call reader "read" [||] in 55 | let promise = Fut.of_promise ~ok:Fun.id read in 56 | Fut.bind promise (function 57 | | Ok v -> read_step v 58 | | Error e -> 59 | print_endline "error in string_of_stream" ; 60 | print_error e ; 61 | Fut.return ()) 62 | in 63 | let+ () = read () in 64 | let r = Buffer.contents buffer in 65 | r 66 | 67 | let inflate str = 68 | let dekompressor = Jv.(new_ "DecompressionStream" [| of_string "deflate" |]) in 69 | let str = Jv.(call global "atob" [| str |]) |> Jv.to_jstr in 70 | let stream = stream_of_string str in 71 | let decompressed_stream = Jv.call stream "pipeThrough" [| dekompressor |] in 72 | string_of_stream decompressed_stream 73 | end 74 | 75 | let db = 76 | Jv.(Decompress_browser.inflate @@ call global "sherlodoc_db" [||]) 77 | |> Fut.map (fun str -> [ Marshal.from_string str 0 ]) 78 | 79 | let string_of_kind = 80 | let open Db.Entry.Kind in 81 | let open Odoc_html_frontend in 82 | function 83 | | Db.Entry.Kind.Doc -> kind_doc 84 | | Type_decl _ -> kind_typedecl 85 | | Module -> kind_module 86 | | Exception _ -> kind_exception 87 | | Class_type -> kind_class_type 88 | | Method -> kind_method 89 | | Class -> kind_class 90 | | Type_extension -> kind_extension 91 | | Extension_constructor _ -> kind_extension_constructor 92 | | Module_type -> kind_module_type 93 | | Constructor _ -> kind_constructor 94 | | Field _ -> kind_field 95 | | Val _ -> kind_value 96 | 97 | let search message db = 98 | let query = Jv.get message "data" in 99 | let query = query |> Jv.to_jstr |> Jstr.to_string in 100 | let results = 101 | Query.Blocking.search ~shards:db { Query.query; packages = []; limit = 50 } 102 | in 103 | let _ = 104 | Jv.(apply (get global "postMessage")) 105 | [| Jv.of_list 106 | (fun Db.Entry.{ name; rhs; doc_html; kind; url; _ } -> 107 | let typedecl_params = 108 | match kind with 109 | | Db.Entry.Kind.Type_decl args -> args 110 | | _ -> None 111 | in 112 | let prefix_name, name = 113 | match kind with 114 | | Db.Entry.Kind.Doc -> None, None 115 | | _ -> begin 116 | match List.rev (String.split_on_char '.' name) with 117 | | [] -> None, None 118 | | [ hd ] -> None, Some hd 119 | | hd :: tl -> Some (String.concat "." (List.rev tl)), Some hd 120 | end 121 | in 122 | let kind = string_of_kind kind in 123 | let html = 124 | Tyxml.Html.string_of_list 125 | @@ Odoc_html_frontend.of_strings 126 | ~kind 127 | ~prefix_name 128 | ~name 129 | ~typedecl_params 130 | ~rhs 131 | ~doc:doc_html 132 | in 133 | Jv.obj [| "html", Jv.of_string html; "url", Jv.of_string url |]) 134 | results 135 | |] 136 | in 137 | () 138 | 139 | let don't_wait_for fut = Fut.await fut Fun.id 140 | 141 | let search message = 142 | don't_wait_for 143 | @@ 144 | let open Fut.Syntax in 145 | let+ db = db in 146 | search message db 147 | 148 | let main () = 149 | let module J' = Jstr in 150 | let o = Jv.callback ~arity:1 search in 151 | Jv.(set global "onmessage" o) 152 | 153 | let _ = main () 154 | -------------------------------------------------------------------------------- /jsoo/odoc_html_frontend.ml: -------------------------------------------------------------------------------- 1 | (* copy-pasted from odoc/src/search/odoc_html_frontend.ml *) 2 | 3 | let of_strings ~kind ~prefix_name ~name ~rhs ~typedecl_params ~doc = 4 | let open Tyxml.Html in 5 | let kind = code ~a:[ a_class [ "entry-kind" ] ] [ txt kind ] 6 | and typedecl_params = 7 | match typedecl_params with 8 | | None -> [] 9 | | Some p -> 10 | [ span 11 | ~a: 12 | [ a_class 13 | [ (* the parameter of the typedecl are highlighted as if part of main entry name. *) 14 | "entry-name" 15 | ] 16 | ] 17 | [ txt (p ^ " ") ] 18 | ] 19 | and prefix_name = 20 | match prefix_name with 21 | | None -> [] 22 | | Some "" -> [] 23 | | Some prefix_name -> 24 | [ span ~a:[ a_class [ "prefix-name" ] ] [ txt (prefix_name ^ ".") ] ] 25 | and name = 26 | match name with 27 | | Some name -> [ span ~a:[ a_class [ "entry-name" ] ] [ txt name ] ] 28 | | None -> [] 29 | and rhs = 30 | match rhs with 31 | | None -> [] 32 | | Some rhs -> [ code ~a:[ a_class [ "entry-rhs" ] ] [ txt rhs ] ] 33 | in 34 | [ kind 35 | ; code ~a:[ a_class [ "entry-title" ] ] (typedecl_params @ prefix_name @ name @ rhs) 36 | ; div ~a:[ a_class [ "entry-comment" ] ] [ Unsafe.data doc ] 37 | ] 38 | 39 | let kind_doc = "doc" 40 | let kind_typedecl = "type" 41 | let kind_module = "mod" 42 | let kind_exception = "exn" 43 | let kind_class_type = "class" 44 | let kind_class = "class" 45 | let kind_method = "meth" 46 | let kind_extension_constructor = "cons" 47 | let kind_module_type = "sig" 48 | let kind_constructor = "cons" 49 | let kind_field = "field" 50 | let kind_value = "val" 51 | let kind_extension = "ext" 52 | -------------------------------------------------------------------------------- /jsoo/tyxml.ml: -------------------------------------------------------------------------------- 1 | module Html : sig 2 | type t 3 | 4 | val string_of_list : t list -> string 5 | 6 | type attr 7 | 8 | val a_class : string list -> attr 9 | val code : a:attr list -> t list -> t 10 | val span : a:attr list -> t list -> t 11 | val div : a:attr list -> t list -> t 12 | val txt : string -> t 13 | 14 | module Unsafe : sig 15 | val data : string -> t 16 | end 17 | end = struct 18 | type t = 19 | | Raw of string 20 | | Txt of string 21 | | Concat of t list 22 | 23 | let add_escape_string buf s = 24 | (* https://discuss.ocaml.org/t/html-encoding-of-string/4289/4 *) 25 | let add = Buffer.add_string buf in 26 | let len = String.length s in 27 | let max_idx = len - 1 in 28 | let flush start i = 29 | if start < len then Buffer.add_substring buf s start (i - start) 30 | in 31 | let rec loop start i = 32 | if i > max_idx 33 | then flush start i 34 | else begin 35 | match String.get s i with 36 | | '&' -> escape "&" start i 37 | | '<' -> escape "<" start i 38 | | '>' -> escape ">" start i 39 | | '\'' -> escape "'" start i 40 | | '"' -> escape """ start i 41 | | '@' -> escape "@" start i 42 | | _ -> loop start (i + 1) 43 | end 44 | and escape amperstr start i = 45 | flush start i ; 46 | add amperstr ; 47 | let next = i + 1 in 48 | loop next next 49 | in 50 | loop 0 0 51 | 52 | let to_string t = 53 | let buf = Buffer.create 16 in 54 | let rec go = function 55 | | Raw s -> Buffer.add_string buf s 56 | | Txt s -> add_escape_string buf s 57 | | Concat xs -> List.iter go xs 58 | in 59 | go t ; 60 | Buffer.contents buf 61 | 62 | let string_of_list lst = to_string (Concat lst) 63 | 64 | type attr = t 65 | 66 | let a_class lst = Concat [ Raw "class=\""; Txt (String.concat " " lst); Raw "\"" ] 67 | 68 | let attrs = function 69 | | [] -> Concat [] 70 | | xs -> Concat (Raw " " :: xs) 71 | 72 | let block name ~a body = 73 | let name = Raw name in 74 | Concat [ Raw "<"; name; attrs a; Raw ">"; Concat body; Raw "" ] 75 | 76 | let code = block "code" 77 | let span = block "span" 78 | let div = block "span" 79 | let txt s = Txt s 80 | 81 | module Unsafe = struct 82 | let data s = Raw s 83 | end 84 | end 85 | -------------------------------------------------------------------------------- /jsoo/tyxml.mli: -------------------------------------------------------------------------------- 1 | (* smaller js bundle than the real TyXml *) 2 | module Html : sig 3 | type t 4 | 5 | val string_of_list : t list -> string 6 | 7 | type attr 8 | 9 | val a_class : string list -> attr 10 | val code : a:attr list -> t list -> t 11 | val span : a:attr list -> t list -> t 12 | val div : a:attr list -> t list -> t 13 | val txt : string -> t 14 | 15 | module Unsafe : sig 16 | val data : string -> t 17 | end 18 | end 19 | -------------------------------------------------------------------------------- /query/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name query) 3 | (libraries db)) 4 | 5 | (menhir 6 | (modules type_parser) 7 | (flags --explain)) 8 | 9 | (ocamllex type_lexer) 10 | -------------------------------------------------------------------------------- /query/dynamic_cost.ml: -------------------------------------------------------------------------------- 1 | module Entry = Db.Entry 2 | 3 | type query = 4 | { name : string list 5 | ; type_paths : Type_distance.t option 6 | } 7 | 8 | let of_query { Query_parser.name; typ } = 9 | let type_paths = 10 | match typ with 11 | | `typ t -> Some (Type_distance.paths_of_type t) 12 | | _ -> None 13 | in 14 | { name; type_paths } 15 | 16 | let type_distance query_type entry = 17 | match query_type, Entry.Kind.get_type entry.Entry.kind with 18 | | Some query_paths, Some entry_type -> 19 | Some (Type_distance.v ~query_paths ~entry:entry_type) 20 | | Some _, None -> Some 1000 21 | | _ -> None 22 | 23 | let score query entry = 24 | let name_matches = Name_cost.best_matches query.name entry.Db.Entry.name in 25 | let type_cost = 26 | match type_distance query.type_paths entry with 27 | | Some cost -> cost 28 | | None -> 0 29 | in 30 | 5 * (name_matches + type_cost) 31 | -------------------------------------------------------------------------------- /query/io.ml: -------------------------------------------------------------------------------- 1 | module type S = sig 2 | (* avoids a dependency on lwt for sherlodoc.js *) 3 | 4 | type 'a t 5 | 6 | val return : 'a -> 'a t 7 | val map : 'a t -> ('a -> 'b) -> 'b t 8 | val bind : 'a t -> ('a -> 'b t) -> 'b t 9 | end 10 | 11 | module Seq (Io : S) = struct 12 | type 'a t = unit -> 'a node Io.t 13 | 14 | and 'a node = 15 | | Nil 16 | | Cons of 'a * 'a t 17 | 18 | let rec of_seq s () = 19 | match s () with 20 | | Seq.Nil -> Io.return Nil 21 | | Cons (x, xs) -> Io.return (Cons (x, of_seq xs)) 22 | 23 | let rec take n xs () = 24 | if n = 0 25 | then Io.return Nil 26 | else begin 27 | Io.map (xs ()) 28 | @@ function 29 | | Nil -> Nil 30 | | Cons (x, xs) -> Cons (x, take (n - 1) xs) 31 | end 32 | 33 | let rec to_list acc s = 34 | Io.bind (s ()) 35 | @@ function 36 | | Nil -> Io.return (List.rev acc) 37 | | Cons (x, xs) -> to_list (x :: acc) xs 38 | 39 | let to_list s = to_list [] s 40 | end 41 | -------------------------------------------------------------------------------- /query/name_cost.ml: -------------------------------------------------------------------------------- 1 | let rec prefix_at ~case ~sub i s j = 2 | if i >= String.length sub 3 | then Some case 4 | else if sub.[i] = s.[j] 5 | then prefix_at ~case ~sub (i + 1) s (j + 1) 6 | else if sub.[i] = Char.lowercase_ascii s.[j] 7 | then prefix_at ~case:(case + 3) ~sub (i + 1) s (j + 1) 8 | else if Char.lowercase_ascii sub.[i] = s.[j] 9 | then prefix_at ~case:(case + 10) ~sub (i + 1) s (j + 1) 10 | else None 11 | 12 | let prefix_at ~sub s j = prefix_at ~case:0 ~sub 0 s j 13 | 14 | let find_all ~sub s = 15 | let rec go j acc = 16 | if j + String.length sub > String.length s 17 | then acc 18 | else begin 19 | let acc = 20 | match prefix_at ~sub s j with 21 | | None -> acc 22 | | Some cost -> (j, cost) :: acc 23 | in 24 | go (j + 1) acc 25 | end 26 | in 27 | go 0 [] 28 | 29 | let is_substring ~sub s = find_all ~sub s <> [] 30 | 31 | let word_boundary s i = 32 | if i < 0 33 | then 0 34 | else if i >= String.length s || List.mem s.[i] [ '.'; '('; ')' ] 35 | then 1 36 | else if s.[i] = '_' 37 | then 3 38 | else 10 39 | 40 | let best_match ?(after = 0) ~sub str = 41 | List.fold_left 42 | (fun acc (i, case_cost) -> 43 | let left = word_boundary str (i - 1) in 44 | let right = word_boundary str (i + String.length sub) / 3 in 45 | let is_after = if i >= after then 0 else 10 in 46 | let cost = case_cost + left + right + is_after in 47 | match acc with 48 | | Some (_, cost') when cost' < cost -> acc 49 | | _ -> Some (i, cost)) 50 | None 51 | (find_all ~sub str) 52 | 53 | let best_matches words str = 54 | let _, found, not_found = 55 | List.fold_left 56 | (fun (i, found, not_found) sub -> 57 | match best_match ~after:i ~sub str with 58 | | Some (i, cost) -> i + String.length sub, found + cost, not_found 59 | | None -> i, found, not_found + String.length sub + 50) 60 | (0, 0, 0) 61 | words 62 | in 63 | found + not_found 64 | -------------------------------------------------------------------------------- /query/priority_queue.ml: -------------------------------------------------------------------------------- 1 | module String_automata = Db.String_automata 2 | module Entry = Db.Entry 3 | 4 | type elt = Entry.t 5 | 6 | type t = 7 | | Empty 8 | | Array of int * elt array 9 | | All of elt * String_automata.t 10 | | Union of elt * t list 11 | 12 | let rec size = function 13 | | Empty -> 0 14 | | Array (i, arr) -> Array.length arr - i 15 | | All (_, s) -> String_automata.size s 16 | | Union (_, xs) -> List.fold_left (fun acc x -> acc + size x) 0 xs 17 | 18 | let minimum = function 19 | | Empty -> None 20 | | Array (i, arr) -> Some arr.(i) 21 | | All (elt, _) | Union (elt, _) -> Some elt 22 | 23 | let of_sorted_array arr = Array (0, arr) 24 | 25 | let of_automata s = 26 | let elt = String_automata.minimum s in 27 | All (elt, s) 28 | 29 | let of_list lst = 30 | let lst = List.filter (( <> ) Empty) lst in 31 | let min x = 32 | match minimum x with 33 | | None -> assert false 34 | | Some elt -> elt 35 | in 36 | let compare a b = Entry.compare (min a) (min b) in 37 | match List.sort compare lst with 38 | | [] -> Empty 39 | | hd :: _ as lst -> Union (min hd, lst) 40 | 41 | let insert_sort x lst = 42 | match minimum x with 43 | | None -> lst 44 | | Some min_elt -> 45 | let rec insert lst = 46 | match lst with 47 | | [] -> [ x ] 48 | | y :: ys -> begin 49 | match minimum y with 50 | | None -> insert ys 51 | | Some min_y when Entry.compare min_elt min_y <= 0 -> x :: lst 52 | | _ -> y :: insert ys 53 | end 54 | in 55 | insert lst 56 | 57 | let union_with ~min_elt lst = 58 | match List.filter (( <> ) Empty) lst with 59 | | [] -> Empty 60 | | [ t ] -> t 61 | | sorted_lst -> Union (min_elt, sorted_lst) 62 | 63 | let rec union_sorted lst = 64 | match lst with 65 | | [] -> Empty 66 | | [ t ] -> t 67 | | x :: xs -> begin 68 | match minimum x with 69 | | None -> union_sorted xs 70 | | Some min_elt -> Union (min_elt, lst) 71 | end 72 | 73 | let expand_automata ~min_elt ({ String_automata.t; _ } as automata) = 74 | match t.terminals with 75 | | String_automata.Summary arr -> Array (0, arr) 76 | | terminals -> 77 | let terminals = 78 | match terminals with 79 | | String_automata.Empty -> Empty 80 | | Terminals terminals -> Array (0, terminals) 81 | | _ -> assert false 82 | in 83 | let lift child = of_automata { automata with String_automata.t = child } in 84 | let children = 85 | Array.to_list @@ Array.map lift @@ Option.value ~default:[||] t.children 86 | in 87 | let all = insert_sort terminals children in 88 | union_with ~min_elt all 89 | 90 | let rec pop_until cond = function 91 | | Empty -> Empty 92 | | Array (i, arr) as t -> 93 | let rec search i j = 94 | assert (not (cond arr.(i))) ; 95 | assert (cond arr.(j)) ; 96 | let m = (i + j) / 2 in 97 | if i = m then Array (j, arr) else if cond arr.(m) then search i m else search m j 98 | in 99 | let rec search_from j step = 100 | if j >= Array.length arr 101 | then begin 102 | let last = Array.length arr - 1 in 103 | let j_prev = j - (step / 2) in 104 | if cond arr.(last) then search j_prev last else Empty 105 | end 106 | else if cond arr.(j) 107 | then if i = j then t else search (j - (step / 2)) j 108 | else search_from (j + step) (step * 2) 109 | in 110 | search_from i 1 111 | | All (min_elt, _) as t when cond min_elt -> t 112 | | All (min_elt, automata) -> pop_until cond (expand_automata ~min_elt automata) 113 | | Union (min_elt, _) as t when cond min_elt -> t 114 | | Union (_, lst) -> 115 | let rec pop_union i = function 116 | | [] -> [] 117 | | x :: xs -> 118 | let x' = pop_until cond x in 119 | if x == x' 120 | then begin 121 | assert (i > 0) ; 122 | x :: xs 123 | end 124 | else insert_sort x' (pop_union (i + 1) xs) 125 | in 126 | let lst = pop_union 0 lst in 127 | union_sorted lst 128 | 129 | let pop_lt elt t = 130 | let cmp_lt x = Entry.compare x elt >= 0 in 131 | pop_until cmp_lt t 132 | 133 | let pop_lte elt t = 134 | let cmp_lte x = Entry.compare x elt > 0 in 135 | pop_until cmp_lte t 136 | -------------------------------------------------------------------------------- /query/priority_queue.mli: -------------------------------------------------------------------------------- 1 | type elt = Db.Entry.t 2 | type t 3 | 4 | val minimum : t -> elt option 5 | val of_automata : Db.String_automata.t -> t 6 | val of_sorted_array : elt array -> t 7 | val of_list : t list -> t 8 | val pop_lt : elt -> t -> t 9 | val pop_lte : elt -> t -> t 10 | val size : t -> int 11 | -------------------------------------------------------------------------------- /query/query.ml: -------------------------------------------------------------------------------- 1 | module Parser = Query_parser 2 | module Dynamic_cost = Dynamic_cost 3 | module Storage = Db.Storage 4 | module Tree = Db.String_automata 5 | 6 | module Private = struct 7 | module Succ = Succ 8 | 9 | module Type_parser = struct 10 | let of_string str = 11 | let lexbuf = Lexing.from_string str in 12 | Ok (Type_parser.main Type_lexer.token lexbuf) 13 | end 14 | end 15 | 16 | let polarities typ = 17 | List.of_seq 18 | @@ Seq.filter 19 | (fun (word, _count, _) -> String.length word > 0) 20 | (Db.Type_polarity.of_typ ~any_is_poly:false typ) 21 | 22 | let find_types ~shard typ = 23 | let polarities = polarities typ in 24 | Succ.inter_of_list 25 | @@ List.map 26 | (fun (name, count, polarity) -> 27 | let st_occ = 28 | match polarity with 29 | | Db.Type_polarity.Sign.Pos -> shard.Db.db_pos_types 30 | | Neg -> shard.Db.db_neg_types 31 | in 32 | Succ.of_automatas 33 | @@ Db.Occurences.fold 34 | (fun occurrences st acc -> 35 | if occurrences < count 36 | then acc 37 | else begin 38 | let ts = Tree.find_star st name in 39 | List.rev_append ts acc 40 | end) 41 | st_occ 42 | []) 43 | polarities 44 | 45 | let find_names ~shard names = 46 | let names = List.map String.lowercase_ascii names in 47 | let db_names = Db.(shard.db_names) in 48 | let candidates = 49 | List.map 50 | (fun name -> 51 | match Tree.find db_names name with 52 | | Some trie -> Succ.of_automata trie 53 | | None -> Succ.empty) 54 | names 55 | in 56 | Succ.inter_of_list candidates 57 | 58 | let search ~shard { Query_parser.name; typ } = 59 | match name, typ with 60 | | _ :: _, `typ typ -> 61 | let results_name = find_names ~shard name in 62 | let results_typ = find_types ~shard typ in 63 | Succ.inter results_name results_typ 64 | | _ :: _, _ -> find_names ~shard name 65 | | [], `typ typ -> find_types ~shard typ 66 | | [], (`no_typ | `parse_error) -> Succ.empty 67 | 68 | let search ~shards query = 69 | Succ.union_of_list (List.map (fun shard -> search ~shard query) shards) 70 | 71 | type t = 72 | { query : string 73 | ; packages : string list 74 | ; limit : int 75 | } 76 | 77 | let pretty params = Parser.(to_string @@ of_string params.query) 78 | 79 | let match_packages ~packages { Db.Entry.pkg; _ } = 80 | List.exists (String.equal pkg.name) packages 81 | 82 | let match_packages ~packages results = 83 | match packages with 84 | | [] -> results 85 | | _ -> Seq.filter (match_packages ~packages) results 86 | 87 | let search ~shards params = 88 | let query = Parser.of_string params.query in 89 | let results = search ~shards query in 90 | let results = Succ.to_seq results in 91 | query, match_packages ~packages:params.packages results 92 | 93 | module type IO = Io.S 94 | 95 | module Make (Io : IO) = struct 96 | module Tr = Top_results.Make (Io) 97 | 98 | let search ~shards ?(dynamic_sort = true) params = 99 | let limit = params.limit in 100 | let query, results = search ~shards params in 101 | let results = Tr.Seq.of_seq results in 102 | if dynamic_sort 103 | then begin 104 | let query = Dynamic_cost.of_query query in 105 | Tr.of_seq ~query ~limit results 106 | end 107 | else Tr.Seq.to_list @@ Tr.Seq.take limit results 108 | end 109 | 110 | module Blocking = Make (struct 111 | type 'a t = 'a 112 | 113 | let return x = x 114 | let map x f = f x 115 | let bind x f = f x 116 | end) 117 | -------------------------------------------------------------------------------- /query/query.mli: -------------------------------------------------------------------------------- 1 | type t = 2 | { query : string 3 | ; packages : string list 4 | ; limit : int 5 | } 6 | 7 | val pretty : t -> string 8 | 9 | module type IO = Io.S 10 | 11 | module Make (Io : IO) : sig 12 | val search : shards:Db.t list -> ?dynamic_sort:bool -> t -> Db.Entry.t list Io.t 13 | (** [search ~shard ~dynamic_sort {query; packages; limit}] returns [(pretty_query, 14 | results)] where [pretty_query] is a re-printed version of [query] and 15 | [results] is the list of results corresponding to the query and the 16 | various parameters. 17 | 18 | - [shards] is a list of databases. [results] is the union of the results of 19 | each database of the list [shards]. If [shards] is a very long list, [api] 20 | might be slow to return, but in some cases you do not have a choice. 21 | Currently, [index] generates only one shard, but it used to generate many 22 | to be able to handle the sheer size of the opam repository. 23 | 24 | - [~dynamic_sort] changes the order of [results]. It is [true] by default, 25 | and is only set to [false] for debugging purposes. 26 | 27 | - [query] is the query string whose shape is a list of space-separated 28 | words, followed by an optionnal [: ...] type annotation that filters the 29 | results by type. The type annotation accepts [_] as a wildcard : [: string 30 | -> _] will return entries that take a [string] as argument, but returns 31 | anything. 32 | 33 | - [limit] is the maximum length of [results]. Having a very large number 34 | might be an issue. 35 | 36 | - [packages] is not function, use [[]] for this argument. *) 37 | end 38 | 39 | module Blocking : sig 40 | val search : shards:Db.t list -> ?dynamic_sort:bool -> t -> Db.Entry.t list 41 | end 42 | 43 | (* val search_lwt : shards:Db.t list -> ?dynamic_sort:bool -> t -> Db.Entry.t list Lwt.t *) 44 | 45 | (** For testing *) 46 | module Private : sig 47 | module Succ = Succ 48 | 49 | module Type_parser : sig 50 | val of_string : string -> (Db.Typexpr.t, string) result 51 | end 52 | end 53 | -------------------------------------------------------------------------------- /query/query_parser.ml: -------------------------------------------------------------------------------- 1 | let balance_parens str = 2 | let rec go i open_parens close_parens = 3 | if i >= String.length str 4 | then open_parens, close_parens 5 | else ( 6 | match str.[i] with 7 | | '(' -> go (i + 1) (open_parens + 1) close_parens 8 | | ')' when open_parens > 0 -> go (i + 1) (open_parens - 1) close_parens 9 | | ')' -> go (i + 1) open_parens (close_parens + 1) 10 | | _ -> go (i + 1) open_parens close_parens) 11 | in 12 | let open_parens, close_parens = go 0 0 0 in 13 | String.make close_parens '(' ^ str ^ String.make open_parens ')' 14 | 15 | let type_of_string str = 16 | let str = balance_parens str in 17 | let lexbuf = Lexing.from_string str in 18 | try `typ (Type_parser.main Type_lexer.token lexbuf) with 19 | | _ -> `parse_error 20 | 21 | let naive_of_string str = 22 | List.filter (fun s -> String.length s > 0) (String.split_on_char ' ' str) 23 | 24 | let guess_type_search str = 25 | String.length str >= 1 26 | && (str.[0] = '\'' || String.contains str '-' || String.contains str '(') 27 | 28 | type t = 29 | { name : string list 30 | ; typ : [ `typ of Db.Typexpr.t | `no_typ | `parse_error ] 31 | } 32 | 33 | let of_string str = 34 | let query_name, typ = 35 | match String.index_opt str ':' with 36 | | None -> if guess_type_search str then "", type_of_string str else str, `no_typ 37 | | Some loc -> 38 | let str_name = String.sub str 0 loc in 39 | let str_typ = String.sub str (loc + 1) (String.length str - loc - 1) in 40 | str_name, type_of_string str_typ 41 | in 42 | let name = naive_of_string query_name in 43 | { name; typ } 44 | 45 | let to_string { name; typ } = 46 | let words = String.concat " " name in 47 | match typ with 48 | | `typ typ -> words ^ " : " ^ Db.Typexpr.show typ 49 | | `parse_error -> words ^ " : " 50 | | `no_typ -> words 51 | -------------------------------------------------------------------------------- /query/query_parser.mli: -------------------------------------------------------------------------------- 1 | type t = 2 | { name : string list 3 | ; typ : [ `typ of Db.Typexpr.t | `no_typ | `parse_error ] 4 | } 5 | 6 | val of_string : string -> t 7 | val to_string : t -> string 8 | -------------------------------------------------------------------------------- /query/succ.ml: -------------------------------------------------------------------------------- 1 | module Entry = Db.Entry 2 | 3 | type elt = Entry.t 4 | 5 | type s = 6 | | Empty 7 | | All 8 | | Pq of Priority_queue.t 9 | | Inter of s * s 10 | | Union of s * s 11 | 12 | type t = 13 | { s : s 14 | ; size : int 15 | } 16 | 17 | let all = { s = All; size = 0 } 18 | let empty = { s = Empty; size = 0 } 19 | let make_pq t = { s = Pq t; size = Priority_queue.size t } 20 | let of_automata t = make_pq (Priority_queue.of_automata t) 21 | let of_automatas ts = make_pq Priority_queue.(of_list (List.map of_automata ts)) 22 | let of_array arr = make_pq (Priority_queue.of_sorted_array arr) 23 | 24 | let inter a b = 25 | match a.s, b.s with 26 | | Empty, _ | _, Empty -> empty 27 | | _, All -> a 28 | | All, _ -> b 29 | | x, y when x == y -> a 30 | | x, y -> 31 | let s = if a.size <= b.size then Inter (x, y) else Inter (y, x) in 32 | { s; size = min a.size b.size } 33 | 34 | let union a b = 35 | match a.s, b.s with 36 | | All, _ | _, All -> all 37 | | _, Empty -> a 38 | | Empty, _ -> b 39 | | x, y when x == y -> a 40 | | x, y -> 41 | let s = if a.size >= b.size then Union (x, y) else Union (y, x) in 42 | { s; size = a.size + b.size } 43 | 44 | let rec join_with fn = function 45 | | [] -> [] 46 | | [ x ] -> [ x ] 47 | | a :: b :: xs -> fn a b :: join_with fn xs 48 | 49 | let rec perfect ~default fn = function 50 | | [] -> default 51 | | [ x ] -> x 52 | | xs -> perfect ~default fn (join_with fn xs) 53 | 54 | let inter_of_list xs = 55 | let xs = List.sort (fun a b -> Int.compare a.size b.size) xs in 56 | perfect ~default:all inter xs 57 | 58 | let union_of_list xs = 59 | let xs = List.sort (fun a b -> Int.compare b.size a.size) xs in 60 | perfect ~default:empty union xs 61 | 62 | type strictness = 63 | | First 64 | | Ge of elt 65 | | Gt of elt 66 | 67 | type result = 68 | | Is_empty 69 | | Is_all 70 | | Found_eq of s 71 | | Found_gt of elt * s 72 | 73 | let rec succ ~strictness t = 74 | match t with 75 | | Empty -> Is_empty 76 | | All -> begin 77 | match strictness with 78 | | First -> Is_all 79 | | Gt _ -> Is_all 80 | | Ge _ -> Found_eq All 81 | end 82 | | Pq pqueue -> begin 83 | let pqueue' = 84 | match strictness with 85 | | First -> pqueue 86 | | Ge elt -> Priority_queue.pop_lt elt pqueue 87 | | Gt elt -> Priority_queue.pop_lte elt pqueue 88 | in 89 | match strictness, Priority_queue.minimum pqueue' with 90 | | _, None -> Is_empty 91 | | Ge elt, Some e when Db.Entry.equal e elt -> Found_eq (Pq pqueue') 92 | | _, Some e -> Found_gt (e, Pq pqueue') 93 | end 94 | | Union (l, r) -> begin 95 | match succ ~strictness l with 96 | | Is_empty -> succ ~strictness r 97 | | Is_all -> failwith "union all" 98 | | Found_eq l -> Found_eq (Union (l, r)) 99 | | Found_gt (elt_l, l') -> begin 100 | match succ ~strictness r with 101 | | Is_empty -> Found_gt (elt_l, l') 102 | | Is_all -> failwith "union all" 103 | | Found_eq r' -> Found_eq (Union (l', r')) 104 | | Found_gt (elt_r, r') when Db.Entry.compare elt_l elt_r <= 0 -> 105 | Found_gt (elt_l, Union (l', r')) 106 | | Found_gt (elt_r, r') -> Found_gt (elt_r, Union (l', r')) 107 | end 108 | end 109 | | Inter (l, r) -> begin 110 | match succ ~strictness l with 111 | | Is_empty -> Is_empty 112 | | Is_all -> failwith "inter all" 113 | | Found_eq l' -> begin 114 | match succ ~strictness r with 115 | | Is_empty -> Is_empty 116 | | Is_all -> failwith "inter all" 117 | | Found_eq r' -> Found_eq (Inter (l', r')) 118 | | Found_gt (elt, r') -> Found_gt (elt, Inter (l', r')) 119 | end 120 | | Found_gt (elt, l') -> Found_gt (elt, Inter (l', r)) 121 | end 122 | 123 | let rec succ_loop ?(count = 0) ~strictness t = 124 | match strictness, succ ~strictness t with 125 | | _, Is_empty -> None 126 | | _, Is_all -> None 127 | | Ge elt, Found_eq t -> Some (elt, t) 128 | | _, Found_gt (elt, t) -> succ_loop ~count:(count + 1) ~strictness:(Ge elt) t 129 | | _ -> assert false 130 | 131 | let first t = succ_loop ~strictness:First t 132 | 133 | let seq_of_dispenser fn = 134 | let rec go () = 135 | match fn () with 136 | | None -> Seq.Nil 137 | | Some x -> Seq.Cons (x, go) 138 | in 139 | go 140 | 141 | let to_seq { s = t; _ } = 142 | let state = ref None in 143 | let loop () = 144 | let result = 145 | match !state with 146 | | None -> first t 147 | | Some (previous_elt, t) -> succ_loop ~strictness:(Gt previous_elt) t 148 | in 149 | match result with 150 | | None -> None 151 | | Some (elt, _) -> 152 | state := result ; 153 | Some elt 154 | in 155 | seq_of_dispenser loop 156 | -------------------------------------------------------------------------------- /query/succ.mli: -------------------------------------------------------------------------------- 1 | (** This module provides a way to get the first n elements of a very large set 2 | without computing the whole list of elements. *) 3 | 4 | type t 5 | 6 | val to_seq : t -> Db.Entry.t Seq.t 7 | val empty : t 8 | val of_automata : Db.String_automata.t -> t 9 | val of_automatas : Db.String_automata.t list -> t 10 | val inter : t -> t -> t 11 | val union : t -> t -> t 12 | val inter_of_list : t list -> t 13 | val union_of_list : t list -> t 14 | val of_array : Db.Entry.t array -> t 15 | -------------------------------------------------------------------------------- /query/test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (libraries alcotest query)) 4 | -------------------------------------------------------------------------------- /query/test/test.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | let open Alcotest in 3 | run "Query" [ "Succ", Test_succ.tests_to_seq; "Type_parser", Test_type_parser.tests ] 4 | -------------------------------------------------------------------------------- /query/test/test_succ.ml: -------------------------------------------------------------------------------- 1 | open Query.Private 2 | 3 | let pkg = Db.Entry.Package.v ~name:"" ~version:"" 4 | 5 | let elt cost = 6 | Db.Entry.v ~cost ~name:"" ~kind:Db.Entry.Kind.Doc ~rhs:None ~doc_html:"" ~url:"" ~pkg () 7 | 8 | (** This module does the same thing as Succ, but its correctness is obvious 9 | and its performance terrible. *) 10 | module Reference = struct 11 | include Set.Make (Db.Entry) 12 | 13 | let of_array arr = arr |> Array.to_seq |> of_seq 14 | end 15 | 16 | (** This module is used to construct a pair of a "set array" using [Reference] 17 | and a Succ that are exactly the same. *) 18 | module Both = struct 19 | let empty = Reference.empty, Succ.empty 20 | let union (l, l') (r, r') = Reference.union l r, Succ.union l' r' 21 | let inter (l, l') (r, r') = Reference.inter l r, Succ.inter l' r' 22 | let of_array arr = Reference.of_array arr, Succ.of_array arr 23 | end 24 | 25 | (** This is a problematic exemple that was found randomly. It is saved here 26 | to check for regressions. *) 27 | let extra_succ = 28 | let open Both in 29 | let of_array arr = Both.of_array (Array.map elt arr) in 30 | union 31 | (inter (of_array [| 0; 1 |]) (of_array [| 0; 1 |])) 32 | (inter (of_array [| 0; 2; 3 |]) (of_array [| 1; 3; 5; 7 |])) 33 | 34 | let random_array size = 35 | List.init size (fun _ -> elt @@ Random.int (size * 2)) 36 | |> List.sort_uniq Db.Entry.compare 37 | |> Array.of_list 38 | 39 | let rec random_set ~empty ~union ~inter ~of_array size = 40 | let random_set = random_set ~empty ~union ~inter ~of_array in 41 | if size = 0 42 | then empty 43 | else ( 44 | match Random.int 3 with 45 | | 0 -> of_array @@ random_array size 46 | | 1 -> inter (random_set (size / 2)) (random_set (size / 2)) 47 | | 2 -> union (random_set (size / 2)) (random_set (size / 2)) 48 | | _ -> assert false) 49 | 50 | let to_costs lst = List.map (fun e -> e.Db.Entry.cost) (List.of_seq lst) 51 | 52 | let test_to_seq tree () = 53 | let ref = fst tree |> Reference.to_seq |> to_costs in 54 | let real = snd tree |> Succ.to_seq |> to_costs in 55 | Alcotest.(check (list int)) "same int list" ref real 56 | 57 | let tests_to_seq = 58 | [ Alcotest.test_case "Succ.to_seq extra" `Quick (test_to_seq extra_succ) ] 59 | @ List.init 50 (fun i -> 60 | let i = i * 7 in 61 | let succ = i |> Both.(random_set ~empty ~union ~inter ~of_array) in 62 | Alcotest.test_case (Printf.sprintf "Succ.to_seq size %i" i) `Quick (test_to_seq succ)) 63 | -------------------------------------------------------------------------------- /query/test/test_type_parser.ml: -------------------------------------------------------------------------------- 1 | open Db.Typexpr 2 | 3 | let random_elt arr = arr.(Random.int (Array.length arr)) 4 | let random_poly () = Poly (random_elt [| "a"; "b"; "c"; "d"; "e" |]) 5 | 6 | let random_constr () = 7 | Constr (random_elt [| "float"; "int"; "string"; "foo"; "bar"; "t" |], []) 8 | 9 | let rec random_type size = 10 | match size with 11 | | 0 | 1 -> random_elt [| random_poly; random_constr; (fun () -> Any) |] () 12 | | (2 | 3 | 4) when Random.bool () -> random_constr_params size 13 | | _ when Random.int 100 < 20 -> 14 | let n = 2 + Random.int 3 in 15 | tuple (List.init n (fun _i -> random_type (size / n))) 16 | | _ when Random.int 100 < 5 -> random_constr_params size 17 | | _ -> 18 | let size = size / 2 in 19 | Arrow (random_type size, random_type size) 20 | 21 | and random_constr_params size = 22 | let n_params = 1 + Random.int 3 in 23 | let name = random_elt [| "list"; "option"; "t"; "result"; "array" |] in 24 | Constr (name, List.init n_params (fun _i -> random_type (size / n_params))) 25 | 26 | open Query.Private 27 | 28 | let test_parser typ () = 29 | let str = Db.Typexpr.show typ in 30 | let typ' = Type_parser.of_string str in 31 | let str' = Result.map Db.Typexpr.show typ' in 32 | Alcotest.(check (result string string)) "same string" (Ok str) str' 33 | 34 | let tests = 35 | List.init 50 (fun i -> 36 | let i = i * 5 in 37 | let typ = random_type i in 38 | Alcotest.test_case (Printf.sprintf "Type_parser size %i" i) `Quick (test_parser typ)) 39 | -------------------------------------------------------------------------------- /query/top_results.ml: -------------------------------------------------------------------------------- 1 | module Bests = Set.Make (Db.Entry) 2 | 3 | type t = 4 | { size : int 5 | ; bests : Bests.t 6 | } 7 | 8 | let empty = { size = 0; bests = Bests.empty } 9 | 10 | type step = 11 | | Continue of t 12 | | Stop of t 13 | 14 | let update_entry query entry = 15 | let extra_cost = Dynamic_cost.score query entry in 16 | Db.Entry.{ entry with cost = entry.cost + extra_cost } 17 | 18 | let add ~query ~limit elt t = 19 | if t.size < limit 20 | then begin 21 | let elt = update_entry query elt in 22 | Continue { size = t.size + 1; bests = Bests.add elt t.bests } 23 | end 24 | else begin 25 | let worst = Bests.max_elt t.bests in 26 | if Db.Entry.(elt.cost > worst.cost) 27 | then Stop t 28 | else begin 29 | let elt = update_entry query elt in 30 | if Db.Entry.(elt.cost > worst.cost) 31 | then Continue t 32 | else Continue { t with bests = Bests.add elt @@ Bests.remove worst t.bests } 33 | end 34 | end 35 | 36 | let max_seek = 10 37 | 38 | module Make (IO : Io.S) = struct 39 | module Seq = Io.Seq (IO) 40 | 41 | let of_seq ~query ~limit seq = 42 | let rec go total_seen t seq = 43 | if total_seen >= limit + max_seek 44 | then IO.return t 45 | else begin 46 | IO.bind (seq ()) 47 | @@ function 48 | | Seq.Nil -> IO.return t 49 | | Cons (x, xs) -> begin 50 | match add ~query ~limit x t with 51 | | Stop t -> IO.return t 52 | | Continue t -> go (total_seen + 1) t xs 53 | end 54 | end 55 | in 56 | IO.map (go 0 empty seq) @@ fun t -> List.of_seq @@ Bests.to_seq t.bests 57 | end 58 | -------------------------------------------------------------------------------- /query/top_results.mli: -------------------------------------------------------------------------------- 1 | module Make (IO : Io.S) : sig 2 | module Seq : module type of Io.Seq (IO) 3 | 4 | val of_seq 5 | : query:Dynamic_cost.query 6 | -> limit:int 7 | -> Db.Entry.t Seq.t 8 | -> Db.Entry.t list IO.t 9 | end 10 | -------------------------------------------------------------------------------- /query/type_distance.ml: -------------------------------------------------------------------------------- 1 | type step = 2 | | Type of string 3 | | Poly 4 | | Any 5 | | Arrow_left 6 | | Arrow_right 7 | | Product of 8 | { pos : int 9 | ; length : int 10 | } 11 | | Argument of 12 | { pos : int 13 | ; length : int 14 | } 15 | 16 | module Sign = Db.Type_polarity.Sign 17 | 18 | type t = step list list 19 | 20 | let rev_concat lst = List.fold_left (fun acc xs -> List.rev_append xs acc) [] lst 21 | 22 | let rec paths_of_type ~prefix t = 23 | match t with 24 | | Db.Typexpr.Poly _ -> [ Poly :: prefix ] 25 | | Any -> [ Any :: prefix ] 26 | | Arrow (a, b) -> 27 | let prefix_left = Arrow_left :: prefix in 28 | let prefix_right = Arrow_right :: prefix in 29 | List.rev_append 30 | (paths_of_type ~prefix:prefix_left a) 31 | (paths_of_type ~prefix:prefix_right b) 32 | | Constr (name, args) -> 33 | let prefix = Type name :: prefix in 34 | begin 35 | match args with 36 | | [] -> [ prefix ] 37 | | _ -> 38 | let length = List.length args in 39 | rev_concat 40 | @@ List.mapi 41 | (fun i arg -> 42 | let prefix = Argument { pos = i; length } :: prefix in 43 | paths_of_type ~prefix arg) 44 | args 45 | end 46 | | Tuple args -> 47 | let length = List.length args in 48 | rev_concat 49 | @@ List.mapi (fun i arg -> 50 | let prefix = Product { pos = i; length } :: prefix in 51 | paths_of_type ~prefix arg) 52 | @@ args 53 | | Unhandled -> [] 54 | 55 | let paths_of_type t = List.map List.rev @@ paths_of_type ~prefix:[] t 56 | 57 | (* *) 58 | 59 | let skip_entry _ = 10 60 | 61 | let distance xs ys = 62 | let len_xs = List.length xs in 63 | let len_ys = List.length ys in 64 | let cache = Array.make_matrix (1 + len_xs) (1 + len_ys) (-1) in 65 | let inv = Db.Type_polarity.Sign.not in 66 | let rec memo ~xsgn ~ysgn i j xs ys = 67 | let r = cache.(i).(j) in 68 | if r >= 0 69 | then r 70 | else begin 71 | let r = go ~xsgn ~ysgn i j xs ys in 72 | cache.(i).(j) <- r ; 73 | r 74 | end 75 | and go ~xsgn ~ysgn i j xs ys = 76 | match xs, ys with 77 | | [], [] -> 0 78 | | [], _ -> 0 79 | | [ Any ], _ when xsgn = ysgn -> 0 80 | | [ Poly ], [ (Any | Poly) ] when xsgn = ysgn -> 0 81 | | Arrow_left :: xs, Arrow_left :: ys -> 82 | memo ~xsgn:(inv xsgn) ~ysgn:(inv ysgn) (i + 1) (j + 1) xs ys 83 | | x :: xs, y :: ys when x = y && xsgn = ysgn -> memo ~xsgn ~ysgn (i + 1) (j + 1) xs ys 84 | | _, Arrow_left :: ys -> 1 + memo ~xsgn ~ysgn:(inv ysgn) i (j + 1) xs ys 85 | | Arrow_left :: xs, _ -> 1 + memo ~xsgn:(inv xsgn) ~ysgn (i + 1) j xs ys 86 | | _, Arrow_right :: ys -> memo ~xsgn ~ysgn i (j + 1) xs ys 87 | | Arrow_right :: xs, _ -> memo ~xsgn ~ysgn (i + 1) j xs ys 88 | | _, [] -> 10_000 89 | | Product _ :: xs, Product _ :: ys -> 1 + memo ~xsgn ~ysgn (i + 1) (j + 1) xs ys 90 | | Argument _ :: xs, Argument _ :: ys -> 1 + memo ~xsgn ~ysgn (i + 1) (j + 1) xs ys 91 | | Product _ :: xs, ys -> 1 + memo ~xsgn ~ysgn (i + 1) j xs ys 92 | | xs, Product _ :: ys -> 1 + memo ~xsgn ~ysgn i (j + 1) xs ys 93 | | Type x :: xs', Type y :: ys' when xsgn = ysgn -> begin 94 | let skip_y = skip_entry y in 95 | match Name_cost.best_match ~sub:x y with 96 | | None -> skip_y + memo ~xsgn ~ysgn i (j + 1) xs ys' 97 | | Some (_, cost) -> (cost / 3) + memo ~xsgn ~ysgn (i + 1) (j + 1) xs' ys' 98 | end 99 | | xs, Type y :: ys' -> skip_entry y + memo ~xsgn ~ysgn i (j + 1) xs ys' 100 | | xs, Argument _ :: ys' -> memo ~xsgn ~ysgn i (j + 1) xs ys' 101 | | _, (Any | Poly) :: _ -> 10_000 102 | in 103 | let pos = Db.Type_polarity.Sign.Pos in 104 | go ~xsgn:pos ~ysgn:pos 0 0 xs ys 105 | 106 | let minimize = function 107 | | [] -> 0 108 | | arr -> 109 | let used = Array.make (List.length (List.hd arr)) false in 110 | let arr = 111 | Array.map (fun lst -> 112 | let lst = List.mapi (fun i x -> x, i) lst in 113 | List.sort Stdlib.compare lst) 114 | @@ Array.of_list arr 115 | in 116 | Array.sort (fun xs ys -> Stdlib.compare xs ys) arr ; 117 | let heuristics = Array.make (Array.length arr + 1) 0 in 118 | for i = Array.length heuristics - 2 downto 0 do 119 | let best = fst (List.hd arr.(i)) in 120 | heuristics.(i) <- heuristics.(i + 1) + best 121 | done ; 122 | let best = ref 1000 in 123 | let limit = ref 0 in 124 | let rec go rem acc i = 125 | incr limit ; 126 | if !limit > 10_000 127 | then false 128 | else if rem <= 0 129 | then begin 130 | (* entry type is smaller than query type *) 131 | let score = acc + (1000 * (Array.length arr - i)) in 132 | best := min score !best ; 133 | true 134 | end 135 | else if i >= Array.length arr 136 | then begin 137 | (* query type is smaller than entry type *) 138 | let score = acc + (5 * rem) in 139 | best := min score !best ; 140 | true 141 | end 142 | else if acc + heuristics.(i) >= !best 143 | then true 144 | else begin 145 | let rec find = function 146 | | [] -> true 147 | | (cost, j) :: rest -> 148 | let continue = 149 | if used.(j) 150 | then true 151 | else begin 152 | used.(j) <- true ; 153 | let continue = go (rem - 1) (acc + cost) (i + 1) in 154 | used.(j) <- false ; 155 | continue 156 | end 157 | in 158 | if continue then find rest else false 159 | in 160 | find arr.(i) 161 | end 162 | in 163 | let _ = go (Array.length used) 0 0 in 164 | !best 165 | 166 | let v ~query_paths ~entry = 167 | let entry_paths = paths_of_type entry in 168 | match entry_paths, query_paths with 169 | | _, [] | [], _ -> 0 170 | | _ -> 171 | let arr = List.map (fun p -> List.map (distance p) entry_paths) query_paths in 172 | minimize arr 173 | -------------------------------------------------------------------------------- /query/type_distance.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val paths_of_type : Db.Typexpr.t -> t 4 | 5 | val v : query_paths:t -> entry:Db.Typexpr.t -> int 6 | (** [Type_distance.v ~query_paths ~entry] is an integer representing a notion of 7 | distance between two types. [query_paths] is a type from a query, and [entry] is 8 | the type of a possible candidate for this query. *) 9 | -------------------------------------------------------------------------------- /query/type_lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Type_parser 3 | } 4 | 5 | rule token = parse 6 | | ' ' { token lexbuf } 7 | | "-" | "->" { ARROW } (* minus sign is interpreted as an arrow to support partially written queries *) 8 | | "(" { PARENS_OPEN } 9 | | ")" { PARENS_CLOSE } 10 | | "," { COMMA } 11 | | '_' { ANY } 12 | | '*' { STAR } 13 | | "'" (['a'-'z' 'A'-'Z' '0'-'9' '\'' '_']* as p) { POLY p } 14 | | ['a'-'z' 'A'-'Z' '0'-'9' '\'' '_' '.']+ as w { WORD w } 15 | | eof { EOF } 16 | -------------------------------------------------------------------------------- /query/type_parser.mly: -------------------------------------------------------------------------------- 1 | (* Type expressions parser, with error correction 2 | to support incomplete / partially written user queries. *) 3 | 4 | %{ 5 | module Printf = struct 6 | (* Without the following placeholder, [menhir_fail] induces 7 | a large dependency to [camlinternalFormat] in the js bundle. *) 8 | let eprintf _ = () 9 | end 10 | 11 | open Db.Typexpr 12 | %} 13 | 14 | %token EOF 15 | %token PARENS_OPEN PARENS_CLOSE 16 | %token ARROW COMMA ANY STAR 17 | %token WORD 18 | %token POLY 19 | 20 | %start main 21 | %type main 22 | 23 | %% 24 | 25 | main: 26 | | t=typ EOF { t } 27 | ; 28 | 29 | typ: 30 | | t=typ2 { t } 31 | | a=typ2 ARROW b=typ { Arrow (a, b) } 32 | ; 33 | 34 | typ2: 35 | | xs=list1(typ1, STAR) { tuple xs } 36 | ; 37 | 38 | typ1: 39 | | { Any } 40 | | ts=typs { tuple ts } 41 | | ts=typs w=WORD ws=list(WORD) { 42 | List.fold_left (fun acc w -> Constr (w, [acc])) (Constr (w, ts)) ws 43 | } 44 | ; 45 | 46 | typ0: 47 | | ANY { Any } 48 | | w=POLY { Poly w } 49 | | w=WORD { Constr (w, []) } 50 | ; 51 | 52 | typs: 53 | | t=typ0 { [t] } 54 | | PARENS_OPEN ts=list1(typ, COMMA) PARENS_CLOSE { ts } 55 | ; 56 | 57 | list1(term, separator): 58 | | x=term { [x] } 59 | | x=term separator xs=list1(term, separator) { x::xs } 60 | ; 61 | -------------------------------------------------------------------------------- /sherlodoc.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.2" 4 | synopsis: "Search engine for OCaml documentation" 5 | maintainer: ["art.wendling@gmail.com"] 6 | authors: ["Arthur Wendling" "Emile Trotignon"] 7 | license: "MIT" 8 | homepage: "https://github.com/art-w/sherlodoc" 9 | bug-reports: "https://github.com/art-w/sherlodoc/issues" 10 | depends: [ 11 | "dune" {>= "3.5"} 12 | "ocaml" {>= "4.0.8"} 13 | "odoc" {>= "2.4.0"} 14 | "base64" {>= "3.5.1"} 15 | "bigstringaf" {>= "0.9.1"} 16 | "js_of_ocaml" {>= "5.6.0"} 17 | "brr" {>= "0.0.6"} 18 | "cmdliner" {>= "1.2.0"} 19 | "decompress" {>= "1.5.3"} 20 | "fpath" {>= "0.7.3"} 21 | "lwt" {>= "5.7.0"} 22 | "menhir" {>= "20230608"} 23 | "ppx_blob" {>= "0.7.2"} 24 | "tyxml" {>= "4.6.0"} 25 | "result" {>= "1.5"} 26 | "odig" {with-test} 27 | "base" {with-test & = "v0.16.3"} 28 | "alcotest" {with-test} 29 | ] 30 | depopts: [ 31 | "dream" {>= "1.0.0~alpha5"} 32 | "ancient" {>= "0.9.1"} 33 | ] 34 | build: [ 35 | ["dune" "subst"] {dev} 36 | [ 37 | "dune" 38 | "build" 39 | "-p" 40 | name 41 | "-j" 42 | jobs 43 | "@install" 44 | "@runtest" {with-test} 45 | "@doc" {with-doc} 46 | ] 47 | ] 48 | dev-repo: "git+https://github.com/art-w/sherlodoc.git" 49 | -------------------------------------------------------------------------------- /store/db_store.default.ml: -------------------------------------------------------------------------------- 1 | type db_format = 2 | [ `ancient 3 | | `marshal 4 | | `js 5 | ] 6 | 7 | let available_backends = [ "marshal", `marshal; "js", `js ] 8 | 9 | let storage_module = function 10 | | `marshal -> (module Storage_marshal : Db.Storage.S) 11 | | `js -> (module Storage_js : Db.Storage.S) 12 | | `ancient -> failwith "ancient is unsupported" 13 | -------------------------------------------------------------------------------- /store/db_store.with_ancient.ml: -------------------------------------------------------------------------------- 1 | type db_format = 2 | [ `ancient 3 | | `marshal 4 | | `js 5 | ] 6 | 7 | let available_backends = [ "ancient", `ancient; "marshal", `marshal; "js", `js ] 8 | 9 | let storage_module = function 10 | | `ancient -> (module Storage_ancient : Db.Storage.S) 11 | | `marshal -> (module Storage_marshal : Db.Storage.S) 12 | | `js -> (module Storage_js : Db.Storage.S) 13 | -------------------------------------------------------------------------------- /store/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name db_store) 3 | (modules db_store) 4 | (libraries 5 | storage_marshal 6 | storage_js 7 | (select 8 | db_store.ml 9 | from 10 | (storage_ancient -> db_store.with_ancient.ml) 11 | (!storage_ancient -> db_store.default.ml)))) 12 | 13 | (library 14 | (name storage_ancient) 15 | (modules storage_ancient) 16 | (optional) 17 | (libraries db ancient unix)) 18 | 19 | (library 20 | (name storage_js) 21 | (modules storage_js) 22 | (libraries db base64 bigstringaf decompress.zl)) 23 | 24 | (library 25 | (name storage_marshal) 26 | (modules storage_marshal) 27 | (libraries db)) 28 | -------------------------------------------------------------------------------- /store/storage_ancient.ml: -------------------------------------------------------------------------------- 1 | let base_addr () = 2 | if Sys.word_size > 32 3 | then Int64.to_nativeint 0x100000000000L 4 | else failwith "TODO: support ancient on 32 bits" 5 | 6 | type writer = 7 | { mutable write_shard : int 8 | ; ancient : Ancient.md 9 | } 10 | 11 | let open_out filename = 12 | let handle = Unix.openfile filename Unix.[ O_RDWR; O_TRUNC; O_CREAT ] 0o640 in 13 | let ancient = Ancient.attach handle (base_addr ()) in 14 | { write_shard = 0; ancient } 15 | 16 | let save ~db (t : Db.t) = 17 | ignore (Ancient.share db.ancient db.write_shard t) ; 18 | db.write_shard <- db.write_shard + 1 19 | 20 | let close_out db = Ancient.detach db.ancient 21 | 22 | type reader = { shards : Db.t array } 23 | 24 | let load_shard md shard = 25 | match Ancient.get md shard with 26 | | t -> Some (Ancient.follow t) 27 | | exception _ -> None 28 | 29 | let load_shards md = 30 | let rec go i = 31 | match load_shard md i with 32 | | None -> [] 33 | | Some t -> t :: go (i + 1) 34 | in 35 | Array.of_list (go 0) 36 | 37 | let db_open_in db : reader = 38 | let filename = db in 39 | let handle = Unix.openfile filename Unix.[ O_RDWR ] 0o640 in 40 | let md = Ancient.attach handle (base_addr ()) in 41 | { shards = load_shards md } 42 | 43 | let load db_filename = 44 | let h = db_open_in db_filename in 45 | Array.to_list h.shards 46 | -------------------------------------------------------------------------------- /store/storage_ancient.mli: -------------------------------------------------------------------------------- 1 | include Db.Storage.S 2 | -------------------------------------------------------------------------------- /store/storage_js.ml: -------------------------------------------------------------------------------- 1 | type writer = out_channel 2 | 3 | let open_out = open_out 4 | let close_out = close_out 5 | 6 | let deflate_string ?(level = 4) str = 7 | let i = De.bigstring_create De.io_buffer_size in 8 | let o = De.bigstring_create De.io_buffer_size in 9 | let w = De.Lz77.make_window ~bits:15 in 10 | let q = De.Queue.create 0x1000 in 11 | let r = Buffer.create 0x1000 in 12 | let p = ref 0 in 13 | let refill buf = 14 | let len = min (String.length str - !p) De.io_buffer_size in 15 | Bigstringaf.blit_from_string str ~src_off:!p buf ~dst_off:0 ~len ; 16 | p := !p + len ; 17 | len 18 | in 19 | let flush buf len = 20 | let str = Bigstringaf.substring buf ~off:0 ~len in 21 | Buffer.add_string r str 22 | in 23 | Zl.Higher.compress ~level ~dynamic:true ~w ~q ~refill ~flush i o ; 24 | Buffer.contents r 25 | 26 | let save ~db t = 27 | let str = Marshal.to_string t [] in 28 | let str = deflate_string str in 29 | let str = Base64.encode_string str in 30 | Printf.fprintf db "function sherlodoc_db () { return %S; }\n%!" str 31 | 32 | let load _ = failwith "js database format is unsupported" 33 | -------------------------------------------------------------------------------- /store/storage_js.mli: -------------------------------------------------------------------------------- 1 | include Db.Storage.S 2 | -------------------------------------------------------------------------------- /store/storage_marshal.ml: -------------------------------------------------------------------------------- 1 | type writer = out_channel 2 | 3 | let open_out = open_out 4 | let close_out = close_out 5 | let save ~db t = Marshal.to_channel db t [] 6 | 7 | let load name = 8 | let file = open_in name in 9 | let t = Marshal.from_channel file in 10 | close_in file ; 11 | [ t ] 12 | -------------------------------------------------------------------------------- /store/storage_marshal.mli: -------------------------------------------------------------------------------- 1 | include Db.Storage.S 2 | -------------------------------------------------------------------------------- /test/cram/base_benchmark.t: -------------------------------------------------------------------------------- 1 | This test will fail, it is not deterministic. Please just check that the values 2 | are not crazy and discard the changes 3 | $ ODOCLS=$(find ../docs/odoc/base/ -name '*.odocl' | grep -v "__") 4 | $ sherlodoc index --format=js --db=db.js $ODOCLS 5 | -------------------------------------------------------------------------------- /test/cram/base_cli.t: -------------------------------------------------------------------------------- 1 | $ ODOCLS=$(find ../docs/odoc/base/ -name '*.odocl' | grep -v "__") 2 | $ export SHERLODOC_DB=db.bin 3 | $ export SHERLODOC_FORMAT=marshal 4 | $ sherlodoc index --index-docstring=false $ODOCLS 5 | $ sherlodoc search --print-cost --limit 100 "S_poly" 6 | 200 sig Base.Map.S_poly 7 | 200 sig Base.Set.S_poly 8 | 204 sig Base.Hashtbl.S_poly 9 | 248 type 'a Base.Hashtbl.S_poly.key = 'a 10 | 257 type ('a, 'b) Base.Map.S_poly.t 11 | 257 type 'elt Base.Set.S_poly.t 12 | 259 type ('a, 'cmp) Base.Set.S_poly.set 13 | 260 val Base.Set.S_poly.mem : 'a t -> 'a -> bool 14 | 260 type ('a, 'b) Base.Map.S_poly.tree 15 | 260 type 'elt Base.Set.S_poly.tree 16 | 261 type ('a, 'b) Base.Hashtbl.S_poly.t 17 | 261 mod Base.Set.S_poly.Named 18 | 267 val Base.Hashtbl.S_poly.data : (_, 'b) t -> 'b list 19 | 271 val Base.Hashtbl.S_poly.keys : ('a, _) t -> 'a key list 20 | 274 type Base.Map.S_poly.comparator_witness 21 | 274 type Base.Set.S_poly.comparator_witness 22 | 277 val Base.Set.S_poly.map : ('a, _) set -> f:('a -> 'b) -> 'b t 23 | 277 val Base.Hashtbl.S_poly.find_exn : ('a, 'b) t -> 'a key -> 'b 24 | 278 val Base.Hashtbl.S_poly.choose_exn : ('a, 'b) t -> 'a key * 'b 25 | 280 val Base.Hashtbl.S_poly.find : ('a, 'b) t -> 'a key -> 'b option 26 | 283 val Base.Hashtbl.S_poly.choose : ('a, 'b) t -> ('a key * 'b) option 27 | 283 val Base.Hashtbl.S_poly.to_alist : ('a, 'b) t -> ('a key * 'b) list 28 | 283 mod Base.Map.S_poly.Make_applicative_traversals 29 | 286 val Base.Hashtbl.S_poly.map : ('a, 'b) t -> f:('b -> 'c) -> ('a, 'c) t 30 | 287 val Base.Hashtbl.S_poly.map_inplace : (_, 'b) t -> f:('b -> 'b) -> unit 31 | 287 val Base.Hashtbl.S_poly.remove_multi : ('a, _ list) t -> 'a key -> unit 32 | 289 val Base.Hashtbl.S_poly.set : ('a, 'b) t -> key:'a key -> data:'b -> unit 33 | 289 val Base.Hashtbl.S_poly.find_multi : ('a, 'b list) t -> 'a key -> 'b list 34 | 291 val Base.Hashtbl.S_poly.find_and_remove : ('a, 'b) t -> 'a key -> 'b option 35 | 300 val Base.Hashtbl.S_poly.update : ('a, 'b) t -> 'a key -> f:('b option -> 'b) -> unit 36 | 300 val Base.Hashtbl.S_poly.add_multi : ('a, 'b list) t -> key:'a key -> data:'b -> unit 37 | 300 val Base.Hashtbl.S_poly.filter_map : ('a, 'b) t -> f:('b -> 'c option) -> ('a, 'c) t 38 | 301 val Base.Hashtbl.S_poly.filter_map_inplace : (_, 'b) t -> f:('b -> 'b option) -> unit 39 | 301 val Base.Hashtbl.S_poly.filter_keys_inplace : ('a, _) t -> f:('a key -> bool) -> unit 40 | 302 val Base.Hashtbl.S_poly.equal : ('b -> 'b -> bool) -> ('a, 'b) t -> ('a, 'b) t -> bool 41 | 303 val Base.Hashtbl.S_poly.iteri : ('a, 'b) t -> f:(key:'a key -> data:'b -> unit) -> unit 42 | 304 val Base.Hashtbl.S_poly.find_or_add : ('a, 'b) t -> 'a key -> default:(unit -> 'b) -> 'b 43 | 305 val Base.Hashtbl.S_poly.add : ('a, 'b) t -> key:'a key -> data:'b -> [ `Ok | `Duplicate ] 44 | 306 val Base.Hashtbl.S_poly.mapi : ('a, 'b) t -> f:(key:'a key -> data:'b -> 'c) -> ('a, 'c) t 45 | 307 val Base.Hashtbl.S_poly.change : ('a, 'b) t -> 'a key -> f:('b option -> 'b option) -> unit 46 | 307 val Base.Hashtbl.S_poly.findi_or_add : ('a, 'b) t -> 'a key -> default:('a key -> 'b) -> 'b 47 | 309 val Base.Hashtbl.S_poly.update_and_return : ('a, 'b) t -> 'a key -> f:('b option -> 'b) -> 'b 48 | 310 val Base.Hashtbl.S_poly.partition_tf : ('a, 'b) t -> f:('b -> bool) -> ('a, 'b) t * ('a, 'b) t 49 | 311 val Base.Hashtbl.S_poly.incr : ?by:int -> ?remove_if_zero:bool -> ('a, int) t -> 'a key -> unit 50 | 319 val Base.Hashtbl.S_poly.choose_randomly_exn : ?random_state:Random.State.t -> ('a, 'b) t -> 'a key * 'b 51 | 320 val Base.Hashtbl.S_poly.filter_mapi : ('a, 'b) t -> f:(key:'a key -> data:'b -> 'c option) -> ('a, 'c) t 52 | 323 val Base.Hashtbl.S_poly.fold : ('a, 'b) t -> init:'acc -> f:(key:'a key -> data:'b -> 'acc -> 'acc) -> 'acc 53 | 324 val Base.Hashtbl.S_poly.partition_map : ('a, 'b) t -> f:('b -> ('c, 'd) Either.t) -> ('a, 'c) t * ('a, 'd) t 54 | 324 val Base.Hashtbl.S_poly.choose_randomly : ?random_state:Random.State.t -> ('a, 'b) t -> ('a key * 'b) option 55 | 330 val Base.Hashtbl.S_poly.partitioni_tf : ('a, 'b) t -> f:(key:'a key -> data:'b -> bool) -> ('a, 'b) t * ('a, 'b) t 56 | 344 val Base.Hashtbl.S_poly.find_and_call : ('a, 'b) t -> 57 | 'a key -> 58 | if_found:('b -> 'c) -> 59 | if_not_found:('a key -> 'c) -> 60 | 'c 61 | 348 val Base.Set.S_poly.empty : 'a t 62 | 348 val Base.Hashtbl.S_poly.partition_mapi : ('a, 'b) t -> 63 | f:(key:'a key -> data:'b -> ('c, 'd) Either.t) -> 64 | ('a, 'c) t * ('a, 'd) t 65 | 353 val Base.Map.S_poly.empty : ('k, _) t 66 | 355 val Base.Set.S_poly.length : _ t -> int 67 | 358 val Base.Set.S_poly.is_empty : _ t -> bool 68 | 358 val Base.Set.S_poly.singleton : 'a -> 'a t 69 | 359 val Base.Set.S_poly.choose_exn : 'a t -> 'a 70 | 360 val Base.Set.S_poly.add : 'a t -> 'a -> 'a t 71 | 360 val Base.Map.S_poly.length : (_, _) t -> int 72 | 360 val Base.Set.S_poly.max_elt_exn : 'a t -> 'a 73 | 360 val Base.Set.S_poly.min_elt_exn : 'a t -> 'a 74 | 361 val Base.Set.S_poly.of_list : 'a list -> 'a t 75 | 361 val Base.Set.S_poly.of_tree : 'a tree -> 'a t 76 | 361 val Base.Set.S_poly.to_list : 'a t -> 'a list 77 | 361 val Base.Set.S_poly.to_tree : 'a t -> 'a tree 78 | 361 val Base.Set.S_poly.invariants : 'a t -> bool 79 | 362 val Base.Set.S_poly.choose : 'a t -> 'a option 80 | 362 val Base.Set.S_poly.elements : 'a t -> 'a list 81 | 362 val Base.Hashtbl.S_poly.merge_into : src:('k, 'a) t -> 82 | dst:('k, 'b) t -> 83 | f:(key:'k key -> 'a -> 'b option -> 'b Merge_into_action.t) -> 84 | unit 85 | 363 val Base.Map.S_poly.data : (_, 'v) t -> 'v list 86 | 363 val Base.Map.S_poly.keys : ('k, _) t -> 'k list 87 | 363 val Base.Set.S_poly.diff : 'a t -> 'a t -> 'a t 88 | 363 val Base.Set.S_poly.remove : 'a t -> 'a -> 'a t 89 | 363 val Base.Set.S_poly.max_elt : 'a t -> 'a option 90 | 363 val Base.Set.S_poly.min_elt : 'a t -> 'a option 91 | 363 val Base.Map.S_poly.is_empty : (_, _) t -> bool 92 | 363 val Base.Set.S_poly.of_array : 'a array -> 'a t 93 | 363 val Base.Set.S_poly.to_array : 'a t -> 'a array 94 | 364 val Base.Set.S_poly.equal : 'a t -> 'a t -> bool 95 | 364 val Base.Set.S_poly.inter : 'a t -> 'a t -> 'a t 96 | 364 val Base.Set.S_poly.union : 'a t -> 'a t -> 'a t 97 | 364 val Base.Hashtbl.S_poly.clear : (_, _) t -> unit 98 | 364 val Base.Hashtbl.S_poly.length : (_, _) t -> int 99 | 364 val Base.Hashtbl.S_poly.hashable : 'a Hashable.t 100 | 365 val Base.Map.S_poly.mem : ('k, _) t -> 'k -> bool 101 | 366 val Base.Set.S_poly.nth : 'a t -> int -> 'a option 102 | 366 val Base.Set.S_poly.union_list : 'a t list -> 'a t 103 | 367 val Base.Map.S_poly.invariants : ('k, 'v) t -> bool 104 | 367 val Base.Hashtbl.S_poly.is_empty : (_, _) t -> bool 105 | 367 val Base.Hashtbl.S_poly.find_and_call1 : ('a, 'b) t -> 106 | 'a key -> 107 | a:'d -> 108 | if_found:('b -> 'd -> 'c) -> 109 | if_not_found:('a key -> 'd -> 'c) -> 110 | 'c 111 | 369 val Base.Map.S_poly.find_exn : ('k, 'v) t -> 'k -> 'v 112 | 370 val Base.Map.S_poly.singleton : 'k -> 'v -> ('k, 'v) t 113 | 370 val Base.Set.S_poly.remove_index : 'a t -> int -> 'a t 114 | 371 val Base.Hashtbl.S_poly.copy : ('a, 'b) t -> ('a, 'b) t 115 | 371 val Base.Map.S_poly.max_elt_exn : ('k, 'v) t -> 'k * 'v 116 | 371 val Base.Map.S_poly.min_elt_exn : ('k, 'v) t -> 'k * 'v 117 | 371 val Base.Set.S_poly.of_sequence : 'a Sequence.t -> 'a t 118 | 371 val Base.Set.S_poly.are_disjoint : 'a t -> 'a t -> bool 119 | 372 val Base.Set.S_poly.compare_direct : 'a t -> 'a t -> int 120 | $ sherlodoc search --print-cost --no-rhs "group b" 121 | 231 val Base.Set.group_by 122 | 255 val Base.List.group 123 | 262 val Base.Sequence.group 124 | 275 val Base.List.sort_and_group 125 | 278 val Base.List.groupi 126 | 285 val Base.List.Assoc.group 127 | 305 val Base.List.Assoc.sort_and_group 128 | 325 val Base.Set.Poly.group_by 129 | 353 val Base.Set.Using_comparator.group_by 130 | 363 val Base.Set.Using_comparator.Tree.group_by 131 | 373 val Base.Hashtbl.group 132 | 427 val Base.Set.S_poly.group_by 133 | 462 val Base.Set.Accessors_generic.group_by 134 | 473 val Base.Hashtbl.Poly.group 135 | 475 val Base.Set.Creators_and_accessors_generic.group_by 136 | 480 val Base.Hashtbl.Creators.group 137 | 487 val Base.Hashtbl.Creators.group 138 | 499 val Base.Hashtbl.S_without_submodules.group 139 | 575 val Base.Hashtbl.S_poly.group 140 | $ sherlodoc search --no-rhs "group by" 141 | val Base.Set.group_by 142 | val Base.Set.Poly.group_by 143 | val Base.Set.Using_comparator.group_by 144 | val Base.Set.Using_comparator.Tree.group_by 145 | val Base.Set.S_poly.group_by 146 | val Base.Set.Accessors_generic.group_by 147 | val Base.Set.Creators_and_accessors_generic.group_by 148 | $ sherlodoc search --print-cost "map2" 149 | 177 mod Base.Applicative.Make_using_map2 150 | 178 mod Base.Applicative.Make2_using_map2 151 | 178 mod Base.Applicative.Make3_using_map2 152 | 188 mod Base.Applicative.Make_using_map2_local 153 | 189 mod Base.Applicative.Make2_using_map2_local 154 | 189 mod Base.Applicative.Make3_using_map2_local 155 | 192 val Base.Uniform_array.map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t 156 | 197 val Base.List.rev_map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t 157 | 200 mod Base.Applicative.Make_using_map2.Applicative_infix 158 | 201 mod Base.Applicative.Make2_using_map2.Applicative_infix 159 | 201 mod Base.Applicative.Make3_using_map2.Applicative_infix 160 | 205 val Base.Applicative.Make_using_map2.(<*>) : ('a -> 'b) X.t -> 'a X.t -> 'b X.t 161 | 211 mod Base.Applicative.Make_using_map2_local.Applicative_infix 162 | 212 mod Base.Applicative.Make2_using_map2_local.Applicative_infix 163 | 212 mod Base.Applicative.Make3_using_map2_local.Applicative_infix 164 | 216 val Base.Applicative.Make_using_map2_local.(<*>) : ('a -> 'b) X.t -> 'a X.t -> 'b X.t 165 | 228 sig Base.Applicative.Basic_using_map2 166 | 228 val Base.Applicative.Make_using_map2.Applicative_infix.(<*>) : ('a -> 'b) X.t -> 'a X.t -> 'b X.t 167 | 229 sig Base.Applicative.Basic2_using_map2 168 | 229 sig Base.Applicative.Basic3_using_map2 169 | 239 sig Base.Applicative.Basic_using_map2_local 170 | 239 val Base.Applicative.Make_using_map2_local.Applicative_infix.(<*>) : ('a -> 'b) X.t -> 'a X.t -> 'b X.t 171 | 240 sig Base.Applicative.Basic2_using_map2_local 172 | 240 sig Base.Applicative.Basic3_using_map2_local 173 | 276 val Base.Option.map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t 174 | 175 | $ sherlodoc search --print-cost --static-sort "List map2" 176 | 177 val Base.List.rev_map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t 177 | 273 val Base.List.map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t 178 | 290 val Base.List.map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t Or_unequal_lengths.t 179 | 292 val Base.List.Cartesian_product.map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t 180 | 294 val Base.List.rev_map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t Or_unequal_lengths.t 181 | 182 | $ sherlodoc search --print-cost "List map2" 183 | 202 val Base.List.rev_map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t 184 | 288 val Base.List.map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t 185 | 300 val Base.List.map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t Or_unequal_lengths.t 186 | 302 val Base.List.Cartesian_product.map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t 187 | 314 val Base.List.rev_map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t Or_unequal_lengths.t 188 | 189 | $ sherlodoc search --no-rhs "Base.Hashtbl.S_without_submodules.group" 190 | val Base.Hashtbl.S_without_submodules.group 191 | $ sherlodoc search --print-cost "list" 192 | 131 type 'a Base.list = 'a List.t 193 | 143 type 'a Base.Export.list = 'a List.t 194 | 151 type 'a Base.List.t = 'a list 195 | 154 mod Base.List 196 | 154 mod Caml.List 197 | 158 val Base.List.rev : 'a t -> 'a t 198 | 159 val Base.List.hd_exn : 'a t -> 'a 199 | 159 val Base.List.return : 'a -> 'a t 200 | 160 val Base.Bytes.to_list : t -> char list 201 | 161 val Base.List.join : 'a t t -> 'a t 202 | 161 val Base.List.tl_exn : 'a t -> 'a t 203 | 161 val Base.Queue.of_list : 'a list -> 'a t 204 | 161 val Base.Stack.of_list : 'a list -> 'a t 205 | 163 val Base.List.concat : 'a t t -> 'a t 206 | 163 mod Shadow_stdlib.List 207 | 164 val Base.List.last : 'a t -> 'a option 208 | 164 val Base.Set.to_list : ('a, _) t -> 'a list 209 | 165 mod Base.List.Assoc 210 | 165 mod Base.List.Infix 211 | 165 cons Base.Sexp.t.List : t list -> t 212 | 165 val Base.List.ignore_m : 'a t -> unit t 213 | 165 val Base.Bytes.of_char_list : char list -> t 214 | 166 val Base.List.drop : 'a t -> int -> 'a t 215 | 166 val Base.List.take : 'a t -> int -> 'a t 216 | 167 val Base.List.nth_exn : 'a t -> int -> 'a 217 | $ sherlodoc search --print-cost ": list" 218 | 168 val Base.List.rev : 'a t -> 'a t 219 | 169 val Base.List.return : 'a -> 'a t 220 | 170 val Base.Bytes.to_list : t -> char list 221 | 171 val Base.List.join : 'a t t -> 'a t 222 | 171 val Base.List.tl_exn : 'a t -> 'a t 223 | 172 val Base.String.split_lines : t -> t list 224 | 173 val Base.List.concat : 'a t t -> 'a t 225 | 175 val Base.List.ignore_m : 'a t -> unit t 226 | 175 val Base.String.to_list_rev : t -> char list 227 | 178 val Base.Sequence.to_list_rev : 'a t -> 'a list 228 | 180 val Base.Pretty_printer.all : unit -> string list 229 | 182 val Base.List.all_unit : unit t list -> unit t 230 | 182 val Base.List.filter_opt : 'a option t -> 'a t 231 | 182 val Base.List.transpose_exn : 'a t t -> 'a t t 232 | 182 val Base.List.concat_no_order : 'a t t -> 'a t 233 | 199 val Base.Set.to_list : ('a, _) t -> 'a list 234 | 200 val Base.Hashtbl.data : (_, 'b) t -> 'b list 235 | 200 val Base.Set.elements : ('a, _) t -> 'a list 236 | 201 val Base.List.drop : 'a t -> int -> 'a t 237 | 201 val Base.List.take : 'a t -> int -> 'a t 238 | 202 val Base.String.split : t -> on:char -> t list 239 | 204 val Base.List.append : 'a t -> 'a t -> 'a t 240 | 204 val Base.Hashtbl.keys : ('a, _) t -> 'a key list 241 | 208 val Base.List.rev_append : 'a t -> 'a t -> 'a t 242 | 211 val Base.List.intersperse : 'a t -> sep:'a -> 'a t 243 | 244 | Partial name search: 245 | $ sherlodoc search --print-cost "strin" 246 | 147 type Base.string = String.t 247 | 159 type Base.Export.string = String.t 248 | 166 val Base.Sexp.of_string : unit 249 | 167 type Base.String.t = string 250 | 167 type Base.String.elt = char 251 | 169 val Base.String.rev : t -> t 252 | 171 mod Base.String 253 | 171 mod Caml.String 254 | 172 val Base.String.hash : t -> int 255 | 172 val Base.Exn.to_string : t -> string 256 | 172 val Base.Sys.max_string_length : int 257 | 173 val Base.String.escaped : t -> t 258 | 173 val Base.String.max_length : int 259 | 174 val Base.String.(^) : t -> t -> t 260 | 174 val Base.Float.to_string : t -> string 261 | 175 mod Base.Stringable 262 | 175 val Base.String.uppercase : t -> t 263 | 176 type Base.String.Caseless.t = t 264 | 176 val Base.String.capitalize : t -> t 265 | 177 mod Base.StringLabels 266 | 177 mod Caml.StringLabels 267 | 177 val Base.String.append : t -> t -> t 268 | 177 val Base.Exn.to_string_mach : t -> string 269 | 177 val Base.Info.to_string_hum : t -> string 270 | 177 val Base.Sign.to_string_hum : t -> string 271 | $ sherlodoc search --print-cost "tring" 272 | 177 type Base.string = String.t 273 | 182 type Base.String.t = string 274 | 182 type Base.String.elt = char 275 | 184 val Base.String.rev : t -> t 276 | 186 mod Base.String 277 | 186 mod Caml.String 278 | 186 val Base.Sexp.of_string : unit 279 | 187 val Base.String.hash : t -> int 280 | 188 val Base.String.escaped : t -> t 281 | 188 val Base.String.max_length : int 282 | 189 val Base.String.(^) : t -> t -> t 283 | 189 type Base.Export.string = String.t 284 | 190 val Base.String.uppercase : t -> t 285 | 191 type Base.String.Caseless.t = t 286 | 191 val Base.String.capitalize : t -> t 287 | 192 val Base.Exn.to_string : t -> string 288 | 192 val Base.String.append : t -> t -> t 289 | 194 val Base.String.equal : t -> t -> bool 290 | 194 val Base.String.prefix : t -> int -> t 291 | 194 val Base.String.suffix : t -> int -> t 292 | 194 val Base.Float.to_string : t -> string 293 | 195 val Base.String.compare : t -> t -> int 294 | 195 mod Shadow_stdlib.String 295 | 197 val Base.String.ascending : t -> t -> int 296 | 197 val Base.String.split_lines : t -> t list 297 | -------------------------------------------------------------------------------- /test/cram/base_odocls.t: -------------------------------------------------------------------------------- 1 | $ find ../docs/odoc/base/ -name '*.odocl' -exec basename '{}' ';' | grep -v "__" | sort 2 | base.odocl 3 | base_internalhash_types.odocl 4 | caml.odocl 5 | md5_lib.odocl 6 | page-index.odocl 7 | shadow_stdlib.odocl 8 | 9 | $ find ../docs/odoc/base/ -name '*.odocl' -exec basename '{}' ';' | sort 10 | base.odocl 11 | base__.odocl 12 | base__Applicative.odocl 13 | base__Applicative_intf.odocl 14 | base__Array.odocl 15 | base__Array0.odocl 16 | base__Array_permute.odocl 17 | base__Avltree.odocl 18 | base__Backtrace.odocl 19 | base__Binary_search.odocl 20 | base__Binary_searchable.odocl 21 | base__Binary_searchable_intf.odocl 22 | base__Blit.odocl 23 | base__Blit_intf.odocl 24 | base__Bool.odocl 25 | base__Bool0.odocl 26 | base__Buffer.odocl 27 | base__Buffer_intf.odocl 28 | base__Bytes.odocl 29 | base__Bytes0.odocl 30 | base__Bytes_tr.odocl 31 | base__Char.odocl 32 | base__Char0.odocl 33 | base__Comparable.odocl 34 | base__Comparable_intf.odocl 35 | base__Comparator.odocl 36 | base__Comparisons.odocl 37 | base__Container.odocl 38 | base__Container_intf.odocl 39 | base__Either.odocl 40 | base__Either0.odocl 41 | base__Either_intf.odocl 42 | base__Equal.odocl 43 | base__Error.odocl 44 | base__Exn.odocl 45 | base__Field.odocl 46 | base__Fieldslib.odocl 47 | base__Float.odocl 48 | base__Float0.odocl 49 | base__Floatable.odocl 50 | base__Fn.odocl 51 | base__Formatter.odocl 52 | base__Globalize.odocl 53 | base__Hash.odocl 54 | base__Hash_intf.odocl 55 | base__Hash_set.odocl 56 | base__Hash_set_intf.odocl 57 | base__Hashable.odocl 58 | base__Hashable_intf.odocl 59 | base__Hasher.odocl 60 | base__Hashtbl.odocl 61 | base__Hashtbl_intf.odocl 62 | base__Hex_lexer.odocl 63 | base__Identifiable.odocl 64 | base__Identifiable_intf.odocl 65 | base__Import.odocl 66 | base__Import0.odocl 67 | base__Indexed_container.odocl 68 | base__Indexed_container_intf.odocl 69 | base__Info.odocl 70 | base__Info_intf.odocl 71 | base__Int.odocl 72 | base__Int0.odocl 73 | base__Int32.odocl 74 | base__Int63.odocl 75 | base__Int63_emul.odocl 76 | base__Int64.odocl 77 | base__Int_conversions.odocl 78 | base__Int_intf.odocl 79 | base__Int_math.odocl 80 | base__Intable.odocl 81 | base__Invariant.odocl 82 | base__Invariant_intf.odocl 83 | base__Lazy.odocl 84 | base__Linked_queue.odocl 85 | base__Linked_queue0.odocl 86 | base__List.odocl 87 | base__List0.odocl 88 | base__List1.odocl 89 | base__Map.odocl 90 | base__Map_intf.odocl 91 | base__Maybe_bound.odocl 92 | base__Monad.odocl 93 | base__Monad_intf.odocl 94 | base__Nativeint.odocl 95 | base__Nothing.odocl 96 | base__Obj_array.odocl 97 | base__Obj_local.odocl 98 | base__Option.odocl 99 | base__Option_array.odocl 100 | base__Or_error.odocl 101 | base__Ordered_collection_common.odocl 102 | base__Ordered_collection_common0.odocl 103 | base__Ordering.odocl 104 | base__Poly0.odocl 105 | base__Popcount.odocl 106 | base__Pow_overflow_bounds.odocl 107 | base__Ppx_compare_lib.odocl 108 | base__Ppx_enumerate_lib.odocl 109 | base__Ppx_hash_lib.odocl 110 | base__Pretty_printer.odocl 111 | base__Printf.odocl 112 | base__Queue.odocl 113 | base__Queue_intf.odocl 114 | base__Random.odocl 115 | base__Random_repr.odocl 116 | base__Ref.odocl 117 | base__Result.odocl 118 | base__Sequence.odocl 119 | base__Set.odocl 120 | base__Set_intf.odocl 121 | base__Sexp.odocl 122 | base__Sexp_with_comparable.odocl 123 | base__Sexpable.odocl 124 | base__Sign.odocl 125 | base__Sign0.odocl 126 | base__Sign_or_nan.odocl 127 | base__Source_code_position.odocl 128 | base__Source_code_position0.odocl 129 | base__Stack.odocl 130 | base__Stack_intf.odocl 131 | base__Staged.odocl 132 | base__String.odocl 133 | base__String0.odocl 134 | base__Stringable.odocl 135 | base__Sys.odocl 136 | base__Sys0.odocl 137 | base__T.odocl 138 | base__Type_equal.odocl 139 | base__Uchar.odocl 140 | base__Uchar0.odocl 141 | base__Uniform_array.odocl 142 | base__Unit.odocl 143 | base__Variant.odocl 144 | base__Variantslib.odocl 145 | base__With_return.odocl 146 | base__Word_size.odocl 147 | base_internalhash_types.odocl 148 | caml.odocl 149 | md5_lib.odocl 150 | page-index.odocl 151 | shadow_stdlib.odocl 152 | -------------------------------------------------------------------------------- /test/cram/base_web.t: -------------------------------------------------------------------------------- 1 | $ ODOCLS=$(find ../docs/odoc/base/ -name '*.odocl' | grep -v "__" | sort) 2 | $ cat $ODOCLS > megaodocl 3 | $ du -sh megaodocl 4 | 13M megaodocl 5 | $ sherlodoc index --index-docstring=true --index-name=true --type-search=true --format=js --db=db.js $ODOCLS 6 | 7 | $ gzip -k db.js 8 | 9 | We want to compare the compressed size with the size of the odocl. The search 10 | database contains information than the odocl, but the information is organised 11 | in queryable way, so a size increase is expected. It should just be reasonable. 12 | $ gzip -k megaodocl 13 | 14 | Marshal size changes between OCaml versions 15 | $ du -s db.js db.js.gz 16 | 2112 db.js 17 | 1596 db.js.gz 18 | 19 | $ for f in $(find . -name '*.odocl'); do 20 | > odoc html-generate --search-uri=db.js --search-uri=sherlodoc.js --output-dir html $f 21 | > done 22 | $ odoc support-files -o html 23 | $ cp db.js html/ 24 | The --no-preserve flag is here so that copying to /tmp will not fail because of 25 | a previous run. .js files built by dune are read only. 26 | $ sherlodoc js html/sherlodoc.js 27 | $ du -sh html/sherlodoc.js 28 | 104K html/sherlodoc.js 29 | $ ls html 30 | db.js 31 | fonts 32 | highlight.pack.js 33 | katex.min.css 34 | katex.min.js 35 | odoc.css 36 | odoc_search.js 37 | sherlodoc.js 38 | indent to see results 39 | $ cp -r html /tmp 40 | $ firefox /tmp/html/base/index.html 41 | -------------------------------------------------------------------------------- /test/cram/cli.t/main.mli: -------------------------------------------------------------------------------- 1 | type foo 2 | 3 | val unique_name : foo 4 | val multiple_hit_1 : foo 5 | val multiple_hit_2 : foo 6 | val multiple_hit_3 : foo 7 | 8 | type name_conflict = foo 9 | 10 | val name_conflict : foo 11 | 12 | module Nest : sig 13 | val nesting_priority : foo 14 | end 15 | 16 | val nesting_priority : foo 17 | 18 | module Map : sig 19 | val to_list : foo 20 | end 21 | 22 | type 'a list 23 | 24 | module List : sig 25 | type 'a t = 'a list 26 | 27 | val map : ('a -> 'b) -> 'a t -> 'b t 28 | val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list 29 | val rev_map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t 30 | end 31 | 32 | val foo : foo 33 | (** this is not a list nor a map *) 34 | 35 | type moo 36 | type t 37 | 38 | val value : moo 39 | val consume : moo -> unit 40 | val consume_2 : moo -> moo -> unit 41 | val consume_2_other : moo -> t -> unit 42 | val produce : unit -> moo 43 | val produce_2' : unit -> unit -> moo 44 | 45 | module type Modtype = sig 46 | val v_modtype : foo 47 | end 48 | 49 | module type S = sig end 50 | 51 | module S_to_S1 : sig end 52 | 53 | (**/**) 54 | 55 | val hidden : foo 56 | 57 | (**/**) 58 | 59 | val poly_1 : 'a -> 'b -> 'c 60 | val poly_2 : 'a -> 'b -> 'c -> 'a -> 'b -> 'c 61 | 62 | type 'a boo 63 | 64 | val poly_param : 'a boo 65 | 66 | type extensible_type = .. 67 | type extensible_type += MyExtension of moo 68 | 69 | type exn_payload 70 | 71 | exception Implicit_exn of exn_payload 72 | exception Explicit_exn : exn_payload -> exn 73 | type exn += Very_explicit_exn : exn_payload -> exn 74 | 75 | type long_name_type 76 | 77 | val long_name_value : long_name_type -------------------------------------------------------------------------------- /test/cram/cli.t/page.mld: -------------------------------------------------------------------------------- 1 | {0 A title} 2 | 3 | A paragraph 4 | 5 | {v some verbatim v} 6 | 7 | {[and code]} 8 | 9 | - a list {e of} things 10 | - bliblib 11 | -------------------------------------------------------------------------------- /test/cram/cli.t/run.t: -------------------------------------------------------------------------------- 1 | $ ocamlc -c main.mli -bin-annot -I . 2 | $ odoc compile -I . main.cmti 3 | $ odoc compile -I . page.mld 4 | $ odoc link -I . main.odoc 5 | $ odoc link -I . page-page.odoc 6 | $ export SHERLODOC_DB=db.bin 7 | $ export SHERLODOC_FORMAT=marshal 8 | $ sherlodoc index $(find . -name '*.odocl') 9 | $ sherlodoc search "unique_name" 10 | val Main.unique_name : foo 11 | $ sherlodoc search "multiple_hit" 12 | val Main.multiple_hit_1 : foo 13 | val Main.multiple_hit_2 : foo 14 | val Main.multiple_hit_3 : foo 15 | $ sherlodoc search --print-cost "name_conflict" 16 | 134 type Main.name_conflict = foo 17 | 234 val Main.name_conflict : foo 18 | $ sherlodoc search "nesting_priority" 19 | val Main.nesting_priority : foo 20 | val Main.Nest.nesting_priority : foo 21 | $ sherlodoc search "list" 22 | type 'a Main.list 23 | type 'a Main.List.t = 'a list 24 | mod Main.List 25 | val Main.Map.to_list : foo 26 | val Main.List.map : ('a -> 'b) -> 'a t -> 'b t 27 | val Main.List.map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list 28 | val Main.List.rev_map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t 29 | val Main.foo : foo 30 | $ sherlodoc search "map" 31 | mod Main.Map 32 | val Main.Map.to_list : foo 33 | val Main.List.map : ('a -> 'b) -> 'a t -> 'b t 34 | val Main.List.map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list 35 | val Main.List.rev_map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t 36 | val Main.foo : foo 37 | $ sherlodoc search "list map" 38 | val Main.List.map : ('a -> 'b) -> 'a t -> 'b t 39 | val Main.List.map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list 40 | val Main.Map.to_list : foo 41 | val Main.List.rev_map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t 42 | val Main.foo : foo 43 | $ sherlodoc search "map2" 44 | val Main.List.map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list 45 | val Main.List.rev_map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t 46 | $ sherlodoc search ":moo" 47 | val Main.value : moo 48 | val Main.produce : unit -> moo 49 | val Main.produce_2' : unit -> unit -> moo 50 | $ sherlodoc search ":_ -> moo" 51 | val Main.produce : unit -> moo 52 | val Main.produce_2' : unit -> unit -> moo 53 | val Main.value : moo 54 | $ sherlodoc search ":moo -> _" 55 | cons Main.MyExtension : moo -> extensible_type 56 | val Main.consume : moo -> unit 57 | val Main.consume_2 : moo -> moo -> unit 58 | val Main.consume_2_other : moo -> t -> unit 59 | $ sherlodoc search "modtype" 60 | sig Main.Modtype 61 | val Main.Modtype.v_modtype : foo 62 | $ sherlodoc search "S" 63 | mod Main.S_to_S1 64 | sig Main.S 65 | type Main.extensible_type = .. 66 | type 'a Main.List.t = 'a list 67 | mod Main.List 68 | mod Main.Nest 69 | type 'a Main.list 70 | type Main.MyExtension 71 | cons Main.MyExtension : moo -> extensible_type 72 | val Main.consume : moo -> unit 73 | val Main.Map.to_list : foo 74 | val Main.nesting_priority : foo 75 | val Main.consume_2 : moo -> moo -> unit 76 | val Main.Nest.nesting_priority : foo 77 | val Main.consume_2_other : moo -> t -> unit 78 | val Main.List.map : ('a -> 'b) -> 'a t -> 'b t 79 | val Main.foo : foo 80 | val Main.List.map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list 81 | val Main.List.rev_map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t 82 | $ sherlodoc search "qwertyuiopasdfghjklzxcvbnm" 83 | [No results] 84 | $ sherlodoc search "hidden" 85 | [No results] 86 | $ sherlodoc search ":mo" 87 | val Main.value : moo 88 | val Main.produce : unit -> moo 89 | val Main.produce_2' : unit -> unit -> moo 90 | $ sherlodoc search ":'a" 91 | val Main.poly_param : 'a boo 92 | val Main.poly_1 : 'a -> 'b -> 'c 93 | val Main.List.map : ('a -> 'b) -> 'a t -> 'b t 94 | val Main.poly_2 : 'a -> 'b -> 'c -> 'a -> 'b -> 'c 95 | val Main.List.map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list 96 | val Main.List.rev_map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t 97 | $ sherlodoc search ": 'a -> 'b -> 'c " 98 | val Main.poly_1 : 'a -> 'b -> 'c 99 | val Main.poly_2 : 'a -> 'b -> 'c -> 'a -> 'b -> 'c 100 | val Main.List.map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list 101 | val Main.List.rev_map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t 102 | $ sherlodoc search ": ('a -> 'b) -> 'a t -> 'b t" 103 | val Main.List.map : ('a -> 'b) -> 'a t -> 'b t 104 | val Main.List.map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list 105 | val Main.List.rev_map2_exn : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t 106 | $ sherlodoc search ": 'a bo" 107 | val Main.poly_param : 'a boo 108 | $ sherlodoc search ":extensible_type" 109 | cons Main.MyExtension : moo -> extensible_type 110 | $ sherlodoc search ":exn" 111 | exn Main.Explicit_exn : exn_payload -> exn 112 | exn Main.Implicit_exn : exn_payload -> exn 113 | cons Main.Very_explicit_exn : exn_payload -> exn 114 | $ sherlodoc search ": exn_payload -> _" 115 | exn Main.Explicit_exn : exn_payload -> exn 116 | exn Main.Implicit_exn : exn_payload -> exn 117 | cons Main.Very_explicit_exn : exn_payload -> exn 118 | $ sherlodoc search ": long_name_type" 119 | val Main.long_name_value : long_name_type 120 | $ sherlodoc search ": long_nam" 121 | val Main.long_name_value : long_name_type 122 | $ sherlodoc search "long_name" 123 | type Main.long_name_type 124 | val Main.long_name_value : long_name_type 125 | -------------------------------------------------------------------------------- /test/cram/cli_poly.t/main.mli: -------------------------------------------------------------------------------- 1 | 2 | 3 | val poly_1 : 'a -> 'b -> 'c 4 | 5 | 6 | 7 | 8 | -------------------------------------------------------------------------------- /test/cram/cli_poly.t/page.mld: -------------------------------------------------------------------------------- 1 | {0 A title} 2 | 3 | A paragraph 4 | 5 | {v some verbatim v} 6 | 7 | {[and code]} 8 | 9 | - a list {e of} things 10 | - bliblib 11 | -------------------------------------------------------------------------------- /test/cram/cli_poly.t/run.t: -------------------------------------------------------------------------------- 1 | $ ocamlc -c main.mli -bin-annot -I . 2 | $ odoc compile -I . main.cmti 3 | $ odoc compile -I . page.mld 4 | $ odoc link -I . main.odoc 5 | $ odoc link -I . page-page.odoc 6 | $ cat $(find . -name '*.odocl') > megaodocl 7 | $ du -sh megaodocl 8 | 4.0K megaodocl 9 | $ export SHERLODOC_DB=db.bin 10 | $ export SHERLODOC_FORMAT=marshal 11 | $ sherlodoc index $(find . -name '*.odocl') 12 | TODO : get a result for the query bellow 13 | $ sherlodoc search ":'a" 14 | val Main.poly_1 : 'a -> 'b -> 'c 15 | $ sherlodoc search ": 'a -> 'b -> 'c " 16 | val Main.poly_1 : 'a -> 'b -> 'c 17 | TODO : get a result for the query bellow 18 | -------------------------------------------------------------------------------- /test/cram/cli_small.t/main.mli: -------------------------------------------------------------------------------- 1 | 2 | type 'a list 3 | 4 | module List : sig 5 | type 'a t = 'a list 6 | 7 | val map : ('a -> 'b) -> 'a t -> 'b t 8 | 9 | val empty : 'a t * 'b t 10 | 11 | 12 | end 13 | 14 | type ('a, 'b) result 15 | 16 | val ok: 'a -> ('a, 'b) result 17 | 18 | val ok_zero : (int, 'a) result -------------------------------------------------------------------------------- /test/cram/cli_small.t/run.t: -------------------------------------------------------------------------------- 1 | $ ocamlc -c main.mli -bin-annot -I . 2 | $ odoc compile -I . main.cmti 3 | $ odoc link -I . main.odoc 4 | $ export SHERLODOC_DB=db.bin 5 | $ export SHERLODOC_FORMAT=marshal 6 | $ sherlodoc index $(find . -name '*.odocl') 7 | $ sherlodoc search --print-cost "list" 8 | 139 type 'a Main.list 9 | 151 type 'a Main.List.t = 'a list 10 | 154 mod Main.List 11 | 259 val Main.List.empty : 'a t * 'b t 12 | 272 val Main.List.map : ('a -> 'b) -> 'a t -> 'b t 13 | $ sherlodoc search ": (int, 'a) result" 14 | val Main.ok_zero : (int, 'a) result 15 | -------------------------------------------------------------------------------- /test/cram/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (deps ../docs %{bin:odoc} %{bin:sherlodoc})) 3 | -------------------------------------------------------------------------------- /test/cram/empty.t/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name foo) 3 | (public_name foo)) 4 | -------------------------------------------------------------------------------- /test/cram/empty.t/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.7) 2 | 3 | (package 4 | (name foo)) 5 | -------------------------------------------------------------------------------- /test/cram/empty.t/foo.ml: -------------------------------------------------------------------------------- 1 | let a = 123 -------------------------------------------------------------------------------- /test/cram/empty.t/run.t: -------------------------------------------------------------------------------- 1 | This test checkes that project that is empty despite not looking empty does not 2 | crash sherlodoc. 3 | $ export PATH=.:$PATH 4 | $ export OCAMLRUNPARAM=b 5 | $ dune build @doc 6 | $ sherlodoc index ./_build/default/_doc/_odocls/foo/page-index.odocl --format=marshal --db=db.marshal 7 | $ sherlodoc search --db=db.marshal lorem 8 | [No results] 9 | 10 | -------------------------------------------------------------------------------- /test/cram/link_in_docstring.t/a.mli: -------------------------------------------------------------------------------- 1 | 2 | (** This is a docstring with a {{:https://sherlocode.com}link} *) 3 | val foo : int 4 | 5 | (** This is a docstring with a ref to {!foo} *) 6 | val bar : int -------------------------------------------------------------------------------- /test/cram/link_in_docstring.t/run.t: -------------------------------------------------------------------------------- 1 | $ ocamlc -c a.mli -bin-annot -I . 2 | $ odoc compile -I . a.cmti 3 | $ odoc link -I . a.odoc 4 | $ export SHERLODOC_DB=db.bin 5 | $ export SHERLODOC_FORMAT=marshal 6 | $ sherlodoc index $(find . -name '*.odocl') 7 | $ sherlodoc search --print-docstring "foo" 8 | val A.foo : int 9 |

This is a docstring with a link

10 | $ sherlodoc search --print-docstring "bar" 11 | val A.bar : int 12 |

This is a docstring with a ref to foo

13 | -------------------------------------------------------------------------------- /test/cram/module_type_cost.t/main.mli: -------------------------------------------------------------------------------- 1 | module M : sig 2 | val my_function : int -> int 3 | end 4 | 5 | module type S = sig 6 | val my_function : int -> int 7 | end 8 | 9 | module type Module_type = sig end 10 | 11 | module Module_nype : sig end 12 | 13 | module Make (M : S) : S -------------------------------------------------------------------------------- /test/cram/module_type_cost.t/run.t: -------------------------------------------------------------------------------- 1 | $ ocamlc -c main.mli -bin-annot -I . 2 | $ odoc compile -I . main.cmti 3 | $ odoc link -I . main.odoc 4 | $ cat $(find . -name '*.odocl') > megaodocl 5 | $ du -sh megaodocl 6 | 4.0K megaodocl 7 | $ export SHERLODOC_DB=db.bin 8 | $ export SHERLODOC_FORMAT=marshal 9 | $ sherlodoc index $(find . -name '*.odocl') 10 | Here we expect to have the `my_function` from the module be above the one from 11 | the module type. 12 | $ sherlodoc search --print-cost --no-rhs "my_function" 13 | 246 val Main.M.my_function 14 | 249 val Main.Make.my_function 15 | 346 val Main.S.my_function 16 | Here we expect both the module type and the module to be ranked the same 17 | $ sherlodoc search --print-cost "module" 18 | 166 mod Main.Module_nype 19 | 216 sig Main.Module_type 20 | -------------------------------------------------------------------------------- /test/cram/odocl_favouritism.t/a.mli: -------------------------------------------------------------------------------- 1 | val unique_name : int 2 | -------------------------------------------------------------------------------- /test/cram/odocl_favouritism.t/b.mli: -------------------------------------------------------------------------------- 1 | val unique_name : int 2 | -------------------------------------------------------------------------------- /test/cram/odocl_favouritism.t/run.t: -------------------------------------------------------------------------------- 1 | $ ocamlc -c a.mli -bin-annot -I . 2 | $ odoc compile -I . a.cmti 3 | $ ocamlc -c b.mli -bin-annot -I . 4 | $ odoc compile -I . b.cmti 5 | $ odoc link -I . a.odoc 6 | $ odoc link -I . b.odoc 7 | 8 | $ export SHERLODOC_DB=db.bin 9 | $ export SHERLODOC_FORMAT=marshal 10 | $ sherlodoc index a.odocl b.odocl 11 | $ sherlodoc search --print-cost "unique_name" 12 | 229 val A.unique_name : int 13 | 229 val B.unique_name : int 14 | $ sherlodoc index --favoured a.odocl b.odocl 15 | $ sherlodoc search --print-cost "unique_name" 16 | 179 val A.unique_name : int 17 | 229 val B.unique_name : int 18 | $ sherlodoc index a.odocl --favoured b.odocl 19 | $ sherlodoc search --print-cost "unique_name" 20 | 179 val B.unique_name : int 21 | 229 val A.unique_name : int 22 | $ sherlodoc index --favoured a.odocl --favoured b.odocl 23 | $ sherlodoc search --print-cost "unique_name" 24 | 179 val A.unique_name : int 25 | 179 val B.unique_name : int 26 | -------------------------------------------------------------------------------- /test/cram/prefix_favouritism.t: -------------------------------------------------------------------------------- 1 | $ ODOCLS=$(find ../docs/odoc/base/ -name '*.odocl') 2 | $ export SHERLODOC_DB=db.bin 3 | $ export SHERLODOC_FORMAT=marshal 4 | $ sherlodoc index $ODOCLS > /dev/null 5 | $ sherlodoc search --print-cost "list" 6 | 131 type 'a Base.list = 'a List.t 7 | 143 type 'a Base.Export.list = 'a List.t 8 | 151 type 'a Base.List.t = 'a list 9 | 154 mod Base.List 10 | 154 mod Caml.List 11 | 158 val Base.List.rev : 'a t -> 'a t 12 | 159 val Base.List.hd_exn : 'a t -> 'a 13 | 159 val Base.List.return : 'a -> 'a t 14 | 160 val Base.Bytes.to_list : t -> char list 15 | 161 val Base.List.join : 'a t t -> 'a t 16 | 161 val Base.List.tl_exn : 'a t -> 'a t 17 | 161 val Base.Queue.of_list : 'a list -> 'a t 18 | 161 val Base.Stack.of_list : 'a list -> 'a t 19 | 163 val Base.List.concat : 'a t t -> 'a t 20 | 163 mod Shadow_stdlib.List 21 | 164 val Base.List.last : 'a t -> 'a option 22 | 165 mod Base.List.Assoc 23 | 165 mod Base.List.Infix 24 | 165 cons Base.Sexp.t.List : t list -> t 25 | 165 val Base.List.ignore_m : 'a t -> unit t 26 | 166 val Base.List.drop : 'a t -> int -> 'a t 27 | 166 val Base.List.take : 'a t -> int -> 'a t 28 | 175 mod Base.ListLabels 29 | 175 mod Caml.ListLabels 30 | 394 mod Base 31 | $ sherlodoc index --favoured-prefixes=Base $ODOCLS > /dev/null 32 | $ sherlodoc search --print-cost "list" 33 | 81 type 'a Base.list = 'a List.t 34 | 93 type 'a Base.Export.list = 'a List.t 35 | 101 type 'a Base.List.t = 'a list 36 | 104 mod Base.List 37 | 108 val Base.List.rev : 'a t -> 'a t 38 | 109 val Base.List.hd_exn : 'a t -> 'a 39 | 109 val Base.List.return : 'a -> 'a t 40 | 110 val Base.Bytes.to_list : t -> char list 41 | 111 val Base.List.join : 'a t t -> 'a t 42 | 111 val Base.List.tl_exn : 'a t -> 'a t 43 | 111 val Base.Queue.of_list : 'a list -> 'a t 44 | 111 val Base.Stack.of_list : 'a list -> 'a t 45 | 113 val Base.List.concat : 'a t t -> 'a t 46 | 114 val Base.List.last : 'a t -> 'a option 47 | 115 mod Base.List.Assoc 48 | 115 mod Base.List.Infix 49 | 115 cons Base.Sexp.t.List : t list -> t 50 | 115 val Base.List.ignore_m : 'a t -> unit t 51 | 116 val Base.List.drop : 'a t -> int -> 'a t 52 | 116 val Base.List.take : 'a t -> int -> 'a t 53 | 125 mod Base.ListLabels 54 | 344 mod Base 55 | 347 type Base.Nothing.t = 56 | 362 val Base.String.append : t -> t -> t 57 | 364 val Base.Int.ascending : t -> t -> int 58 | $ sherlodoc index --favoured-prefixes=Caml $ODOCLS > /dev/null 59 | $ sherlodoc search --print-cost "list" 60 | 104 mod Caml.List 61 | 125 mod Caml.ListLabels 62 | 131 type 'a Base.list = 'a List.t 63 | 143 type 'a Base.Export.list = 'a List.t 64 | 151 type 'a Base.List.t = 'a list 65 | 154 mod Base.List 66 | 158 val Base.List.rev : 'a t -> 'a t 67 | 159 val Base.List.hd_exn : 'a t -> 'a 68 | 159 val Base.List.return : 'a -> 'a t 69 | 160 val Base.Bytes.to_list : t -> char list 70 | 161 val Base.List.join : 'a t t -> 'a t 71 | 161 val Base.List.tl_exn : 'a t -> 'a t 72 | 161 val Base.Queue.of_list : 'a list -> 'a t 73 | 161 val Base.Stack.of_list : 'a list -> 'a t 74 | 163 val Base.List.concat : 'a t t -> 'a t 75 | 163 mod Shadow_stdlib.List 76 | 164 val Base.List.last : 'a t -> 'a option 77 | 165 mod Base.List.Assoc 78 | 165 mod Base.List.Infix 79 | 165 cons Base.Sexp.t.List : t list -> t 80 | 165 val Base.List.ignore_m : 'a t -> unit t 81 | 166 val Base.List.drop : 'a t -> int -> 'a t 82 | 166 val Base.List.take : 'a t -> int -> 'a t 83 | 175 mod Base.ListLabels 84 | 394 mod Base 85 | $ sherlodoc index --favoured-prefixes=Base,Caml $ODOCLS > /dev/null 86 | $ sherlodoc search --print-cost "list" 87 | 81 type 'a Base.list = 'a List.t 88 | 93 type 'a Base.Export.list = 'a List.t 89 | 101 type 'a Base.List.t = 'a list 90 | 104 mod Base.List 91 | 104 mod Caml.List 92 | 108 val Base.List.rev : 'a t -> 'a t 93 | 109 val Base.List.hd_exn : 'a t -> 'a 94 | 109 val Base.List.return : 'a -> 'a t 95 | 110 val Base.Bytes.to_list : t -> char list 96 | 111 val Base.List.join : 'a t t -> 'a t 97 | 111 val Base.List.tl_exn : 'a t -> 'a t 98 | 111 val Base.Queue.of_list : 'a list -> 'a t 99 | 111 val Base.Stack.of_list : 'a list -> 'a t 100 | 113 val Base.List.concat : 'a t t -> 'a t 101 | 114 val Base.List.last : 'a t -> 'a option 102 | 115 mod Base.List.Assoc 103 | 115 mod Base.List.Infix 104 | 115 cons Base.Sexp.t.List : t list -> t 105 | 115 val Base.List.ignore_m : 'a t -> unit t 106 | 116 val Base.List.drop : 'a t -> int -> 'a t 107 | 116 val Base.List.take : 'a t -> int -> 'a t 108 | 125 mod Base.ListLabels 109 | 125 mod Caml.ListLabels 110 | 344 mod Base 111 | 347 type Base.Nothing.t = 112 | $ sherlodoc index $ODOCLS --favoured-prefixes "" > /dev/null 113 | $ sherlodoc search --print-cost "list" 114 | 131 type 'a Base.list = 'a List.t 115 | 143 type 'a Base.Export.list = 'a List.t 116 | 151 type 'a Base.List.t = 'a list 117 | 154 mod Base.List 118 | 154 mod Caml.List 119 | 158 val Base.List.rev : 'a t -> 'a t 120 | 159 val Base.List.hd_exn : 'a t -> 'a 121 | 159 val Base.List.return : 'a -> 'a t 122 | 160 val Base.Bytes.to_list : t -> char list 123 | 161 val Base.List.join : 'a t t -> 'a t 124 | 161 val Base.List.tl_exn : 'a t -> 'a t 125 | 161 val Base.Queue.of_list : 'a list -> 'a t 126 | 161 val Base.Stack.of_list : 'a list -> 'a t 127 | 163 val Base.List.concat : 'a t t -> 'a t 128 | 163 mod Shadow_stdlib.List 129 | 164 val Base.List.last : 'a t -> 'a option 130 | 165 mod Base.List.Assoc 131 | 165 mod Base.List.Infix 132 | 165 cons Base.Sexp.t.List : t list -> t 133 | 165 val Base.List.ignore_m : 'a t -> unit t 134 | 166 val Base.List.drop : 'a t -> int -> 'a t 135 | 166 val Base.List.take : 'a t -> int -> 'a t 136 | 175 mod Base.ListLabels 137 | 175 mod Caml.ListLabels 138 | 394 mod Base 139 | 140 | Partial name search: 141 | -------------------------------------------------------------------------------- /test/cram/query_syntax.t: -------------------------------------------------------------------------------- 1 | We need a dummy file because sherlodoc requires an odocl. 2 | $ touch main.mli 3 | $ ocamlc -c main.mli -bin-annot -I . 4 | $ odoc compile -I . main.cmti 5 | $ odoc link -I . main.odoc 6 | $ export SHERLODOC_FORMAT=marshal 7 | $ export SHERLODOC_DB=db.bin 8 | $ sherlodoc index main.odocl 9 | $ sherlodoc search --pretty-query ": int list option" 10 | : int list option 11 | [No results] 12 | $ export OCAMLRUNPARAM=b 13 | $ sherlodoc search --pretty-query ": _" 14 | : _ 15 | [No results] 16 | Testing incomplete queries 17 | $ sherlodoc search --pretty-query ": ->" 18 | : _ -> _ 19 | [No results] 20 | $ sherlodoc search --pretty-query ": int ->" 21 | : int -> _ 22 | [No results] 23 | $ sherlodoc search --pretty-query ": int *" 24 | : int * _ 25 | [No results] 26 | $ sherlodoc search --pretty-query ": string -> (" 27 | : string -> _ 28 | [No results] 29 | $ sherlodoc search --pretty-query ": (int" 30 | : int 31 | [No results] 32 | $ sherlodoc search --pretty-query ": (int ->" 33 | : int -> _ 34 | [No results] 35 | $ sherlodoc search --pretty-query ": (int *" 36 | : int * _ 37 | [No results] 38 | $ sherlodoc search --pretty-query ": foo bar qux" 39 | : foo bar qux 40 | [No results] 41 | $ sherlodoc search --pretty-query ": ()" 42 | : _ 43 | [No results] 44 | $ sherlodoc search --pretty-query ": )" 45 | : _ 46 | [No results] 47 | $ sherlodoc search --pretty-query ": (int," 48 | : int * _ 49 | [No results] 50 | $ sherlodoc search --pretty-query ": (int,string" 51 | : int * string 52 | [No results] 53 | $ sherlodoc search --pretty-query ": 'a, 'b) result -" 54 | : ('a, 'b) result -> _ 55 | [No results] 56 | $ sherlodoc search --pretty-query ": 'a * 'b) list" 57 | : ('a * 'b) list 58 | [No results] 59 | $ sherlodoc search --pretty-query ": - ,'a * 'b, 'c) result -) - ( -" 60 | : ((_ -> _, 'a * 'b, 'c) result -> _) -> _ -> _ 61 | [No results] 62 | Testing syntax errors 63 | $ sherlodoc search --pretty-query ": )(" 64 | : 65 | [No results] 66 | -------------------------------------------------------------------------------- /test/cram/simple.t/main.ml: -------------------------------------------------------------------------------- 1 | type t = int 2 | (** A comment *) 3 | 4 | (** {1 this is a title} 5 | 6 | and this is a paragraph 7 | 8 | *) 9 | 10 | module type Signature = sig end 11 | 12 | class istack = 13 | object 14 | val mutable v = [ 0; 2 ] 15 | 16 | method pop = 17 | match v with 18 | | hd :: tl -> 19 | v <- tl ; 20 | Some hd 21 | | [] -> None 22 | 23 | method push hd = v <- hd :: v 24 | end 25 | 26 | class type my_class_type = object end 27 | 28 | module Modulule = struct 29 | type t 30 | (** dsdsd *) 31 | end 32 | 33 | (** a reference {!t}, and some {e formatted} {b content} with [code] and 34 | 35 | {[ 36 | code blocks 37 | ]} 38 | 39 | *) 40 | let v = 9 41 | 42 | (** lorem 1 43 | *) 44 | let lorem _ = 'a' 45 | 46 | (** lorem 2 47 | *) 48 | let lorem2 _ = 'a' 49 | 50 | (** lorem 3 51 | *) 52 | let lorem3 _ = 'e' 53 | 54 | (** lorem 4 55 | *) 56 | module Trucmuche = struct 57 | let bidule = 4 58 | end 59 | 60 | include Trucmuche 61 | 62 | let lorem4 = 1 63 | 64 | type my_type = int * char 65 | 66 | type babar = 67 | | A of string 68 | | B 69 | | C of 70 | { z : int 71 | ; w : char 72 | } 73 | 74 | type _ celeste = 75 | { x : babar 76 | ; y : int -> string 77 | } 78 | 79 | type 'a list = 80 | | Cons of 'a * 'a list 81 | | Nil 82 | 83 | (** Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod 84 | tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, 85 | quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo 86 | consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse 87 | cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat 88 | non proident, sunt in culpa qui officia deserunt mollit anim id est laborum. *) 89 | let long = 3 90 | 91 | type ext_t = .. 92 | type ext_t += Ext_const of int 93 | -------------------------------------------------------------------------------- /test/cram/simple.t/page.mld: -------------------------------------------------------------------------------- 1 | {0 A title} 2 | 3 | A paragraph 4 | 5 | {v some verbatim v} 6 | 7 | {[and code]} 8 | 9 | - a list {e of} things 10 | - bliblib 11 | 12 | {!Main} -------------------------------------------------------------------------------- /test/cram/simple.t/run.t: -------------------------------------------------------------------------------- 1 | $ ocamlc -c main.ml -bin-annot -I . 2 | $ odoc compile --child module-main -I . page.mld 3 | $ odoc compile --parent page -I . main.cmt 4 | $ odoc link -I . main.odoc 5 | $ odoc link -I . page-page.odoc 6 | $ cat $(find . -name '*.odocl') > megaodocl 7 | $ du -sh megaodocl 8 | 12K megaodocl 9 | $ mkdir html 10 | $ sherlodoc index --format=js --db=html/db.js $(find . -name '*.odocl') 2> /dev/null 11 | $ sherlodoc js html/sherlodoc.js 12 | $ odoc support-files -o html 13 | $ for f in $(find . -name '*.odocl' | sort); do 14 | > echo $f ; 15 | > cd html ; 16 | > odoc html-generate --search-uri db.js --search-uri sherlodoc.js --output-dir . ../$f ; 17 | > cd .. 18 | > done | sort 19 | ./main.odocl 20 | ./page-page.odocl 21 | $ ls | sort 22 | html 23 | main.cmi 24 | main.cmo 25 | main.cmt 26 | main.ml 27 | main.odoc 28 | main.odocl 29 | megaodocl 30 | page-page.odoc 31 | page-page.odocl 32 | page.mld 33 | $ ls html | sort 34 | db.js 35 | fonts 36 | highlight.pack.js 37 | katex.min.css 38 | katex.min.js 39 | odoc.css 40 | odoc_search.js 41 | page 42 | sherlodoc.js 43 | $ ls html/page | sort 44 | Main 45 | index.html 46 | $ find . -name "*.html" -type f | sort 47 | ./html/page/Main/Modulule/index.html 48 | ./html/page/Main/Trucmuche/index.html 49 | ./html/page/Main/class-istack/index.html 50 | ./html/page/Main/class-type-my_class_type/index.html 51 | ./html/page/Main/index.html 52 | ./html/page/Main/module-type-Signature/index.html 53 | ./html/page/index.html 54 | $ find . -name "*.js" -type f | sort 55 | ./html/db.js 56 | ./html/highlight.pack.js 57 | ./html/katex.min.js 58 | ./html/odoc_search.js 59 | ./html/sherlodoc.js 60 | 61 | Indent to see results 62 | $ cp -r html /tmp 63 | $ firefox /tmp/html/page/index.html 64 | $ grep -E -o "'[\./a-zA-Z0-9_]*\.js" html/page/index.html 65 | '../db.js 66 | '../sherlodoc.js 67 | 68 | 69 | -------------------------------------------------------------------------------- /test/cram/size_bound.t: -------------------------------------------------------------------------------- 1 | This tests that sherlodoc.js is not bigger than 120000 bytes. We test a threshold 2 | of the size because the precise size depends on specific ocaml and dependencies 3 | versions. This test should pass on every version. If it fails, we can either 4 | update the threshold to be large enough or forbid certain dependency versions 5 | in the opam file. 6 | $ sherlodoc js sherlodoc.js 7 | $ if [ "$(du sherlodoc.js | cut -f 1)" -gt 120000 ]; then 8 | > du sherlodoc.js 9 | > else 10 | > echo "All good! "; 11 | > fi 12 | All good! 13 | -------------------------------------------------------------------------------- /test/cram/version.t: -------------------------------------------------------------------------------- 1 | $ sherlodoc --version 2 | 0.2 3 | -------------------------------------------------------------------------------- /test/cram_ancient/cli_small.t/main.mli: -------------------------------------------------------------------------------- 1 | 2 | type 'a list 3 | 4 | module List : sig 5 | type 'a t = 'a list 6 | 7 | val map : ('a -> 'b) -> 'a t -> 'b t 8 | 9 | val empty : 'a t * 'b t 10 | 11 | 12 | end 13 | 14 | type ('a, 'b) result 15 | 16 | val ok: 'a -> ('a, 'b) result 17 | 18 | val ok_zero : (int, 'a) result -------------------------------------------------------------------------------- /test/cram_ancient/cli_small.t/run.t: -------------------------------------------------------------------------------- 1 | $ ocamlc -c main.mli -bin-annot -I . 2 | $ odoc compile -I . main.cmti 3 | $ odoc link -I . main.odoc 4 | $ cat $(find . -name '*.odocl') > megaodocl 5 | $ du -sh megaodocl 6 | 4.0K megaodocl 7 | $ export SHERLODOC_DB=db.bin 8 | $ export SHERLODOC_FORMAT=ancient 9 | $ sherlodoc index $(find . -name '*.odocl') 10 | $ sherlodoc search --print-cost "list" 11 | 139 type 'a Main.list 12 | 151 type 'a Main.List.t = 'a list 13 | 154 mod Main.List 14 | 259 val Main.List.empty : 'a t * 'b t 15 | 272 val Main.List.map : ('a -> 'b) -> 'a t -> 'b t 16 | $ sherlodoc search ": (int, 'a) result" 17 | val Main.ok_zero : (int, 'a) result 18 | -------------------------------------------------------------------------------- /test/cram_ancient/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (enabled_if %{lib-available:ancient}) 3 | (deps %{bin:odoc} %{bin:sherlodoc})) 4 | -------------------------------------------------------------------------------- /test/cram_ancient/empty.t: -------------------------------------------------------------------------------- 1 | $ export SHERLODOC_DB=db.bin 2 | $ export SHERLODOC_FORMAT=ancient 3 | $ sherlodoc index 4 | $ sherlodoc search "query" 5 | [No results] 6 | $ sherlodoc search ": type_query" 7 | [No results] 8 | -------------------------------------------------------------------------------- /test/cram_static/base_web.t: -------------------------------------------------------------------------------- 1 | $ export ODOCLS=$(find ../docs/odoc/base/ -name '*.odocl') 2 | $ cat $ODOCLS > megaodocl 3 | $ du -sh megaodocl 4 | 5.4M megaodocl 5 | $ sherlodoc index --index-docstring=true --index-name=true --type-search=true --format=js --db=db.js $ODOCLS > /dev/null 6 | 7 | $ gzip -k db.js 8 | 9 | We want to compare the compressed size with the size of the odocl. The search 10 | database contains information than the odocl, but the information is organised 11 | in queryable way, so a size increase is expected. It should just be reasonable. 12 | 13 | $ du -s *.js *.gz 14 | 2108 db.js 15 | 1592 db.js.gz 16 | 17 | $ for f in $(find . -name '*.odocl'); do 18 | > odoc html-generate --search-uri=db.js --search-uri=sherlodoc.js --output-dir html $f 19 | > done 20 | $ odoc support-files -o html 21 | $ cp db.js html/ 22 | The --no-preserve flag is here so that copying to /tmp will not fail because of 23 | a previous run. .js files built by dune are read only. 24 | $ sherlodoc js html/sherlodoc.js 25 | $ ls html 26 | db.js 27 | fonts 28 | highlight.pack.js 29 | katex.min.css 30 | katex.min.js 31 | odoc.css 32 | odoc_search.js 33 | sherlodoc.js 34 | indent to see results 35 | $ cp -r html /tmp 36 | $ firefox /tmp/html/base/index.html 37 | -------------------------------------------------------------------------------- /test/cram_static/dune: -------------------------------------------------------------------------------- 1 | (cram 2 | (enabled_if 3 | (and 4 | (= %{version:menhirLib} 20230608) 5 | (= %{ocaml_version} 4.14.1))) 6 | (deps ../docs %{bin:odoc} %{bin:sherlodoc})) 7 | -------------------------------------------------------------------------------- /test/cram_static/js_static_size.t: -------------------------------------------------------------------------------- 1 | $ sherlodoc js sherlodoc.js 2 | $ du -sh sherlodoc.js 3 | 92K sherlodoc.js 4 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (rule 2 | (target 3 | (dir docs)) 4 | (deps 5 | (package base)) 6 | (action 7 | (progn 8 | (run mkdir -p docs) 9 | (run odig odoc --cache-dir=docs --no-pkg-deps --quiet base) 10 | (run rm docs/html/base/_doc-dir)))) 11 | -------------------------------------------------------------------------------- /test/whole_switch/.gitignore: -------------------------------------------------------------------------------- 1 | packages 2 | -------------------------------------------------------------------------------- /test/whole_switch/readme.md: -------------------------------------------------------------------------------- 1 | This is directory meants for test on a whole switch. We only test that we can 2 | actually build a documentation database in for every package. We do not check 3 | that the results of search are good, because we do not have a definition of that 4 | for any package. 5 | 6 | It has two scripts : 7 | 8 | - `set_big_switch.sh` installs a lot of compatible packages in the current 9 | switch. 10 | - `test.sh` generates the search database of every installed package. Its output 11 | is in the `packages` folder. -------------------------------------------------------------------------------- /test/whole_switch/setup_big_switch.sh: -------------------------------------------------------------------------------- 1 | opam install 2 | absolute.0.3 3 | accessor.v0.16.0 4 | aches.1.0.0 5 | aches-lwt.1.0.0 6 | acp4.1.0.1 7 | alcotest.1.7.0 8 | alsa.0.3.0 9 | alt-ergo.2.5.2 10 | alt-ergo-lib.2.5.2 11 | alt-ergo-parsers.2.5.2 12 | ancient.0.9.1 13 | angstrom.0.15.0 14 | apron.v0.9.14 15 | apronext.1.0.4 16 | arrakis.1.0.0 17 | art.0.2.0 18 | asetmap.0.8.1 19 | asn1-combinators.0.2.6 20 | astring.0.8.5 21 | async.v0.16.0 22 | async_kernel.v0.16.0 23 | async_rpc_kernel.v0.16.0 24 | async_unix.v0.16.0 25 | async_websocket.v0.16.0 26 | b0.0.0.5 27 | base.v0.16.3 28 | base-bigarray.base 29 | base-bytes.base 30 | base-threads.base 31 | base-unix.base 32 | base64.3.5.1 33 | base_bigstring.v0.16.0 34 | base_quickcheck.v0.16.0 35 | batteries.3.7.1 36 | bheap.2.0.0 37 | bigarray-compat.1.1.0 38 | bigarray-overlap.0.2.1 39 | bigstring.0.3 40 | bigstringaf.0.9.1 41 | bin_prot.v0.16.0 42 | bls12-381.18.0 43 | bos.0.2.1 44 | brr.0.0.6 45 | bst.7.0.1 46 | ca-certs.0.2.3 47 | camlidl.1.11 48 | camlp-streams.5.0.1 49 | camlzip.1.11 50 | caqti.1.9.0 51 | caqti-lwt.1.9.0 52 | checkseum.0.5.2 53 | chrome-trace.3.11.1 54 | class_group_vdf.0.0.4 55 | cmdliner.1.2.0 56 | cohttp.5.3.0 57 | cohttp-lwt.5.3.0 58 | cohttp-lwt-unix.5.3.0 59 | conduit.6.2.0 60 | conduit-lwt.6.2.0 61 | conduit-lwt-unix.6.2.0 62 | conf-alsa.1 63 | conf-autoconf.0.1 64 | conf-cmake.1 65 | conf-g++.1.0 66 | conf-gmp.4 67 | conf-gmp-powm-sec.3 68 | conf-hidapi.0 69 | conf-libev.4-12 70 | conf-libffi.2.0.0 71 | conf-libssl.4 72 | conf-mpfr.3 73 | conf-perl.2 74 | conf-pkg-config.3 75 | conf-rust.0.1 76 | conf-rust-2021.1 77 | conf-sdl2.1 78 | conf-which.1 79 | conf-zlib.1 80 | core.v0.16.2 81 | core_kernel.v0.16.0 82 | core_unix.v0.16.0 83 | cpm.12.2.0 84 | cppo.1.6.9 85 | cpu.2.0.0 86 | cryptokit.1.16.1 87 | csexp.1.5.2 88 | cstruct.6.2.0 89 | cstruct-lwt.6.2.0 90 | ctypes.0.20.2 91 | ctypes-foreign.0.18.0 92 | ctypes_stubs_js.0.1 93 | data-encoding.0.7.1 94 | decompress.1.5.3 95 | digestif.1.1.4 96 | dolmen.0.9 97 | dolmen_loop.0.9 98 | dolmen_type.0.9 99 | dolog.6.0.0 100 | domain-name.0.4.0 101 | dream.1.0.0~alpha5 102 | dream-httpaf.1.0.0~alpha2 103 | dream-pure.1.0.0~alpha2 104 | dune.3.10.0 105 | dune-build-info.3.11.1 106 | dune-configurator.3.11.1 107 | dune-private-libs.3.11.1 108 | dune-rpc.3.11.1 109 | dune-site.3.11.1 110 | duration.0.2.1 111 | dyn.3.11.1 112 | either.1.0.0 113 | eqaf.0.9 114 | expect_test_helpers_core.v0.16.0 115 | ezjsonm.1.3.0 116 | faraday.0.8.2 117 | faraday-lwt.0.8.2 118 | faraday-lwt-unix.0.8.2 119 | fiber.3.7.0 120 | fieldslib.v0.16.0 121 | fix.20230505 122 | fmlib.0.5.6 123 | fmlib_browser.0.5.6 124 | fmlib_js.0.5.6 125 | fmlib_parse.0.5.6 126 | fmlib_pretty.0.5.6 127 | fmlib_std.0.5.6 128 | fmt.0.9.0 129 | fpath.0.7.3 130 | gen.1.1 131 | gg.1.0.0 132 | gmap.0.3.0 133 | graphql.0.14.0 134 | graphql-lwt.0.14.0 135 | graphql_parser.0.14.0 136 | hacl-star.0.7.1 137 | hacl-star-raw.0.7.1 138 | hashcons.1.3 139 | hex.1.5.0 140 | hidapi.1.1.2 141 | higher_kinded.v0.16.0 142 | hkdf.1.0.4 143 | hmap.0.8.1 144 | htmlit.0.1.0 145 | index.1.6.1 146 | int_repr.v0.16.0 147 | integers.0.7.0 148 | integers_stubs_js.1.0 149 | ipaddr.5.5.0 150 | ipaddr-sexp.5.5.0 151 | irmin.3.7.2 152 | irmin-pack.3.7.2 153 | jane-street-headers.v0.16.0 154 | js_of_ocaml.5.4.0 155 | js_of_ocaml-compiler.5.4.0 156 | js_of_ocaml-ppx.5.4.0 157 | js_of_ocaml-toplevel.5.4.0 158 | json-data-encoding.0.12.1 159 | json-data-encoding-bson.0.12.1 160 | jsonm.1.0.2 161 | jst-config.v0.16.0 162 | ke.0.6 163 | ledgerwallet.0.3.0 164 | ledgerwallet-tezos.0.3.0 165 | libabsolute.0.1 166 | line_oriented.1.3.0 167 | logs.0.7.0 168 | lru.0.3.1 169 | lwt.5.7.0 170 | lwt-canceler.0.3 171 | lwt-exit.1.0 172 | lwt-watcher.0.2 173 | lwt_ppx.2.1.0 174 | lwt_ssl.1.2.0 175 | macaddr.5.5.0 176 | magic-mime.1.3.1 177 | matplotlib.0.2 178 | mdx.2.3.1 179 | menhir.20230608 180 | menhirLib.20230608 181 | menhirSdk.20230608 182 | merlin-lib.4.12-414 183 | minicli.5.0.2 184 | mirage-clock.4.2.0 185 | mirage-crypto.0.11.2 186 | mirage-crypto-ec.0.11.2 187 | mirage-crypto-pk.0.11.2 188 | mirage-crypto-rng.0.11.2 189 | mirage-crypto-rng-lwt.0.11.2 190 | mlgmpidl.1.2.15 191 | mtime.1.4.0 192 | multipart_form.0.5.0 193 | multipart_form-lwt.0.5.0 194 | num.1.4 195 | ocaml.4.14.1 196 | ocaml-base-compiler.4.14.1 197 | ocaml-compiler-libs.v0.12.4 198 | ocaml-config.2 199 | ocaml-migrate-parsetree.2.4.0 200 | ocaml-options-vanilla.1 201 | ocaml-syntax-shims.1.0.0 202 | ocaml-version.3.6.2 203 | ocaml_intrinsics.v0.16.0 204 | ocamlbuild.0.14.2 205 | ocamlc-loc.3.11.1 206 | ocamlfind.1.9.6 207 | ocamlformat.0.26.1 208 | ocamlformat-lib.0.26.1 209 | ocamlformat-rpc-lib.0.26.1 210 | ocamlgraph.2.1.0 211 | ocp-indent.1.8.1 212 | ocp-ocamlres.0.4 213 | ocplib-endian.1.2 214 | ocplib-simplex.0.5 215 | octez.18.0 216 | octez-accuser-Proxford.18.0 217 | octez-accuser-PtNairob.18.0 218 | octez-alcotezt.18.0 219 | octez-baker-Proxford.18.0 220 | octez-baker-PtNairob.18.0 221 | octez-client.18.0 222 | octez-codec.18.0 223 | octez-crawler.18.0 224 | octez-dac-client.18.0 225 | octez-dac-node.18.0 226 | octez-distributed-internal.18.0 227 | octez-distributed-lwt-internal.18.0 228 | octez-injector.18.0 229 | octez-l2-libs.18.0 230 | octez-libs.18.0 231 | octez-node.18.0 232 | octez-node-config.18.0 233 | octez-proto-libs.18.0 234 | octez-protocol-000-Ps9mPmXa-libs.18.0 235 | octez-protocol-001-PtCJ7pwo-libs.18.0 236 | octez-protocol-002-PsYLVpVv-libs.18.0 237 | octez-protocol-003-PsddFKi3-libs.18.0 238 | octez-protocol-004-Pt24m4xi-libs.18.0 239 | octez-protocol-005-PsBabyM1-libs.18.0 240 | octez-protocol-006-PsCARTHA-libs.18.0 241 | octez-protocol-007-PsDELPH1-libs.18.0 242 | octez-protocol-008-PtEdo2Zk-libs.18.0 243 | octez-protocol-009-PsFLoren-libs.18.0 244 | octez-protocol-010-PtGRANAD-libs.18.0 245 | octez-protocol-011-PtHangz2-libs.18.0 246 | octez-protocol-012-Psithaca-libs.18.0 247 | octez-protocol-013-PtJakart-libs.18.0 248 | octez-protocol-014-PtKathma-libs.18.0 249 | octez-protocol-015-PtLimaPt-libs.18.0 250 | octez-protocol-016-PtMumbai-libs.18.0 251 | octez-protocol-017-PtNairob-libs.18.0 252 | octez-protocol-018-Proxford-libs.18.0 253 | octez-protocol-alpha-libs.18.0 254 | octez-protocol-compiler.18.0 255 | octez-proxy-server.18.0 256 | octez-shell-libs.18.0 257 | octez-signer.18.0 258 | octez-smart-rollup-client-Proxford.18.0 259 | octez-smart-rollup-client-PtNairob.18.0 260 | octez-smart-rollup-node-lib.18.0 261 | octez-smart-rollup-node-Proxford.18.0 262 | octez-smart-rollup-node-PtNairob.18.0 263 | octez-smart-rollup-wasm-debugger.18.0 264 | octez-version.18.0 265 | odig.0.0.9 266 | odoc.2.3.0 267 | odoc-parser.2.3.0 268 | opam-core.2.1.5 269 | optint.0.3.0 270 | ordering.3.11.1 271 | parany.14.0.1 272 | parsexp.v0.16.0 273 | pbkdf.1.2.0 274 | pecu.0.6 275 | picasso.0.4.0 276 | pp.1.2.0 277 | pp_loc.2.1.0 278 | pprint.20230830 279 | ppx_assert.v0.16.0 280 | ppx_base.v0.16.0 281 | ppx_bench.v0.16.0 282 | ppx_bin_prot.v0.16.0 283 | ppx_blob.0.7.2 284 | ppx_cold.v0.16.0 285 | ppx_compare.v0.16.0 286 | ppx_custom_printf.v0.16.0 287 | ppx_derivers.1.2.1 288 | ppx_deriving.5.2.1 289 | ppx_disable_unused_warnings.v0.16.0 290 | ppx_enumerate.v0.16.0 291 | ppx_expect.v0.16.0 292 | ppx_fields_conv.v0.16.0 293 | ppx_fixed_literal.v0.16.0 294 | ppx_globalize.v0.16.0 295 | ppx_hash.v0.16.0 296 | ppx_here.v0.16.0 297 | ppx_ignore_instrumentation.v0.16.0 298 | ppx_import.1.10.0 299 | ppx_inline_test.v0.16.0 300 | ppx_irmin.3.7.2 301 | ppx_jane.v0.16.0 302 | ppx_let.v0.16.0 303 | ppx_log.v0.16.0 304 | ppx_module_timer.v0.16.0 305 | ppx_optcomp.v0.16.0 306 | ppx_optional.v0.16.0 307 | ppx_pipebang.v0.16.0 308 | ppx_repr.0.7.0 309 | ppx_sexp_conv.v0.16.0 310 | ppx_sexp_message.v0.16.0 311 | ppx_sexp_value.v0.16.0 312 | ppx_stable.v0.16.0 313 | ppx_stable_witness.v0.16.0 314 | ppx_string.v0.16.0 315 | ppx_tydi.v0.16.0 316 | ppx_typerep_conv.v0.16.0 317 | ppx_variants_conv.v0.16.0 318 | ppx_yojson_conv_lib.v0.16.0 319 | ppxlib.0.31.0 320 | prbnmcn-basic-structures.0.0.1 321 | prbnmcn-linalg.0.0.1 322 | prbnmcn-stats.0.0.6 323 | prettym.0.0.3 324 | pringo.1.3 325 | progress.0.2.1 326 | prometheus.1.2 327 | prometheus-app.1.2 328 | protocol_version_header.v0.16.0 329 | psmt2-frontend.0.4.0 330 | psq.0.2.1 331 | ptime.1.1.0 332 | pure-splitmix.0.3 333 | pyml.20220905 334 | qcheck-alcotest.0.21.2 335 | qcheck-core.0.21.2 336 | re.1.11.0 337 | redis.0.7.1 338 | repr.0.7.0 339 | resto.1.2 340 | resto-acl.1.2 341 | resto-cohttp.1.2 342 | resto-cohttp-client.1.2 343 | resto-cohttp-self-serving-client.1.2 344 | resto-cohttp-server.1.2 345 | resto-directory.1.2 346 | result.1.5 347 | ringo.1.0.0 348 | rresult.0.7.0 349 | rusage.1.0.0 350 | secp256k1-internal.0.4.0 351 | sedlex.3.2 352 | semaphore-compat.1.0.1 353 | seq.base 354 | seqes.0.2 355 | sexp_pretty.v0.16.0 356 | sexplib.v0.16.0 357 | sexplib0.v0.16.0 358 | spawn.v0.15.1 359 | spelll.0.4 360 | splittable_random.v0.16.0 361 | ssl.0.7.0 362 | stdcompat.19 363 | stdint.0.7.2 364 | stdio.v0.16.0 365 | stdlib-shims.0.3.0 366 | stdune.3.11.1 367 | stringext.1.6.0 368 | tar.2.6.0 369 | tar-unix.2.6.0 370 | terminal.0.2.1 371 | textutils.v0.16.0 372 | textutils_kernel.v0.16.0 373 | tezos-benchmark.18.0 374 | tezos-dac-client-lib.18.0 375 | tezos-dac-lib.18.0 376 | tezos-dac-node-lib.18.0 377 | tezos-dal-node-lib.18.0 378 | tezos-dal-node-services.18.0 379 | tezos-lwt-result-stdlib.17.3 380 | tezos-protocol-000-Ps9mPmXa.18.0 381 | tezos-protocol-001-PtCJ7pwo.18.0 382 | tezos-protocol-002-PsYLVpVv.18.0 383 | tezos-protocol-003-PsddFKi3.18.0 384 | tezos-protocol-004-Pt24m4xi.18.0 385 | tezos-protocol-005-PsBABY5H.18.0 386 | tezos-protocol-005-PsBabyM1.18.0 387 | tezos-protocol-006-PsCARTHA.18.0 388 | tezos-protocol-007-PsDELPH1.18.0 389 | tezos-protocol-008-PtEdo2Zk.18.0 390 | tezos-protocol-008-PtEdoTez.18.0 391 | tezos-protocol-009-PsFLoren.18.0 392 | tezos-protocol-010-PtGRANAD.18.0 393 | tezos-protocol-011-PtHangz2.18.0 394 | tezos-protocol-012-Psithaca.18.0 395 | tezos-protocol-013-PtJakart.18.0 396 | tezos-protocol-014-PtKathma.18.0 397 | tezos-protocol-015-PtLimaPt.18.0 398 | tezos-protocol-016-PtMumbai.18.0 399 | tezos-protocol-017-PtNairob.18.0 400 | tezos-protocol-018-Proxford.18.0 401 | tezos-protocol-alpha.18.0 402 | tezos-proxy-server-config.18.0 403 | tezos-rust-libs.1.6 404 | tezos-sapling-parameters.1.1.0 405 | tezt.3.1.1 406 | tezt-tezos.18.0 407 | tgls.0.8.6 408 | time_now.v0.16.0 409 | timezone.v0.16.0 410 | tls.0.17.1 411 | tls-lwt.0.17.1 412 | topkg.1.0.7 413 | tsdl.1.0.0 414 | typerep.v0.16.0 415 | tyxml.4.6.0 416 | unstrctrd.0.3 417 | uri.4.4.0 418 | uri-sexp.4.4.0 419 | uucd.15.1.0 420 | uucp.15.1.0 421 | uuidm.0.9.8 422 | uunf.15.1.0 423 | uuseg.15.1.0 424 | uutf.1.0.3 425 | variantslib.v0.16.0 426 | vector.1.0.0 427 | vector3.1.0.0 428 | vg.0.9.4 429 | webbrowser.0.6.1 430 | x509.0.16.5 431 | xdg.3.11.1 432 | xmlm.1.4.0 433 | yaml.3.1.0 434 | yojson.2.1.1 435 | zarith.1.12 436 | zarith_stubs_js.v0.16.0 437 | -------------------------------------------------------------------------------- /test/whole_switch/test.sh: -------------------------------------------------------------------------------- 1 | odig odoc 2 | mkdir -p packages 3 | cd packages 4 | for PKG in $(ls $OPAM_SWITCH_PREFIX/var/cache/odig/odoc) 5 | do 6 | echo $PKG 7 | dune exec sherlodoc_index -- --format=marshal --db=$PKG.db $(find $OPAM_SWITCH_PREFIX/var/cache/odig/odoc/$PKG -name "*.odocl") 2> $PKG.stderr > $PKG.stdout 8 | done -------------------------------------------------------------------------------- /www/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name www) 3 | (optional) 4 | (libraries lwt cmdliner dream tyxml db db_store query) 5 | (preprocess 6 | (pps ppx_blob)) 7 | (preprocessor_deps 8 | static/bg.jpg 9 | static/favicon.ico 10 | static/packages.csv 11 | static/robots.txt 12 | static/style.css)) 13 | -------------------------------------------------------------------------------- /www/packages.ml: -------------------------------------------------------------------------------- 1 | type package = 2 | { category : string 3 | ; name : string 4 | ; description : string 5 | } 6 | 7 | module M = Map.Make (String) 8 | 9 | module S = Set.Make (struct 10 | type t = package 11 | 12 | let compare a b = 13 | String.compare (String.lowercase_ascii a.name) (String.lowercase_ascii b.name) 14 | end) 15 | 16 | let pretty = function 17 | | "ai" -> "Sciences" 18 | | "app" -> "Applications" 19 | | "ascii" -> "Formats: Restricted alphabet" 20 | | "audio" -> "Multimedia: Audio" 21 | | "bap" -> "PLT: Binary Analysis Platform" 22 | | "bench" -> "Benchmarking" 23 | | "bindings" -> "Various bindings" 24 | | "bio" -> "Sciences" 25 | | "build" -> "Tooling: Build systems" 26 | | "chemistry" -> "Sciences" 27 | | "cloud" -> "Cloud" 28 | | "color" -> "Multimedia: Images" 29 | | "compression" -> "Formats: Compression" 30 | | "conf" -> "conf" 31 | | "cordova" -> "Javascript: Cordova" 32 | | "crypto" -> "Cryptography" 33 | | "data" -> "Datastructures" 34 | | "databases" -> "Databases" 35 | | "dns" -> "Network: DNS" 36 | | "document" -> "Formats: Text document" 37 | | "documentation" -> "Tooling: Documentation" 38 | | "email" -> "Network: Email" 39 | | "format" -> "Formats" 40 | | "frp" -> "Reactive programming" 41 | | "graphics2d" -> "Graphics: 2D" 42 | | "graphics3d" -> "Graphics: 3D" 43 | | "gui" -> "GUI" 44 | | "hardcaml" -> "Hardcaml" 45 | | "http" -> "Network: HTTP client" 46 | | "ide" -> "Tooling: IDE" 47 | | "images" -> "Multimedia: Images" 48 | | "interoperability" -> "Interoperability" 49 | | "io" -> "I/O" 50 | | "irc" -> "Network: IRC" 51 | | "irmin" -> "Databases: Irmin" 52 | | "javascript" -> "Javascript" 53 | | "js" -> "Javascript" 54 | | "json" -> "Formats: Json" 55 | | "language" -> "Programming languages" 56 | | "linux" -> "System: Linux" 57 | | "log" -> "Logs" 58 | | "macos" -> "System: Mac Os" 59 | | "maths" -> "Maths" 60 | | "mirage" -> "Mirage" 61 | | "monads" -> "Stdlib monadic" 62 | | "monitor" -> "Monitoring" 63 | | "multimedia" -> "Multimedia" 64 | | "network" -> "Network" 65 | | "notebook" -> "Tooling: Toplevel / Notebook" 66 | | "opam" -> "Tooling: Opam / Packaging" 67 | | "packaging" -> "Tooling: Opam / Packaging" 68 | | "parser" -> "Parsers" 69 | | "plt" -> "PLT" 70 | | "ppx" -> "PPX" 71 | | "prover" -> "Theorem provers" 72 | | "retrocompatibility" -> "Stdlib retrocompatibility" 73 | | "science" -> "Sciences" 74 | | "security" -> "Cryptography" 75 | | "sexp" -> "Formats: Sexp" 76 | | "solver" -> "Constraint solvers" 77 | | "ssh" -> "Network: SSH" 78 | | "stdlib" -> "Stdlib extended" 79 | | "system" -> "System" 80 | | "terminal" -> "Terminal" 81 | | "tests" -> "Testing" 82 | | "text" -> "Text" 83 | | "tezos" -> "Tezos" 84 | | "time" -> "Date and Time" 85 | | "tooling" -> "Tooling" 86 | | "unix" -> "System: Unix" 87 | | "utils" -> "Stdlib complements" 88 | | "variants" -> "OCaml variants" 89 | | "video" -> "Multimedia: Video" 90 | | "web" -> "Web server" 91 | | "windows" -> "System: Windows" 92 | | "xen" -> "Xen" 93 | | "xml" -> "Formats: Xml" 94 | | "" -> "--- TODO ---" 95 | | other -> 96 | Format.printf "TODO: missing category name %S@." other ; 97 | other 98 | 99 | let unescape str = 100 | let str = String.trim str in 101 | let buf = Buffer.create (String.length str) in 102 | for i = 0 to String.length str - 1 do 103 | let chr = str.[i] in 104 | if not (chr = '\'' || chr = '"') then Buffer.add_char buf chr 105 | done ; 106 | Buffer.contents buf 107 | 108 | let parse_str str = 109 | let parse_line acc line = 110 | let package = 111 | match String.split_on_char '\t' line with 112 | | [ category; name; description ] -> 113 | { category = pretty category; name; description = unescape description } 114 | | [ name; description ] -> 115 | { category = pretty ""; name; description = unescape description } 116 | | _ -> failwith (Printf.sprintf "invalid package: %s" line) 117 | in 118 | let set = 119 | try M.find package.category acc with 120 | | Not_found -> S.empty 121 | in 122 | let set = S.add package set in 123 | M.add package.category set acc 124 | in 125 | List.fold_left parse_line M.empty 126 | @@ List.filter (( <> ) "") 127 | @@ String.split_on_char '\n' str 128 | 129 | let packages () = parse_str [%blob "www/static/packages.csv"] 130 | 131 | let packages () = 132 | List.fold_left (fun acc p -> M.remove p acc) (packages ()) [ "Tezos"; "conf" ] 133 | 134 | open Tyxml.Html 135 | 136 | let html () = 137 | div 138 | ~a:[ a_class [ "categories" ] ] 139 | (M.bindings (packages ()) 140 | |> List.map (fun (category, packages) -> 141 | div 142 | ~a:[ a_class [ "category" ] ] 143 | [ h3 [ txt (if category = "" then "Not classified" else category) ] 144 | ; div 145 | ~a:[ a_class [ "packages" ] ] 146 | (S.elements packages 147 | |> List.map (fun package -> 148 | a 149 | ~a: 150 | [ a_href ("https://ocaml.org/p/" ^ package.name) 151 | ; a_title package.description 152 | ] 153 | [ txt package.name ])) 154 | ])) 155 | 156 | let html = lazy (html ()) 157 | let html () = Lazy.force html 158 | -------------------------------------------------------------------------------- /www/static/bg.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/art-w/sherlodoc/77ecc829dea23a312a50a74852c3263365bbdeab/www/static/bg.jpg -------------------------------------------------------------------------------- /www/static/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/art-w/sherlodoc/77ecc829dea23a312a50a74852c3263365bbdeab/www/static/favicon.ico -------------------------------------------------------------------------------- /www/static/robots.txt: -------------------------------------------------------------------------------- 1 | User-agent: * 2 | Allow: /$ 3 | Disallow: / 4 | -------------------------------------------------------------------------------- /www/static/style.css: -------------------------------------------------------------------------------- 1 | html { 2 | min-height: 100%; 3 | } 4 | 5 | body { 6 | margin: 0; 7 | padding: 0; 8 | margin-bottom: 1em; 9 | min-height: 100%; 10 | background: url("/bg.jpg") no-repeat bottom right; 11 | font-family: system-ui, sans-serif; 12 | } 13 | 14 | form { 15 | display: flex; 16 | margin: 0; 17 | padding: 1rem; 18 | background-color: #EABB60; 19 | border-bottom: 2px solid #C78746; 20 | position: fixed; 21 | top: 0px; 22 | width: 100%; 23 | height: 2.5em; 24 | } 25 | 26 | #results { 27 | margin-top: 7.5em; 28 | } 29 | 30 | input { 31 | line-height: 1.5em; 32 | } 33 | 34 | input[type="text"] { 35 | width: 80%; 36 | background-color: #FADFB1; 37 | font-size: 1.5em; 38 | border: none; 39 | margin-right: -2px; 40 | padding: 0 0.5em; 41 | margin-left: 1.7em; 42 | outline: 1px solid #553515; 43 | } 44 | input[type="submit"] { 45 | padding: 0 1em; 46 | font-size: 1.5em; 47 | background-color: #C78746; 48 | border: none; 49 | color: #553515; 50 | font-weight: bold; 51 | outline: 1px solid #553515; 52 | } 53 | 54 | a { 55 | text-decoration: none; 56 | } 57 | 58 | .comment p { 59 | line-height: 1.3em; 60 | } 61 | 62 | .comment pre { 63 | margin: 0 2em; 64 | font-size: 1.1rem; 65 | white-space: pre; 66 | } 67 | 68 | .found > li > pre { 69 | margin: 0.5em; 70 | padding-left: 6em; 71 | text-indent: -6em; 72 | font-size: 1.1rem; 73 | white-space: normal; 74 | } 75 | 76 | pre em { 77 | font-style: normal; 78 | font-weight: bold; 79 | } 80 | 81 | ul { 82 | margin: 0; 83 | padding: 0; 84 | } 85 | 86 | .found > li { 87 | list-style: none; 88 | margin: 0; 89 | padding: 0; 90 | margin-bottom: 1.5em; 91 | margin-right: 5em; 92 | margin-left: 0.95em; 93 | } 94 | 95 | .found > li > pre em { 96 | margin: 0 -3px; 97 | padding: 3px; 98 | color: black; 99 | } 100 | 101 | .found > li:hover > pre em { 102 | background: #FADFB1; 103 | } 104 | 105 | .found > li > pre a:hover em { 106 | background: #EABB60; 107 | border-bottom: 2px solid #553515; 108 | } 109 | 110 | 111 | h1, ul.doc, .comment { 112 | margin: 0; 113 | padding: 0; 114 | margin-left: 3.4rem; 115 | } 116 | 117 | .comment a, .comment a:visited { color: black } 118 | .comment .at-tag { font-style: italic } 119 | .comment li { list-style: square } 120 | 121 | h1 { 122 | margin-bottom: 1em; 123 | font-size: 3em; 124 | font-family: serif; 125 | } 126 | 127 | p.doc { 128 | margin-bottom: 1em; 129 | margin-left: 2.3em; 130 | font-size: 1.5em; 131 | } 132 | 133 | ul.doc > li { 134 | margin-bottom: 0.5em; 135 | } 136 | 137 | .doc code { 138 | font-size: 1rem; 139 | background: #eee; 140 | padding: 0.1em 0.5em; 141 | } 142 | 143 | .query { 144 | background-color: #FADFB1; 145 | border-top: 1px solid #C78746; 146 | border-bottom: 2px solid #C78746; 147 | position: fixed; 148 | top: 4.5em; 149 | width: 100%; 150 | padding: 0.3em 4.2em; 151 | font-style: italic; 152 | color: #553515; 153 | } 154 | .query code { 155 | margin-left: 1em; 156 | } 157 | 158 | code { 159 | font-size: 1rem; 160 | } 161 | 162 | .pkg { 163 | margin-left: 3em; 164 | margin-bottom: -0.4em; 165 | } 166 | 167 | .pkg a, .pkg a:visited { 168 | margin: 0; 169 | font-weight: bold; 170 | font-size: 0.8em; 171 | padding: 0 5px; 172 | color: #1A3B60; 173 | } 174 | 175 | .pkg .version { 176 | font-weight: normal; 177 | color: #8BA4C0; 178 | } 179 | 180 | .pkg a:hover, .pkg a:hover .version { 181 | background: #3D5570; 182 | color: white !important; 183 | text-decoration: none; 184 | } 185 | 186 | .ad { 187 | padding: 3rem 0; 188 | margin-left: 2.3em; 189 | font-style: italic; 190 | font-size: 1rem; 191 | } 192 | 193 | pre, code, .ad, .packages a, input#q { 194 | font-family: ui-monospace, 'Fira Code', 'Cascadia Code', 'Source Code Pro', Menlo, Consolas, 'DejaVu Sans Mono', monospace; 195 | } 196 | 197 | .ad svg { vertical-align: middle; margin-right: 0.5rem } 198 | 199 | .categories { 200 | margin: 0; 201 | margin-top: 3em; 202 | margin-left: 2.5em; 203 | margin-right: 2.5em; 204 | padding: 0; 205 | column-count: 4; 206 | column-gap: 1em; 207 | column-width: 20em; 208 | line-height: 1.1em; 209 | } 210 | 211 | .categories .category { 212 | margin: 0; 213 | padding: 0; 214 | display: inline-block; 215 | } 216 | 217 | .category h3 { 218 | margin: 0; 219 | padding: 0; 220 | margin-top: 1.5em; 221 | margin-bottom: 0.7em; 222 | } 223 | 224 | .packages a { 225 | display: inline-block; 226 | white-space: nowrap; 227 | margin-right: 1.5em; 228 | } 229 | .packages a:hover { 230 | background: #eee; 231 | } 232 | -------------------------------------------------------------------------------- /www/ui.ml: -------------------------------------------------------------------------------- 1 | open Tyxml.Html 2 | 3 | let list_of_option = function 4 | | None -> [] 5 | | Some x -> [ x ] 6 | 7 | let render_link elt = [ a_href (Db.Entry.link elt) ] 8 | 9 | let string_of_kind = 10 | let open Db.Entry.Kind in 11 | function 12 | | Doc -> "doc" 13 | | Type_decl None -> "type" 14 | | Type_decl (Some str) -> "type " ^ str 15 | | Module -> "module" 16 | | Exception _ -> "exception" 17 | | Class_type -> "class" 18 | | Method -> "method" 19 | | Class -> "class" 20 | | Type_extension -> "type" 21 | | Extension_constructor _ -> "constructor" 22 | | Module_type -> "module type" 23 | | Constructor _ -> "constructor" 24 | | Field _ -> "field" 25 | | Val _ -> "val" 26 | 27 | let render_elt elt = 28 | let open Db.Entry in 29 | let link = render_link elt in 30 | let html_txt = Unsafe.data in 31 | let rhs = 32 | match elt.rhs with 33 | | Some rhs -> [ html_txt rhs ] 34 | | None -> [] 35 | in 36 | let kind = string_of_kind elt.kind ^ " " in 37 | let doc = 38 | if elt.doc_html = "" 39 | then [] 40 | else [ div ~a:[ a_class [ "comment" ] ] [ Unsafe.data elt.doc_html ] ] 41 | in 42 | pre (txt kind :: a ~a:link [ em [ txt elt.name ] ] :: rhs) :: doc 43 | 44 | let render_pkg elt = 45 | let open Db.Entry in 46 | let { Package.name; version } = elt.pkg in 47 | let link = Package.link elt.pkg in 48 | [ div 49 | ~a:[ a_class [ "pkg" ] ] 50 | [ a 51 | ~a:[ a_href link ] 52 | [ txt name; txt " "; span ~a:[ a_class [ "version" ] ] [ txt version ] ] 53 | ] 54 | ] 55 | 56 | let render_result elt = render_pkg elt @ render_elt elt 57 | 58 | let render ~pretty results = 59 | match results with 60 | | [] -> div ~a:[ a_class [ "query" ] ] [ txt "No results! "; code [ txt pretty ] ] 61 | | _ -> 62 | div 63 | [ div ~a:[ a_class [ "query" ] ] [ txt "Results for "; code [ txt pretty ] ] 64 | ; ul ~a:[ a_class [ "found" ] ] @@ List.map (fun r -> li (render_result r)) results 65 | ] 66 | 67 | let ajax_reload = 68 | {js| 69 | var latest = 0; 70 | var current = 0; 71 | document.getElementById('q').addEventListener('input', function(e) { 72 | var param = encodeURIComponent(e.target.value); 73 | ++latest; 74 | var self = latest; 75 | var req = new XMLHttpRequest(); 76 | req.onreadystatechange = function() { 77 | if (this.readyState === 4 && current < self) { 78 | current = self; 79 | document.getElementById('results').innerHTML = this.response; 80 | } 81 | }; 82 | req.open('GET', '/api?q=' + param, true); 83 | req.send(); 84 | var url = param === '' ? '/' : '/?q=' + param; 85 | history.replaceState(null, 'Sherlodoc', url); 86 | }); 87 | |js} 88 | 89 | let search_form query = 90 | div 91 | ~a:[ a_class [ "header" ] ] 92 | [ form 93 | ~a:[ a_method `Get ] 94 | [ input 95 | ~a: 96 | [ a_input_type `Text 97 | ; a_id "q" 98 | ; a_name "q" 99 | ; a_value query 100 | ; a_placeholder "Search..." 101 | ; a_autofocus () 102 | ; a_autocomplete `Off 103 | ] 104 | () 105 | ; input ~a:[ a_input_type `Submit; a_value "Search!" ] () 106 | ] 107 | ; script (Unsafe.data ajax_reload) 108 | ] 109 | 110 | let template query contents = 111 | html 112 | ~a:[ a_lang "en" ] 113 | (head 114 | (title (txt "Sherlodoc")) 115 | [ meta ~a:[ a_charset "UTF-8" ] () 116 | ; meta ~a:[ a_name "viewport"; a_content "width=device-width, initial-scale=1" ] () 117 | ; link ~rel:[ `Stylesheet ] ~href:"/s.css" () 118 | ]) 119 | @@ body [ search_form query; div ~a:[ a_id "results" ] [ contents ] ] 120 | 121 | let github_icon = 122 | let open Tyxml.Svg in 123 | Tyxml.Html.svg 124 | ~a:[ a_width (16., None); a_height (16.0, None); a_viewBox (0., 0., 16., 16.) ] 125 | [ path 126 | ~a: 127 | [ a_d 128 | "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 \ 129 | 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 \ 130 | 1.08.58 1.23.82.72 1.21 1.87.87 \ 131 | 2.33.66.07-.52.28-.87.51-1.07-1.78-.2-3.64-.89-3.64-3.95 \ 132 | 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 \ 133 | 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 \ 134 | 1.92.08 2.12.51.56.82 1.27.82 2.15 0 3.07-1.87 3.75-3.65 \ 135 | 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 \ 136 | 8.012 0 0 0 16 8c0-4.42-3.58-8-8-8z" 137 | ] 138 | [] 139 | ] 140 | 141 | let link_to_repo = 142 | p 143 | ~a:[ a_class [ "ad" ] ] 144 | [ txt {|(* Read the source, fork and contribute to |} 145 | ; a 146 | ~a:[ a_href "https://github.com/art-w/sherlodoc" ] 147 | [ github_icon; txt "art-w/sherlodoc" ] 148 | ; txt " *)" 149 | ] 150 | 151 | let link str = a ~a:[ a_href ("?q=" ^ Uri.pct_encode str) ] [ code [ txt str ] ] 152 | 153 | let explain () = 154 | div 155 | ~a:[ a_class [ "doc" ] ] 156 | [ h1 [ txt "Sherlodoc" ] 157 | ; p 158 | ~a:[ a_class [ "doc" ] ] 159 | [ txt "Fuzzy search in OCaml's documentation for almost all opam packages." ] 160 | ; ul 161 | ~a:[ a_class [ "doc" ] ] 162 | [ li [ txt "Search by name: "; link "concat map"; txt " and "; link "Lwt pool" ] 163 | ; li [ txt "Search by type with a colon: "; link ": list list -> list" ] 164 | ; li 165 | [ txt "Search on name and type with a colon separator: " 166 | ; link "Yojson : t -> string" 167 | ] 168 | ; li [ txt "Search for constructors of a type: "; link ": Gg.color" ] 169 | ; li 170 | [ txt "Use _ to omit a subtype and search for consumers of a type: " 171 | ; link ": Gg.color -> _" 172 | ] 173 | ; li 174 | [ txt "Products and reordering of arguments: " 175 | ; link ": 'a list -> ('a * int -> bool) -> 'a list" 176 | ] 177 | ] 178 | ; Packages.html () 179 | ; link_to_repo 180 | ] 181 | 182 | let explain = lazy (explain ()) 183 | let explain () = Lazy.force explain 184 | -------------------------------------------------------------------------------- /www/www.ml: -------------------------------------------------------------------------------- 1 | module Storage = Db.Storage 2 | module H = Tyxml.Html 3 | open Lwt.Syntax 4 | 5 | module Query_lwt = Query.Make (struct 6 | type 'a t = 'a Lwt.t 7 | 8 | let return = Lwt.return 9 | let map x f = Lwt.map f x 10 | let bind x f = Lwt.bind x f 11 | end) 12 | 13 | let api ~shards params = 14 | let+ results = Query_lwt.search ~shards params in 15 | let pretty = Query.pretty params in 16 | Ui.render ~pretty results 17 | 18 | let api ~shards params = 19 | if String.trim params.Query.query = "" 20 | then Lwt.return (Ui.explain ()) 21 | else api ~shards params 22 | 23 | let get_query params = Option.value ~default:"" (Dream.query params "q") 24 | 25 | let get_packages params = 26 | match Dream.query params "packages" with 27 | | None -> [] 28 | | Some str -> String.split_on_char ',' str 29 | 30 | let get_limit params = 31 | let default = 100 in 32 | match Dream.query params "limit" with 33 | | None -> default 34 | | Some str -> 35 | (try max 1 (min default (int_of_string str)) with 36 | | _ -> default) 37 | 38 | let get_params params = 39 | { Query.query = get_query params 40 | ; packages = get_packages params 41 | ; limit = get_limit params 42 | } 43 | 44 | let root fn params = 45 | let* result = fn params in 46 | Dream.html result 47 | 48 | let string_of_tyxml html = Format.asprintf "%a" (Tyxml.Html.pp ()) html 49 | let string_of_tyxml' html = Format.asprintf "%a" (Tyxml.Html.pp_elt ()) html 50 | 51 | let root fn params = 52 | let params = get_params params in 53 | try root fn params with 54 | | err -> 55 | Format.printf "ERROR: %S@." (Printexc.to_string err) ; 56 | Dream.html (string_of_tyxml @@ Ui.template params.query (Ui.explain ())) 57 | 58 | let root fn params = 59 | try root fn params with 60 | | _ -> Dream.html (string_of_tyxml @@ Ui.template "" (Ui.explain ())) 61 | 62 | let cache_header : int option -> Dream.middleware = 63 | fun max_age f req -> 64 | let+ response = f req in 65 | begin 66 | match max_age with 67 | | None -> () 68 | | Some max_age -> 69 | Dream.add_header 70 | response 71 | "Cache-Control" 72 | ("public, max-age=" ^ string_of_int max_age) 73 | end ; 74 | response 75 | 76 | let cors_header f req = 77 | let+ response = f req in 78 | Dream.add_header response "Access-Control-Allow-Origin" "*" ; 79 | response 80 | 81 | let cors_options = 82 | Dream.options "**" (fun _ -> 83 | let+ response = Dream.empty `No_Content in 84 | Dream.add_header response "Access-Control-Allow-Methods" "GET, OPTIONS" ; 85 | Dream.add_header response "Access-Control-Allow-Headers" "*" ; 86 | response) 87 | 88 | let static ctype contents = Dream.respond ~headers:[ "Content-Type", ctype ] contents 89 | let style_css _ = static "text/css" [%blob "www/static/style.css"] 90 | let favicon_ico _ = static "image/x-icon" [%blob "www/static/favicon.ico"] 91 | let robots_txt _ = static "text/plain" [%blob "www/static/robots.txt"] 92 | let bg_jpg _ = static "image/jpeg" [%blob "www/static/bg.jpg"] 93 | 94 | let main cache_max_age db_format db_filename = 95 | let module Storage = (val Db_store.storage_module db_format) in 96 | let shards = Storage.load db_filename in 97 | Dream.run ~interface:"127.0.0.1" ~port:1234 98 | @@ Dream.logger 99 | @@ cache_header cache_max_age 100 | @@ cors_header 101 | @@ Dream.router 102 | [ Dream.get 103 | "/" 104 | (root (fun params -> 105 | let+ result = api ~shards params in 106 | string_of_tyxml @@ Ui.template params.query result)) 107 | ; Dream.get 108 | "/api" 109 | (root (fun params -> 110 | let+ result = api ~shards params in 111 | string_of_tyxml' result)) 112 | ; Dream.get "/s.css" style_css 113 | ; Dream.get "/robots.txt" robots_txt 114 | ; Dream.get "/favicon.ico" favicon_ico 115 | ; Dream.get "/bg.jpg" bg_jpg 116 | ; cors_options 117 | ] 118 | 119 | open Cmdliner 120 | 121 | let cache_max_age = 122 | let doc = "HTTP cache max age (in seconds)" in 123 | Arg.(value & opt (some int) None & info [ "c"; "cache" ] ~docv:"MAX_AGE" ~doc) 124 | 125 | let term = Term.(const main $ cache_max_age) 126 | -------------------------------------------------------------------------------- /www/www.mli: -------------------------------------------------------------------------------- 1 | val term : (Db_store.db_format -> string -> unit) Cmdliner.Term.t 2 | --------------------------------------------------------------------------------