1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
open! Base
open Ppxlib
open Ast_builder.Default
type 'a t =
{ value_bindings : value_binding list
; body : 'a
}
include Monad.Make (struct
type nonrec 'a t = 'a t
let return body = { value_bindings = []; body }
let bind a ~f =
let b = f a.body in
{ value_bindings = a.value_bindings @ b.value_bindings; body = b.body }
;;
let map = `Define_using_bind
end)
let create ~loc ~prefix ~ty rhs =
let name = gen_symbol ~prefix () in
let lhs = pvar ~loc name in
let body = evar ~loc name in
let ty, rhs, body =
if Helpers.is_value_expression rhs
then ty, rhs, body
else (
let ty = [%type: Stdlib.Unit.t -> [%t ty]] in
let rhs = [%expr fun () -> [%e rhs]] in
let body = [%expr [%e body] ()] in
ty, rhs, body)
in
{ value_bindings = [ value_binding ~loc ~pat:(ppat_constraint ~loc lhs ty) ~expr:rhs ]
; body
}
;;
let let_bind_user_expressions { value_bindings; body } ~loc =
if List.is_empty value_bindings
then body
else pexp_let ~loc Nonrecursive value_bindings body
;;