unikernel/duniverse/ppx_sexp_conv/expander/lifted.ml

@@ -0,0 +1,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 (
+      (* Thunkify the value to evaluate when referred to. *)
+      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
+;;