Mutually recursive parser in Angstrom

Community
,
1

I want to defined mutually recursive parser functions using Angstrom and

  1. it seems that built-in fix doesn’t help me
  2. I can’t declare my own polyvariadic fix because parser type is abstract.

I also checked other parser-combinator libraries and they seems to have parser type to be concrete. How should I proceed? @seliopou ?

open Angstrom

let rec fix_comb f a = f (fix_comb f) a

let fix_poly :
    (('a -> 'b) list -> 'a -> 'b) list -> ('a -> 'b) list =
 fun l ->
  fix_comb
    (fun self l -> List.map (fun li x -> li (self l) x) l)
    l

[@@@warning "-8-27"]

let [ even; odd ] =
  let open_even [ even; odd ] n = n = 0 || odd (n - 1)
  and open_odd [ even; odd ] n = n <> 0 && even (n - 1) in
  fix_poly [ open_even; open_odd ]

[@@@warning "+8+27"]

let parens p =
  char '(' >>= fun _ ->
  p >>= fun x ->
  char ')' >>= fun _ -> return x

let const =
  char '0' >>= fun c -> return (Printf.sprintf "%c" c)

let [ sum; product ] =
  let open_sum [ sum; product ] =
    choice
      [
        parens sum;
        ( product >>= fun h ->
          many (char '+' >>= fun _ -> product) >>= fun tl ->
          return
            (List.fold_left
               (fun acc r -> Printf.sprintf "%s+%s" acc r)
               h tl) );
      ]
  and open_product [ sum; product ] =
    choice
      [
        parens sum;
        ( const >>= fun h ->
          many (char '*' >>= fun _ -> product) >>= fun tl ->
          return
            (List.fold_left
               (fun acc r -> Printf.sprintf "%s*%s" acc r)
               h tl) );
      ]
  in

  fix_poly [ open_sum; open_product ]

(*
81 |   fix_poly [ open_sum; open_product ]
                  ^^^^^^^^
Error: This expression has type string t list -> string t
       but an expression was expected of type ('a -> 'b) list -> 'a -> 'b
       Type string t is not compatible with type 'a -> 'b  *)
2

I found a dirty hack but I still need proper solution

let sum, product =
  let sum1 : string t ref =
    ref @@ Obj.magic (fun _ -> failwith "sum")
  in
  let pro1 : string t ref =
    ref @@ Obj.magic (fun _ -> failwith "product")
  in
  let sum =
    fix @@ fun self ->
    choice
      [
        parens self;
        ( !pro1 >>= fun h ->
          many (char '+' >>= fun _ -> !pro1) >>= fun tl ->
          return
            (List.fold_left
               (fun acc r -> Printf.sprintf "%s+%s" acc r)
               h tl) );
      ]
  in
  let product =
    fix @@ fun self ->
    choice
      [
        parens !sum1;
        ( const >>= fun h ->
          many (char '*' >>= fun _ -> self) >>= fun tl ->
          return
            (List.fold_left
               (fun acc r -> Printf.sprintf "%s*%s" acc r)
               h tl) );
      ]
  in
  pro1 := product;
  sum1 := sum;
  (sum, product)

let%test _ =
  parse_string ~consume:Consume.All sum "0*0+0*0"
  = Ok "0*0+0*0"
1 Like
3

One way of coding recursion without let-rec is via a recursively-typed dispatch-table. I think there’s an example of this in typing/tast_mapper.mli.

1 Like
4

Yeah, thanks Chet. But I still think that it is not an expected solution.

  type dispatch = {
    sum : dispatch -> string t;
    product : dispatch -> string t;
  }

  let d =
    let sum d =
      fix @@ fun self ->
      choice
        [
          parens self;
          ( d.product d >>= fun h ->
            many (char '+' >>= fun _ -> d.product d)
            >>= fun tl ->
            return
              (List.fold_left
                 (fun acc r -> Printf.sprintf "%s+%s" acc r)
                 h tl) );
        ]
    in
    let product d =
      fix @@ fun self ->
      choice
        [
          parens (d.sum d);
          ( const >>= fun h ->
            many (char '*' >>= fun _ -> self) >>= fun tl ->
            return
              (List.fold_left
                 (fun acc r -> Printf.sprintf "%s*%s" acc r)
                 h tl) );
        ]
    in
    { sum; product }

  let%test _ =
    parse_string ~consume:Consume.All (d.sum d) "0*0+0*0"
    = Ok "0*0+0*0"
5

Oh hm, no, I didn’t mean that. I don’t know Angstrom, but let’s suppose that we have a recursive-descent parser, with type 'a t as the type of parsers that parse the input to a type 'a [I suspect that that’s what you mean above, but just being concrete]. Suppose we have three nonterminals, say … “expr”, “block”, and “procedure”, which are mutually-recusive. Then I might do the following:

let expr __dt__ strm = ........ __dt__.expr __dt__ strm ....
   ..... __dt__.block __dt__ strm ... 
and block __dt__ strm = ...... __dt__.expr __dt__ strm .....
and procedure __dt__ strm = .... __dt__.block __dt__ strm ...

let dt = { expr = expr ; block = block ; procedure = procedure }

let top_expr strm = dt.expr dt strm
... etc ....

Notice that there’s no recursion in the code: it all comes about via the type. This referred to as “open recursion” because you can replace (in the dispatch table) the definition of any of the constituent functions by a new one (that can (heh) use the previous one as a fallback, of course).

6

The thing you describe is essentially the same, so it looks like that we understand each other :slight_smile:

7

Ah, ok. I assumed you were turned-off by the need to use “fix” in your example code.