@ -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,24 +289,104 @@ 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
module type Common = sig
(* Template arguments *)
val any_typ :
( ' f , ' f , ' captured_types , ' captured_types , ' markers , ' markers , accept_more ) template_arg
(* * Eats a type *)
(* * 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 )
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
module Common = struct
(* Template arguments *)
let add_no_marker capture_markers = capture_markers
@ -318,7 +402,11 @@ let any_template_args
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
match template_args with
| ( Typ . TType _ ) :: rest ->
Some ( f , captured_types , rest )
| _ ->
None
in
{ eat_template_arg ; add_marker = add_no_marker }
@ -358,7 +446,11 @@ let capt_int
, 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
match template_args with
| ( Typ . TInt i ) :: rest ->
Some ( f i , captured_types , rest )
| _ ->
None
in
{ eat_template_arg ; add_marker = add_no_marker }
@ -379,6 +471,48 @@ let capt_all
{ eat_template_arg ; add_marker = add_no_marker }
let ( < ! ) name_matcher () = templ_begin name_matcher
let ( > ! ) templ_matcher () = templ_end templ_matcher
let ( & :: ! ) path_matcher name = name_cons path_matcher name
let ( ~ - ) name = empty & :: ! name
let ( & + ) templ_matcher template_arg = templ_cons templ_matcher template_arg
let ( < ) name_matcher template_arg = name_matcher < ! () & + template_arg
let ( > :: ) templ_matcher name = templ_matcher > ! () & :: ! name
let ( & + .. . > :: ) templ_matcher name = templ_matcher & + any_template_args > :: name
let ( & :: ) path_matcher name = path_matcher < any_template_args > :: name
let ( < > :: ) name_matcher name = name_matcher < ! () > :: name
end
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
(* * 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 )
(* Function args *)
let no_checker _ = true
@ -431,7 +565,6 @@ let capt_arg : (FuncArg.t -> 'f, 'f, _, _) func_arg =
(* 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
@ -470,28 +603,12 @@ let wrong_args_internal_error procname _args =
" Unexpected number/types of arguments for %a " Typ . Procname . pp procname
(* Notation shorthands *)
let ( < ! ) name_matcher () = templ_begin name_matcher
let ( > ! ) templ_matcher () = templ_end templ_matcher
let ( $! ) path_matcher () = args_begin path_matcher
let ( > $! ) templ_matcher () = templ_matcher > ! () $! ()
let ( & :: ! ) path_matcher name = name_cons path_matcher name
let ( $* - -> ) all_args_matcher f = make_matcher all_args_matcher f
let ( ~ - ) name = empty & :: ! name
let ( & + ) templ_matcher template_arg = templ_cons templ_matcher template_arg
let ( < ) name_matcher template_arg = name_matcher < ! () & + template_arg
let ( > :: ) templ_matcher name = templ_matcher > ! () & :: ! name
let ( $+ ) args_matcher func_arg = args_cons args_matcher func_arg
let ( > $ ) templ_matcher func_arg = templ_matcher > $! () $+ func_arg
@ -500,12 +617,6 @@ let ( $* ) args_matcher func_args_end = args_end args_matcher func_args_end
let ( $- -> ) args_matcher f = args_matcher $* no_args_left $* - -> f
let ( & + .. . > :: ) templ_matcher name = templ_matcher & + any_template_args > :: name
let ( & :: ) path_matcher name = path_matcher < any_template_args > :: name
let ( < > :: ) name_matcher name = name_matcher < ! () > :: name
let ( $ ) name_matcher func_arg = name_matcher < any_template_args > $ func_arg
let ( < > $ ) name_matcher func_arg = name_matcher < ! () > $ func_arg
@ -527,3 +638,28 @@ let ( <>--> ) name_matcher f = name_matcher <! () >--> 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