Skip to content

Commit

Permalink
WIP: Precompute Find in signature datastructure
Browse files Browse the repository at this point in the history
  • Loading branch information
@Julow
Julow committed Nov 15, 2023
1 parent 5b64e28 commit 783bfd7
Showing 1 changed file with 134 additions and 89 deletions.
223 changes: 134 additions & 89 deletions src/xref2/find.ml
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,10 @@
open Odoc_model.Names
open Component
module StringTbl = Hashtbl.Make (struct
type t = string
let equal : string -> string -> bool = (=)
let hash : string -> int = Hashtbl.hash
end)

type module_ = [ `FModule of ModuleName.t * Module.t Delayed.t ]

Expand Down Expand Up @@ -55,42 +60,106 @@ type method_ = [ `FMethod of MethodName.t * Method.t ]

type any_in_class_sig = [ instance_variable | method_ ]

type sig_ctx = Signature.t
module N = Ident.Name

type sig_item =
| Sitem of Signature.item
| Sremoved of Signature.removed_item
| Stype_item of any_in_type

type sig_ctx = sig_item list StringTbl.t
type type_ctx = TypeDecl.t
type typext_ctx = Extension.t
type class_sig_ctx = ClassSignature.t

let context_of_sig sg = sg
(** Add a binding to a ['a list StringTbl.t]. If the binding already exists in
the table, the new value is appended to the corresponding list instead. *)
let tbl_add_multi tbl k v =
try StringTbl.replace tbl k (v :: StringTbl.find tbl k)
with Not_found -> StringTbl.add tbl k [ v ]

let items_in_type (typ : TypeDecl.t) =
let variant_items cons =
(cons.TypeDecl.Constructor.name, `FConstructor cons)
in
let record_items field = (field.TypeDecl.Field.name, `FField field) in
match typ.representation with
| Some (Variant cons) -> List.map variant_items cons
| Some (Record fields) -> List.map record_items fields
| Some Extensible | None -> []

let context_of_sig sg =
let tbl = StringTbl.create 32 in
let rec inner = function
| Signature.Include i -> List.iter inner i.Include.expansion_.items
| Signature.Module (id, _, m) ->
let n = N.typed_module id in
tbl_add_multi tbl (ModuleName.to_string n) (`FModule (n, m))
| ModuleSubstitution (id, ms) ->
tbl_add_multi tbl (N.module_ id) (`FModule_subst ms)
| ModuleType (id, mt) ->
let n = N.typed_module_type id in
tbl_add_multi tbl (ModuleTypeName.to_string n) (`FModuleType (n, mt))
| Type (id, _, t) ->
let t = Delayed.get t in
let n = N.type' id in
tbl_add_multi tbl (TypeName.to_string n) (`FType (n, t));
List.iter
(fun (name, item) -> tbl_add_multi tbl name (`In_type (n, t, item)))
(items_in_type t)
| TypeSubstitution (id, ts) ->
tbl_add_multi tbl (N.type_ id) (`FType_subst ts)
| Exception (id, exc) ->
let n = N.typed_exception id in
tbl_add_multi tbl (ExceptionName.to_string n) (`FExn (n, exc))
| Value (id, v) ->
let n = N.typed_value id in
tbl_add_multi tbl (ValueName.to_string n) (`FValue (n, v))
| Class (id, _, c) ->
let n = N.class' id in
tbl_add_multi tbl (ClassName.to_string n) (`FClass (n, c))
| ClassType (id, _, ct) ->
let n = N.class_type' id in
tbl_add_multi tbl (ClassTypeName.to_string n) (`FClassType (n, ct))
| TypExt typext ->
List.iter
(fun (c : Extension.Constructor.t) ->
tbl_add_multi tbl c.name (`FExt (typext, c)))
typext.constructors
| Comment (`Docs d) ->
List.iter
(fun elt ->
match elt.Odoc_model.Location_.value with
| `Heading lbl ->
tbl_add_multi tbl
(Ident.Name.label lbl.Label.label)
(`FLabel lbl)
| _ -> ())
d
| ModuleTypeSubstitution _
| Open _
| Comment (`Stop) -> ()
in
List.iter inner sg.Signature.items

let context_of_type typ = typ
let context_of_typext ext = ext
let context_of_class_sig csig = csig

module N = Ident.Name

let rec find_map f = function
| hd :: tl -> ( match f hd with Some _ as x -> x | None -> find_map f tl)
| [] -> None

let find_in_sig sg f =
let rec inner f = function
| Signature.Include i :: tl -> (
match inner f i.Include.expansion_.items with
| Some _ as x -> x
| None -> inner f tl)
| hd :: tl -> ( match f hd with Some _ as x -> x | None -> inner f tl)
| [] -> None
in
inner f sg.Signature.items

let filter_in_sig sg f =
let rec inner f = function
| Signature.Include i :: tl ->
inner f i.Include.expansion_.items @ inner f tl
| hd :: tl -> (
match f hd with Some x -> x :: inner f tl | None -> inner f tl)
| [] -> []
in
inner f sg.Signature.items
let rec filter_map f = function
| hd :: tl -> (
match f hd with Some x -> x :: filter_map f tl | None -> filter_map f tl)
| [] -> []

let find_in_sig sg name f =
try find_map f (StringTbl.find sg name) with Not_found -> None

let filter_in_sig sg name f =
try filter_map f (StringTbl.find sg name) with Not_found -> []

(** Returns the last element of a list. Used to implement [_unambiguous]
functions. *)
Expand All @@ -100,31 +169,26 @@ let rec disambiguate = function
| _ :: tl -> disambiguate tl

let module_in_sig sg name =
find_in_sig sg (function
| Signature.Module (id, _, m) when N.module_ id = name ->
Some (`FModule (N.typed_module id, m))
find_in_sig sg name (function
| Signature.Module (id, _, m) -> Some (`FModule (N.typed_module id, m))
| _ -> None)

let module_type_in_sig sg name =
find_in_sig sg (function
| Signature.ModuleType (id, mt) when N.module_type id = name ->
find_in_sig sg name (function
| Signature.ModuleType (id, mt) ->
Some (`FModuleType (N.typed_module_type id, mt))
| _ -> None)

let type_in_sig sg name =
find_in_sig sg (function
| Signature.Type (id, _, m) when N.type_ id = name ->
Some (`FType (N.type' id, Delayed.get m))
| Class (id, _, c) when N.class_ id = name ->
Some (`FClass (N.class' id, c))
| ClassType (id, _, c) when N.class_type id = name ->
Some (`FClassType (N.class_type' id, c))
find_in_sig sg name (function
| Signature.Type (id, _, m) -> Some (`FType (N.type' id, Delayed.get m))
| Class (id, _, c) -> Some (`FClass (N.class' id, c))
| ClassType (id, _, c) -> Some (`FClassType (N.class_type' id, c))
| _ -> None)

let datatype_in_sig sg name =
find_in_sig sg (function
| Signature.Type (id, _, m) when N.type_ id = name ->
Some (`FType (N.type' id, Delayed.get m))
find_in_sig sg name (function
| Signature.Type (id, _, m) -> Some (`FType (N.type' id, Delayed.get m))
| _ -> None)

type removed_type =
Expand Down Expand Up @@ -180,11 +244,9 @@ let careful_datatype_in_sig sg name =
| None -> removed_type_in_sig sg name

let class_in_sig sg name =
filter_in_sig sg (function
| Signature.Class (id, _, c) when N.class_ id = name ->
Some (`FClass (N.class' id, c))
| Signature.ClassType (id, _, c) when N.class_type id = name ->
Some (`FClassType (N.class_type' id, c))
filter_in_sig sg name (function
| Signature.Class (id, _, c) -> Some (`FClass (N.class' id, c))
| Signature.ClassType (id, _, c) -> Some (`FClassType (N.class_type' id, c))
| _ -> None)

let class_in_sig_unambiguous sg name = disambiguate (class_in_sig sg name)
Expand Down Expand Up @@ -248,24 +310,16 @@ let any_in_comment d name =
inner d

let any_in_sig sg name =
filter_in_sig sg (function
| Signature.Module (id, _, m) when N.module_ id = name ->
Some (`FModule (N.typed_module id, m))
| ModuleSubstitution (id, ms) when N.module_ id = name ->
Some (`FModule_subst ms)
| ModuleType (id, mt) when N.module_type id = name ->
Some (`FModuleType (N.typed_module_type id, mt))
| Type (id, _, t) when N.type_ id = name ->
Some (`FType (N.type' id, Delayed.get t))
| TypeSubstitution (id, ts) when N.type_ id = name -> Some (`FType_subst ts)
| Exception (id, exc) when N.exception_ id = name ->
Some (`FExn (N.typed_exception id, exc))
| Value (id, v) when N.value id = name ->
Some (`FValue (N.typed_value id, v))
| Class (id, _, c) when N.class_ id = name ->
Some (`FClass (N.class' id, c))
| ClassType (id, _, ct) when N.class_type id = name ->
Some (`FClassType (N.class_type' id, ct))
filter_in_sig sg name (function
| Signature.Module (id, _, m) -> Some (`FModule (N.typed_module id, m))
| ModuleSubstitution (id, ms) -> Some (`FModule_subst ms)
| ModuleType (id, mt) -> Some (`FModuleType (N.typed_module_type id, mt))
| Type (id, _, t) -> Some (`FType (N.type' id, Delayed.get t))
| TypeSubstitution (id, ts) -> Some (`FType_subst ts)
| Exception (id, exc) -> Some (`FExn (N.typed_exception id, exc))
| Value (id, v) -> Some (`FValue (N.typed_value id, v))
| Class (id, _, c) -> Some (`FClass (N.class' id, c))
| ClassType (id, _, ct) -> Some (`FClassType (N.class_type' id, ct))
| Type (id, _, t) -> (
let typ = Delayed.get t in
match any_in_type typ name with
Expand All @@ -276,36 +330,32 @@ let any_in_sig sg name =
| _ -> None)

let signature_in_sig sg name =
filter_in_sig sg (function
| Signature.Module (id, _, m) when N.module_ id = name ->
Some (`FModule (N.typed_module id, m))
| ModuleType (id, mt) when N.module_type id = name ->
Some (`FModuleType (N.typed_module_type id, mt))
filter_in_sig sg name (function
| Signature.Module (id, _, m) -> Some (`FModule (N.typed_module id, m))
| ModuleType (id, mt) -> Some (`FModuleType (N.typed_module_type id, mt))
| _ -> None)

let module_type_in_sig sg name =
find_in_sig sg (function
| Signature.ModuleType (id, m) when N.module_type id = name ->
find_in_sig sg name (function
| Signature.ModuleType (id, m) ->
Some (`FModuleType (N.typed_module_type id, m))
| _ -> None)

let value_in_sig sg name =
filter_in_sig sg (function
| Signature.Value (id, m) when N.value id = name ->
Some (`FValue (N.typed_value id, m))
filter_in_sig sg name (function
| Signature.Value (id, m) -> Some (`FValue (N.typed_value id, m))
| _ -> None)

let value_in_sig_unambiguous sg name = disambiguate (value_in_sig sg name)

let label_in_sig sg name =
filter_in_sig sg (function
filter_in_sig sg name (function
| Signature.Comment (`Docs d) -> any_in_comment d name
| _ -> None)

let exception_in_sig sg name =
find_in_sig sg (function
| Signature.Exception (id, e) when N.exception_ id = name ->
Some (`FExn (N.typed_exception id, e))
find_in_sig sg name (function
| Signature.Exception (id, e) -> Some (`FExn (N.typed_exception id, e))
| _ -> None)

let extension_in_sig sg name =
Expand All @@ -314,26 +364,21 @@ let extension_in_sig sg name =
| _ :: tl -> inner t tl
| [] -> None
in
find_in_sig sg (function
find_in_sig sg name (function
| Signature.TypExt t -> inner t t.Extension.constructors
| _ -> None)

let label_parent_in_sig sg name =
filter_in_sig sg (function
| Signature.Module (id, _, m) when N.module_ id = name ->
Some (`FModule (N.typed_module id, m))
| ModuleType (id, mt) when N.module_type id = name ->
Some (`FModuleType (N.typed_module_type id, mt))
| Type (id, _, t) when N.type_ id = name ->
Some (`FType (N.type' id, Component.Delayed.get t))
| Class (id, _, c) when N.class_ id = name ->
Some (`FClass (N.class' id, c))
| ClassType (id, _, c) when N.class_type id = name ->
Some (`FClassType (N.class_type' id, c))
filter_in_sig sg name (function
| Signature.Module (id, _, m) -> Some (`FModule (N.typed_module id, m))
| ModuleType (id, mt) -> Some (`FModuleType (N.typed_module_type id, mt))
| Type (id, _, t) -> Some (`FType (N.type' id, Component.Delayed.get t))
| Class (id, _, c) -> Some (`FClass (N.class' id, c))
| ClassType (id, _, c) -> Some (`FClassType (N.class_type' id, c))
| _ -> None)

let any_in_type_in_sig sg name =
filter_in_sig sg (function
filter_in_sig sg name (function
| Signature.Type (id, _, t) -> (
let t = Delayed.get t in
match any_in_type t name with
Expand Down

0 comments on commit 783bfd7

Please sign in to comment.