[ProcnameDispatcher] Move stuff around

Summary: Move `Procname`-specific (resp. `Typname`) things to `Procname` (resp. `Typname`)

Reviewed By: skcho

Differential Revision: D7124847

fbshipit-source-id: 2709275

infer/src/IR/ProcnameDispatcher.ml

@@ -55,15 +55,6 @@ let templated_name_of_class_name class_name =
       raise DoNotHandleJavaYet
 
 
-(** Little abstraction over arguments: currently actual args, we'll want formal args later *)
-module FuncArg = struct
-  type t = Exp.t * Typ.t
-
-  let typ (_, ty) = ty
-
-  let exp (e, _) = e
-end
-
 (* Intermediate matcher types *)
 
 type ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher =
@@ -100,58 +91,6 @@ type ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, 'emptyness) pat
   ; path_extra: ('f_in, 'f_out, 'captured_types, 'emptyness) path_extra
   ; get_markers: 'markers_in -> 'markers_out }
 
-type ('f_in, 'f_out, 'captured_types) proc_matcher =
-  { on_objc_cpp: 'f_in -> objc_cpp -> ('f_out * 'captured_types) option
-  ; on_c: 'f_in -> c -> ('f_out * 'captured_types) option }
-
-type ('f_in, 'f_out, 'captured_types) on_args =
-  'captured_types -> 'f_in * FuncArg.t list -> ('f_out * FuncArg.t list) option
-
-type ('f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher =
-  { on_proc: ('f_in, 'f_proc_out, 'captured_types) proc_matcher
-  ; on_args: ('f_proc_out, 'f_out, 'captured_types) on_args
-  ; markers: 'markers }
-
-type ('captured_types, 'markers) one_arg_matcher =
-  {match_arg: 'captured_types -> FuncArg.t -> bool; marker_static_checker: 'markers -> bool}
-
-type ('arg_in, 'arg_out, 'f_in, 'f_out) arg_capture =
-  {get_captured_value: FuncArg.t -> 'arg_in; do_capture: 'f_in -> 'arg_out -> 'f_out}
-
-type ('arg_in, 'arg_out, 'f_in, 'f_out, 'captured_types, 'markers) one_arg =
-  { one_arg_matcher: ('captured_types, 'markers) one_arg_matcher
-  ; capture: ('arg_in, 'arg_out, 'f_in, 'f_out) arg_capture }
-
-type ('arg_in, 'arg_out, 'f_in, 'f_out) arg_preparer =
-  { on_empty: ('f_in -> 'arg_out -> 'f_out) -> 'f_in -> ('f_out * FuncArg.t list) option
-  ; wrapper: 'arg_in -> 'arg_out }
-
-type ('f_in, 'f_out, 'captured_types, 'markers) func_arg =
-  {eat_func_arg: ('f_in, 'f_out, 'captured_types) on_args; marker_static_checker: 'markers -> bool}
-
-type 'f matcher =
-  {on_objc_cpp: objc_cpp -> FuncArg.t list -> 'f option; on_c: c -> FuncArg.t list -> 'f option}
-
-type 'f pre_result = DoesNotMatch | Matches of 'f | RetryWith of 'f matcher
-
-let pre_bind_opt opt ~f = match opt with None -> DoesNotMatch | Some x -> f x
-
-let pre_map_opt opt ~f = match opt with None -> DoesNotMatch | Some x -> Matches (f x)
-
-type ('f_in, 'f_out, 'captured_types) func_args_end =
-  on_args:('f_in, 'f_out, 'captured_types) on_args -> FuncArg.t list -> 'f_in * 'captured_types
-  -> 'f_out pre_result
-
-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 = {on_templated_name: templated_name -> 'f option}
-
-type 'f dispatcher = Typ.Procname.t -> FuncArg.t list -> 'f option
-
-type 'f typ_dispatcher = Typ.name -> 'f option
-
 (* Combinators *)
 
 let empty : ('f, 'f, unit, 'markers, 'markers, empty) path_matcher =
@@ -286,48 +225,13 @@ let templ_end
     {on_templated_name; path_extra= PathNonEmpty {on_objc_cpp}; get_markers}
 
 
-let args_begin
+module type Common = sig
-    : ('f_in, 'f_out, 'captured_types, unit, 'markers, non_empty) path_matcher
+  type 'f matcher
-      -> ('f_in, 'f_out, 'f_out, 'captured_types, 'markers) args_matcher =
-  let on_args _capt f_args = Some f_args in
-  fun m ->
-    let {on_templated_name; path_extra= PathNonEmpty {on_objc_cpp}; get_markers} = m in
-    let markers = get_markers () in
-    let get_captures (f, captured_types) = (f, captured_types ()) in
-    let on_c f (c: c) =
-      let template_args = template_args_of_template_spec_info c.template_args in
-      on_templated_name f (c.name, template_args) |> Option.map ~f:get_captures
-    in
-    let on_objc_cpp f objc_cpp = on_objc_cpp f objc_cpp |> Option.map ~f:get_captures in
-    let on_proc : (_, _, _) proc_matcher = {on_objc_cpp; on_c} in
-    {on_proc; on_args; markers}
-
 
-let args_cons
+  type 'f dispatcher
-    : ('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 =
- fun m func_arg ->
-  let {on_proc; on_args; markers} = m in
-  let {marker_static_checker; eat_func_arg} = func_arg in
-  assert (marker_static_checker markers) ;
-  let on_args capt f_args = on_args capt f_args |> Option.bind ~f:(eat_func_arg capt) in
-  {on_proc; on_args; markers}
-
-
-let args_end
-    : ('f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher
-      -> ('f_proc_out, 'f_out, 'captured_types) func_args_end -> ('f_in, 'f_out) all_args_matcher =
- fun m func_args_end ->
-  let {on_proc= {on_c; on_objc_cpp}; on_args} = m in
-  let on_c f c args = on_c f c |> pre_bind_opt ~f:(func_args_end ~on_args args) in
-  let on_objc_cpp f objc_cpp args =
-    on_objc_cpp f objc_cpp |> pre_bind_opt ~f:(func_args_end ~on_args args)
-  in
-  {on_c; on_objc_cpp}
 
+  val make_dispatcher : 'f matcher list -> 'f dispatcher
 
-module type Common = sig
   (* Template arguments *)
 
   val any_typ :
@@ -539,6 +443,105 @@ end
 module Procname = struct
   include Common
 
+  (** Little abstraction over arguments: currently actual args, we'll want formal args later *)
+  module FuncArg = struct
+    type t = Exp.t * Typ.t
+
+    let typ (_, ty) = ty
+
+    let exp (e, _) = e
+  end
+
+  type ('f_in, 'f_out, 'captured_types) proc_matcher =
+    { on_objc_cpp: 'f_in -> objc_cpp -> ('f_out * 'captured_types) option
+    ; on_c: 'f_in -> c -> ('f_out * 'captured_types) option }
+
+  type ('f_in, 'f_out, 'captured_types) on_args =
+    'captured_types -> 'f_in * FuncArg.t list -> ('f_out * FuncArg.t list) option
+
+  type ('f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher =
+    { on_proc: ('f_in, 'f_proc_out, 'captured_types) proc_matcher
+    ; on_args: ('f_proc_out, 'f_out, 'captured_types) on_args
+    ; markers: 'markers }
+
+  type ('captured_types, 'markers) one_arg_matcher =
+    {match_arg: 'captured_types -> FuncArg.t -> bool; marker_static_checker: 'markers -> bool}
+
+  type ('arg_in, 'arg_out, 'f_in, 'f_out) arg_capture =
+    {get_captured_value: FuncArg.t -> 'arg_in; do_capture: 'f_in -> 'arg_out -> 'f_out}
+
+  type ('arg_in, 'arg_out, 'f_in, 'f_out, 'captured_types, 'markers) one_arg =
+    { one_arg_matcher: ('captured_types, 'markers) one_arg_matcher
+    ; capture: ('arg_in, 'arg_out, 'f_in, 'f_out) arg_capture }
+
+  type ('arg_in, 'arg_out, 'f_in, 'f_out) arg_preparer =
+    { on_empty: ('f_in -> 'arg_out -> 'f_out) -> 'f_in -> ('f_out * FuncArg.t list) option
+    ; wrapper: 'arg_in -> 'arg_out }
+
+  type ('f_in, 'f_out, 'captured_types, 'markers) func_arg =
+    { eat_func_arg: ('f_in, 'f_out, 'captured_types) on_args
+    ; marker_static_checker: 'markers -> bool }
+
+  type 'f matcher =
+    {on_objc_cpp: objc_cpp -> FuncArg.t list -> 'f option; on_c: c -> FuncArg.t list -> 'f option}
+
+  type 'f pre_result = DoesNotMatch | Matches of 'f | RetryWith of 'f matcher
+
+  let pre_bind_opt opt ~f = match opt with None -> DoesNotMatch | Some x -> f x
+
+  let pre_map_opt opt ~f = match opt with None -> DoesNotMatch | Some x -> Matches (f x)
+
+  type ('f_in, 'f_out, 'captured_types) func_args_end =
+    on_args:('f_in, 'f_out, 'captured_types) on_args -> FuncArg.t list -> 'f_in * 'captured_types
+    -> 'f_out pre_result
+
+  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 dispatcher = Typ.Procname.t -> FuncArg.t list -> 'f option
+
+  let args_begin
+      : ('f_in, 'f_out, 'captured_types, unit, 'markers, non_empty) path_matcher
+        -> ('f_in, 'f_out, 'f_out, 'captured_types, 'markers) args_matcher =
+    let on_args _capt f_args = Some f_args in
+    fun m ->
+      let {on_templated_name; path_extra= PathNonEmpty {on_objc_cpp}; get_markers} = m in
+      let markers = get_markers () in
+      let get_captures (f, captured_types) = (f, captured_types ()) in
+      let on_c f (c: c) =
+        let template_args = template_args_of_template_spec_info c.template_args in
+        on_templated_name f (c.name, template_args) |> Option.map ~f:get_captures
+      in
+      let on_objc_cpp f objc_cpp = on_objc_cpp f objc_cpp |> Option.map ~f:get_captures in
+      let on_proc : (_, _, _) proc_matcher = {on_objc_cpp; on_c} in
+      {on_proc; on_args; markers}
+
+
+  let args_cons
+      : ('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 =
+   fun m func_arg ->
+    let {on_proc; on_args; markers} = m in
+    let {marker_static_checker; eat_func_arg} = func_arg in
+    assert (marker_static_checker markers) ;
+    let on_args capt f_args = on_args capt f_args |> Option.bind ~f:(eat_func_arg capt) in
+    {on_proc; on_args; markers}
+
+
+  let args_end
+      : ('f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher
+        -> ('f_proc_out, 'f_out, 'captured_types) func_args_end -> ('f_in, 'f_out) all_args_matcher =
+   fun m func_args_end ->
+    let {on_proc= {on_c; on_objc_cpp}; on_args} = m in
+    let on_c f c args = on_c f c |> pre_bind_opt ~f:(func_args_end ~on_args args) in
+    let on_objc_cpp f objc_cpp args =
+      on_objc_cpp f objc_cpp |> pre_bind_opt ~f:(func_args_end ~on_args args)
+    in
+    {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
@@ -814,8 +817,11 @@ end
 module TypName = struct
   include Common
 
-  let make_matcher
+  type 'f matcher = {on_templated_name: templated_name -> 'f option}
-      : ('f_in, 'f_out, _, _, _, non_empty) path_matcher -> 'f_in -> 'f_out typ_matcher =
+
+  type 'f dispatcher = Typ.name -> 'f option
+
+  let make_matcher : ('f_in, 'f_out, _, _, _, non_empty) path_matcher -> 'f_in -> 'f_out matcher =
    fun m f ->
     let {on_templated_name} : ('f_in, 'f_out, _, _, _, non_empty) path_matcher = m in
     let on_templated_name templated_name =
@@ -824,13 +830,13 @@ module TypName = struct
     {on_templated_name}
 
 
-  let make_dispatcher : 'f typ_matcher list -> 'f typ_dispatcher =
+  let make_dispatcher : 'f matcher list -> 'f dispatcher =
    fun matchers typname ->
     match templated_name_of_class_name typname with
     | exception DoNotHandleJavaYet ->
         None
     | templated_name ->
-        List.find_map matchers ~f:(fun (matcher: _ typ_matcher) ->
+        List.find_map matchers ~f:(fun (matcher: _ matcher) ->
             matcher.on_templated_name templated_name )
 
 

infer/src/IR/ProcnameDispatcher.mli

@@ -23,11 +23,6 @@ type accept_more
 
 type 'marker mtyp = Typ.t
 
-(** Little abstraction over arguments: currently actual args, we'll want formal args later *)
-module FuncArg : sig
-  type t = Exp.t * Typ.t
-end
-
 (* Intermediate matcher types *)
 
 type ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher
@@ -42,18 +37,6 @@ type ( 'f_in
 
 type ('f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, 'list_constraint) templ_matcher
 
-type ('f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher
-
-type ('arg_in, 'arg_out, 'f_in, 'f_out, 'captured_types, 'markers) one_arg
-
-type 'f matcher
-
-type 'f dispatcher = Typ.Procname.t -> FuncArg.t list -> 'f option
-
-type 'f typ_matcher
-
-type 'f typ_dispatcher = Typ.name -> 'f option
-
 (* A matcher is a rule associating a function [f] to a [C/C++ function/method]:
   - [C/C++ function/method] --> [f]
 
@@ -70,6 +53,13 @@ type 'f typ_dispatcher = Typ.name -> 'f option
 *)
 
 module type Common = sig
+  type 'f matcher
+
+  type 'f dispatcher
+
+  val make_dispatcher : 'f matcher list -> 'f dispatcher
+  (** Combines matchers to create a dispatcher *)
+
   (* Template arguments *)
 
   val any_typ :
@@ -167,7 +157,16 @@ module type Common = sig
 end
 
 module Procname : sig
-  include Common
+  (** 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 'f dispatcher = Typ.Procname.t -> FuncArg.t list -> 'f option
+
+  type ('f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher
+
+  type ('arg_in, 'arg_out, 'f_in, 'f_out, 'captured_types, 'markers) one_arg
 
   (* Function args *)
 
@@ -200,9 +199,6 @@ module Procname : sig
     'marker -> (unit, _, 'f, 'f, _ * (_ * ('marker mtyp * _)), _ * (_ * ('marker * _))) one_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
     -> ('arg, 'arg, 'f_interm, 'f_out, 'captured_types, 'markers) one_arg
@@ -279,22 +275,19 @@ end
 [@@warning "-32"]
 
 module TypName : sig
-  include Common
+  include Common with type 'f dispatcher = Typ.name -> 'f option
-
-  val make_dispatcher : 'f typ_matcher list -> 'f typ_dispatcher
 
   val ( >--> ) :
-    ('f_in, 'f_out, 'captured_types, unit, 'markers, _) templ_matcher -> 'f_in
+    ('f_in, 'f_out, 'captured_types, unit, 'markers, _) templ_matcher -> 'f_in -> 'f_out matcher
-    -> 'f_out typ_matcher
 
   val ( <>--> ) :
-    ('f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in -> 'f_out typ_matcher
+    ('f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in -> 'f_out matcher
 
   val ( &--> ) :
-    ('f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in -> 'f_out typ_matcher
+    ('f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in -> 'f_out matcher
 
   val ( &::.*--> ) :
-    ('f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in -> 'f_out typ_matcher
+    ('f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in -> 'f_out matcher
   (** After a name, accepts ALL template arguments, accepts ALL path tails (names, templates),
         accepts ALL function arguments, binds the function *)
 end

infer/src/bufferoverrun/bufferOverrunModels.ml

@@ -294,7 +294,7 @@ module Make (BoUtils : BufferOverrunUtils.S) = struct
   end
 
   module Procname = struct
-    let dispatch : model ProcnameDispatcher.dispatcher =
+    let dispatch : model ProcnameDispatcher.Procname.dispatcher =
       let open ProcnameDispatcher.Procname in
       let mk_std_array () = -"std" &:: "array" < any_typ &+ capt_int in
       let std_array0 = mk_std_array () in
@@ -324,7 +324,7 @@ module Make (BoUtils : BufferOverrunUtils.S) = struct
   end
 
   module TypName = struct
-    let dispatch : typ_model ProcnameDispatcher.typ_dispatcher =
+    let dispatch : typ_model ProcnameDispatcher.TypName.dispatcher =
       let open ProcnameDispatcher.TypName in
       make_dispatcher
         [ -"std" &:: "array" < capt_typ `T &+ capt_int >--> StdArray.typ