diff --git a/ppx_import.opam b/ppx_import.opam index ba3cfb2..3e31a96 100644 --- a/ppx_import.opam +++ b/ppx_import.opam @@ -14,7 +14,7 @@ tags: [ "syntax" ] depends: [ "ocaml" { >= "4.04.2" } "dune" { >= "1.2.0" } - "ppxlib" { >= "0.15.0" } + "ppxlib" { >= "0.21.0" } "ounit" { with-test } "ppx_deriving" { with-test & >= "4.2.1" } ] diff --git a/src/ppx_import.ml b/src/ppx_import.ml index 5c5567a..b64e77b 100644 --- a/src/ppx_import.ml +++ b/src/ppx_import.ml @@ -1,4 +1,5 @@ module Ot = Outcometree +module Tt = Ppx_types_migrate let lazy_env = lazy @@ -171,16 +172,15 @@ let get_modtype_decl ~loc sig_items parent_lid elem = let longident_of_path = Untypeast.lident_of_path let rec core_type_of_type_expr ~subst (type_expr : Ocaml_common.Types.type_expr) - = - let open Ppxlib in - let open Ppxlib.Ast_helper in + : Ppxlib.core_type = match type_expr.desc with - | Tvar None -> Typ.any () + | Tvar None -> Ppxlib.Ast_helper.Typ.any () | Tvar (Some var) -> ( match List.assoc (`Var var) subst with | typ -> typ - | exception Not_found -> Typ.var var) + | exception Not_found -> Ppxlib.Ast_helper.Typ.var var) | Tarrow (label, lhs, rhs, _) -> + let label = Tt.copy_arg_label label in let lhs = core_type_of_type_expr ~subst lhs in let lhs = match label with @@ -190,8 +190,9 @@ let rec core_type_of_type_expr ~subst (type_expr : Ocaml_common.Types.type_expr) | _ -> assert false) | _ -> lhs in - Typ.arrow label lhs (core_type_of_type_expr ~subst rhs) - | Ttuple xs -> Typ.tuple (List.map (core_type_of_type_expr ~subst) xs) + Ppxlib.Ast_helper.Typ.arrow label lhs (core_type_of_type_expr ~subst rhs) + | Ttuple xs -> + Ppxlib.Ast_helper.Typ.tuple (List.map (core_type_of_type_expr ~subst) xs) | Tconstr (path, args, _) -> ( let lid = longident_of_path path in let args = List.map (core_type_of_type_expr ~subst) args in @@ -200,30 +201,40 @@ let rec core_type_of_type_expr ~subst (type_expr : Ocaml_common.Types.type_expr) { typ with ptyp_desc = Ptyp_constr (lid, args) } | _ -> assert false | exception Not_found -> - Typ.constr { txt = longident_of_path path; loc = !default_loc } args) + Ppxlib.Ast_helper.Typ.constr + { + txt = longident_of_path path; + loc = !Ppxlib.Ast_helper.default_loc; + } + args) | Tvariant { row_fields; _ } -> let fields = row_fields |> List.map (fun (label, row_field) -> - let open Ocaml_common in - let label = Location.mknoloc label in + let label = Ocaml_common.Location.mknoloc label in let desc = match row_field with - | Types.Rpresent None -> Rtag (label, true, []) + | Types.Rpresent None -> Ppxlib.Rtag (label, true, []) | Types.Rpresent (Some ttyp) -> - Rtag (label, false, [ core_type_of_type_expr ~subst ttyp ]) + Ppxlib.Rtag + (label, false, [ core_type_of_type_expr ~subst ttyp ]) | _ -> assert false in - { prf_desc = desc; prf_loc = !default_loc; prf_attributes = [] }) + Ppxlib. + { + prf_desc = desc; + prf_loc = !Ppxlib.Ast_helper.default_loc; + prf_attributes = []; + }) in - Typ.variant fields Closed None + Ppxlib.Ast_helper.Typ.variant fields Closed None | _ -> assert false let ptype_decl_of_ttype_decl ~manifest ~subst ptype_name (ttype_decl : Ocaml_common.Types.type_declaration) : Ppxlib.type_declaration = - let open Ppxlib in let subst = + let open Ppxlib in match manifest with | Some { ptyp_desc = Ptyp_constr (_, ptype_args); ptyp_loc; _ } -> ( subst @@ -257,53 +268,62 @@ let ptype_decl_of_ttype_decl ~manifest ~subst ptype_name and ptype_kind = let map_labels = List.map (fun (ld : Ocaml_common.Types.label_declaration) -> - { - pld_name = - { txt = Ocaml_common.Ident.name ld.ld_id; loc = ld.ld_loc }; - pld_mutable = ld.ld_mutable; - pld_type = core_type_of_type_expr ~subst ld.ld_type; - pld_loc = ld.ld_loc; - pld_attributes = ld.ld_attributes; - }) + Ppxlib. + { + pld_name = + { txt = Ocaml_common.Ident.name ld.ld_id; loc = ld.ld_loc }; + pld_mutable = Tt.copy_mutable_flag ld.ld_mutable; + pld_type = core_type_of_type_expr ~subst ld.ld_type; + pld_loc = ld.ld_loc; + pld_attributes = Tt.copy_attributes ld.ld_attributes; + }) in - match ttype_decl.type_kind with - | Type_abstract -> Ptype_abstract - | Type_open -> Ptype_open - | Type_record (labels, _) -> Ptype_record (map_labels labels) - | Type_variant constrs -> - let map_args (constrs : Ocaml_common.Types.constructor_arguments) = - match constrs with - | Cstr_tuple args -> - Pcstr_tuple (List.map (core_type_of_type_expr ~subst) args) - | Cstr_record labels -> Pcstr_record (map_labels labels) - in - Ptype_variant - (constrs - |> List.map (fun (cd : Ocaml_common.Types.constructor_declaration) -> - { - pcd_name = - { txt = Ocaml_common.Ident.name cd.cd_id; loc = cd.cd_loc }; - pcd_args = map_args cd.cd_args; - pcd_res = - (match cd.cd_res with + Ppxlib.( + match ttype_decl.type_kind with + | Type_abstract -> Ptype_abstract + | Type_open -> Ptype_open + | Type_record (labels, _) -> Ptype_record (map_labels labels) + | Type_variant constrs -> + let map_args (constrs : Ocaml_common.Types.constructor_arguments) = + match constrs with + | Cstr_tuple args -> + Pcstr_tuple (List.map (core_type_of_type_expr ~subst) args) + | Cstr_record labels -> Pcstr_record (map_labels labels) + in + Ptype_variant + (constrs + |> List.map + (fun (cd : Ocaml_common.Types.constructor_declaration) -> + let pcd_res = + match cd.cd_res with | Some x -> Some (core_type_of_type_expr ~subst x) - | None -> None); - pcd_loc = cd.cd_loc; - pcd_attributes = cd.cd_attributes; - })) + | None -> None + in + { + pcd_name = + { + txt = Ocaml_common.Ident.name cd.cd_id; + loc = cd.cd_loc; + }; + pcd_args = map_args cd.cd_args; + pcd_res; + pcd_loc = cd.cd_loc; + pcd_attributes = Tt.copy_attributes cd.cd_attributes; + }))) and ptype_manifest = match ttype_decl.type_manifest with | Some typ -> Some (core_type_of_type_expr ~subst typ) | None -> manifest in + { ptype_name; ptype_params; ptype_kind; ptype_manifest; ptype_cstrs = []; - ptype_private = ttype_decl.type_private; - ptype_attributes = ttype_decl.type_attributes; + ptype_private = Tt.copy_private_flag ttype_decl.type_private; + ptype_attributes = Tt.copy_attributes ttype_decl.type_attributes; ptype_loc = ttype_decl.type_loc; } @@ -445,7 +465,8 @@ let rec cut_tsig_block_of_rec_types accu (tsig : Compat.signature_item_407 list) cut_tsig_block_of_rec_types ((id, ttype_decl) :: accu) rest | _ -> (List.rev accu, tsig) -let rec psig_of_tsig ~subst (tsig : Compat.signature_item_407 list) = +let rec psig_of_tsig ~subst (tsig : Compat.signature_item_407 list) : + Ppxlib.signature_item list = let open Ppxlib in match tsig with | Sig_type (id, ttype_decl, rec_flag) :: rest -> @@ -491,7 +512,7 @@ let rec psig_of_tsig ~subst (tsig : Compat.signature_item_407 list) = pval_name = Ocaml_common.Location.mknoloc (Ocaml_common.Ident.name id); pval_loc = val_loc; - pval_attributes = val_attributes; + pval_attributes = Tt.copy_attributes val_attributes; pval_prim; pval_type = core_type_of_type_expr ~subst val_type; }; diff --git a/src/ppx_types_migrate.ml b/src/ppx_types_migrate.ml new file mode 100644 index 0000000..6c9cc25 --- /dev/null +++ b/src/ppx_types_migrate.ml @@ -0,0 +1,23 @@ +module At = Asttypes +module Conv = Ppxlib_ast.Select_ast (Ppxlib_ast.Compiler_version) +module To_ppxlib = Conv.Of_ocaml + +(* copy_mutable_flag / private_flag / arg_label are not exported by + OMP so not worth the pain of the hack *) +let copy_mutable_flag (l : At.mutable_flag) : Ppxlib.mutable_flag = + match l with At.Immutable -> Ppxlib.Immutable | At.Mutable -> Ppxlib.Mutable + +let copy_private_flag (l : At.private_flag) : Ppxlib.private_flag = + match l with At.Private -> Ppxlib.Private | At.Public -> Ppxlib.Public + +let copy_arg_label (l : At.arg_label) : Ppxlib.arg_label = + match l with + | At.Nolabel -> Ppxlib.Nolabel + | At.Labelled l -> Ppxlib.Labelled l + | At.Optional x -> Ppxlib.Optional x + +(* Here we want to do a hack due to the large type *) +let copy_attributes (attrs : Parsetree.attributes) = + let td = Ast_helper.Typ.any ~attrs () in + let tb = To_ppxlib.copy_core_type td in + tb.ptyp_attributes