restore menhir parser and handle _ -> int

db/type_polarity.ml

@@ -34,16 +34,16 @@ type t = string * int
 let all_type_names name =
   name |> String.split_on_char '.' |> tails |> List.map (String.concat ".")
 
-let rec of_typ ~ignore_any ~all_names ~prefix ~sgn = function
+let rec of_typ ~any_is_poly ~all_names ~prefix ~sgn = function
   | Poly _ -> [ Sign.to_string sgn :: "POLY" :: prefix ]
   | Any ->
-      if ignore_any
-      then [ prefix ]
-      else [ Sign.to_string sgn :: "POLY" :: prefix ]
+      if any_is_poly
+      then [ Sign.to_string sgn :: "POLY" :: prefix ]
+      else [ Sign.to_string sgn :: prefix ]
   | Arrow (a, b) ->
       List.rev_append
-        (of_typ ~ignore_any ~all_names ~prefix ~sgn:(Sign.not sgn) a)
-        (of_typ ~ignore_any ~all_names ~prefix ~sgn b)
+        (of_typ ~any_is_poly ~all_names ~prefix ~sgn:(Sign.not sgn) a)
+        (of_typ ~any_is_poly ~all_names ~prefix ~sgn b)
   | Constr (name, args) ->
       name
       |> (if all_names then all_type_names else fun name -> [ name ])
@@ -57,23 +57,18 @@ let rec of_typ ~ignore_any ~all_names ~prefix ~sgn = function
                    @@ List.mapi
                         (fun i arg ->
                           let prefix = string_of_int i :: prefix in
-                          of_typ ~ignore_any ~all_names ~prefix ~sgn arg)
+                          of_typ ~any_is_poly ~all_names ~prefix ~sgn arg)
                         args
              end)
       |> rev_concat
   | Tuple args ->
       rev_concat
-      @@ List.map (of_typ ~ignore_any ~all_names ~prefix ~sgn)
+      @@ List.map (of_typ ~any_is_poly ~all_names ~prefix ~sgn)
       @@ args
   | Unhandled -> []
 
-(** [of_typ ~ignore_any ~prefix ~sgn t] is a representation of [t] that
-    encodes the polarity of the elements of the type : in [string -> int] [int]
-    is positive and [string] negative.
-    It is registered in the database and search-base type uses this to obtain
-    results that fit the type asked for by the user. *)
-let of_typ ~ignore_any ~all_names t =
+let of_typ ~any_is_poly ~all_names t =
   t
-  |> of_typ ~ignore_any ~all_names ~prefix:[] ~sgn:Pos
+  |> of_typ ~any_is_poly ~all_names ~prefix:[] ~sgn:Pos
   |> List.map (String.concat "")
   |> regroup

db/type_polarity.mli

@@ -72,12 +72,12 @@ type t = string * int
   toplevel documentation of the module.
 *)
 
-val of_typ : ignore_any:bool -> all_names:bool -> Typexpr.t -> t list
+val of_typ : any_is_poly:bool -> all_names:bool -> Typexpr.t -> t list
 (** [of_typ ~ignore_any ~all_names typ] is the list of polarised types
     corresponding to [typ].
 
-  - If [ignore_any] is true, the type [_] will be ignored, otherwise it will be
-    treated like a type variable ['a].
+  - If [any_is_poly] is true, the type [_] will be treated like a type variable
+    ['a], other it will be represented solely by its sign ("+" or "-").
 
   - If [all_names] is true, extra polarities are added for every "possible name"
     of each type constructor. For instance the possible names of

index/load_doc.ml

@@ -144,7 +144,7 @@ let convert_kind (Odoc_search.Entry.{ kind; _ } as entry) =
 let register_type_expr ~db elt type_ =
   let type_polarities =
     type_ |> typ_of_odoc_typ
-    |> Db.Type_polarity.of_typ ~ignore_any:false ~all_names:true
+    |> Db.Type_polarity.of_typ ~any_is_poly:true ~all_names:true
   in
   Db.store_type_polarities db elt type_polarities
 

query/dune

@@ -5,4 +5,8 @@
  (name query)
  (libraries lwt re db))
 
+(menhir
+ (modules type_parser)
+ (flags --explain))
+
 (ocamllex type_lexer)

query/query.ml

@@ -8,7 +8,12 @@ module Occ = Db.Occ
 module Private = struct
   module Array_succ = Array_succ
   module Succ = Succ
-  module Type_parser = Type_parser
+
+  module Type_parser = struct
+    let of_string str =
+      let lexbuf = Lexing.from_string str in
+      Ok (Type_parser.main Type_lexer.token lexbuf)
+  end
 end
 
 let collapse_occ ~count occs =
@@ -26,10 +31,12 @@ let collapse_trie t =
 let polarities typ =
   List.filter
     (fun (word, _count) -> String.length word > 0)
-    (Db.Type_polarity.of_typ ~ignore_any:true ~all_names:false typ)
+    (Db.Type_polarity.of_typ ~any_is_poly:false ~all_names:false typ)
 
 let find_types ~shards typ =
   let polarities = polarities typ in
+  if polarities = []
+  then failwith "Query.find_types : type with empty polarities" ;
   List.fold_left
     (fun acc shard ->
       let db = Db.(shard.db_types) in

query/query.mli

@@ -36,5 +36,8 @@ val pretty : t -> string
 module Private : sig
   module Array_succ = Array_succ
   module Succ = Succ
-  module Type_parser = Type_parser
+
+  module Type_parser : sig
+    val of_string : string -> (Db.Typexpr.t, string) result
+  end
 end

query/query_parser.ml

@@ -1,4 +1,7 @@
-let parse str = Type_parser.of_string str
+let type_of_string str =
+  let lexbuf = Lexing.from_string str in
+  try Ok (Type_parser.main Type_lexer.token lexbuf)
+  with Type_parser.Error -> Error "parse error"
 
 let naive_of_string str =
   List.filter (fun s -> String.length s > 0) (String.split_on_char ' ' str)
@@ -18,7 +21,7 @@ let of_string str =
 
   let typ =
     Result.bind str_typ (fun str_typ ->
-        match parse str_typ with
+        match type_of_string str_typ with
         | Ok Any -> Error `any
         | Ok typ -> Ok typ
         | Error _ -> Error `parse)

query/type_lexer.mll

@@ -1,16 +1,7 @@
-(* This is the lexer for the [parser.mly]. *)
+(* This is the lexer for [type_parser.mly]. *)
 
 {
-  type token =
-  | ARROW
-  | PARENS_OPEN
-  | PARENS_CLOSE
-  | COMMA
-  | ANY
-  | STAR
-  | POLY of string
-  | WORD of string
-  | EOF
+open Type_parser
 }
 
 rule token = parse

query/type_parser.mly

@@ -0,0 +1,57 @@
+(* This is a parser for type expressions. It is written in a weird style to
+   allow for incomplete queries to be reasonably answered. It also has conflicts
+   for the same reason. They are impossible to solve.
+   Its behaviour on correct types is tested in [query/test/test_type_parser.ml]
+   and its behaviour on incomplete types is tested in [test/cram/query_syntax.t/run.t] *)
+
+%{
+  open Db.Typexpr
+%}
+
+%token EOF
+%token PARENS_OPEN PARENS_CLOSE
+%token ARROW COMMA ANY STAR
+%token<string> WORD
+%token<string> POLY
+
+%start main
+%type<Db.Typexpr.t> main
+
+%%
+
+main:
+  | t=typ EOF { t }
+  | EOF { any }
+  ;
+
+typ:
+  | a=typ1 ARROW b=typ { arrow a b }
+  | a=typ1 ARROW EOF { arrow a any }
+  | ARROW b=typ { arrow any b }
+  | ARROW EOF { arrow any any }
+  | t=typ1 { t }
+  ;
+
+typ1:
+  | x=typ0 xs=tups { match xs with [] -> x | xs -> tuple (x::xs) }
+  ;
+
+tups:
+  | STAR x=typ0 xs=tups { x::xs }
+  | STAR { [any] }
+  | EOF { [] }
+  | { [] }
+  ;
+
+typ0:
+  | ANY { any }
+  | w=POLY { poly w }
+  | w=WORD { constr w [] }
+  | t=typ0 w=WORD { constr w [t] }
+  | PARENS_OPEN ts=typ_list PARENS_CLOSE w=WORD { constr w ts }
+  | PARENS_OPEN t=typ PARENS_CLOSE { t }
+  | PARENS_OPEN t=typ EOF { t }
+  | PARENS_OPEN EOF { any }
+  ;
+
+typ_list: ts=separated_list(COMMA, typ) { ts } ;

review.md

@@ -50,6 +50,13 @@ they are interpreted as relative to the `-o` option")
 
 - separate pretty_query from the api function
 
+- Try to support `_ -> int` with dynamic cost ?
+> Done, but with polarities. `_` in a query has polarity `"+"` or `"-"`.
+  Previously the two possibilities were `"+POLY"`/`"-POLY"` or nothing.
+
+
+- Rewrite the type parser in a more flexible framework than menhir (combinator or recursive descent)
+> Not needed in the end
 
 # TODO
 
@@ -65,9 +72,7 @@ they are interpreted as relative to the `-o` option")
 
 <!-- - Essayer de comprendre dans `Load_doc.type_path` pourquoi l'ordre ne fait pas d'importance (see) -->
 
-- Rewrite the type parser in a more flexible framework than menhir (combinator or recursive descent)
 
-- Try to support `_ -> int` with dynamic cost ?
 
 # Explications commentée
 

test/cram/base_benchmark.t

@@ -7,9 +7,9 @@
   ./base_odocls/shadow_stdlib.odocl
   $ time sherlodoc_index --format=js --db=db.js $(find . -name '*.odocl')
 
-  real	0m1.449s
-  user	0m1.407s
-  sys	0m0.037s
+  real	0m1.488s
+  user	0m1.409s
+  sys	0m0.067s
 
 
 

test/cram/base_web.t

@@ -31,7 +31,7 @@ The --no-preserve flag is here so that copying to /tmp will not fail because of
 a previous run. .js files built by dune are read only.
   $ cp --no-preserve=mode,ownership ../../jsoo/main.bc.js html/sherlodoc.js
   $ du -sh html/sherlodoc.js
-  5.1M	html/sherlodoc.js
+  264K	html/sherlodoc.js
   $ ls html
   base
   db.js