(** First class AST patterns *)

open! Import

(** PPX rewriters often need to recognize fragments the OCaml AST, for instance to parse
    the payload of an attribute/expression. You can do that with a pattern matching and
    manual error reporting when the input is not what you expect but this has proven to
    quickly become extremely verbose and unreadable.

    This module aims to help with that by providing first class AST patterns.

    To understand how to use it, let's consider the example of ppx_inline_test. We want to
    recognize patterns of the form:

    {[
      let%test "name" = expr
    ]}

    Which is a syntactic sugar for:

    {[
      [%%test let "name" = expr]
    ]}

    If we wanted to write a function that recognizes the payload of [%%test] using normal
    pattern matching we would write:

    {[
      let match_payload = function
        | Pstr [ { pstr_desc = Pstr_value (Nonrecursive,
                                           [ { pvb_pat = Ppat_constant (Constant_string
                                                                          (name, None))
                                             ; pvb_expr = e
                                             ; _ } ])
                 ; _ } ] ->
          (name, e)
        | _ -> Location.raisef ...
    ]}

    This is quite cumbersome, and this is still not right: this function drops all
    attributes without notice.

    Now let's imagine we wanted to construct the payload instead, using [Ast_builder] one
    would write:

    {[
      let build_payload ~loc name expr =
        let (module B) = Ast_builder.with_loc loc in
        let open B in
        pstr [ pstr_value Nonrecursive (value_binding ~pat:(pstring name) ~expr) ]
    ]}

    Constructing a first class pattern is almost as simple as replacing [Ast_builder] by
    [Ast_pattern]:

    {[
      let payload_pattern name expr =
        let open Ast_pattern in
        pstr (pstr_value nonrecursive (value_binding ~pat:(pstring __) ~expr:__) ^:: nil)
    ]}

    Notice that the place-holders for [name] and [expr] have been replaced by [__]. The
    following pattern with have type:

    {[ (payload, string -> expression -> 'a, 'a) Ast_pattern.t ]}

    which means that it matches values of type [payload] and captures a string and
    expression from it. The two captured elements comes from the use of [__].
*)

(** Type of a pattern:

    - ['a] is the type of value matched by the pattern
    - ['b] is the continuation, for instance for a pattern that captures an [int] and a
      [string], ['b] will be [int -> string -> _]
    - ['c] is the result of the continuation.
*)
type ('a, 'b, 'c) t = ('a, 'b, 'c) Ast_pattern0.t

(** Matches a value against a pattern. *)
val parse : ('a, 'b, 'c) t -> Location.t -> ?on_error:(unit -> 'c) -> 'a -> 'b -> 'c

module Packed : sig
  type ('a, 'b, 'c) pattern = ('a, 'b, 'c) t
  type ('a, 'b) t

  val create : ('a, 'b, 'c) pattern -> 'b -> ('a, 'c) t
  val parse : ('a, 'b) t -> Location.t -> 'a -> 'b
end with type ('a, 'b, 'c) pattern := ('a, 'b, 'c) t

(** Pattern that captures its input. *)
val __ : ('a, 'a -> 'b, 'b) t

(** Same as [__] but also captures the location.

    Note: this should only be used for types that do not embed a location. For instance
    you can use it to capture a string constant:

    {[
      estring __'
    ]}

    but using it to capture an expression would not yield the expected result:

    {[
      pair (eint (int 42)) __'
    ]}

    In the latter case you should use the [pexp_loc] field of the captured expression
    instead.
*)
val __' : ('a, 'a Loc.t -> 'b, 'b) t

(** [alt] stands for `alternatives'. It matches either the first pattern or the second
    one. *)
val alt : ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t

(** Same as [alt], for the common case where the left-hand-side captures a value but not
    the right-hand-side. *)
val alt_option : ('a, 'v -> 'b, 'c) t -> ('a, 'b, 'c) t -> ('a, 'v option -> 'b, 'c) t

(** Same as [alt] *)
val ( ||| ) : ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t

val map : ('a, 'b, 'c) t -> f:('d -> 'b) -> ('a, 'd, 'c) t
val map' : ('a, 'b, 'c) t -> f:(Location.t -> 'd -> 'b) -> ('a, 'd, 'c) t
val map_result : ('a, 'b, 'c) t -> f:('c -> 'd) -> ('a, 'b, 'd) t

(** Same as [map] *)
val ( >>| ) : ('a, 'b, 'c) t -> ('d -> 'b) -> ('a, 'd, 'c) t

val map0 : ('a,               'b, 'c) t -> f:               'v  -> ('a, 'v -> 'b, 'c) t
val map1 : ('a, 'v1 ->        'b, 'c) t -> f:('v1 ->        'v) -> ('a, 'v -> 'b, 'c) t
val map2 : ('a, 'v1 -> 'v2 -> 'b, 'c) t -> f:('v1 -> 'v2 -> 'v) -> ('a, 'v -> 'b, 'c) t

val map0' : ('a,               'b, 'c) t -> f:(Location.t ->               'v) -> ('a, 'v -> 'b, 'c) t
val map1' : ('a, 'v1 ->        'b, 'c) t -> f:(Location.t -> 'v1 ->        'v) -> ('a, 'v -> 'b, 'c) t
val map2' : ('a, 'v1 -> 'v2 -> 'b, 'c) t -> f:(Location.t -> 'v1 -> 'v2 -> 'v) -> ('a, 'v -> 'b, 'c) t

val nil : (_ list, 'a, 'a) t
val ( ^:: ) : ('a, 'b, 'c) t -> ('a list, 'c, 'd) t -> ('a list, 'b, 'd) t
val many : ('a, 'b -> 'b, 'c) t -> ('a list, 'c list -> 'd, 'd) t

val int       : int       -> (int       , 'a, 'a) t
val char      : char      -> (char      , 'a, 'a) t
val string    : string    -> (string    , 'a, 'a) t
val float     : float     -> (float     , 'a, 'a) t
val int32     : int32     -> (int32     , 'a, 'a) t
val int64     : int64     -> (int64     , 'a, 'a) t
val nativeint : nativeint -> (nativeint , 'a, 'a) t
val bool      : bool      -> (bool      , 'a, 'a) t

val cst
  :  to_string:('a -> string)
  -> ?equal:('a -> 'a -> bool)
  -> 'a
  -> ('a, 'b, 'b) t

val none : (_ option, 'a, 'a) t
val some : ('a, 'b, 'c) t -> ('a option, 'b, 'c) t

val pair : ('a1, 'b, 'c) t -> ('a2, 'c, 'd) t -> ('a1 * 'a2, 'b, 'd) t
val ( ** ) : ('a1, 'b, 'c) t -> ('a2, 'c, 'd) t -> ('a1 * 'a2, 'b, 'd) t
val triple
  :  ('a1, 'b, 'c) t
  -> ('a2, 'c, 'd) t
  -> ('a3, 'd, 'e) t
  -> ('a1 * 'a2 * 'a3, 'b, 'e) t

val loc : ('a, 'b, 'c) t -> ('a Loc.t, 'b, 'c) t

val pack0 : ('a, 'b, 'c) t -> ('a, unit -> 'b, 'c) t
val pack2 : ('a, 'b -> 'c -> 'd, 'e) t -> ('a, 'b * 'c -> 'd, 'e) t
val pack3 : ('a, 'b -> 'c -> 'd -> 'e, 'f) t -> ('a, 'b * 'c * 'd -> 'e, 'f) t

(** AST patterns for each constructur/record of the parsetree are generated in the same
    way AST builders are generated. In addition, for every {it wrapper} we generate a
    pattern to match the [loc] and [attributes] fields. For instanct for the [expression]
    type:

    {[
      val pexp_loc
        :  (Location.t, 'a, 'b) t
        -> (expression, 'b, 'c) t
        -> (expression, 'a, 'c) t

      val pexp_attributes
        :  (attributes, 'a, 'b) t
        -> (expression, 'b, 'c) t
        -> (expression, 'a, 'c) t
    ]}
*)
include module type of Ast_pattern_generated

val true_  : (bool, 'a, 'a) t
val false_ : (bool, 'a, 'a) t

val eint       : (int       , 'a, 'b) t -> (expression, 'a, 'b) t
val echar      : (char      , 'a, 'b) t -> (expression, 'a, 'b) t
val estring    : (string    , 'a, 'b) t -> (expression, 'a, 'b) t
val efloat     : (string    , 'a, 'b) t -> (expression, 'a, 'b) t
val eint32     : (int32     , 'a, 'b) t -> (expression, 'a, 'b) t
val eint64     : (int64     , 'a, 'b) t -> (expression, 'a, 'b) t
val enativeint : (nativeint , 'a, 'b) t -> (expression, 'a, 'b) t

val pint       : (int       , 'a, 'b) t -> (pattern, 'a, 'b) t
val pchar      : (char      , 'a, 'b) t -> (pattern, 'a, 'b) t
val pstring    : (string    , 'a, 'b) t -> (pattern, 'a, 'b) t
val pfloat     : (string    , 'a, 'b) t -> (pattern, 'a, 'b) t
val pint32     : (int32     , 'a, 'b) t -> (pattern, 'a, 'b) t
val pint64     : (int64     , 'a, 'b) t -> (pattern, 'a, 'b) t
val pnativeint : (nativeint , 'a, 'b) t -> (pattern, 'a, 'b) t

val single_expr_payload : (expression, 'a, 'b) t -> (payload, 'a, 'b) t

val no_label : (expression, 'a, 'b) t -> (Asttypes.arg_label * expression, 'a, 'b) t

val attribute : name:(string, 'a, 'b) t -> payload:(payload, 'b, 'c) t -> (attribute, 'a, 'c) t
val extension : (string, 'a, 'b) t -> (payload, 'b, 'c) t -> (extension, 'a, 'c) t

val elist : (expression, 'a -> 'a, 'b) t -> (expression, 'b list -> 'c, 'c) t

type context
val of_func : (context -> Location.t -> 'a -> 'b -> 'c) -> ('a, 'b, 'c) t
val to_func : ('a, 'b, 'c) t -> (context -> Location.t -> 'a -> 'b -> 'c)
