pa_monad.ml

(* name:          pa_monad.ml
 * synopsis:      Haskell-like "do" for monads
 * authors:       Jacques Carette and Oleg Kiselyov,
 *                based in part of work of Lydia E. Van Dijk
 * last revision: Thu Nov 13 09:27:46 UTC 2008
 * ocaml version: 3.11
 *
 * Copyright (C) 2006-2008  J. Carette, L. E. van Dijk, O. Kiselyov
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Library General Public
 * License as published by the Free Software Foundation; either
 * version 2 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Library General Public License for more details.
 *
 * You should have received a copy of the GNU Library General Public
 * License along with this library; if not, write to the Free
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 *)


(** {2 Syntax Extension to Support Monads}

This module extends OCaml's syntax by a Haskell-like "[do]"-notation
particularly suited for the work with monads.

By the nature of the translation process (at pre-processing time,
before compilation) it cannot be guaranteed that the result code
actually obeys the three fundamental laws for all monads:
+ [bind (return x) f]  is identical to  [f x]
+ [bind m return]      is identical to  [m]
+ [bind (bind m f) g]  is identical to  [bind m (fun x -> bind (f x) g)]

where [bind] and [return] are user defined functions.  Incidentally,
in Haskell, too, it is entirely the responsibility of the programmer
to make sure that [bind] and [return] are implemented for a particular
Monad do indeed obey the above laws.


{2 Conversion Rules}

{3 Grammar informally}
We support four different constructs to introduce monadic
expressions.
- [perform exp]
- [perform exp1; exp2]
- [perform x <-- exp1; exp2]
- [perform let x = foo in exp]

which is almost literally the grammar of the Haskell's
"[do]"-notation, with the differences that Haskell uses "[do]" and
"[<-]" where we use "[perform]" and "[<--]".

We support not only [let x = foo in ...] expressions but arbitrarily
complex [let]-expressions, including [let rec] and [let module].


{4 Extended Forms}
The actual bind function of the monad defaults to "[bind]" and the
match-failure function to "[failwith]".  The latter is only used for
refutable patterns; see below.  To select different functions, use the
extended forms of "[perform]".

{b Expression:} Use the given expression as "[bind]"-function and
apply the default match-failure function ([failwith]) where necessary.
{[
        perform with exp1 in exp2
        perform with exp1 in exp3; exp4
        perform with exp1 in x <-- exp2; exp3
        perform with exp in let x = foo in exp
]}
Use the first given expression ([exp1]) as "[bind]"-function and the
second ([exp2]) as match-failure function.
{[
        perform with exp1 and exp2 in exp3
        perform with exp1 and exp2 in exp3; exp4
        perform with exp1 and exp2 in x <-- exp3; exp4
        perform with exp1 and exp2 in let x = foo in exp1
]}

{b Module:} Use the function named "[bind]" from module "[Mod]".  In
addition use the module's "[failwith]"-function in refutable patterns.
{[
        perform with module Mod in exp2
        perform with module Mod in exp3; exp4
        perform with module Mod in x <-- exp2; exp3
        perform with module Mod in let x = foo in exp
]}


{4 Refutable Patterns}
An irrefutable pattern is either:
- A variable,
- The wildcard "[_]",
- The constructor "[()]",
- A tuple with irrefutable patterns,
- A record with irrefutable patterns, or
- An irrefutable pattern with a type constraint.

Any other pattern is refutable.

Why do we need this distinction?  Well, the expression
{[
        perform x <-- exp1; exp2
]}
expands to
{[
        bind exp2 (fun x -> exp1)
]}
where pattern match can never fail as "[x]" can take any value.  This
is an example of an irrefutable pattern.  No catch-all branch is
required here.  Compare this with
{[
        perform 1 <-- exp1; exp2
]}
which expands to
{[
        bind exp2 (fun 1 -> exp1 | _ -> failwith "pattern match")
]}
As the match can fail -- "[1]" being a refutable pattern in this
position -- we must add a second branch that catches the remaining
values.  The user is free to override the "[failwith]" function with
her own version.

Refer to the thread on the Haskell mailing list concerning the topic
of {{:http://www.haskell.org/pipermail/haskell/2006-January/017237.html}
refutable patterns} and an excerpt from an earlier
{{:http://www.cs.chalmers.se/~rjmh/Haskell/Messages/Decision.cgi?id=2}
discussion} on the same issue.


{3 Grammar formally}
Formally the grammar of [pa_monad] can be specified as follows.
{[
        "perform" ["with" <user-function-spec> "in"] <perform-body>

        <user-function-spec> ::=
                  EXPR ["and" EXPR]
                | "module" MODULE-NAME

        <perform-body> ::=
                  <LET-FORM> <perform-body>
                | EXPR
                | <binding> ";" <perform-body>
                | "rec" <binding> ["and" <binding> [...]] ";" <perform-body>

        <binding> ::= PATTERN "<--" EXPR
]}
where
- [EXPR] is an OCaml expression {i expr} as defined in
{{:http://caml.inria.fr/pub/docs/manual-ocaml/expr.html} Section 6.7, "Expressions"},
of the OCaml manual,
- [MODULE-NAME] a {i module-name}
({{:http://caml.inria.fr/pub/docs/manual-ocaml/manual011.html} Sec. 6.3, "Names"}),
- [LET-FORM] is any of the [let], [let rec], or [let module] {i let-forms}
({{:http://caml.inria.fr/pub/docs/manual-ocaml/expr.html} Sec. 6.7, "Expressions"}), and
- [PATTERN] a {i pattern}
({{:http://caml.inria.fr/pub/docs/manual-ocaml/patterns.html} Sec. 6.6, "Patterns"}).

The "[rec]" keyword allows for a recursive binding in
{[
        "rec" PATTERN "<--" EXPR
        "and" PATTERN "<--" EXPR
        ...
        "and" PATTERN "<--" EXPR ";"
]}
The syntax extension groups all bindings in a "[rec]"-"[and]", but
it does not group consecutive "[rec]"-bindings.  This grouping is
sometimes called segmentation.

{b Example:} Define a recursive group of bindings consisting of three
patterns ([PATTERN1]-[PATTERN3]) and expressions ([EXPR1]-[EXPR3]), a
non-recursive binding [PATTERN4]/[EXPR4], and finally a single
recursive binding [PATTERN5]/[EXPR5]:
{[
        "rec" PATTERN1 "<--" EXPR1
        "and" PATTERN2 "<--" EXPR2
        "and" PATTERN3 "<--" EXPR3 ";"
              PATTERN4 "<--" EXPR4 ";"
        "rec" PATTERN5 "<--" EXPR5 ";"
]}
Please consult
{{:http://caml.inria.fr/pub/docs/manual-ocaml/manual021.html} Section
7.3, "Recursive definitions of values"} of the Manual for valid
recursive definitions of values, as the only allowed [PATTERN] in the
recursive case is a [NAME].  Similarly stringent restrictions apply to
[EXPR].

The theoretical aspects of recursive monadic bindings can be found in:
Levent Erkök and John Launchbury, "A Recursive do for Haskell".

{b Formal Types of [bind] and [failwith]}

For any ['a monad] the expansion uses the functions "[bind]" and
"[failwith]" with the signatures
{[
        val bind: 'a monad -> ('a -> 'b monad) -> 'b monad
        val failwith: string -> 'a monad
]}
unless overridden by the user.  Analogously, the signatures of modules
used in the "[with module]"-form must enclose
{[
        sig
          type 'a monad
          val bind: 'a monad -> ('a -> 'b monad) -> 'b monad
          val failwith: string -> 'a monad
        end
]}
Note that although a proper monad requires a [return] function, the
translation itself does not need it.


{3 Semantics (as re-writing into the core language)}
In this section, we abbreviate irrefutable patterns with [ipat] and
refutable patterns with [rpat].
{[
        perform exp1                 ===>  exp1
        perform ipat <-- exp; rest   ===>  bind exp (fun ipat -> perform rest)
        perform rpat <-- exp; rest   ===>  bind exp (fun rpat -> perform rest
                                                         | _ -> failwith "pattern match")
        perform let ... in rest      ===>  let ... in perform rest
        perform exp; rest            ===>  bind exp (fun _ -> perform rest)

        perform with bexp in body
                ===> perform body
                        where bind is substituted with bexp

        perform with bexp and fexp in body
                ===> perform body
                        where bind is substituted with bexp and
                              failwith is substituted with fexp

        perform with module Mod in body
                ===> perform body
                        where bind is substituted with Mod.bind and
                              failwith with Mod.failwith
]}


{4 Implementation Notes And Design Decisions}
It is be possible to use "[<-]" instead of "[<--]".  In that case, the
similarity to the "[do]" notation of Haskell will be complete.
However, if the program has [_ <- exp] outside of [perform], this will
be accepted by the parser (and create an incomprehensible error later
on).  It is better to use a dedicated symbol "[<--]", so if the user
abuses it, the error should be clear right away.

The major difficulty with the [perform] notation is that it cannot
truly be parsed by an LR-grammar.  Indeed, to figure out if we should
start parsing <perform-body> as an expression or a pattern, we have to
parse it as a pattern and check for the "[<--]" delimiter.  If it is
not there, we should {e backtrack} and parse it again as an
expression.  Furthermore, [a <-- b] (or [a <- b]) can also be parsed
as an expression.  However, some patterns, for example [_ <-- exp],
cannot be parsed as an expression.

It is possible (via some kind of flag) to avoid parsing [_ <-- exp]
outside of [perform].  But this becomes quite complex and unreliable.
To record a particular expression [patt <-- exp] in the AST, we use
the node
{[
    <:expr< let [(patt, exp)] in $lid:"<--"$ >>
]}
If the construction [_ <-- exp] is used by mistake, we get an error
message about an unbound identifier "[<--]", which is our intention.


{2 Known Issues}

- Sum types are assumed to have more than one constructor, thus always
  yield refutable patterns.  This is, if you define
  {[
        type t = T
  ]}
  and later use
  {[
        perform T <-- T; ...
  ]}
  you get "Warning U: this match case is unused." which is not deserved.

- Aliases in patterns are not supported yet.  Code like
  {[
        perform
          ((x, y, z) as tuple) <-- 1, 2, 3;
          ...
  ]}
  blows the extension out of the water.  As a matter of fact, it is
  not clear that this should be supported at all: patterns with
  aliases are not "simple patterns" (see {i pa_o.ml}).  For example,
  patterns with aliases cannot be used in [fun pattern -> ...].  Thus,
  at present monadic bindings should include only those patterns that
  are permissible in [fun].  And perhaps this is the optimal decision.

- The recursive form "[rec ... <-- ...]" is not implemented completely.
  It lacks support for a (user-specified) fix-point function.  See
  for example Erkök and Launchbury's "A Recursive do for Haskell".
 *)


open Camlp4.PreCast
open Syntax


(** [failure_text]

    This is the text that accompanies a match failure of a refutable
    pattern. *)
let failure_text = "pattern match"


(** [default_bind_expr _loc]

    This is the default expression for the "bind" function. *)
let default_bind_expr (_loc: Ast.Loc.t): Ast.expr =
  <:expr< bind >>


(** [default_failure_fun_expr _loc]

    This is the expression for the default "failwith" function. *)
let default_failure_fun_expr (_loc: Ast.Loc.t): Ast.expr =
  <:expr< failwith >>


(** [default_failure_expr _loc]

    This is the expression for the default "failwith" function
    ({!Pa_monad.default_failure_fun_expr}) after the
    {!Pa_monad.failure_text} has been applied. *)
let default_failure_expr (_loc: Ast.Loc.t): Ast.expr =
  let fun_expr = default_failure_fun_expr _loc
  and text_expr = <:expr< $str:failure_text$ >> in
    <:expr< $fun_expr$ $text_expr$ >>


(** [exp_to_patt _loc an_expression]

    Convert [an_expression] to a (simple) pattern, if we "accidentally" parse
    a pattern as an expression. *)
(* The code is based on [pattern_eq_expression] in {i pa_fstream.ml}. *)
let rec exp_to_patt (_loc: Ast.Loc.t) (an_expression: Ast.expr): Ast.patt =
  match an_expression with
      <:expr< $int:s$ >> -> <:patt< $int:s$ >> (* integer constant *)
    | <:expr< $chr:c$ >> -> <:patt< $chr:c$ >> (* character constant *)
    | <:expr< $str:s$ >> -> <:patt< $str:s$ >> (* string constant *)
    | <:expr< $lid:b$ >> -> <:patt< $lid:b$ >> (* local variable *)
    | <:expr< $uid:b$ >> -> <:patt< $uid:b$ >> (* variable of other module *)
    | <:expr< $e1$ $e2$ >> ->                  (* function application *)
      let p1 = exp_to_patt _loc e1
      and p2 = exp_to_patt _loc e2 in
        <:patt< $p1$ $p2$ >>
    | <:expr< ($tup:e$) >> ->                  (* tuple *)
      let p = exp_to_patt _loc e in
        <:patt< ($tup:p$) >>
    | <:expr< $e1$, $e2$ >> ->
      let p1 = exp_to_patt _loc e1
      and p2 = exp_to_patt _loc e2 in
        <:patt< $p1$, $p2$ >>
    | <:expr< { $rec_binding:r$ } >> ->        (* record *)
      let p = recbinding_to_patt _loc r in
        <:patt< { $p$ } >>
    | <:expr< ($e$ : $t$) >> ->                (* type restriction *)
      let p = exp_to_patt _loc e in
        <:patt< ($p$ : $t$) >>
    | _ ->
      Loc.raise _loc
        (Stream.Error "exp_to_patt: this expression is not yet supported")
(** [recbinding_to_pattrec _loc an_exp_record]

    Convert [an_exp_record] to a pattern matching a record. *)
and recbinding_to_patt (_loc: Ast.Loc.t) (an_exp_record: Ast.rec_binding): Ast.patt =
  match an_exp_record with
      <:rec_binding< >> -> <:patt< >>
    | <:rec_binding< $i$ = $e$ >> ->
      let p = exp_to_patt _loc e in
        <:patt< $i$ = $p$ >>
    | <:rec_binding< $b1$ ; $b2$ >> ->
        let p1 = recbinding_to_patt _loc b1
        and p2 = recbinding_to_patt _loc b2 in
          <:patt< $p1$; $p2$ >>
    | <:rec_binding< $anti:_$ >> ->
      Loc.raise _loc
        (Stream.Error "recbinding_to_patt: antiquotations are not yet supported")


(** [patt_to_exp _loc a_pattern]

    Convert [a_pattern] to an expression, if we must reuse it in a
    different semantic position. *)
let rec patt_to_exp (_loc: Ast.Loc.t) (a_pattern: Ast.patt): Ast.expr =
  match a_pattern with
      <:patt< $int:s$ >> -> <:expr< $int:s$ >> (* integer constant *)
    | <:patt< $chr:c$ >> -> <:expr< $chr:c$ >> (* character constant *)
    | <:patt< $str:s$ >> -> <:expr< $str:s$ >> (* string constant *)
    | <:patt< $lid:b$ >> -> <:expr< $lid:b$ >> (* local variable *)
    | <:patt< $uid:b$ >> -> <:expr< $uid:b$ >> (* variable of other module *)
    | <:patt< $e1$ $e2$ >> ->                  (* function application *)
      let p1 = patt_to_exp _loc e1
      and p2 = patt_to_exp _loc e2 in
        <:expr< $p1$ $p2$ >>
    | <:patt< ($tup:p$) >> ->                  (* tuple *)
      let e = patt_to_exp _loc p in
        <:expr< ($tup:e$) >>
    | <:patt< $p1$, $p2$ >> ->
      let e1 = patt_to_exp _loc p1
      and e2 = patt_to_exp _loc p2 in
        <:expr< $e1$, $e2$ >>
    | <:patt< { $r$ } >> ->
      <:expr< { $rec_binding:patt_to_recbinding _loc r$ } >>
    | <:patt< ($e$ : $t$) >> ->                (* type restriction *)
      let p = patt_to_exp _loc e in
        <:expr< ($p$ : $t$) >>
    | _ ->
      Loc.raise _loc
        (Stream.Error "patt_to_exp: this pattern is not yet supported")
(** [patt_to_recbinding _loc a_pattern]

    Convert [a_pattern] to a recursive binding. *)
and patt_to_recbinding (_loc: Ast.Loc.t) (a_pattern: Ast.patt): Ast.rec_binding =
  match a_pattern with
      <:patt< >> -> <:rec_binding< >>
    | <:patt< $i$ = $p$ >> ->
      let p = patt_to_exp _loc p in
        <:rec_binding< $i$ = $p$ >>
    | <:patt< $p1$ ; $p2$ >> ->
        let b1 = patt_to_recbinding _loc p1
        and b2 = patt_to_recbinding _loc p2 in
          <:rec_binding< $b1$; $b2$ >>
    | <:patt< $anti:_$ >> ->
      Loc.raise _loc
        (Stream.Error "patt_to_recbinding: antiquotation are not yet supported")
    | _ ->
      Loc.raise _loc
        (Stream.Error "patt_to_recbinding: never reached")


(** [is_irrefutable_pattern a_pattern]

    Answer whether [a_pattern] is irrefutable.

    Implementation Note: In OCaml 3.10.0 the function
    [Ast.is_irrefut_patt] is buggy.  Thus, we must use our own
    implementation. *)
let rec is_irrefutable_pattern (a_pattern: Ast.patt): bool =
  match a_pattern with
      <:patt< () >> -> true             (* unit *)
    | <:patt< ( $p$ : $_$ ) >> ->       (* type constraint *)
      is_irrefutable_pattern p
    | <:patt< ( $p1$ as $_p2$ ) >> ->   (* alias *)
      is_irrefutable_pattern p1
    | <:patt< { $r$ } >> ->             (* record *)
      is_irrefutable_pattern r
    | <:patt< $_$ = $p$ >> ->           (* field in a record *)
      is_irrefutable_pattern p
    | <:patt< $r1$; $r2$ >> ->          (* sum of fields *)
        is_irrefutable_pattern r1 && is_irrefutable_pattern r2
    | <:patt< $t1$, $t2$ >> ->          (* sum in a tuple *)
      is_irrefutable_pattern t1 && is_irrefutable_pattern t2
    | <:patt< ($tup:t$) >> ->           (* tuple *)
      is_irrefutable_pattern t
    | <:patt< $lid:_$ >> -> true        (* variable *)
    | <:patt< _ >> -> true              (* wildcard *)
    | _ -> false


(** [tuplify_expr _loc an_expression_list]

    Convert [an_expression_list] to a tuple of expressions. *)
let tuplify_expr (_loc: Ast.Loc.t) (an_expression_list: Ast.expr list): Ast.expr =
  match an_expression_list with
      [] -> Loc.raise _loc (Stream.Error "tuplify_expr: empty expression list")
    | x :: [] -> x
    | _ -> <:expr< ($tup:Ast.exCom_of_list an_expression_list$) >>


(** [tuplify_patt _loc a_pattern_list]

    Convert [a_pattern_list] to a tuple of patterns. *)
let tuplify_patt (_loc: Ast.Loc.t) (a_pattern_list: Ast.patt list): Ast.patt =
  match a_pattern_list with
      [] -> Loc.raise _loc (Stream.Error "tuplify_patt: empty pattern list")
    | x :: [] -> x
    | _ -> <:patt< ($tup:Ast.paCom_of_list a_pattern_list$) >>


(** [convert _loc a_perform_body a_bind_function a_fail_function]

    Convert all expressions of [a_perform_body] inside [perform] into
    core OCaml.  Use [a_bind_function] as the monad's "bind"-function,
    and [a_fail_function] as the "failure"-function. *)
let convert
    (_loc: Ast.Loc.t)
    (a_perform_body: Ast.expr)
    (a_bind_function: Ast.expr)
    (a_fail_function: Ast.expr): Ast.expr =
  let rec loop _loc a_perform_body =
    match a_perform_body with
        <:expr< let $rec:_$ $_$ in $lid:"<--"$ >> -> (* x <-- e at the last *)
          Loc.raise _loc
            (Stream.Error "convert: monadic binding cannot be last in a \"perform\" body")
      | <:expr< let $rec:r$ $binding:bs$ in $body$ >> ->
        let body' = loop _loc body in
          <:expr< let $rec:r$ $binding:bs$ in $body'$ >>
      | <:expr< let module $m$ = $mb$ in $body$ >> ->
        let body' = loop _loc body in
          <:expr< let module $m$ = $mb$ in $body'$ >>
      | <:expr< do { $e$ } >> -> (* b1; b2; ... *) 
         let b1, b2, bs =
           match Ast.list_of_expr e [] with
               b1 :: b2 :: bs -> b1, b2, bs
             | _ -> assert false in
         let do_rest () =
           loop _loc
             (match bs with
                 [] -> b2
               | _  -> <:expr< do { $list:(b2 :: bs)$ } >>)
         and do_merge a_body =
           loop _loc <:expr< do { $list:(a_body :: b2 :: bs)$ } >> in
         begin
               match b1 with
                   (* monadic binding *)
                   <:expr< let $p$ = $e$ in $lid:"<--"$ >> ->
                     if is_irrefutable_pattern p then
                       <:expr< $a_bind_function$ $e$ (fun $p$ -> $do_rest ()$) >>
                     else
                       <:expr< $a_bind_function$
                               $e$
                               (fun [$p$ -> $do_rest ()$
                                     | _ -> $a_fail_function$ ]) >>
                   (* recursive monadic binding *)
                 | <:expr< let rec $binding:b$ in $lid:"<--"$ >> ->
                   let pattern_list = List.map fst (Ast.pel_of_binding b) in
                   let patterns = tuplify_patt _loc pattern_list
                   and patt_as_exp =
                     tuplify_expr
                       _loc
                       (List.map (fun x -> patt_to_exp _loc x) pattern_list)
                   in
                     List.iter
                       (fun p ->
                         if not (is_irrefutable_pattern p) then
                           Loc.raise _loc
                             (Stream.Error
                                 ("convert: refutable patterns and " ^
                                     "recursive bindings do not go together")))
                       pattern_list;
                     <:expr< let rec $binding:b$ in
                               $a_bind_function$
                                 $patt_as_exp$
                                 (fun $patterns$ -> $do_rest ()$) >>
                 (* escaped sequence *)
                 | <:expr< let () = $e$ in $lid:";"$ >> ->
                     <:expr< do { $e$; $do_rest ()$ } >>
                 | (* map through the regular let *)
                   <:expr< let $rec:r$ $binding:bs$ in $body$ >> ->
                     <:expr< let $rec:r$ $binding:bs$ in $do_merge body$ >>
                 | <:expr< let module $m$ = $mb$ in $body$ >> ->
                     <:expr< let module $m$ = $mb$ in $do_merge body$ >>
                 | _ -> 
                     let rest = do_rest () in
                     let f = 
                       let _loc = Ast.loc_of_expr b1 in
                       <:expr< (fun $lid:"__must_be_unit"$ (* was _ *) -> do { $lid:"__must_be_unit"$; $rest$ }) >>
                     in
                     <:expr< $a_bind_function$ $b1$ $f$ >>
         end
      | any_body -> any_body
  in loop _loc a_perform_body


(** [qualify _loc a_module_ident a_function_expression]

    Append [a_function_expression] to the module name given in
    [a_module_ident], this is, qualify [a_function_expression] by
    [a_module_ident].  Fail if [a_module_ident] is not a valid
    module name. *)
let qualify
    (_loc: Ast.Loc.t)
    (a_module_ident: Ast.ident)
    (a_function_expression: Ast.expr): Ast.expr =
  let mod_expr = <:expr< $id:a_module_ident$ >> in
    <:expr< $mod_expr$ . $a_function_expression$ >>


(* Here we have to do the same nasty trick that Camlp4 uses and even
 * mentions in its documentation (viz. 'horrible hack' in pa_o.ml).  We
 * see if we can expect [patt <--] to succeed.  Here [patt] is a simple
 * pattern and it definitely does not parse as an expression.
 * Rather than resorting to unlimited lookahead and emulating the
 * Pcaml.patt LEVEL simple grammar, we do it the other way around: We
 * make sure that a pattern can always be parsed as an expression and
 * declare "[_]" a valid identifier!  If you attempt to use it,
 * you will get an undefined identifier anyway, so it is safe. *)

EXTEND Gram
    GLOBAL: expr;

    expr: LEVEL "top"
    [
      [ "perform"; "with"; "module"; monad_module = uid; "in";
        perform_body = expr LEVEL ";" ->
          let qualified_fail_expr =
            qualify _loc monad_module (default_failure_fun_expr _loc) in
            convert _loc
              perform_body
              (qualify _loc monad_module (default_bind_expr _loc))
              <:expr< $qualified_fail_expr$ $str:failure_text$ >> ]
    |
      [ "perform"; "with"; bind_fun = expr;
                           fail_fun = OPT opt_failure_expr; "in";
        perform_body = expr LEVEL ";" ->
          convert _loc
            perform_body
            bind_fun
            (match fail_fun with
                 None -> default_failure_expr _loc
               | Some f -> <:expr< $f$ $str:failure_text$ >>) ]
    |
      [ "perform";
        perform_body = expr LEVEL ";" ->
          convert _loc
            perform_body
            (default_bind_expr _loc)
            (default_failure_expr _loc) ]
    ] ;

    uid:
    [
     [i = LIST1 a_UIDENT SEP "." ->
       let rec uid_to_ident = function
           [a]-> <:ident< $uid:a$ >>
         | a :: b -> <:ident< $uid:a$.$uid_to_ident b$ >>
         | [] -> assert false
       in
         uid_to_ident i]
    ];

    opt_failure_expr:
    [
      [ "and"; fail_fun = expr -> fail_fun ]
    ] ;

    recursive_monadic_binding:
    [
      [ e1 = expr LEVEL "simple"; "<--"; e2 = expr LEVEL "top" ->
         <:binding< $exp_to_patt _loc e1$ = $e2$ >>
      ]
    ] ;

    expr: BEFORE "apply"
    [ NONA
      [ "rec"; binding_list = LIST1 recursive_monadic_binding SEP "and" ->
         let bind = Ast.biAnd_of_list binding_list in
           <:expr< let rec $binding:bind$ in $lid:"<--"$ >> ]
    |
      [ e1 = SELF; "<--"; e2 = expr LEVEL "top" ->
        let p1 = exp_to_patt _loc e1 in
          <:expr< let $p1$ =  $exp:e2$ in $lid:"<--"$ >> ]
    |
      [ "\\"; e = expr LEVEL "top" ->
          <:expr< let () = $exp:e$ in $lid:";"$ >> ]
    ] ;

    (* The difference between the expression and patterns is just [_].
     * So, we make [_] identifier. *)
    expr: LEVEL "simple"
    [
      [ "_" -> <:expr< $lid:"_"$ >> ]
    ] ;

END;