[dispatcher] Typename dispatcher

Summary:
Extends `ProcnameDispatcher` to allow matching typenames only.
There isn't much new here, mainly moving stuff so that we only have to open one module to use the operators.

Reviewed By: skcho

Differential Revision: D6408245

fbshipit-source-id: afc6533
master
Mehdi Bouaziz 7 years ago committed by Facebook Github Bot
parent 43758e9fd7
commit 73906d537d

@ -136,9 +136,13 @@ type ('f_in, 'f_out) all_args_matcher =
{ on_objc_cpp: 'f_in -> objc_cpp -> FuncArg.t list -> 'f_out pre_result
; on_c: 'f_in -> c -> FuncArg.t list -> 'f_out pre_result }
type 'f typ_matcher = Typ.name -> 'f option
(* they are actually just the same thing *)
type 'f dispatcher = 'f matcher
type 'f typ_dispatcher = 'f typ_matcher
(* Combinators *)
let empty : ('f, 'f, unit, 'markers, 'markers, empty) path_matcher =
@ -285,245 +289,377 @@ let args_end
{on_c; on_objc_cpp}
let make_matcher : ('f_in, 'f_out) all_args_matcher -> 'f_in -> 'f_out matcher =
fun m f ->
let {on_c; on_objc_cpp} : (_, _) all_args_matcher = m in
fun procname args ->
match procname with
| ObjC_Cpp objc_cpp ->
on_objc_cpp f objc_cpp args |> pre_to_opt procname args
| C c ->
on_c f c args |> pre_to_opt procname args
| _ ->
None
(** Simple implementation of a dispatcher, could be optimized later *)
let make_dispatcher : 'f matcher list -> 'f dispatcher =
fun matchers procname args -> List.find_map matchers ~f:(fun matcher -> matcher procname args)
module type Common = sig
(* Template arguments *)
val any_typ :
('f, 'f, 'captured_types, 'captured_types, 'markers, 'markers, accept_more) template_arg
(** Eats a type *)
val capt_typ :
'marker
-> ( 'marker mtyp -> 'f
, 'f
, 'captured_types
, 'marker mtyp * 'captured_types
, 'markers
, 'marker * 'markers
, accept_more )
template_arg
(** Captures a type than can be back-referenced *)
val capt_int :
( Int64.t -> 'f
, 'f
, 'captured_types
, 'captured_types
, 'markers
, 'markers
, accept_more )
template_arg
(** Captures an int *)
val capt_all :
( Typ.template_arg list -> 'f
, 'f
, 'captured_types
, 'captured_types
, 'markers
, 'markers
, end_of_list )
template_arg
(** Captures all template args *)
val ( ~- ) : string -> ('f, 'f, unit, 'markers, 'markers) name_matcher
(** Starts a path with a name *)
val ( &+ ) :
( 'f_in
, 'f_interm
, 'captured_types_in
, 'markers_interm
, 'markers_out
, accept_more )
templ_matcher
-> ( 'f_interm
, 'f_out
, 'captured_types_in
, 'captured_types_out
, 'markers_in
, 'markers_interm
, 'lc )
template_arg
-> ('f_in, 'f_out, 'captured_types_out, 'markers_in, 'markers_out, 'lc) templ_matcher
(** Separate template arguments *)
val ( < ) :
('f_in, 'f_interm, 'captured_types_in, 'markers_interm, 'markers_out) name_matcher
-> ( 'f_interm
, 'f_out
, 'captured_types_in
, 'captured_types_out
, 'markers_in
, 'markers_interm
, 'lc )
template_arg
-> ('f_in, 'f_out, 'captured_types_out, 'markers_in, 'markers_out, 'lc) templ_matcher
(** Starts template arguments after a name *)
val ( >:: ) :
('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, _) templ_matcher -> string
-> ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher
(** Ends template arguments and starts a name *)
val ( &+...>:: ) :
('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, accept_more) templ_matcher
-> string -> ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher
(** Ends template arguments with eats-ALL and starts a name *)
val ( &:: ) :
('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher -> string
-> ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher
(** Separates names (accepts ALL template arguments on the left one) *)
val ( <>:: ) :
('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher -> string
-> ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher
(** Separates names (accepts NO template arguments on the left one) *)
end
(* Template arguments *)
module Common = struct
(* Template arguments *)
let add_no_marker capture_markers = capture_markers
let add_no_marker capture_markers = capture_markers
(** Eats all template args *)
let any_template_args
: ('f, 'f, 'captured_types, 'captured_types, 'markers, 'markers, end_of_list) template_arg =
let eat_template_arg (f, captured_types, _) = Some (f, captured_types, []) in
{eat_template_arg; add_marker= add_no_marker}
(** Eats all template args *)
let any_template_args
: ('f, 'f, 'captured_types, 'captured_types, 'markers, 'markers, end_of_list) template_arg =
let eat_template_arg (f, captured_types, _) = Some (f, captured_types, []) in
{eat_template_arg; add_marker= add_no_marker}
(** Eats a type *)
let any_typ
: ('f, 'f, 'captured_types, 'captured_types, 'markers, 'markers, accept_more) template_arg =
let eat_template_arg (f, captured_types, template_args) =
match template_args with (Typ.TType _) :: rest -> Some (f, captured_types, rest) | _ -> None
in
{eat_template_arg; add_marker= add_no_marker}
(** Captures a type than can be back-referenced *)
let capt_typ
: 'marker
-> ( 'marker mtyp -> 'f
, 'f
, 'captured_types
, 'marker mtyp * 'captured_types
, 'markers
, 'marker * 'markers
, accept_more )
template_arg =
fun marker ->
(** Eats a type *)
let any_typ
: ('f, 'f, 'captured_types, 'captured_types, 'markers, 'markers, accept_more) template_arg =
let eat_template_arg (f, captured_types, template_args) =
match template_args with
| (Typ.TType ty) :: rest ->
let captured_types () = (ty, captured_types ()) in
Some (f ty, captured_types, rest)
| (Typ.TType _) :: rest ->
Some (f, captured_types, rest)
| _ ->
None
in
let add_marker capture_markers = (marker, capture_markers) in
{eat_template_arg; add_marker}
(** Captures an int *)
let capt_int
: ( Int64.t -> 'f
, 'f
, 'captured_types
, 'captured_types
, 'markers
, 'markers
, accept_more )
template_arg =
let eat_template_arg (f, captured_types, template_args) =
match template_args with (Typ.TInt i) :: rest -> Some (f i, captured_types, rest) | _ -> None
in
{eat_template_arg; add_marker= add_no_marker}
(** Captures all template args *)
let capt_all
: ( Typ.template_arg list -> 'f
, 'f
, 'captured_types
, 'captured_types
, 'markers
, 'markers
, end_of_list )
template_arg =
let eat_template_arg (f, captured_types, template_args) =
Some (f template_args, captured_types, [])
in
{eat_template_arg; add_marker= add_no_marker}
{eat_template_arg; add_marker= add_no_marker}
(** Captures a type than can be back-referenced *)
let capt_typ
: 'marker
-> ( 'marker mtyp -> 'f
, 'f
, 'captured_types
, 'marker mtyp * 'captured_types
, 'markers
, 'marker * 'markers
, accept_more )
template_arg =
fun marker ->
let eat_template_arg (f, captured_types, template_args) =
match template_args with
| (Typ.TType ty) :: rest ->
let captured_types () = (ty, captured_types ()) in
Some (f ty, captured_types, rest)
| _ ->
None
in
let add_marker capture_markers = (marker, capture_markers) in
{eat_template_arg; add_marker}
(** Captures an int *)
let capt_int
: ( Int64.t -> 'f
, 'f
, 'captured_types
, 'captured_types
, 'markers
, 'markers
, accept_more )
template_arg =
let eat_template_arg (f, captured_types, template_args) =
match template_args with
| (Typ.TInt i) :: rest ->
Some (f i, captured_types, rest)
| _ ->
None
in
{eat_template_arg; add_marker= add_no_marker}
(** Captures all template args *)
let capt_all
: ( Typ.template_arg list -> 'f
, 'f
, 'captured_types
, 'captured_types
, 'markers
, 'markers
, end_of_list )
template_arg =
let eat_template_arg (f, captured_types, template_args) =
Some (f template_args, captured_types, [])
in
{eat_template_arg; add_marker= add_no_marker}
(* Function args *)
let ( <! ) name_matcher () = templ_begin name_matcher
let no_checker _ = true
let ( >! ) templ_matcher () = templ_end templ_matcher
let eat_one_func_arg ~match_if capt (f, args) =
match args with arg :: rest when match_if capt arg -> Some (f, rest) | _ -> None
let ( &::! ) path_matcher name = name_cons path_matcher name
let ( ~- ) name = empty &::! name
(** Eats one arg *)
let any_arg : ('f, 'f, _, _) func_arg =
let eat_func_arg capt = eat_one_func_arg ~match_if:(fun _ _ -> true) capt in
{eat_func_arg; marker_static_checker= no_checker}
let ( &+ ) templ_matcher template_arg = templ_cons templ_matcher template_arg
let ( < ) name_matcher template_arg = name_matcher <! () &+ template_arg
let mk_typ_nth
: ('markers -> 'marker) -> ('captured_types -> 'marker mtyp) -> 'marker
-> ('f, 'f, 'captured_types, 'markers) func_arg =
fun get_m get_c marker ->
let marker_static_checker markers = Polymorphic_compare.( = ) marker (get_m markers) in
let eat_func_arg =
eat_one_func_arg ~match_if:(fun capt func_arg ->
Typ.equal (FuncArg.typ func_arg) (get_c capt) )
in
{eat_func_arg; marker_static_checker}
let ( >:: ) templ_matcher name = templ_matcher >! () &::! name
let ( &+...>:: ) templ_matcher name = templ_matcher &+ any_template_args >:: name
(** Matches first captured type *)
let typ1 : 'marker -> ('f, 'f, 'marker mtyp * _, 'marker * _) func_arg =
let pos1 (x, _) = x in
fun marker -> mk_typ_nth pos1 pos1 marker
let ( &:: ) path_matcher name = path_matcher < any_template_args >:: name
let ( <>:: ) name_matcher name = name_matcher <! () >:: name
end
(** Matches second captured type *)
let typ2 : 'marker -> ('f, 'f, _ * ('marker mtyp * _), _ * ('marker * _)) func_arg =
let pos2 (_, (x, _)) = x in
fun marker -> mk_typ_nth pos2 pos2 marker
module Procname = struct
include Common
let make_matcher : ('f_in, 'f_out) all_args_matcher -> 'f_in -> 'f_out matcher =
fun m f ->
let {on_c; on_objc_cpp} : (_, _) all_args_matcher = m in
fun procname args ->
match procname with
| ObjC_Cpp objc_cpp ->
on_objc_cpp f objc_cpp args |> pre_to_opt procname args
| C c ->
on_c f c args |> pre_to_opt procname args
| _ ->
None
(** Matches third captured type *)
let typ3 : 'marker -> ('f, 'f, _ * (_ * ('marker mtyp * _)), _ * (_ * ('marker * _))) func_arg =
let pos3 (_, (_, (x, _))) = x in
fun marker -> mk_typ_nth pos3 pos3 marker
(** Simple implementation of a dispatcher, could be optimized later *)
let make_dispatcher : 'f matcher list -> 'f dispatcher =
fun matchers procname args -> List.find_map matchers ~f:(fun matcher -> matcher procname args)
let capt_arg : (FuncArg.t -> 'f, 'f, _, _) func_arg =
let eat_func_arg _capt (f, args) =
match args with arg :: rest -> Some (f arg, rest) | _ -> None
in
{eat_func_arg; marker_static_checker= no_checker}
(* Function args *)
(* Function args end *)
let no_checker _ = true
(** Matches if there is no function arguments left *)
let no_args_left : (_, _, _) func_args_end =
let match_empty_args = function Some (f, []) -> Matches f | _ -> DoesNotMatch in
fun ~on_args args (f, capt) -> on_args capt (f, args) |> match_empty_args
let eat_one_func_arg ~match_if capt (f, args) =
match args with arg :: rest when match_if capt arg -> Some (f, rest) | _ -> None
(** Matches any function arguments *)
let any_func_args : (_, _, _) func_args_end =
fun ~on_args args (f, capt) -> on_args capt (f, args) |> pre_map_opt ~f:fst
(** Eats one arg *)
let any_arg : ('f, 'f, _, _) func_arg =
let eat_func_arg capt = eat_one_func_arg ~match_if:(fun _ _ -> true) capt in
{eat_func_arg; marker_static_checker= no_checker}
(** If [func_args_end1] does not match, use [func_args_end2] *)
let alternative_args_end
: ('f_in, 'f_out, 'captured_types) func_args_end
-> ('f_in, 'f_out, 'captured_types) func_args_end
-> ('f_in, 'f_out, 'captured_types) func_args_end =
fun func_args_end1 func_args_end2 ~on_args args f_capt ->
match func_args_end1 ~on_args args f_capt with
| DoesNotMatch ->
func_args_end2 ~on_args args f_capt
| otherwise ->
otherwise
let mk_typ_nth
: ('markers -> 'marker) -> ('captured_types -> 'marker mtyp) -> 'marker
-> ('f, 'f, 'captured_types, 'markers) func_arg =
fun get_m get_c marker ->
let marker_static_checker markers = Polymorphic_compare.( = ) marker (get_m markers) in
let eat_func_arg =
eat_one_func_arg ~match_if:(fun capt func_arg ->
Typ.equal (FuncArg.typ func_arg) (get_c capt) )
in
{eat_func_arg; marker_static_checker}
(** Retries matching with another matcher *)
let args_end_retry : _ -> (_, _, _) func_args_end = fun f ~on_args:_ _args _f_capt -> RetryWith f
(** Matches first captured type *)
let typ1 : 'marker -> ('f, 'f, 'marker mtyp * _, 'marker * _) func_arg =
let pos1 (x, _) = x in
fun marker -> mk_typ_nth pos1 pos1 marker
(** Matches second captured type *)
let typ2 : 'marker -> ('f, 'f, _ * ('marker mtyp * _), _ * ('marker * _)) func_arg =
let pos2 (_, (x, _)) = x in
fun marker -> mk_typ_nth pos2 pos2 marker
(** Retries matching with another matcher if the function does not have the
exact number/types of args *)
let exact_args_or_retry : 'f -> (_, _, _) func_args_end =
fun f -> alternative_args_end no_args_left (args_end_retry f)
(** Matches third captured type *)
let typ3 : 'marker -> ('f, 'f, _ * (_ * ('marker mtyp * _)), _ * (_ * ('marker * _))) func_arg =
let pos3 (_, (_, (x, _))) = x in
fun marker -> mk_typ_nth pos3 pos3 marker
let wrong_args_internal_error procname _args =
Logging.(die InternalError)
"Unexpected number/types of arguments for %a" Typ.Procname.pp procname
let capt_arg : (FuncArg.t -> 'f, 'f, _, _) func_arg =
let eat_func_arg _capt (f, args) =
match args with arg :: rest -> Some (f arg, rest) | _ -> None
in
{eat_func_arg; marker_static_checker= no_checker}
(* Notation shorthands *)
(* Function args end *)
(** Matches if there is no function arguments left *)
let no_args_left : (_, _, _) func_args_end =
let match_empty_args = function Some (f, []) -> Matches f | _ -> DoesNotMatch in
fun ~on_args args (f, capt) -> on_args capt (f, args) |> match_empty_args
let ( <! ) name_matcher () = templ_begin name_matcher
let ( >! ) templ_matcher () = templ_end templ_matcher
(** Matches any function arguments *)
let any_func_args : (_, _, _) func_args_end =
fun ~on_args args (f, capt) -> on_args capt (f, args) |> pre_map_opt ~f:fst
let ( $! ) path_matcher () = args_begin path_matcher
let ( >$! ) templ_matcher () = templ_matcher >! () $! ()
(** If [func_args_end1] does not match, use [func_args_end2] *)
let alternative_args_end
: ('f_in, 'f_out, 'captured_types) func_args_end
-> ('f_in, 'f_out, 'captured_types) func_args_end
-> ('f_in, 'f_out, 'captured_types) func_args_end =
fun func_args_end1 func_args_end2 ~on_args args f_capt ->
match func_args_end1 ~on_args args f_capt with
| DoesNotMatch ->
func_args_end2 ~on_args args f_capt
| otherwise ->
otherwise
let ( &::! ) path_matcher name = name_cons path_matcher name
let ( $*--> ) all_args_matcher f = make_matcher all_args_matcher f
(** Retries matching with another matcher *)
let args_end_retry : _ -> (_, _, _) func_args_end = fun f ~on_args:_ _args _f_capt -> RetryWith f
let ( ~- ) name = empty &::! name
(** Retries matching with another matcher if the function does not have the
exact number/types of args *)
let exact_args_or_retry : 'f -> (_, _, _) func_args_end =
fun f -> alternative_args_end no_args_left (args_end_retry f)
let ( &+ ) templ_matcher template_arg = templ_cons templ_matcher template_arg
let ( < ) name_matcher template_arg = name_matcher <! () &+ template_arg
let wrong_args_internal_error procname _args =
Logging.(die InternalError)
"Unexpected number/types of arguments for %a" Typ.Procname.pp procname
let ( >:: ) templ_matcher name = templ_matcher >! () &::! name
let ( $+ ) args_matcher func_arg = args_cons args_matcher func_arg
let ( $! ) path_matcher () = args_begin path_matcher
let ( >$ ) templ_matcher func_arg = templ_matcher >$! () $+ func_arg
let ( >$! ) templ_matcher () = templ_matcher >! () $! ()
let ( $* ) args_matcher func_args_end = args_end args_matcher func_args_end
let ( $*--> ) all_args_matcher f = make_matcher all_args_matcher f
let ( $--> ) args_matcher f = args_matcher $* no_args_left $*--> f
let ( $+ ) args_matcher func_arg = args_cons args_matcher func_arg
let ( &+...>:: ) templ_matcher name = templ_matcher &+ any_template_args >:: name
let ( >$ ) templ_matcher func_arg = templ_matcher >$! () $+ func_arg
let ( &:: ) path_matcher name = path_matcher < any_template_args >:: name
let ( $* ) args_matcher func_args_end = args_end args_matcher func_args_end
let ( <>:: ) name_matcher name = name_matcher <! () >:: name
let ( $--> ) args_matcher f = args_matcher $* no_args_left $*--> f
let ( $ ) name_matcher func_arg = name_matcher < any_template_args >$ func_arg
let ( $ ) name_matcher func_arg = name_matcher < any_template_args >$ func_arg
let ( <>$ ) name_matcher func_arg = name_matcher <! () >$ func_arg
let ( <>$ ) name_matcher func_arg = name_matcher <! () >$ func_arg
let ( $+...$--> ) args_matcher f = args_matcher $* any_func_args $*--> f
let ( $+...$--> ) args_matcher f = args_matcher $* any_func_args $*--> f
let ( >--> ) templ_matcher f = templ_matcher >$! () $+...$--> f
let ( >--> ) templ_matcher f = templ_matcher >$! () $+...$--> f
let ( >$$--> ) templ_matcher f = templ_matcher >$! () $--> f
let ( >$$--> ) templ_matcher f = templ_matcher >$! () $--> f
let ( $$--> ) name_matcher f = name_matcher < any_template_args >$$--> f
let ( $$--> ) name_matcher f = name_matcher < any_template_args >$$--> f
let ( <>$$--> ) name_matcher f = name_matcher <! () >$$--> f
let ( <>$$--> ) name_matcher f = name_matcher <! () >$$--> f
let ( &--> ) name_matcher f = name_matcher < any_template_args >--> f
let ( &--> ) name_matcher f = name_matcher < any_template_args >--> f
let ( <>--> ) name_matcher f = name_matcher <! () >--> f
let ( <>--> ) name_matcher f = name_matcher <! () >--> f
let ( $!--> ) args_matcher f =
args_matcher $* exact_args_or_retry wrong_args_internal_error $*--> f
let ( $!--> ) args_matcher f =
args_matcher $* exact_args_or_retry wrong_args_internal_error $*--> f
end
module TypName = struct
include Common
let make_matcher
: ('f_in, 'f_out, _, _, _, non_empty) path_matcher -> 'f_in -> 'f_out typ_matcher =
fun m f ->
let {on_templated_name} = m in
function
| name -> name |> templated_name_of_class_name |> on_templated_name f |> Option.map ~f:fst
let make_dispatcher : 'f typ_matcher list -> 'f typ_dispatcher =
fun matchers typname -> List.find_map matchers ~f:(fun matcher -> matcher typname)
let ( &-->! ) path_matcher f = make_matcher path_matcher f
let ( >--> ) templ_matcher f = templ_matcher >! () &-->! f
let ( <>--> ) name_matcher f = name_matcher <! () >--> f
let ( &--> ) name_matcher f = name_matcher < any_template_args >--> f
end

@ -54,65 +54,9 @@ type 'f matcher = Typ.Procname.t -> FuncArg.t list -> 'f option
type 'f dispatcher = 'f matcher
val make_dispatcher : 'f matcher list -> 'f dispatcher
(** Combines matchers to create a dispatcher *)
(* Template arguments *)
val any_typ :
('f, 'f, 'captured_types, 'captured_types, 'markers, 'markers, accept_more) template_arg
(** Eats a type *)
val capt_typ :
'marker
-> ( 'marker mtyp -> 'f
, 'f
, 'captured_types
, 'marker mtyp * 'captured_types
, 'markers
, 'marker * 'markers
, accept_more )
template_arg
(** Captures a type than can be back-referenced *)
val capt_int :
( Int64.t -> 'f
, 'f
, 'captured_types
, 'captured_types
, 'markers
, 'markers
, accept_more )
template_arg
(** Captures an int *)
val capt_all :
( Typ.template_arg list -> 'f
, 'f
, 'captured_types
, 'captured_types
, 'markers
, 'markers
, end_of_list )
template_arg
(** Captures all template args *)
(* Function args *)
val any_arg : ('f, 'f, _, _) func_arg
(** Eats one arg *)
val capt_arg : (FuncArg.t -> 'f, 'f, _, _) func_arg
(** Captures one arg *)
val typ1 : 'marker -> ('f, 'f, 'marker mtyp * _, 'marker * _) func_arg
(** Matches first captured type *)
val typ2 : 'marker -> ('f, 'f, _ * ('marker mtyp * _), _ * ('marker * _)) func_arg
(** Matches second captured type *)
val typ3 : 'marker -> ('f, 'f, _ * (_ * ('marker mtyp * _)), _ * (_ * ('marker * _))) func_arg
(** Matches third captured type *)
type 'f typ_matcher = Typ.name -> 'f option
type 'f typ_dispatcher = 'f typ_matcher
(* A matcher is a rule associating a function [f] to a [C/C++ function/method]:
- [C/C++ function/method] --> [f]
@ -129,112 +73,201 @@ val typ3 : 'marker -> ('f, 'f, _ * (_ * ('marker mtyp * _)), _ * (_ * ('marker *
-"std" &:: "vector" < capt_typ T &+ capt_typ A >:: "vector" $ typ2 A $--> f
*)
val ( ~- ) : string -> ('f, 'f, unit, 'markers, 'markers) name_matcher
(** Starts a path with a name *)
module type Common = sig
(* Template arguments *)
val any_typ :
('f, 'f, 'captured_types, 'captured_types, 'markers, 'markers, accept_more) template_arg
(** Eats a type *)
val capt_typ :
'marker
-> ( 'marker mtyp -> 'f
, 'f
, 'captured_types
, 'marker mtyp * 'captured_types
, 'markers
, 'marker * 'markers
, accept_more )
template_arg
(** Captures a type than can be back-referenced *)
val capt_int :
( Int64.t -> 'f
, 'f
, 'captured_types
, 'captured_types
, 'markers
, 'markers
, accept_more )
template_arg
(** Captures an int *)
val capt_all :
( Typ.template_arg list -> 'f
, 'f
, 'captured_types
, 'captured_types
, 'markers
, 'markers
, end_of_list )
template_arg
(** Captures all template args *)
val ( ~- ) : string -> ('f, 'f, unit, 'markers, 'markers) name_matcher
(** Starts a path with a name *)
val ( &+ ) :
( 'f_in
, 'f_interm
, 'captured_types_in
, 'markers_interm
, 'markers_out
, accept_more )
templ_matcher
-> ( 'f_interm
, 'f_out
, 'captured_types_in
, 'captured_types_out
, 'markers_in
, 'markers_interm
, 'lc )
template_arg
-> ('f_in, 'f_out, 'captured_types_out, 'markers_in, 'markers_out, 'lc) templ_matcher
(** Separate template arguments *)
val ( < ) :
('f_in, 'f_interm, 'captured_types_in, 'markers_interm, 'markers_out) name_matcher
-> ( 'f_interm
, 'f_out
, 'captured_types_in
, 'captured_types_out
, 'markers_in
, 'markers_interm
, 'lc )
template_arg
-> ('f_in, 'f_out, 'captured_types_out, 'markers_in, 'markers_out, 'lc) templ_matcher
(** Starts template arguments after a name *)
val ( >:: ) :
('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, _) templ_matcher -> string
-> ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher
(** Ends template arguments and starts a name *)
val ( &+...>:: ) :
('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, accept_more) templ_matcher
-> string -> ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher
(** Ends template arguments with eats-ALL and starts a name *)
val ( &:: ) :
('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher -> string
-> ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher
(** Separates names (accepts ALL template arguments on the left one) *)
val ( <>:: ) :
('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher -> string
-> ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher
(** Separates names (accepts NO template arguments on the left one) *)
end
val ( &+ ) :
('f_in, 'f_interm, 'captured_types_in, 'markers_interm, 'markers_out, accept_more) templ_matcher
-> ( 'f_interm
, 'f_out
, 'captured_types_in
, 'captured_types_out
, 'markers_in
, 'markers_interm
, 'lc )
template_arg
-> ('f_in, 'f_out, 'captured_types_out, 'markers_in, 'markers_out, 'lc) templ_matcher
(** Separate template arguments *)
val ( < ) :
('f_in, 'f_interm, 'captured_types_in, 'markers_interm, 'markers_out) name_matcher
-> ( 'f_interm
, 'f_out
, 'captured_types_in
, 'captured_types_out
, 'markers_in
, 'markers_interm
, 'lc )
template_arg
-> ('f_in, 'f_out, 'captured_types_out, 'markers_in, 'markers_out, 'lc) templ_matcher
(** Starts template arguments after a name *)
val ( >:: ) :
('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, _) templ_matcher -> string
-> ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher
(** Ends template arguments and starts a name *)
val ( $+ ) :
('f_in, 'f_proc_out, 'f_interm, 'captured_types, 'markers) args_matcher
-> ('f_interm, 'f_out, 'captured_types, 'markers) func_arg
-> ('f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher
(** Separate function arguments *)
val ( >$ ) :
('f_in, 'f_proc_out, 'ct, unit, 'cm, _) templ_matcher -> ('f_proc_out, 'f_out, 'ct, 'cm) func_arg
-> ('f_in, 'f_proc_out, 'f_out, 'ct, 'cm) args_matcher
(** Ends template arguments and starts function arguments *)
val ( $--> ) :
('f_in, _, 'f_out, 'captured_types, 'markers) args_matcher -> 'f_in -> 'f_out matcher
(** Ends function arguments, binds the function *)
val ( &+...>:: ) :
('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, accept_more) templ_matcher -> string
-> ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher
(** Ends template arguments with eats-ALL and starts a name *)
val ( &:: ) :
('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher -> string
-> ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher
(** Separates names (accepts ALL template arguments on the left one) *)
val ( <>:: ) :
('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher -> string
-> ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher
(** Separates names (accepts NO template arguments on the left one) *)
val ( $ ) :
('f_in, 'f_proc_out, 'captured_types, unit, 'markers) name_matcher
-> ('f_proc_out, 'f_out, 'captured_types, 'markers) func_arg
-> ('f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher
(** Ends a name with accept-ALL template arguments and starts function arguments *)
val ( <>$ ) :
('f_in, 'f_proc_out, 'captured_types, unit, 'markers) name_matcher
-> ('f_proc_out, 'f_out, 'captured_types, 'markers) func_arg
-> ('f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher
(** Ends a name with accept-NO template arguments and starts function arguments *)
val ( >--> ) :
('f_in, 'f_out, 'captured_types, unit, 'markers, _) templ_matcher -> 'f_in -> 'f_out matcher
(** Ends template arguments, accepts ALL function arguments, binds the function *)
val ( $+...$--> ) :
('f_in, _, 'f_out, 'captured_types, 'markers) args_matcher -> 'f_in -> 'f_out matcher
(** Ends function arguments with eats-ALL and binds the function *)
val ( >$$--> ) :
('f_in, 'f_out, 'captured_types, unit, 'markers, _) templ_matcher -> 'f_in -> 'f_out matcher
(** Ends template arguments, accepts NO function arguments, binds the function *)
val ( $$--> ) :
('f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in -> 'f_out matcher
(** After a name, accepts ALL template arguments, accepts NO function arguments, binds the function *)
val ( <>$$--> ) :
('f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in -> 'f_out matcher
(** After a name, accepts NO template arguments, accepts NO function arguments, binds the function *)
val ( &--> ) :
('f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in -> 'f_out matcher
(** After a name, accepts ALL template arguments, accepts ALL function arguments, binds the function *)
val ( <>--> ) :
('f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in -> 'f_out matcher
(** After a name, accepts NO template arguments, accepts ALL function arguments, binds the function *)
val ( $!--> ) :
('f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher -> 'f_in -> 'f_out matcher
(** Ends function arguments, accepts NO more function arguments.
module Procname : sig
include Common
(* Function args *)
val any_arg : ('f, 'f, _, _) func_arg
(** Eats one arg *)
val capt_arg : (FuncArg.t -> 'f, 'f, _, _) func_arg
(** Captures one arg *)
val typ1 : 'marker -> ('f, 'f, 'marker mtyp * _, 'marker * _) func_arg
(** Matches first captured type *)
val typ2 : 'marker -> ('f, 'f, _ * ('marker mtyp * _), _ * ('marker * _)) func_arg
(** Matches second captured type *)
val typ3 : 'marker -> ('f, 'f, _ * (_ * ('marker mtyp * _)), _ * (_ * ('marker * _))) func_arg
(** Matches third captured type *)
val make_dispatcher : 'f matcher list -> 'f dispatcher
(** Combines matchers to create a dispatcher *)
val ( $+ ) :
('f_in, 'f_proc_out, 'f_interm, 'captured_types, 'markers) args_matcher
-> ('f_interm, 'f_out, 'captured_types, 'markers) func_arg
-> ('f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher
(** Separate function arguments *)
val ( >$ ) :
('f_in, 'f_proc_out, 'ct, unit, 'cm, _) templ_matcher
-> ('f_proc_out, 'f_out, 'ct, 'cm) func_arg
-> ('f_in, 'f_proc_out, 'f_out, 'ct, 'cm) args_matcher
(** Ends template arguments and starts function arguments *)
val ( $--> ) :
('f_in, _, 'f_out, 'captured_types, 'markers) args_matcher -> 'f_in -> 'f_out matcher
(** Ends function arguments, binds the function *)
val ( $ ) :
('f_in, 'f_proc_out, 'captured_types, unit, 'markers) name_matcher
-> ('f_proc_out, 'f_out, 'captured_types, 'markers) func_arg
-> ('f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher
(** Ends a name with accept-ALL template arguments and starts function arguments *)
val ( <>$ ) :
('f_in, 'f_proc_out, 'captured_types, unit, 'markers) name_matcher
-> ('f_proc_out, 'f_out, 'captured_types, 'markers) func_arg
-> ('f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher
(** Ends a name with accept-NO template arguments and starts function arguments *)
val ( >--> ) :
('f_in, 'f_out, 'captured_types, unit, 'markers, _) templ_matcher -> 'f_in -> 'f_out matcher
(** Ends template arguments, accepts ALL function arguments, binds the function *)
val ( $+...$--> ) :
('f_in, _, 'f_out, 'captured_types, 'markers) args_matcher -> 'f_in -> 'f_out matcher
(** Ends function arguments with eats-ALL and binds the function *)
val ( >$$--> ) :
('f_in, 'f_out, 'captured_types, unit, 'markers, _) templ_matcher -> 'f_in -> 'f_out matcher
(** Ends template arguments, accepts NO function arguments, binds the function *)
val ( $$--> ) :
('f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in -> 'f_out matcher
(** After a name, accepts ALL template arguments, accepts NO function arguments, binds the function *)
val ( <>$$--> ) :
('f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in -> 'f_out matcher
(** After a name, accepts NO template arguments, accepts NO function arguments, binds the function *)
val ( &--> ) :
('f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in -> 'f_out matcher
(** After a name, accepts ALL template arguments, accepts ALL function arguments, binds the function *)
val ( <>--> ) :
('f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in -> 'f_out matcher
(** After a name, accepts NO template arguments, accepts ALL function arguments, binds the function *)
val ( $!--> ) :
('f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher -> 'f_in -> 'f_out matcher
(** Ends function arguments, accepts NO more function arguments.
If the args do not match, raise an internal error.
*)
end
module TypName : sig
include Common
val make_dispatcher : 'f typ_matcher list -> 'f typ_dispatcher
val ( >--> ) :
('f_in, 'f_out, 'captured_types, unit, 'markers, _) templ_matcher -> 'f_in
-> 'f_out typ_matcher
val ( <>--> ) :
('f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in -> 'f_out typ_matcher
val ( &--> ) :
('f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in -> 'f_out typ_matcher
end

@ -154,7 +154,7 @@ module Make (CFG : ProcCfg.S) = struct
let dispatcher : model ProcnameDispatcher.dispatcher =
let open ProcnameDispatcher in
let open ProcnameDispatcher.Procname in
make_dispatcher
[ -"__inferbo_min" <>$ capt_arg $+ capt_arg $!--> inferbo_min
; -"__inferbo_set_size" <>$ capt_arg $+ capt_arg $!--> inferbo_set_size

Loading…
Cancel
Save