unikernel/duniverse/ppx_sexp_conv/expander/conversion.ml

@@ -0,0 +1,184 @@
+open! Base
+open! Ppxlib
+open Ast_builder.Default
+open Helpers
+
+module Reference = struct
+  type t =
+    { types : type_declaration list
+    ; binds : value_binding list list
+    ; ident : longident_loc
+    ; args : (arg_label * expression) list
+    }
+
+  let bind t binds = { t with binds = binds :: t.binds }
+  let bind_types t types = { t with types = types @ t.types }
+
+  let maybe_apply { types; binds; ident; args } ~loc maybe_arg =
+    let ident = pexp_ident ~loc ident in
+    let args =
+      match maybe_arg with
+      | None -> args
+      | Some arg -> args @ [ Nolabel, arg ]
+    in
+    let expr =
+      match args with
+      | [] -> ident
+      | _ -> pexp_apply ~loc ident args
+    in
+    with_types ~loc ~types (with_let ~loc ~binds expr)
+  ;;
+
+  let apply t ~loc arg = maybe_apply t ~loc (Some arg)
+  let to_expression t ~loc = maybe_apply t ~loc None
+
+  let to_value_expression t ~loc ~rec_flag ~values_being_defined =
+    let may_refer_directly_to ident =
+      match rec_flag with
+      | Nonrecursive -> true
+      | Recursive -> not (Set.mem values_being_defined (Longident.name ident.txt))
+    in
+    match t with
+    | { types = []; binds = []; ident; args = [] } when may_refer_directly_to ident ->
+      pexp_ident ~loc ident
+    | _ -> fresh_lambda ~loc (fun ~arg -> apply t ~loc arg)
+  ;;
+end
+
+module Lambda = struct
+  type t =
+    { types : type_declaration list
+    ; binds : value_binding list list
+    ; cases : cases
+    }
+
+  let bind t binds = { t with binds = binds :: t.binds }
+  let bind_types t types = { t with types = types @ t.types }
+
+  (* generic case: use [function] or [match] *)
+  let maybe_apply_generic ~loc ~types ~binds maybe_arg cases =
+    let expr =
+      match maybe_arg with
+      | None -> pexp_function_cases ~loc cases
+      | Some arg -> pexp_match ~loc arg cases
+    in
+    with_types ~loc ~types (with_let ~loc ~binds expr)
+  ;;
+
+  (* zero cases: synthesize an "impossible" case, i.e. [| _ -> .] *)
+  let maybe_apply_impossible ~loc ~types ~binds maybe_arg =
+    [ case ~lhs:(ppat_any ~loc) ~guard:None ~rhs:(pexp_unreachable ~loc) ]
+    |> maybe_apply_generic ~loc ~binds ~types maybe_arg
+  ;;
+
+  (* one case without guard: use [fun] or [let] *)
+  let maybe_apply_simple ~loc ~types ~binds maybe_arg pat body =
+    let expr =
+      match maybe_arg with
+      | None -> pexp_fun ~loc Nolabel None pat body
+      | Some arg -> pexp_let ~loc Nonrecursive [ value_binding ~loc ~pat ~expr:arg ] body
+    in
+    with_types ~loc ~types (with_let ~loc ~binds expr)
+  ;;
+
+  (* shared special-casing logic for [apply] and [to_expression] *)
+  let maybe_apply t ~loc maybe_arg =
+    match t with
+    | { types; binds; cases = [] } -> maybe_apply_impossible ~loc ~types ~binds maybe_arg
+    | { types; binds; cases = [ { pc_lhs; pc_guard = None; pc_rhs } ] } ->
+      maybe_apply_simple ~loc ~types ~binds maybe_arg pc_lhs pc_rhs
+    | { types; binds; cases } -> maybe_apply_generic ~loc ~types ~binds maybe_arg cases
+  ;;
+
+  let apply t ~loc arg = maybe_apply t ~loc (Some arg)
+  let to_expression t ~loc = maybe_apply t ~loc None
+
+  let to_value_expression t ~loc =
+    match t with
+    | { types = []; binds = []; cases = _ } ->
+      (* lambdas without [let] are already values *)
+      let expr = to_expression t ~loc in
+      assert (is_value_expression expr);
+      expr
+    | _ -> fresh_lambda ~loc (fun ~arg -> apply t ~loc arg)
+  ;;
+end
+
+type t =
+  | Reference of Reference.t
+  | Lambda of Lambda.t
+
+let of_lambda cases = Lambda { types = []; binds = []; cases }
+
+let of_reference_exn expr =
+  match expr.pexp_desc with
+  | Pexp_ident ident -> Reference { types = []; binds = []; ident; args = [] }
+  | Pexp_apply ({ pexp_desc = Pexp_ident ident; _ }, args) ->
+    Reference { types = []; binds = []; ident; args }
+  | _ ->
+    Location.raise_errorf
+      ~loc:expr.pexp_loc
+      "ppx_sexp_conv: internal error.\n\
+       [Conversion.of_reference_exn] expected an identifier possibly applied to arguments.\n\
+       Instead, got:\n\
+       %s"
+      (Pprintast.string_of_expression expr)
+;;
+
+let to_expression t ~loc =
+  match t with
+  | Reference reference -> Reference.to_expression ~loc reference
+  | Lambda lambda -> Lambda.to_expression ~loc lambda
+;;
+
+let to_value_expression t ~loc ~rec_flag ~values_being_defined =
+  match t with
+  | Reference reference ->
+    Reference.to_value_expression ~loc ~rec_flag ~values_being_defined reference
+  | Lambda lambda -> Lambda.to_value_expression ~loc lambda
+;;
+
+let apply t ~loc e =
+  match t with
+  | Reference reference -> Reference.apply ~loc reference e
+  | Lambda lambda -> Lambda.apply ~loc lambda e
+;;
+
+let bind t binds =
+  match t with
+  | Reference reference -> Reference (Reference.bind reference binds)
+  | Lambda lambda -> Lambda (Lambda.bind lambda binds)
+;;
+
+let bind_types t types =
+  match t with
+  | Reference reference -> Reference (Reference.bind_types reference types)
+  | Lambda lambda -> Lambda (Lambda.bind_types lambda types)
+;;
+
+module Apply_all = struct
+  type t =
+    { bindings : value_binding list
+    ; arguments : pattern list
+    ; converted : expression list
+    }
+end
+
+let gen_symbols list ~prefix =
+  List.mapi list ~f:(fun i _ -> gen_symbol ~prefix:(prefix ^ Int.to_string i) ())
+;;
+
+let apply_all ts ~loc =
+  let arguments_names = gen_symbols ts ~prefix:"arg" in
+  let converted_names = gen_symbols ts ~prefix:"res" in
+  let bindings =
+    List.map3_exn ts arguments_names converted_names ~f:(fun t arg conv ->
+      let expr = apply ~loc t (evar ~loc arg) in
+      value_binding ~loc ~pat:(pvar ~loc conv) ~expr)
+  in
+  ({ bindings
+   ; arguments = List.map arguments_names ~f:(pvar ~loc)
+   ; converted = List.map converted_names ~f:(evar ~loc)
+   }
+    : Apply_all.t)
+;;