Infinite recursion with the fixpoint ?

[Jo-Blade]

I have the following code to implement LDAP filters for search queries:

let filter_part1 x =
  choice5
    (implicit 0 (set_of x))
    (implicit 1 (set_of x))
    (implicit 2 null)
    (* wrong !!, should be x but it causes an infinite recursion *)
    (implicit 3 attribute_value_assertion)
    (implicit 4 substring_filter)

let filter_part2 _ =
  choice5
    (implicit 5 attribute_value_assertion)
    (implicit 6 attribute_value_assertion)
    (implicit 7 attribute_description)
    (implicit 8 attribute_value_assertion)
    (implicit 9 matching_rule_assertion)

type filter =
  [ `And of filter list
  | `ApproxMatch of string * string
  | `EqualityMatch of string * string
  | `ExtensibleMatch of string option * string option * string * bool
  | `GreaterOrEqual of string * string
  | `LessOrEqual of string * string
  | `Not of unit
  | `Or of filter list
  | `Present of string
  | `Substrings of
    string * [ `C1 of string | `C2 of string | `C3 of string ] list ]

let filter : filter t =
  fix @@ fun x ->
  map
    (function
      | `C1 (`C1 abs_l) -> `And abs_l
      | `C1 (`C2 abs_l) -> `Or abs_l
      | `C1 (`C3 x) -> `Not x
      | `C1 (`C4 x) -> `EqualityMatch x
      | `C1 (`C5 x) -> `Substrings x
      | `C2 (`C1 x) -> `GreaterOrEqual x
      | `C2 (`C2 x) -> `LessOrEqual x
      | `C2 (`C3 x) -> `Present x
      | `C2 (`C4 x) -> `ApproxMatch x
      | `C2 (`C5 x) -> `ExtensibleMatch x)
    (function
      | `And x -> `C1 (`C1 x)
      | `Or x -> `C1 (`C2 x)
      | `Not x -> `C1 (`C3 x)
      | `EqualityMatch x -> `C1 (`C4 x)
      | `Substrings x -> `C1 (`C5 x)
      | `GreaterOrEqual x -> `C2 (`C1 x)
      | `LessOrEqual x -> `C2 (`C2 x)
      | `Present x -> `C2 (`C3 x)
      | `ApproxMatch x -> `C2 (`C4 x)
      | `ExtensibleMatch x -> `C2 (`C5 x))
  @@ choice2 (filter_part1 x) (filter_part2 x)

The problem is in the "filter_part_1" function, in the 3rd choice that implements the "not" filter (see https://www.rfc-editor.org/rfc/rfc4511). I had to put implicit 2 null (not spec compliant) instead of implicit 2 x (spec compliant); otherwise, my program would freeze. I suspect the fixpoint to cause an infinite recursion in this case, but I don't know how to prevent it.

You can see the full source code here: https://git.inpt.fr/pisentt/ocaml-ldap-client/-/blob/main/lib/messages.ml?ref_type=heads#L229

[Jo-Blade]

I succeed to prevent the infinite recursion in my code with this little hack:

(** Ugly hack to prevent fixpoint infinite recursion by wrapping variable into a
    useless choice construct *)
let identity asn =
  Asn.S.choice2 asn Asn.S.null
  |> Asn.S.map (function `C1 x -> x | `C2 () -> assert false) (fun x -> `C1 x)

let filter_part1 x =
  choice5
    (implicit 0 (set_of x))
    (implicit 1 (set_of x))
    (implicit 2 (identity x) (* identity prevent infinite recursion *))
    (implicit 3 attribute_value_assertion)
    (implicit 4 substring_filter)

let filter_part2 _ =
  choice5
    (implicit 5 attribute_value_assertion)
    (implicit 6 attribute_value_assertion)
    (implicit 7 attribute_description)
    (implicit 8 attribute_value_assertion)
    (implicit 9 matching_rule_assertion)

[hannesm]

Interesting, do you have a sample input for this grammar when it leads to infinite recursion?

[Jo-Blade]

Interesting, do you have a sample input for this grammar when it leads to infinite recursion?

Here is the simplest example I could write that causes the infinite recursion:

open Asn.S

let test_parser =
  fix @@ fun x -> choice2 (implicit 1 x) (implicit 2 octet_string)

let encode = Asn.encode @@ Asn.codec Asn.ber test_parser
let () = print_endline @@ encode (`C1 (`C2 "a"))

NB. In this case too, using the "identity" function of my previous message can prevent the infinite recursion