Fixpoint and monadic combinators for Ast_pattern

[just-max]

Lets say we wanted to implement a pattern that takes a module type of the form

functor (X) (Y) (Z) -> S

and parses it to a list of the functor arguments, followed by the core module type, of the form:

([X; Y; Z], S)

Here's a simple implementation that's not quite right:

let rec strip_functors base =
  pmty_functor __ (strip_functors base) |> map2 ~f:List.cons
  ||| (base |> map0 ~f:[])

This would work, but the strict nature of OCaml means this does nothing but run in circles.

Instead, a fix combinator may be added to Ast_pattern:

val fix : f:(('a -> ('b, 'c, 'd) t) -> 'a -> ('b, 'c, 'd) t) -> 'a -> ('b, 'c, 'd) t

Then, the definition of strip_functors becomes:

let strip_functors base =
  let open Ast_pattern in
  let f self n =
    pmty_functor __ (self ()) |> map2 ~f:List.cons
    ||| (base |> map0 ~f:[])
  in
  fix ~f ()

This terminates just fine!

Here's a possible implementation for fix:

let rec fix ~f x =
  T
    (fun ctx ->
      let (T f') = f (fix ~f) x in
      f' ctx)

Here's an example that doesn't just pass () to the recursive call, and searches for a let binding with the given name to a maximum depth:

(** search through nested [let .. in ..] bindings until [let name = .. in ..] is found *)
let find_depth name d =
  let pure x = __ |> map1 ~f:(Fun.const x) in
  let f self n =
    if n > 0 then
      pexp_let drop
        (value_binding ~pat:(ppat_var (string name) |> as__) ~expr:drop ^:: nil)
        drop
      |> map1 ~f:Option.some
      ||| pexp_let drop drop (self (n - 1))
      ||| pure None
    else pure None
  in
  fix ~f d

Inspired partly by QCheck.

---

With an implementation for bind : ('a, 'b -> 'c, 'd) t -> f:('b -> ('a, 'e, 'c) t) -> ('a, 'e, 'd) t, the recursive parser can depend on parsed values:

let ( let* ) p f = bind p ~f
(** in a sequence of [let .. in ..] bindings, find a shadowed binding *)
let find_shadow =
  let f (self : _ -> (_, pattern option -> _, _) t) trace =
    let let_var = value_binding ~pat:(ppat_var __ |> as__) ~expr:drop ^:: nil in
    let ppat_let_var =
      let* pat, name = pexp_let drop let_var drop |> pack2 in
      match List.assoc_opt name trace with
      | Some shadow -> pure (Some shadow)
      | None -> pexp_let drop drop (self ((name, pat) :: trace))
    in
    ppat_let_var ||| pexp_let drop drop (self trace) ||| pure None
  in

  fix ~f []

Here is such an implementation:

let bind (T f1) ~f =
  T
    (fun ctx loc x k ->
      f1 ctx loc x (fun x' ->
          let (T f2) = f x' in
          f2 ctx loc x k))

Finally, this combinator might be useful:

let reject msg = T (fun _ctx loc _x _k -> fail loc msg)

---

I think fix and bind would both be very useful for writing general patterns. The performance of fix should be acceptable, but with bind there comes the risk of an explosion of search paths if one is not careful, given the backtracking implementation of the parser.

Is there any desire to have these included in the library?

[panglesd]

Hello and thanks for the issue!

Unfortunately, I have very few time to allocate to ppxlib, and most of it is already taken by the modifications to the parsetree.

At first sight, your proposition seems a good improvement, and I've seen other people facing the same problem; and having to come up with a similar solution (ping @EmileTrotignon).

So, we will try to review your proposition to include this in the library in a not too distant future, but don't expect too much reactivity, at least from me... Apologies in advance!