Skip to content

Commit

Permalink
try to fix build for ocaml < 4.12
Browse files Browse the repository at this point in the history
  • Loading branch information
@tatchi
tatchi committed May 17, 2021
1 parent 233d9d0 commit 8d13b18
Show file tree
Hide file tree
Showing 3 changed files with 96 additions and 52 deletions.
2 changes: 1 addition & 1 deletion ppx_import.opam
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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" }
]
Expand Down
123 changes: 72 additions & 51 deletions src/ppx_import.ml
View file
Original file line number Diff line number Diff line change
@@ -1,4 +1,5 @@
module Ot = Outcometree
module Tt = Ppx_types_migrate

let lazy_env =
lazy
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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;
}

Expand Down Expand Up @@ -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 ->
Expand Down Expand Up @@ -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;
};
Expand Down
23 changes: 23 additions & 0 deletions src/ppx_types_migrate.ml
View file
Original file line number Diff line number Diff line change
@@ -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

0 comments on commit 8d13b18

Please sign in to comment.