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:"<--"$ >> ->
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$ } >> ->
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
<: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$ ]) >>
| <: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 ()$) >>
|
<: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$ >>
| _ -> <:expr< $a_bind_function$ $b1$ (fun _ -> $do_rest ()$) >>
end
| any_body -> any_body
in loop _loc a_perform_body