@greenlabs/ppx-spice 0.1.8 → 0.1.9-rc1

package/src/ppx/polyvariants.ml

@@ -1,288 +0,0 @@
-open Parsetree
-open Ast_helper
-open Utils
-
-(* Polyvariants arguments are wrapped inside a Tuple, meaning that if there's only
-   one arg it's the coreType, but if there's more than one arg it's a tuple of one tuple with those args.
-   This function abstract this particuliarity from polyvariants (It's different from Variants). *)
-
-type parsed_field = {
-  name : string;
-  alias : expression;
-  has_attr_as : bool;
-  row_field : Parsetree.row_field;
-}
-
-let get_args_from_polyvars ~loc coreTypes =
-  match coreTypes with
-  | [] -> []
-  | [ coreType ] -> (
-      match coreType.ptyp_desc with
-      (* If it's a tuple, return the args *)
-      | Ptyp_tuple coreTypes -> coreTypes
-      (* If it's any other coreType, return it *)
-      | _ -> [ coreType ])
-  | _ ->
-      fail loc
-        "This error shoudn't happen, means that the AST of your polyvariant is \
-         wrong"
-
-let generate_encoder_case generator_settings unboxed has_attr_as row =
-  let { name; alias; row_field = { prf_desc } } = row in
-  match prf_desc with
-  | Rtag (_, _attributes, core_types) ->
-      let alias_name, _, delimit = get_string_from_expression alias in
-      let constructor_expr =
-        Exp.constant (Pconst_string (alias_name, Location.none, delimit))
-      in
-      let args = get_args_from_polyvars ~loc core_types in
-
-      let lhs_vars =
-        match args with
-        | [] -> None
-        | [ _ ] -> Some (Pat.var (mknoloc "v0"))
-        | _ ->
-            args
-            |> List.mapi (fun i _ ->
-                   mkloc ("v" ^ string_of_int i) loc |> Pat.var)
-            |> Pat.tuple
-            |> fun v -> Some v
-      in
-
-      let rhs_list =
-        args
-        |> List.map (Codecs.generate_codecs generator_settings)
-        |> List.map (fun (encoder, _) -> Option.get encoder)
-        |> List.mapi (fun i e ->
-               Exp.apply ~loc e
-                 [ (Asttypes.Nolabel, make_ident_expr ("v" ^ string_of_int i)) ])
-        |> List.append [ [%expr Js.Json.string [%e constructor_expr]] ]
-      in
-
-      {
-        pc_lhs = Pat.variant name lhs_vars;
-        pc_guard = None;
-        pc_rhs =
-          (if unboxed then List.tl rhs_list |> List.hd (* diff *)
-          else if has_attr_as then [%expr Js.Json.string [%e constructor_expr]]
-          else [%expr Js.Json.array [%e rhs_list |> Exp.array]]);
-      }
-  (* We don't have enough information to generate a encoder *)
-  | Rinherit arg ->
-      fail arg.ptyp_loc "This syntax is not yet implemented by spice"
-
-let generate_decode_success_case num_args constructor_name =
-  {
-    pc_lhs =
-      Array.init num_args (fun i ->
-          mknoloc ("v" ^ string_of_int i) |> Pat.var |> fun p ->
-          [%pat? Belt.Result.Ok [%p p]])
-      |> Array.to_list
-      |> tuple_or_singleton Pat.tuple;
-    pc_guard = None;
-    pc_rhs =
-      ( Array.init num_args (fun i -> make_ident_expr ("v" ^ string_of_int i))
-      |> Array.to_list
-      |> tuple_or_singleton Exp.tuple
-      |> fun v ->
-        Some v |> Exp.variant constructor_name |> fun e ->
-        [%expr Belt.Result.Ok [%e e]] );
-  }
-
-let generate_arg_decoder generator_settings args constructor_name =
-  let num_args = List.length args in
-  args
-  |> List.mapi (Decode_cases.generate_error_case num_args)
-  |> List.append [ generate_decode_success_case num_args constructor_name ]
-  |> Exp.match_
-       (args
-       |> List.map (Codecs.generate_codecs generator_settings)
-       |> List.mapi (fun i (_, decoder) ->
-              Exp.apply (Option.get decoder)
-                [
-                  ( Asttypes.Nolabel,
-                    (* +1 because index 0 is the constructor *)
-                    let idx =
-                      Pconst_integer (string_of_int (i + 1), None)
-                      |> Exp.constant
-                    in
-                    [%expr Belt.Array.getExn json_arr [%e idx]] );
-                ])
-       |> tuple_or_singleton Exp.tuple)
-
-let generate_decoder_case generator_settings { prf_desc } =
-  match prf_desc with
-  | Rtag ({ txt }, _, core_types) ->
-      let args = get_args_from_polyvars ~loc core_types in
-      let arg_len =
-        Pconst_integer (string_of_int (List.length args + 1), None)
-        |> Exp.constant
-      in
-      let decoded =
-        match args with
-        | [] ->
-            let resultant_exp = Exp.variant txt None in
-            [%expr Belt.Result.Ok [%e resultant_exp]]
-        | _ -> generate_arg_decoder generator_settings args txt
-      in
-
-      {
-        pc_lhs =
-          ( Pconst_string (txt, Location.none, None) |> Pat.constant |> fun v ->
-            Some v |> Pat.construct (lid "Js.Json.JSONString") );
-        pc_guard = None;
-        pc_rhs =
-          [%expr
-            if Js.Array.length tagged != [%e arg_len] then
-              Spice.error
-                "Invalid number of arguments to polyvariant constructor" v
-            else [%e decoded]];
-      }
-  | Rinherit core_type ->
-      fail core_type.ptyp_loc "This syntax is not yet implemented by spice"
-
-let generate_decoder_case_attr generator_settings row =
-  let { alias; row_field = { prf_desc } } = row in
-  match prf_desc with
-  | Rtag ({ txt }, _, core_types) ->
-      let args = get_args_from_polyvars ~loc core_types in
-      let alias_name, loc, delimit = get_string_from_expression alias in
-      let decoded =
-        match args with
-        | [] ->
-            let resultant_exp = Exp.variant txt None in
-            [%expr Belt.Result.Ok [%e resultant_exp]]
-        | _ -> generate_arg_decoder generator_settings args txt
-      in
-
-      let if' =
-        Exp.apply (make_ident_expr "=")
-          [
-            ( Asttypes.Nolabel,
-              Pconst_string (alias_name, Location.none, delimit) |> Exp.constant
-            );
-            (Asttypes.Nolabel, [%expr str]);
-          ]
-      in
-      let then' = [%expr [%e decoded]] in
-
-      (if', then')
-  | Rinherit core_type ->
-      fail core_type.ptyp_loc "This syntax is not yet implemented by spice"
-
-let generate_unboxed_decode generator_settings { prf_desc } =
-  match prf_desc with
-  | Rtag ({ txt; loc }, _, args) -> (
-      match args with
-      | [ a ] -> (
-          let _, d = Codecs.generate_codecs generator_settings a in
-          match d with
-          | Some d ->
-              let constructor = Exp.construct (lid txt) (Some [%expr v]) in
-
-              Some
-                [%expr
-                  fun v ->
-                    Belt.Result.map ([%e d] v) (fun v -> [%e constructor])]
-          | None -> None)
-      | _ -> fail loc "Expected exactly one type argument")
-  | Rinherit coreType ->
-      fail coreType.ptyp_loc "This syntax is not yet implemented by spice"
-
-let parse_decl ({ prf_desc; prf_loc; prf_attributes } as row_field) =
-  let txt =
-    match prf_desc with
-    | Rtag ({ txt }, _, _) -> txt
-    | _ -> failwith "cannot get polymorphic variant constructor"
-  in
-
-  let alias, has_attr_as =
-    match get_attribute_by_name prf_attributes "spice.as" with
-    | Ok (Some attribute) -> (get_expression_from_payload attribute, true)
-    | Ok None -> (Exp.constant (Pconst_string (txt, Location.none, None)), false)
-    | Error s -> (fail prf_loc s, false)
-  in
-
-  { name = txt; alias; has_attr_as; row_field }
-
-let generate_codecs ({ do_encode; do_decode } as generator_settings) row_fields
-    unboxed =
-  let parsed_fields = List.map parse_decl row_fields in
-  let count_has_attr =
-    parsed_fields |> List.filter (fun v -> v.has_attr_as) |> List.length
-  in
-  let has_attr_as =
-    if count_has_attr > 0 then
-      if count_has_attr = List.length parsed_fields then true
-      else failwith "Partial @spice.as usage is not allowed"
-    else false
-  in
-
-  let encoder =
-    some_if_true do_encode
-      (List.map
-         (generate_encoder_case generator_settings unboxed has_attr_as)
-         parsed_fields
-      |> Exp.match_ [%expr v]
-      |> Exp.fun_ Asttypes.Nolabel None [%pat? v])
-  in
-
-  let decoder =
-    match not do_decode with
-    | true -> None
-    | false ->
-        if unboxed then
-          generate_unboxed_decode generator_settings (List.hd row_fields)
-        else if has_attr_as then
-          let rec make_ifthenelse cases =
-            match cases with
-            | [] -> [%expr Spice.error "Not matched" v]
-            | hd :: tl ->
-                let if_, then_ = hd in
-                Exp.ifthenelse if_ then_ (Some (make_ifthenelse tl))
-          in
-
-          let decoder_switch =
-            parsed_fields
-            |> List.map (generate_decoder_case_attr generator_settings)
-            |> make_ifthenelse
-          in
-
-          Some
-            [%expr
-              fun v ->
-                match Js.Json.classify v with
-                | Js.Json.JSONString str -> [%e decoder_switch]
-                | _ -> Spice.error "Not a JSONString" v]
-        else
-          let decoder_default_case =
-            {
-              pc_lhs = [%pat? _];
-              pc_guard = None;
-              pc_rhs =
-                [%expr
-                  Spice.error "Invalid polymorphic constructor"
-                    (Belt.Array.getExn json_arr 0)];
-            }
-          in
-
-          let decoder_switch =
-            row_fields |> List.map (generate_decoder_case generator_settings)
-            |> fun l ->
-            l @ [ decoder_default_case ]
-            |> Exp.match_ [%expr Belt.Array.getExn tagged 0]
-          in
-
-          Some
-            [%expr
-              fun v ->
-                match Js.Json.classify v with
-                | Js.Json.JSONArray [||] ->
-                    Spice.error "Expected polyvariant, found empty array" v
-                | Js.Json.JSONArray json_arr ->
-                    let tagged = Js.Array.map Js.Json.classify json_arr in
-                    [%e decoder_switch]
-                | _ -> Spice.error "Not a polyvariant" v]
-  in
-
-  (encoder, decoder)

package/src/ppx/ppx_spice.ml

@@ -1,19 +0,0 @@
-open Ppxlib
-
-class mapper =
-  object (self)
-    inherit Ast_traverse.map
-
-    method! signature sign =
-      sign |> List.map (Signature.map_signature_item self) |> List.concat
-
-    method! structure strt =
-      strt |> List.map (Structure.map_structure_item self) |> List.concat
-  end
-
-let signature_mapper = (new mapper)#signature
-
-let structure_mapper = (new mapper)#structure;;
-
-Ppxlib.Driver.register_transformation ~preprocess_impl:structure_mapper
-  ~preprocess_intf:signature_mapper "spice"

package/src/ppx/records.ml

@@ -1,163 +0,0 @@
-open Ppxlib
-open Parsetree
-open Ast_helper
-open Utils
-
-type parsed_decl = {
-  name : string;
-  (* "NAME" *)
-  key : expression;
-  (* v.NAME *)
-  field : expression;
-  codecs : expression option * expression option;
-  default : expression option;
-  is_optional : bool;
-}
-
-let optional_attr : Ppxlib.Parsetree.attribute =
-  {
-    attr_name = { txt = "ns.optional"; loc = Location.none };
-    attr_payload = PStr [];
-    attr_loc = Location.none;
-  }
-
-let generate_encoder decls unboxed =
-  match unboxed with
-  | true ->
-      let { codecs; field } = List.hd decls in
-      let e, _ = codecs in
-      [%expr fun v -> [%e Option.get e] [%e field]]
-  | false ->
-      let arrExpr =
-        decls
-        |> List.map (fun { key; field; codecs = encoder, _; is_optional } ->
-               let is_optional =
-                 if is_optional then [%expr true] else [%expr false]
-               in
-               [%expr
-                 [%e key], [%e is_optional], [%e Option.get encoder] [%e field]])
-        |> Exp.array
-      in
-      [%expr
-        [%e arrExpr] |> Spice.filterOptional |> Js.Dict.fromArray
-        |> Js.Json.object_]
-      |> Exp.fun_ Asttypes.Nolabel None [%pat? v]
-
-let generate_dict_get { key; codecs = _, decoder; default } =
-  let decoder = Option.get decoder in
-  match default with
-  | Some default ->
-      [%expr
-        Belt.Option.getWithDefault
-          (Belt.Option.map (Js.Dict.get dict [%e key]) [%e decoder])
-          (Belt.Result.Ok [%e default])]
-  | None ->
-      [%expr
-        Belt.Option.getWithDefault (Js.Dict.get dict [%e key]) Js.Json.null
-        |> [%e decoder]]
-
-let generate_dict_gets decls =
-  decls |> List.map generate_dict_get |> tuple_or_singleton Exp.tuple
-
-let generate_error_case { key } =
-  {
-    pc_lhs = [%pat? Belt.Result.Error (e : Spice.decodeError)];
-    pc_guard = None;
-    pc_rhs = [%expr Belt.Result.Error { e with path = "." ^ [%e key] ^ e.path }];
-  }
-
-let generate_final_record_expr decls =
-  decls
-  |> List.map (fun { name; is_optional } ->
-         let attrs = if is_optional then [ optional_attr ] else [] in
-         (lid name, make_ident_expr ~attrs name))
-  |> fun l -> [%expr Belt.Result.Ok [%e Exp.record l None]]
-
-let generate_success_case { name } success_expr =
-  {
-    pc_lhs = (mknoloc name |> Pat.var |> fun p -> [%pat? Belt.Result.Ok [%p p]]);
-    pc_guard = None;
-    pc_rhs = success_expr;
-  }
-
-let rec generate_nested_switches_recurse all_decls remaining_decls =
-  let current, success_expr =
-    match remaining_decls with
-    | [] -> failwith "Spice internal error: [] not expected"
-    | [ last ] -> (last, generate_final_record_expr all_decls)
-    | first :: tail -> (first, generate_nested_switches_recurse all_decls tail)
-  in
-  [ generate_error_case current ]
-  |> List.append [ generate_success_case current success_expr ]
-  |> Exp.match_ (generate_dict_get current)
-  [@@ocaml.doc
-    " Recursively generates an expression containing nested switches, first\n\
-    \ *  decoding the first record items, then (if successful) the second, \
-     etc. "]
-
-let generate_nested_switches decls =
-  generate_nested_switches_recurse decls decls
-
-let generate_decoder decls unboxed =
-  match unboxed with
-  | true ->
-      let { codecs; name } = List.hd decls in
-      let _, d = codecs in
-
-      let record_expr = Exp.record [ (lid name, make_ident_expr "v") ] None in
-
-      [%expr
-        fun v ->
-          Belt.Result.map ([%e Option.get d] v) (fun v -> [%e record_expr])]
-  | false ->
-      [%expr
-        fun v ->
-          match Js.Json.classify v with
-          | Js.Json.JSONObject dict -> [%e generate_nested_switches decls]
-          | _ -> Spice.error "Not an object" v]
-
-let parse_decl generator_settings
-    { pld_name = { txt }; pld_loc; pld_type; pld_attributes } =
-  let default =
-    match get_attribute_by_name pld_attributes "spice.default" with
-    | Ok (Some attribute) -> Some (get_expression_from_payload attribute)
-    | Ok None -> None
-    | Error s -> fail pld_loc s
-  in
-  let key =
-    match get_attribute_by_name pld_attributes "spice.key" with
-    | Ok (Some attribute) -> get_expression_from_payload attribute
-    | Ok None -> Exp.constant (Pconst_string (txt, Location.none, None))
-    | Error s -> fail pld_loc s
-  in
-  let optional_attrs = [ "ns.optional"; "res.optional" ] in
-  let is_optional =
-    optional_attrs
-    |> List.map (fun attr -> get_attribute_by_name pld_attributes attr)
-    |> List.exists (function Ok (Some _) -> true | _ -> false)
-  in
-  let codecs = Codecs.generate_codecs generator_settings pld_type in
-  let codecs =
-    if is_optional then
-      match codecs with
-      | Some encode, Some decode ->
-          ( Some [%expr Spice.optionToJson [%e encode]],
-            Some [%expr Spice.optionFromJson [%e decode]] )
-      | _ -> codecs
-    else codecs
-  in
-
-  {
-    name = txt;
-    key;
-    field = Exp.field [%expr v] (lid txt);
-    codecs;
-    default;
-    is_optional;
-  }
-
-let generate_codecs ({ do_encode; do_decode } as generator_settings) decls
-    unboxed =
-  let parsed_decls = List.map (parse_decl generator_settings) decls in
-  ( some_if_true do_encode (generate_encoder parsed_decls unboxed),
-    some_if_true do_decode (generate_decoder parsed_decls unboxed) )

package/src/ppx/signature.ml

@@ -1,86 +0,0 @@
-open Ppxlib
-open Parsetree
-open Utils
-
-let rec add_encoder_params param_names result_type =
-  match param_names with
-  | [] -> result_type
-  | hd :: tl ->
-      [%type: ([%t Ast_helper.Typ.var hd] -> Js.Json.t) -> [%t result_type]]
-      |> add_encoder_params tl
-
-let make_result_type value_type =
-  [%type: ([%t value_type], Spice.decodeError) Belt.Result.t]
-
-let rec add_decoder_params param_names result_type =
-  match param_names with
-  | [] -> result_type
-  | hd :: tl ->
-      let decoder_param =
-        [%type: Js.Json.t -> [%t make_result_type (Ast_helper.Typ.var hd)]]
-      in
-      [%type: [%t decoder_param] -> [%t result_type]] |> add_decoder_params tl
-
-let generate_sig_decls { do_encode; do_decode } type_name param_names =
-  let encoder_pat = type_name ^ Utils.encoder_func_suffix in
-  let decoder_pat = type_name ^ Utils.decoder_func_suffix in
-  let value_type =
-    param_names
-    |> List.map Ast_helper.Typ.var
-    |> Ast_helper.Typ.constr (lid type_name)
-  in
-
-  let decls = [] in
-
-  let decls =
-    match do_encode with
-    | true ->
-        decls
-        @ [
-            [%type: [%t value_type] -> Js.Json.t]
-            |> add_encoder_params (List.rev param_names)
-            |> Ast_helper.Val.mk (mknoloc encoder_pat)
-            |> Ast_helper.Sig.value;
-          ]
-    | false -> decls
-  in
-  let decls =
-    match do_decode with
-    | true ->
-        decls
-        @ [
-            [%type: Js.Json.t -> [%t make_result_type value_type]]
-            |> add_decoder_params (List.rev param_names)
-            |> Ast_helper.Val.mk (mknoloc decoder_pat)
-            |> Ast_helper.Sig.value;
-          ]
-    | false -> decls
-  in
-
-  decls
-
-let map_type_decl decl =
-  let {
-    ptype_attributes;
-    ptype_name = { txt = type_name };
-    ptype_params;
-    ptype_loc;
-  } =
-    decl
-  in
-
-  match get_generator_settings_from_attributes ptype_attributes with
-  | Error s -> fail ptype_loc s
-  | Ok None -> []
-  | Ok (Some generator_settings) ->
-      generate_sig_decls generator_settings type_name
-        (get_param_names ptype_params)
-
-let map_signature_item mapper ({ psig_desc } as signature_item) =
-  match psig_desc with
-  | Psig_type (_, decls) ->
-      let generated_sig_items =
-        decls |> List.map map_type_decl |> List.concat
-      in
-      mapper#signature_item signature_item :: generated_sig_items
-  | _ -> [ mapper#signature_item signature_item ]

package/src/ppx/structure.ml

@@ -1,109 +0,0 @@
-open Ppxlib
-open Parsetree
-open Ast_helper
-open Codecs
-open Utils
-
-let add_params param_names expr =
-  List.fold_right
-    (fun s acc ->
-      let pat = Pat.var (mknoloc s) in
-      Exp.fun_ Asttypes.Nolabel None pat acc)
-    param_names
-    [%expr fun v -> [%e expr] v]
-
-let generate_codec_decls type_name param_names (encoder, decoder) =
-  let encoder_pat = Pat.var (mknoloc (type_name ^ Utils.encoder_func_suffix)) in
-  let encoder_param_names =
-    List.map (fun s -> encoder_var_prefix ^ s) param_names
-  in
-
-  let decoder_pat = Pat.var (mknoloc (type_name ^ Utils.decoder_func_suffix)) in
-  let decoder_param_names =
-    List.map (fun s -> decoder_var_prefix ^ s) param_names
-  in
-
-  let vbs = [] in
-
-  let vbs =
-    match encoder with
-    | None -> vbs
-    | Some encoder ->
-        vbs
-        @ [
-            Vb.mk
-              ~attrs:[ attr_warning [%expr "-39"] ]
-              encoder_pat
-              (add_params encoder_param_names encoder);
-          ]
-  in
-
-  let vbs =
-    match decoder with
-    | None -> vbs
-    | Some decoder ->
-        vbs
-        @ [
-            Vb.mk
-              ~attrs:[ attr_warning [%expr "-4"]; attr_warning [%expr "-39"] ]
-              decoder_pat
-              (add_params decoder_param_names decoder);
-          ]
-  in
-
-  vbs
-
-let map_type_decl decl =
-  let {
-    ptype_attributes;
-    ptype_name = { txt = type_name };
-    ptype_manifest;
-    ptype_params;
-    ptype_loc;
-    ptype_kind;
-  } =
-    decl
-  in
-
-  let is_unboxed =
-    match Utils.get_attribute_by_name ptype_attributes "unboxed" with
-    | Ok (Some _) -> true
-    | _ -> false
-  in
-
-  match get_generator_settings_from_attributes ptype_attributes with
-  | Ok None -> []
-  | Ok (Some generator_settings) -> (
-      match (ptype_manifest, ptype_kind) with
-      | None, Ptype_abstract ->
-          fail ptype_loc "Can't generate codecs for unspecified type"
-      | Some { ptyp_desc = Ptyp_variant (row_fields, _, _) }, Ptype_abstract ->
-          generate_codec_decls type_name
-            (get_param_names ptype_params)
-            (Polyvariants.generate_codecs generator_settings row_fields
-               is_unboxed)
-      | Some manifest, _ ->
-          generate_codec_decls type_name
-            (get_param_names ptype_params)
-            (generate_codecs generator_settings manifest)
-      | None, Ptype_variant decls ->
-          generate_codec_decls type_name
-            (get_param_names ptype_params)
-            (Variants.generate_codecs generator_settings decls is_unboxed)
-      | None, Ptype_record decls ->
-          generate_codec_decls type_name
-            (get_param_names ptype_params)
-            (Records.generate_codecs generator_settings decls is_unboxed)
-      | _ -> fail ptype_loc "This type is not handled by spice")
-  | Error s -> fail ptype_loc s
-
-let map_structure_item mapper ({ pstr_desc } as structure_item) =
-  match pstr_desc with
-  | Pstr_type (rec_flag, decls) -> (
-      let value_bindings = decls |> List.map map_type_decl |> List.concat in
-      [ mapper#structure_item structure_item ]
-      @
-      match List.length value_bindings > 0 with
-      | true -> [ Str.value rec_flag value_bindings ]
-      | false -> [])
-  | _ -> [ mapper#structure_item structure_item ]