You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
334 lines
12 KiB
334 lines
12 KiB
(*
|
|
* Copyright (c) 2017-present, Facebook, Inc.
|
|
*
|
|
* This source code is licensed under the MIT license found in the
|
|
* LICENSE file in the root directory of this source tree.
|
|
*)
|
|
|
|
open! IStd
|
|
|
|
(** To be used in 'list_constraint *)
|
|
type accept_more
|
|
and end_of_list
|
|
|
|
(* Markers are a fool-proofing mechanism to avoid mistaking captured types.
|
|
Template argument types can be captured with [capt_typ] to be referenced later
|
|
by their position [typ1], [typ2], [typ3], ...
|
|
To avoid mixing them, give a different name to each captured type, using whatever
|
|
type/value you want and reuse it when referencing the captured type, e.g.
|
|
[capt_typ `T &+ capt_typ `A], then use [typ1 `T], [typ2 `A].
|
|
If you get them wrong, you will get a typing error at compile-time or an
|
|
assertion failure at matcher-building time.
|
|
*)
|
|
|
|
type 'marker mtyp = Typ.t
|
|
|
|
(* Intermediate matcher types *)
|
|
|
|
type ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher
|
|
|
|
type ( 'f_in
|
|
, 'f_out
|
|
, 'captured_types_in
|
|
, 'captured_types_out
|
|
, 'markers_in
|
|
, 'markers_out
|
|
, 'list_constraint ) template_arg
|
|
|
|
type ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, 'list_constraint) templ_matcher
|
|
|
|
(* A matcher is a rule associating a function [f] to a [C/C++ function/method]:
|
|
- [C/C++ function/method] --> [f]
|
|
|
|
The goal is to write the C/C++ function/method as naturally as possible, with the following
|
|
exceptions:
|
|
Start with -
|
|
Use $ instead of parentheses for function arguments
|
|
Use + instead of comma to separate function/template arguments
|
|
Concatenate consecutive symbols (e.g. >:: instead of > ::)
|
|
Operators must start with & $ < >
|
|
|
|
E.g. std::vector<T, A>::vector(A) --> f becomes
|
|
-"std" &:: "vector" < capt_typ T &+ capt_typ A >:: "vector" $ typ2 A $--> f
|
|
*)
|
|
|
|
module type Common = sig
|
|
type ('context, 'f) matcher
|
|
|
|
type ('context, 'f) dispatcher
|
|
|
|
val make_dispatcher : ('context, 'f) matcher list -> ('context, '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 *)
|
|
|
|
val ( ~- ) : string -> ('context, 'f, 'f, unit, 'markers, 'markers) name_matcher
|
|
(** Starts a path with a name *)
|
|
|
|
val ( &+ ) :
|
|
( 'context
|
|
, '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
|
|
-> ('context, 'f_in, 'f_out, 'captured_types_out, 'markers_in, 'markers_out, 'lc) templ_matcher
|
|
(** Separate template arguments *)
|
|
|
|
val ( < ) :
|
|
('context, '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
|
|
-> ('context, 'f_in, 'f_out, 'captured_types_out, 'markers_in, 'markers_out, 'lc) templ_matcher
|
|
(** Starts template arguments after a name *)
|
|
|
|
val ( >:: ) :
|
|
('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, _) templ_matcher
|
|
-> string -> ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher
|
|
(** Ends template arguments and starts a name *)
|
|
|
|
val ( &+...>:: ) :
|
|
( 'context
|
|
, 'f_in
|
|
, 'f_out
|
|
, 'captured_types
|
|
, 'markers_in
|
|
, 'markers_out
|
|
, accept_more )
|
|
templ_matcher -> string
|
|
-> ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher
|
|
(** Ends template arguments with eats-ALL and starts a name *)
|
|
|
|
val ( &:: ) :
|
|
('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher -> string
|
|
-> ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher
|
|
(** Separates names (accepts ALL template arguments on the left one) *)
|
|
|
|
val ( <>:: ) :
|
|
('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher -> string
|
|
-> ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher
|
|
(** Separates names (accepts NO template arguments on the left one) *)
|
|
end
|
|
|
|
module type NameCommon = sig
|
|
include Common
|
|
|
|
val ( >--> ) :
|
|
('context, 'f_in, 'f_out, 'captured_types, unit, 'markers, _) templ_matcher -> 'f_in
|
|
-> ('context, 'f_out) matcher
|
|
|
|
val ( <>--> ) :
|
|
('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in
|
|
-> ('context, 'f_out) matcher
|
|
|
|
val ( &--> ) :
|
|
('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in
|
|
-> ('context, 'f_out) matcher
|
|
|
|
val ( &::.*--> ) :
|
|
('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in
|
|
-> ('context, 'f_out) matcher
|
|
(** After a name, accepts ALL template arguments, accepts ALL path tails (names, templates),
|
|
accepts ALL function arguments, binds the function *)
|
|
end
|
|
|
|
(* ocaml ignores the warning suppression at toplevel, hence the [include struct ... end] trick *)
|
|
|
|
include sig
|
|
[@@@warning "-60"]
|
|
|
|
module ProcName :
|
|
NameCommon with type ('context, 'f) dispatcher = 'context -> Typ.Procname.t -> 'f option
|
|
end
|
|
|
|
module TypName : NameCommon with type ('context, 'f) dispatcher = 'context -> Typ.name -> 'f option
|
|
|
|
module Call : sig
|
|
(** Little abstraction over arguments: currently actual args, we'll want formal args later *)
|
|
module FuncArg : sig
|
|
type t = Exp.t * Typ.t
|
|
end
|
|
|
|
include Common
|
|
with type ('context, 'f) dispatcher =
|
|
'context -> Typ.Procname.t -> FuncArg.t list -> 'f option
|
|
|
|
type ('context, 'f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher
|
|
|
|
type ('context, 'arg_in, 'arg_out, 'f_in, 'f_out, 'captured_types, 'markers) one_arg
|
|
|
|
(* Function args *)
|
|
|
|
val any_arg : ('context, unit, _, 'f, 'f, _, _) one_arg
|
|
(** Eats one arg *)
|
|
|
|
val capt_arg : ('context, FuncArg.t, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, _, _) one_arg
|
|
(** Captures one arg *)
|
|
|
|
val capt_exp : ('context, Exp.t, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, _, _) one_arg
|
|
(** Captures one arg expression *)
|
|
|
|
val capt_arg_of_typ :
|
|
('context, unit, _, unit, unit, unit) name_matcher
|
|
-> ('context, FuncArg.t, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, _, _) one_arg
|
|
(** Captures one arg of the given type *)
|
|
|
|
val capt_exp_of_typ :
|
|
('context, unit, _, unit, unit, unit) name_matcher
|
|
-> ('context, Exp.t, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, _, _) one_arg
|
|
(** Captures one arg expression of the given type *)
|
|
|
|
val capt_var_exn : ('context, Ident.t, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, _, _) one_arg
|
|
(** Captures one arg Var. Fails with an internal error if the expression is not a Var *)
|
|
|
|
val typ1 : 'marker -> ('context, unit, _, 'f, 'f, 'marker mtyp * _, 'marker * _) one_arg
|
|
(** Matches first captured type *)
|
|
|
|
val typ2 :
|
|
'marker -> ('context, unit, _, 'f, 'f, _ * ('marker mtyp * _), _ * ('marker * _)) one_arg
|
|
(** Matches second captured type *)
|
|
|
|
val typ3 :
|
|
'marker
|
|
-> ('context, unit, _, 'f, 'f, _ * (_ * ('marker mtyp * _)), _ * (_ * ('marker * _))) one_arg
|
|
(** Matches third captured type *)
|
|
|
|
val ( $+ ) :
|
|
('context, 'f_in, 'f_proc_out, 'f_interm, 'captured_types, 'markers) args_matcher
|
|
-> ('context, 'arg, 'arg, 'f_interm, 'f_out, 'captured_types, 'markers) one_arg
|
|
-> ('context, 'f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher
|
|
(** Separate function arguments *)
|
|
|
|
val ( $+? ) :
|
|
('context, 'f_in, 'f_proc_out, 'f_interm, 'captured_types, 'markers) args_matcher
|
|
-> ('context, 'arg, 'arg option, 'f_interm, 'f_out, 'captured_types, 'markers) one_arg
|
|
-> ('context, 'f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher
|
|
(** Add an optional argument *)
|
|
|
|
val ( >$ ) :
|
|
('context, 'f_in, 'f_proc_out, 'ct, unit, 'cm, _) templ_matcher
|
|
-> ('context, 'arg, 'arg, 'f_proc_out, 'f_out, 'ct, 'cm) one_arg
|
|
-> ('context, 'f_in, 'f_proc_out, 'f_out, 'ct, 'cm) args_matcher
|
|
(** Ends template arguments and starts function arguments *)
|
|
|
|
val ( $--> ) :
|
|
('context, 'f_in, _, 'f_out, 'captured_types, 'markers) args_matcher -> 'f_in
|
|
-> ('context, 'f_out) matcher
|
|
(** Ends function arguments, binds the function *)
|
|
|
|
val ( $ ) :
|
|
('context, 'f_in, 'f_proc_out, 'captured_types, unit, 'markers) name_matcher
|
|
-> ('context, 'arg, 'arg, 'f_proc_out, 'f_out, 'captured_types, 'markers) one_arg
|
|
-> ('context, '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 ( <>$ ) :
|
|
('context, 'f_in, 'f_proc_out, 'captured_types, unit, 'markers) name_matcher
|
|
-> ('context, 'arg, 'arg, 'f_proc_out, 'f_out, 'captured_types, 'markers) one_arg
|
|
-> ('context, '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 ( >--> ) :
|
|
('context, 'f_in, 'f_out, 'captured_types, unit, 'markers, _) templ_matcher -> 'f_in
|
|
-> ('context, 'f_out) matcher
|
|
(** Ends template arguments, accepts ALL function arguments, binds the function *)
|
|
|
|
val ( $+...$--> ) :
|
|
('context, 'f_in, _, 'f_out, 'captured_types, 'markers) args_matcher -> 'f_in
|
|
-> ('context, 'f_out) matcher
|
|
(** Ends function arguments with eats-ALL and binds the function *)
|
|
|
|
val ( >$$--> ) :
|
|
('context, 'f_in, 'f_out, 'captured_types, unit, 'markers, _) templ_matcher -> 'f_in
|
|
-> ('context, 'f_out) matcher
|
|
(** Ends template arguments, accepts NO function arguments, binds the function *)
|
|
|
|
val ( $$--> ) :
|
|
('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in
|
|
-> ('context, 'f_out) matcher
|
|
(** After a name, accepts ALL template arguments, accepts NO function arguments, binds the function *)
|
|
|
|
val ( <>$$--> ) :
|
|
('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in
|
|
-> ('context, 'f_out) matcher
|
|
(** After a name, accepts NO template arguments, accepts NO function arguments, binds the function *)
|
|
|
|
val ( &--> ) :
|
|
('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in
|
|
-> ('context, 'f_out) matcher
|
|
(** After a name, accepts ALL template arguments, accepts ALL function arguments, binds the function *)
|
|
|
|
val ( <>--> ) :
|
|
('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in
|
|
-> ('context, 'f_out) matcher
|
|
(** After a name, accepts NO template arguments, accepts ALL function arguments, binds the function *)
|
|
|
|
val ( &::.*--> ) :
|
|
('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in
|
|
-> ('context, 'f_out) matcher
|
|
(** After a name, accepts ALL template arguments, accepts ALL path tails (names, templates),
|
|
accepts ALL function arguments, binds the function *)
|
|
|
|
val ( $!--> ) :
|
|
('context, 'f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher -> 'f_in
|
|
-> ('context, 'f_out) matcher
|
|
(** Ends function arguments, accepts NO more function arguments.
|
|
If the args do not match, raise an internal error.
|
|
*)
|
|
end
|
|
[@@warning "-32"]
|