From 90a6e7d29d69a9714d7b26514877bcc5e324d1e3 Mon Sep 17 00:00:00 2001 From: Kakadu Date: Sun, 16 Nov 2025 13:54:49 +0300 Subject: [PATCH 1/6] Support camlp5 8.04.0 Signed-off-by: Kakadu --- GT.opam | 6 +++--- camlp5/Camlp5Helpers.ml | 20 +++++++++++--------- dune-project | 8 ++++---- 3 files changed, 18 insertions(+), 16 deletions(-) diff --git a/GT.opam b/GT.opam index a1d0b9c0..4ab609db 100644 --- a/GT.opam +++ b/GT.opam @@ -1,6 +1,6 @@ # This file is generated by dune, edit dune-project instead opam-version: "2.0" -version: "0.5.3" +version: "0.5.5" synopsis: "Generic programming with extensible transformations" description: """ Yet another library for generic programming. Provides syntax extensions @@ -22,10 +22,10 @@ license: "LGPL-2.1-or-later" homepage: "https://github.com/PLTools/GT" bug-reports: "https://github.com/PLTools/GT/issues" depends: [ - "ocaml" {>= "4.14" & < "5.0.0" | >= "5.2.0" & < "5.3.0"} + "ocaml" {>= "4.14" & < "5.0.0" | >= "5.2.0" & <= "5.4.0"} "dune" {>= "3.16"} "ppxlib" {<= "0.34.0"} - "camlp5" {>= "8.00.05"} + "camlp5" {>= "8.04.00"} "ocamlgraph" "ppx_inline_test_nobase" "mdx" {build} diff --git a/camlp5/Camlp5Helpers.ml b/camlp5/Camlp5Helpers.ml index 575a69de..f084e5aa 100644 --- a/camlp5/Camlp5Helpers.ml +++ b/camlp5/Camlp5Helpers.ml @@ -39,7 +39,7 @@ let loc_from_caml camlloc = let noloc = Ploc.dummy type type_arg = MLast.type_var -let named_type_arg ~loc s : type_arg = (Ploc.VaVal (Some s), (None, false)) +let named_type_arg ~loc s : type_arg = (Ploc.VaVal (Some s), Ploc.VaVal "") type lab_decl = (loc * string * bool * ctyp) let lab_decl ~loc name is_mut typ = (loc, name, is_mut, typ) @@ -270,7 +270,7 @@ module Typ = struct let ident ~loc s = <:ctyp< $lid:s$ >> let string ~loc = <:ctyp< string >> let unit ~loc = <:ctyp< unit >> - let pair ~loc l r = <:ctyp< ( $list:[l;r]$ ) >> + let access2 ~loc mname tname = assert (HelpersBase.Char.is_uppercase mname.[0]); @@ -282,7 +282,8 @@ module Typ = struct let alias ~loc t s = let p = var ~loc s in <:ctyp< $t$ as $p$ >> - let tuple ~loc lt = <:ctyp< ( $list:lt$ ) >> + let tuple ~loc lt = <:ctyp< ( $list:List.map (fun x -> (VaVal None,x)) lt$ ) >> + let pair ~loc : t -> t -> t = fun l r -> <:ctyp< ( $list:[(VaVal None, l); (VaVal None, r)]$ ) >> let constr ~loc lident = let init = of_longident ~loc lident in function @@ -322,7 +323,7 @@ module Typ = struct | Ptyp_var s -> <:ctyp< '$s$ >> | Ptyp_arrow (lab, l, r) -> arrow ~loc (helper l) (helper r) | Ptyp_constr ({txt;_}, ts) -> constr ~loc txt (List.map helper ts) - | Ptyp_tuple ts -> <:ctyp< ( $list:(List.map helper ts)$ ) >> + | Ptyp_tuple ts -> <:ctyp< ( $list:(List.map (fun x -> (Ploc.VaVal None, helper x)) ts)$ ) >> | Ptyp_variant (cs, flg, None) -> variant ~loc ~is_open:(match flg with Closed -> false | Open -> true) cs | Ptyp_variant (_,_,Some _ ) @@ -436,7 +437,7 @@ module Str = struct <:str_item< class $list:[c]$ >> let tdecl ~loc ~name ~params rhs = - let tdPrm = List.map (fun s -> (VaVal (Some s), (None,false))) params in + let tdPrm = List.map (fun s -> (VaVal (Some s), VaVal "")) params in let t = <:type_decl< $tp:(loc, VaVal name)$ $list:tdPrm$ = $rhs$ >> in <:str_item< type $list:[t]$ >> @@ -454,7 +455,7 @@ module Str = struct fun ~loc ~name ~params_count ts -> let ltv = List.init params_count (fun n -> - (VaVal (Some (Printf.sprintf "dummy%d" n)), (None, false))) in + (VaVal (Some (Printf.sprintf "dummy%d" n)), VaVal "")) in let ls = (loc, VaVal name) in let ltt = [] in let t = @@ -595,7 +596,7 @@ module Sig = struct <:ctyp< [ $list:cs$ ] >> in let tdPrm = List.init params_count (fun n -> - (VaVal (Some (Printf.sprintf "dummy%d" n)), (None,false))) in + (VaVal (Some (Printf.sprintf "dummy%d" n)), VaVal "")) in let td = <:type_decl< $tp:(loc, VaVal name)$ $list:tdPrm$ = $tdDef$ >> in <:sig_item< type $list:[td]$ >> @@ -604,7 +605,7 @@ module Sig = struct let tdecl_abstr: loc:loc -> string -> string option list -> t = fun ~loc name params -> - let tdPrm = List.map (fun s -> (VaVal s, (None,false))) params in + let tdPrm = List.map (fun s -> (VaVal s, VaVal "")) params in let td = <:type_decl< $tp:(loc, VaVal name)$ $list:tdPrm$ = 'abstract >> in <:sig_item< type $list:[td]$ >> @@ -779,7 +780,8 @@ let typ_vars_of_typ t = | <:ctyp< { $list:llsbt$ } >> -> ListLabels.fold_left ~init:acc ~f:(fun acc (_,_,_,t, _) -> helper acc t) llsbt | <:ctyp< [ $list:llslt$ ] >> -> failwith "sum" - | <:ctyp< ( $list:lt$ ) >> -> ListLabels.fold_left ~init:acc ~f:helper lt + | <:ctyp< ( $list:lt$ ) >> -> + ListLabels.fold_left ~init:acc ~f:(fun acc (_,x) -> helper acc x) lt | <:ctyp< [ = $list:lpv$ ] >> -> failwith "polyvariant" | _ -> acc (* This could be wrong *) in diff --git a/dune-project b/dune-project index 5648ccbe..68d154b1 100644 --- a/dune-project +++ b/dune-project @@ -24,7 +24,7 @@ "Yet another library for generic programming. Provides syntax extensions\nboth for camlp5 and PPX which allow decoration of type declarations with\nfollowing compile-time code generation. Provides the way for creating\nplugins (compiled separately from the library) for enchancing supported\ntype transformations.\n\nStrongly reminds the `visitors` library from François Pottier.\nDuring desing of a library of these kind there many possible\ndesign decision and in many cases we decided to implement\nthe decision opposite to the one used in `visitors`.\n\n\nP.S. Since 2023 development team is no longer associated with JetBrains Research") (authors "https://github.com/dboulytchev" "https://github.com/Kakadu") (maintainers "Kakadu@pm.me") - (version 0.5.3) + (version 0.5.5) (depends (ocaml (or @@ -33,12 +33,12 @@ (< "5.0.0")) (and (>= "5.2.0") - (< "5.3.0")))) + (<= "5.4.0")))) dune (ppxlib (<= "0.34.0")) (camlp5 - (>= "8.00.05")) + (>= "8.04.00")) ocamlgraph ppx_inline_test_nobase (mdx :build) @@ -56,10 +56,10 @@ (name GT-bench) (synopsis "Some benchmarks. Should not be installed") (version 0.1) + (allow_empty) (authors "Dmitrii Kosarev a.k.a. Kakadu") (maintainers "Kakadu@pm.me") (depends dune (benchmark (< "1.7")))) - From 146224ee798b53de77765c68efe0e6dc597a00bb Mon Sep 17 00:00:00 2001 From: Kakadu Date: Fri, 31 Jul 2026 20:19:36 +0300 Subject: [PATCH 2/6] WIP on ppxlib 0.38 and ocaml 5.5 Signed-off-by: Kakadu --- GT.opam | 4 +- bench/bench2.ml | 4 +- camlp5/Camlp5Helpers.ml | 17 ++- common/GTHELPERS_sig.ml | 10 +- common/HelpersBase.ml | 37 +++--- common/dune | 5 +- common/expander.ml | 203 +++++++++++++++-------------- common/plugin.ml | 278 +++++++++++++++++++++------------------- dune-project | 4 +- ppx/PpxHelpers.ml | 50 ++++---- regression/dune.tests | 9 ++ 11 files changed, 321 insertions(+), 300 deletions(-) diff --git a/GT.opam b/GT.opam index 4ab609db..b4f79547 100644 --- a/GT.opam +++ b/GT.opam @@ -22,9 +22,9 @@ license: "LGPL-2.1-or-later" homepage: "https://github.com/PLTools/GT" bug-reports: "https://github.com/PLTools/GT/issues" depends: [ - "ocaml" {>= "4.14" & < "5.0.0" | >= "5.2.0" & <= "5.4.0"} + "ocaml" {>= "4.14" & < "5.0.0" | >= "5.2.0" & < "5.6.0"} "dune" {>= "3.16"} - "ppxlib" {<= "0.34.0"} + "ppxlib" {>= "0.38.0"} "camlp5" {>= "8.04.00"} "ocamlgraph" "ppx_inline_test_nobase" diff --git a/bench/bench2.ml b/bench/bench2.ml index af6ee9e3..2612415e 100644 --- a/bench/bench2.ml +++ b/bench/bench2.ml @@ -347,7 +347,7 @@ let repeat = 20 let style = Auto let style = Nil let confidence = 0.95 -let sizes = [ 100; 200; 300; 500; 700; 900; 1000 ] +let sizes = [ 100; 500; 1000 ] let __ () = let module M = Lambda.Iter in @@ -433,7 +433,7 @@ let () = tabulate ~confidence res) ;; -let () = +let __ () = let module M = Lambda.Eval in sizes |> List.iter (fun n -> diff --git a/camlp5/Camlp5Helpers.ml b/camlp5/Camlp5Helpers.ml index f084e5aa..36d2ed13 100644 --- a/camlp5/Camlp5Helpers.ml +++ b/camlp5/Camlp5Helpers.ml @@ -81,13 +81,14 @@ module Pat = struct let sprintf ~loc fmt = Printf.ksprintf (fun s -> <:patt< $lid:s$ >>) fmt let of_longident ~loc lid = + let _ : Ppxlib.longident = lid in let is_lident s = not (capitalized s) in match lid with - | Longident.Lident ("[]" as s) + | Astlib.Longident.Lident ("[]" as s) | Lident ("::" as s) -> <:patt< $uid:s$ >> - | Longident.Lident s when is_lident s -> <:patt< $lid:s$ >> + | Lident s when is_lident s -> <:patt< $lid:s$ >> | Ldot(li, s) when is_lident s -> - let li = Longid.of_longident ~loc li in + let li = Longid.of_longident ~loc li in <:patt< $longid:li$ . $lid:s$ >> | li -> let li = Longid.of_longident ~loc li in @@ -105,7 +106,8 @@ module Pat = struct List.fold_left (fun acc x -> <:patt< $acc$ $x$ >>) c ps let type_ ~loc lident = - <:patt< # $lilongid:Asttools.longident_lident_of_string_list loc (Longident.flatten lident)$ >> + let _ : Ppxlib.longident = lident in + <:patt< # $lilongid:Asttools.longident_lident_of_string_list loc (Astlib.Longident.flatten lident)$ >> let record ~loc fs = <:patt< { $list:List.map (fun (l,r) -> (of_longident ~loc l, r) ) fs$ } >> @@ -216,7 +218,7 @@ module Exp = struct | le -> <:expr< ($list:le$) >> let new_ ~loc lident = - <:expr< new $lilongid: Asttools.longident_lident_of_string_list loc (Longident.flatten lident)$ >> + <:expr< new $lilongid: Asttools.longident_lident_of_string_list loc (Astlib.Longident.flatten lident)$ >> let object_ ~loc (pat, fields) = <:expr< object ($pat$) $list:fields$ end >> let send ~loc left s = <:expr< $left$ # $s$ >> @@ -292,7 +294,8 @@ module Typ = struct List.fold_left (app ~loc) init lt let class_ ~loc lident = - let init = <:ctyp< # $lilongid:Asttools.longident_lident_of_string_list loc (Longident.flatten lident)$ >> in + + let init = <:ctyp< # $lilongid:Asttools.longident_lident_of_string_list loc (Astlib.Longident.flatten lident)$ >> in function | [] -> init (* | [r] -> <:ctyp< $init$ $r$ >> *) @@ -686,7 +689,7 @@ end module Cl = struct type t = class_expr let constr ~loc lident args = - let ls = Asttools.longident_lident_of_string_list loc (Longident.flatten lident) in + let ls = Asttools.longident_lident_of_string_list loc (Astlib.Longident.flatten lident) in <:class_expr< [ $list:args$ ] $lilongid:ls$ >> let apply ~loc l xs = List.fold_left (fun acc r -> <:class_expr< $acc$ $r$ >>) l xs diff --git a/common/GTHELPERS_sig.ml b/common/GTHELPERS_sig.ml index 1295ad56..94c2b900 100644 --- a/common/GTHELPERS_sig.ml +++ b/common/GTHELPERS_sig.ml @@ -142,7 +142,7 @@ module type S = sig end and Ctf : (* class_sig_item *) - sig + sig type t val inherit_ : loc:loc -> Cty.t -> t @@ -218,7 +218,7 @@ module type S = sig type t val structure : loc:loc -> Str.t list -> t - val ident : loc:loc -> Longident.t -> t + val ident : loc:loc -> Ppxlib.longident -> t val apply : loc:loc -> t -> t -> t (* val functor_ : loc:loc -> string -> Mt.t option -> t -> t *) end @@ -226,7 +226,7 @@ module type S = sig and Mt : sig type t - val ident : loc:loc -> Longident.t -> t + val ident : loc:loc -> Ppxlib.longident -> t val signature : loc:loc -> Sig.t list -> t (* val functor_: loc:loc -> string -> t option -> t -> t *) @@ -240,12 +240,12 @@ module type S = sig end and Cl : (* class_expr *) - sig + sig type t val fun_ : loc:loc -> Pat.t -> t -> t val fun_list : loc:loc -> Pat.t list -> t -> t - val constr : loc:loc -> Longident.t -> Typ.t list -> t + val constr : loc:loc -> Ppxlib.longident -> Typ.t list -> t val apply : loc:loc -> t -> Exp.t list -> t val let_ : loc:loc -> ?flg:Ppxlib.rec_flag -> Vb.t list -> t -> t end diff --git a/common/HelpersBase.ml b/common/HelpersBase.ml index 6c8af648..6a447401 100644 --- a/common/HelpersBase.ml +++ b/common/HelpersBase.ml @@ -131,13 +131,13 @@ let compare_core_type a b = ;; let visit_typedecl - ~loc - ?(onrecord = fun _ -> not_implemented ~loc "record types") - ?(onmanifest = fun _ -> not_implemented ~loc "manifest") - ?(onvariant = fun _ -> not_implemented ~loc "algebraic types") - ?(onabstract = fun _ -> not_implemented ~loc "abstract types without manifest") - ?(onopen = fun () -> not_implemented ~loc "open types") - tdecl + ~loc + ?(onrecord = fun _ -> not_implemented ~loc "record types") + ?(onmanifest = fun _ -> not_implemented ~loc "manifest") + ?(onvariant = fun _ -> not_implemented ~loc "algebraic types") + ?(onabstract = fun _ -> not_implemented ~loc "abstract types without manifest") + ?(onopen = fun () -> not_implemented ~loc "open types") + tdecl = match tdecl.ptype_kind with | Ptype_record r -> onrecord r @@ -155,7 +155,7 @@ let affect_longident ~f = function | Lapply (_, _) as l -> l ;; -let rec map_longident ~f = function +let rec map_longident ~f : _ -> Longident.t = function | Lident x -> Lident (f x) | Ldot (l, s) -> Ldot (l, f s) | Lapply (l, r) -> Lapply (l, map_longident ~f r) @@ -175,11 +175,11 @@ let vars_from_core_type = | Ptyp_var s -> SS.add s acc | Ptyp_tuple args | Ptyp_constr (_, args) -> List.fold_left args ~init:acc ~f:helper | Ptyp_arrow (_, l, r) -> helper (helper acc l) r - | Ptyp_alias (t, lab) -> SS.remove lab (helper acc t) + | Ptyp_alias (t, lab) -> SS.remove lab.txt (helper acc t) | Ptyp_object (_, _) | Ptyp_class (_, _) | Ptyp_variant (_, _, _) - | Ptyp_any + | Ptyp_any | Ptyp_open _ | Ptyp_poly (_, _) | Ptyp_package _ | Ptyp_extension _ -> acc in @@ -211,12 +211,11 @@ let vars_from_tdecl tdecl = | Ptype_open | Ptype_abstract -> SS.empty | Ptype_record ls -> of_labels ls | Ptype_variant cds -> - List.fold_left cds ~init:SS.empty ~f:(fun acc -> - function - | { pcd_args = Pcstr_tuple ts } -> - List.fold_left ~init:SS.empty ts ~f:(fun acc x -> - SS.union acc (vars_from_core_type x)) - | { pcd_args = Pcstr_record ls } -> SS.union acc (of_labels ls)) + List.fold_left cds ~init:SS.empty ~f:(fun acc -> function + | { pcd_args = Pcstr_tuple ts } -> + List.fold_left ~init:SS.empty ts ~f:(fun acc x -> + SS.union acc (vars_from_core_type x)) + | { pcd_args = Pcstr_record ls } -> SS.union acc (of_labels ls)) in SS.union ans2 ans ;; @@ -261,7 +260,7 @@ let is_type_used_in ~tdecl lident = let rec helper t = match t.ptyp_desc with | Ptyp_constr ({ txt }, _) when lident = txt -> raise Found - | Ptyp_object _ -> () + | Ptyp_open _ | Ptyp_object _ -> () | Ptyp_any | Ptyp_var _ | Ptyp_class _ | Ptyp_package _ | Ptyp_extension _ -> () | Ptyp_variant (rfs, _, _) -> List.iter rfs ~f:(function @@ -283,8 +282,8 @@ let is_type_used_in ~tdecl lident = ~onmanifest:helper ~onvariant: (List.iter ~f:(function - | { pcd_args = Pcstr_tuple ls } -> List.iter ~f:helper ls - | { pcd_args = Pcstr_record ls } -> onrecord ls)) + | { pcd_args = Pcstr_tuple ls } -> List.iter ~f:helper ls + | { pcd_args = Pcstr_record ls } -> onrecord ls)) ~onrecord; false with diff --git a/common/dune b/common/dune index d4e55fc7..81d485c9 100644 --- a/common/dune +++ b/common/dune @@ -16,10 +16,7 @@ (instrumentation (backend bisect_ppx)) (preprocess - (pps - ppx_inline_test_nobase - ;ppx_expect - ppxlib.metaquot)) + (pps ppx_inline_test_nobase ppxlib.metaquot)) (foreign_stubs (language c) (names common_stubs))) diff --git a/common/expander.ml b/common/expander.ml index edf25787..331fa63c 100644 --- a/common/expander.ml +++ b/common/expander.ml @@ -46,21 +46,20 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct let k cs = Exp.match_ ~loc what cs in k @@ List.map cdts ~f:(fun cd -> - match cd.pcd_args with - | Pcstr_record ls -> - let names = List.map ls ~f:(fun _ -> gen_symbol ()) in - case - ~lhs: - (Pat.constr_record ~loc cd.pcd_name.txt - @@ List.map2_exn ls names ~f:(fun l s -> l.pld_name.txt, Pat.var ~loc s) - ) - ~rhs:(make_rhs cd names) - | Pcstr_tuple args -> - let names = List.map args ~f:(fun _ -> gen_symbol ()) in - (* notify "constructing %s of %s" cd.pcd_name.txt (String.concat ~sep:" " names); *) - case - ~lhs:(Pat.constr ~loc cd.pcd_name.txt @@ List.map ~f:(Pat.var ~loc) names) - ~rhs:(make_rhs cd names)) + match cd.pcd_args with + | Pcstr_record ls -> + let names = List.map ls ~f:(fun _ -> gen_symbol ()) in + case + ~lhs: + (Pat.constr_record ~loc cd.pcd_name.txt + @@ List.map2_exn ls names ~f:(fun l s -> l.pld_name.txt, Pat.var ~loc s)) + ~rhs:(make_rhs cd names) + | Pcstr_tuple args -> + let names = List.map args ~f:(fun _ -> gen_symbol ()) in + (* notify "constructing %s of %s" cd.pcd_name.txt (String.concat ~sep:" " names); *) + case + ~lhs:(Pat.constr ~loc cd.pcd_name.txt @@ List.map ~f:(Pat.var ~loc) names) + ~rhs:(make_rhs cd names)) @ match else_case with | None -> [] @@ -116,10 +115,10 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct *) (List.concat @@ map_type_param_names params ~f:(fun s -> - [ named_type_arg ~loc ("i" ^ s) - ; named_type_arg ~loc s - ; named_type_arg ~loc ("s" ^ s) - ])) + [ named_type_arg ~loc ("i" ^ s) + ; named_type_arg ~loc s + ; named_type_arg ~loc ("s" ^ s) + ])) @ [ named_type_arg ~loc "inh" ; named_type_arg ~loc Naming.extra_param_name ; named_type_arg ~loc "syn" @@ -211,7 +210,7 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct map_core_type typ ~onvar:(fun as_ -> let params = List.map ~f:fst tdecl.ptype_params in let open Ppxlib.Ast_builder.Default in - if String.equal as_ new_name + if String.equal as_ new_name.txt then Some (ptyp_constr ~loc (Located.lident ~loc name.txt) params) else Some (ptyp_var ~loc as_)) |> helper @@ -345,7 +344,7 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct let loc = typ.ptyp_loc in map_core_type typ ~onvar:(fun as_ -> let open Ppxlib.Ast_builder.Default in - if String.equal as_ new_name + if String.equal as_ new_name.txt then Some (ptyp_constr ~loc (Located.lident ~loc name.txt) params) else Some (ptyp_var ~loc as_)) |> helper @@ -353,37 +352,36 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct (* rows go to virtual methods. label goes to inherit fields *) ans ~is_poly:true @@ List.concat_map rows ~f:(fun rf -> - match rf.prf_desc with - | Rtag (lab, _, []) -> - let methname = sprintf "c_%s" lab.txt in - [ (Cf.method_virtual ~loc methname - @@ Typ.( - var ~loc "syn" - |> arrow ~loc @@ var ~loc "extra" - |> arrow ~loc (var ~loc "inh"))) - ] - | Rtag (lab, _, [ typ ]) -> - (* print_endline "HERE"; *) - let args = - match typ.ptyp_desc with - | Ptyp_tuple ts -> ts - | _ -> [ typ ] - in - let methname = sprintf "c_%s" lab.txt in - [ (Cf.method_virtual ~loc methname - @@ - let open Typ in - List.fold_right args ~init:(var ~loc "syn") ~f:(fun t -> - arrow ~loc (from_caml t)) - |> arrow ~loc @@ var ~loc "extra" - |> arrow ~loc (var ~loc "inh")) - ] - | Rtag (_, _, _) -> failwith "Can't deal with conjunctive types" - | Rinherit typ -> - (match typ.ptyp_desc with - | Ptyp_constr ({ txt; loc }, params) -> - wrap ~is_poly:true txt params - | _ -> assert false)) + match rf.prf_desc with + | Rtag (lab, _, []) -> + let methname = sprintf "c_%s" lab.txt in + [ (Cf.method_virtual ~loc methname + @@ Typ.( + var ~loc "syn" + |> arrow ~loc @@ var ~loc "extra" + |> arrow ~loc (var ~loc "inh"))) + ] + | Rtag (lab, _, [ typ ]) -> + (* print_endline "HERE"; *) + let args = + match typ.ptyp_desc with + | Ptyp_tuple ts -> ts + | _ -> [ typ ] + in + let methname = sprintf "c_%s" lab.txt in + [ (Cf.method_virtual ~loc methname + @@ + let open Typ in + List.fold_right args ~init:(var ~loc "syn") ~f:(fun t -> + arrow ~loc (from_caml t)) + |> arrow ~loc @@ var ~loc "extra" + |> arrow ~loc (var ~loc "inh")) + ] + | Rtag (_, _, _) -> failwith "Can't deal with conjunctive types" + | Rinherit typ -> + (match typ.ptyp_desc with + | Ptyp_constr ({ txt; loc }, params) -> wrap ~is_poly:true txt params + | _ -> assert false)) | Ptyp_extension _ -> not_implemented "extensions in types `%s`" (string_of_core_type typ) | _ -> failwith "not implemented ") @@ -435,19 +433,19 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct ~onvariant:(fun cds -> Typ.object_ ~loc Open @@ List.map cds ~f:(fun cd -> - let typs = - match cd.pcd_args with - | Pcstr_record ls -> List.map ls ~f:(fun x -> x.pld_type) - | Pcstr_tuple ts -> ts - in - let new_ts = - let open Typ in - [ var ~loc "inh"; use_tdecl tdecl ] - @ List.map typs ~f:Typ.from_caml - @ [ Typ.var ~loc "syn" ] - in - ( Naming.meth_name_for_constructor cd.pcd_attributes cd.pcd_name.txt - , Typ.chain_arrow ~loc new_ts ))) + let typs = + match cd.pcd_args with + | Pcstr_record ls -> List.map ls ~f:(fun x -> x.pld_type) + | Pcstr_tuple ts -> ts + in + let new_ts = + let open Typ in + [ var ~loc "inh"; use_tdecl tdecl ] + @ List.map typs ~f:Typ.from_caml + @ [ Typ.var ~loc "syn" ] + in + ( Naming.meth_name_for_constructor cd.pcd_attributes cd.pcd_name.txt + , Typ.chain_arrow ~loc new_ts ))) ~onmanifest:(fun t -> let rec helper typ = match typ.ptyp_desc with @@ -539,16 +537,16 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct let onvariant cds = ans @@ prepare_patt_match ~loc (Exp.ident ~loc "subj") (`Algebraic cds) (fun cd names -> - (* TODO: Subj ident has to be passed as an argument *) - let subj = "subj" in - List.fold_left - ("inh" :: subj :: names) - ~init: - (Exp.send - ~loc - (Exp.ident ~loc "tr") - (Naming.meth_name_for_constructor cd.pcd_attributes cd.pcd_name.txt)) - ~f:(fun acc arg -> Exp.app ~loc acc (Exp.ident ~loc arg))) + (* TODO: Subj ident has to be passed as an argument *) + let subj = "subj" in + List.fold_left + ("inh" :: subj :: names) + ~init: + (Exp.send + ~loc + (Exp.ident ~loc "tr") + (Naming.meth_name_for_constructor cd.pcd_attributes cd.pcd_name.txt)) + ~f:(fun acc arg -> Exp.app ~loc acc (Exp.ident ~loc arg))) in visit_typedecl ~loc @@ -608,6 +606,7 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct | Ptyp_package _ -> failwith "not implemented: package types" | Ptyp_extension _ -> failwith "not implemented: extension types" | Ptyp_arrow _ -> failwith "not implemented: arrow types" + | Ptyp_open _ -> failwith "not implemented: open types" | Ptyp_any -> failwith "not implemented: wildcard types (but it should be easy to rewrite)" | Ptyp_poly (_, _) -> failwith "not implemented: existential types" @@ -669,15 +668,14 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct @@ class_structure ~self:(Pat.any ~loc) ~fields:plugin_fields ) ]) :: List.filter_map plugins ~f:(fun p -> - (* also we generate transformation function with unit preapplied + (* also we generate transformation function with unit preapplied Because we seems to need them in case of abstract type in the interface *) - if p#need_inh_attr - then None - else ( - let fname = Naming.trf_function p#trait_name tdecl.ptype_name.txt in - Option.some - @@ Str.single_value ~loc (Pat.sprintf ~loc "%s" fname) (wrap p tdecl))) + if p#need_inh_attr + then None + else ( + let fname = Naming.trf_function p#trait_name tdecl.ptype_name.txt in + Option.some @@ Str.single_value ~loc (Pat.sprintf ~loc "%s" fname) (wrap p tdecl))) ;; let rename_params tdecl = @@ -714,10 +712,10 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct (* TODO: Implement general case about renaming of paramters *) module G = Graph.Persistent.Digraph.Concrete (struct - include String + include String - let hash = Hashtbl.hash - end) + let hash = Hashtbl.hash + end) module T = Graph.Topological.Make (G) module SM = Stdlib.Map.Make (String) @@ -862,7 +860,7 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct let fix_arg = tup ~loc @@ List.map tdecls ~f:(fun { ptype_name = { txt } } -> - Typ.var ~loc (sprintf "alias_for_%s" txt)) + Typ.var ~loc (sprintf "alias_for_%s" txt)) in List.fold_right ys @@ -910,15 +908,15 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct (Exp.sprintf ~loc "%s0" tdecl.ptype_name.txt) ((Exp.tuple ~loc @@ List.map tdecls ~f:(fun { ptype_name = { txt } } -> - Exp.sprintf ~loc "trait%s" txt)) + Exp.sprintf ~loc "trait%s" txt)) :: map_type_param_names tdecl.ptype_params ~f:(fun txt -> - Exp.sprintf ~loc "f%s" txt) - (* @ - * [Exp.app_list ~loc - * (Exp.sprintf ~loc "trait%s" tdecl.ptype_name.txt) - * (map_type_param_names tdecl.ptype_params - * ~f:(fun txt -> Exp.sprintf ~loc "f%s" txt)) - * ] *)) + Exp.sprintf ~loc "f%s" txt) + (* @ + * [Exp.app_list ~loc + * (Exp.sprintf ~loc "trait%s" tdecl.ptype_name.txt) + * (map_type_param_names tdecl.ptype_params + * ~f:(fun txt -> Exp.sprintf ~loc "f%s" txt)) + * ] *)) ; Exp.ident ~loc "inh" ; Exp.ident ~loc "subj" ] @@ -942,7 +940,7 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct [ make_gcata_typ ~loc tdecl ; Typ.object_ ~loc Closed @@ List.map plugins ~f:(fun p -> - p#trait_name, p#make_final_trans_function_typ ~loc tdecl) + p#trait_name, p#make_final_trans_function_typ ~loc tdecl) (* ; make_gcata_typ ~loc tdecl *) ; fix_typ ~loc tdecls ] @@ -999,15 +997,16 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct (* TODO: it could be a bug with topological sorting here *) sis @ List.concat_map tdecls ~f:(fun tdecl -> - List.concat [ make_interface_class_sig ~loc tdecl; make_gcata_sig ~loc tdecl ]) + List.concat [ make_interface_class_sig ~loc tdecl; make_gcata_sig ~loc tdecl ]) @ [ fix_sig ~loc tdecls ] @ List.concat_map plugins ~f:(fun p -> - (p (true, tdecls))#do_mutuals_sigs ~loc ~is_rec:true) - @ (* (List.concat_map tdecls ~f:(fun tdecl -> - * List.concat_map plugins ~f:(fun p -> - * collect_plugins_sig ~loc tdecl (p tdecls)) - * ) - * ) @ *) + (p (true, tdecls))#do_mutuals_sigs ~loc ~is_rec:true) + @ + (* (List.concat_map tdecls ~f:(fun tdecl -> + * List.concat_map plugins ~f:(fun p -> + * collect_plugins_sig ~loc tdecl (p tdecls)) + * ) + * ) @ *) collect_plugins_sig ~loc tdecls (List.map plugins ~f:(fun p -> p (true, tdecls))) ;; diff --git a/common/plugin.ml b/common/plugin.ml index 048090ba..93536a92 100644 --- a/common/plugin.ml +++ b/common/plugin.ml @@ -34,16 +34,16 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct Plugin_intf.plugin_args -> bool * Ppxlib.type_declaration list -> ( loc - , Exp.t - , Typ.t - , type_arg - , Cl.t - , Ctf.t - , Cf.t - , Str.t - , Sig.t - , Pat.t ) - Plugin_intf.typ_g + , Exp.t + , Typ.t + , type_arg + , Cl.t + , Ctf.t + , Cf.t + , Str.t + , Sig.t + , Pat.t ) + Plugin_intf.typ_g let add_dummy_attr ?(loc = AstHelpers.noloc) ?extra name = let loc = Location.none in @@ -208,12 +208,12 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct then facc else fun rhs -> - make_let - ~loc - ~flg:Nonrecursive - ~pat:(Pat.any ~loc) - ~expr:(Exp.sprintf ~loc "f%s" name) - (facc rhs)) ) + make_let + ~loc + ~flg:Nonrecursive + ~pat:(Pat.any ~loc) + ~expr:(Exp.sprintf ~loc "f%s" name) + (facc rhs)) ) method apply_fas_in_new_object ~loc tdecl = (* very similar to self#make_inherit_args_for_alias but the latter @@ -305,8 +305,8 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct ~loc (Pat.tuple ~loc @@ List.map mutuals_pack_names ~f:(function - | Some s -> Pat.var ~loc s - | None -> Pat.any ~loc)) + | Some s -> Pat.var ~loc s + | None -> Pat.any ~loc)) Naming.mutuals_pack in Cl.fun_ ~loc pat (extra_ignores rhs) @@ -318,7 +318,8 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct @ self#extra_class_str_members tdecl @ fields - method virtual make_typ_of_class_argument + method + virtual make_typ_of_class_argument : 'a. loc:loc -> type_declaration @@ -370,7 +371,7 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct ~loc (Typ.tuple ~loc @@ List.map self#tdecls ~f:(fun tdecl -> - self#long_trans_function_typ ~loc tdecl (* TODO: rename *))) + self#long_trans_function_typ ~loc tdecl (* TODO: rename *))) tl in ans @@ -413,7 +414,7 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct ~loc (Typ.tuple ~loc @@ List.map self#tdecls ~f:(fun tdecl -> - self#long_trans_function_typ ~loc tdecl (* TODO: rename *))) + self#long_trans_function_typ ~loc tdecl (* TODO: rename *))) tl) (self#extra_class_sig_members tdecl @ fields) ] @@ -456,8 +457,8 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct ~onvariant:(fun cds -> k @@ List.map cds ~f:(fun cd -> - on_constructor cd - (* cd.pcd_args + on_constructor cd + (* cd.pcd_args (Ast_builder.Default.Located.map (Naming.meth_name_for_constructor cd.pcd_attributes) cd.pcd_name) *))) ~onmanifest:(fun typ -> @@ -474,7 +475,7 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct let loc = t.ptyp_loc in map_core_type t ~onvar:(fun as_ -> let open Ppxlib.Ast_builder.Default in - if String.equal as_ aname + if String.equal as_ aname.txt then Option.some @@ ptyp_constr ~loc (Located.lident ~loc tdecl.ptype_name.txt) @@ -485,7 +486,7 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct (* there for type 'a list = ('a,'a list) alist * we inherit plugin class for base type, for example (gmap): * inherit ('a,'a2,'a list,'a2 list) gmap_alist - * *) + *) k [ Ctf.inherit_ ~loc @@ Cty.constr @@ -519,31 +520,33 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct | Rtag (lab, _, typs) -> Ctf.method_ ~loc (sprintf "c_%s" lab.txt) ~virt:false @@ - (match typs with - | [] -> - Typ.( - chain_arrow - ~loc - [ self#inh_of_main ~loc tdecl - ; var ~loc @@ Printf.sprintf "extra_%s" tdecl.ptype_name.txt - ; self#syn_of_main ~loc ~in_class:true tdecl - ]) - | [ t ] -> - Typ.( - chain_arrow ~loc - @@ [ self#inh_of_main ~loc tdecl - ; var ~loc @@ Printf.sprintf "extra_%s" tdecl.ptype_name.txt - ] - @ (List.map ~f:Typ.from_caml @@ unfold_tuple t) - @ [ self#syn_of_main ~loc ~in_class:true tdecl ]) - | typs -> - Typ.( - chain_arrow ~loc - @@ [ self#inh_of_main ~loc tdecl + (match typs with + | [] -> + Typ.( + chain_arrow + ~loc + [ self#inh_of_main ~loc tdecl ; var ~loc @@ Printf.sprintf "extra_%s" tdecl.ptype_name.txt - ] - @ List.map ~f:Typ.from_caml typs - @ [ self#syn_of_main ~loc ~in_class:true tdecl ]))) + ; self#syn_of_main ~loc ~in_class:true tdecl + ]) + | [ t ] -> + Typ.( + chain_arrow ~loc + @@ [ self#inh_of_main ~loc tdecl + ; var ~loc + @@ Printf.sprintf "extra_%s" tdecl.ptype_name.txt + ] + @ (List.map ~f:Typ.from_caml @@ unfold_tuple t) + @ [ self#syn_of_main ~loc ~in_class:true tdecl ]) + | typs -> + Typ.( + chain_arrow ~loc + @@ [ self#inh_of_main ~loc tdecl + ; var ~loc + @@ Printf.sprintf "extra_%s" tdecl.ptype_name.txt + ] + @ List.map ~f:Typ.from_caml typs + @ [ self#syn_of_main ~loc ~in_class:true tdecl ]))) in k @@ rr | _ -> assert false @@ -762,7 +765,7 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct let open Ppxlib.Ast_builder.Default in let loc = tdecl.ptype_loc in map_core_type t ~onvar:(fun as_ -> - if String.equal as_ aname + if String.equal as_ aname.txt then Option.some @@ ptyp_constr @@ -807,6 +810,8 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct "not implemented: extension types" | Ptyp_arrow _ -> Location.raise_errorf ~loc:typ.ptyp_loc "not implemented: arrow types" + | Ptyp_open _ -> + Location.raise_errorf ~loc:typ.ptyp_loc "not implemented: open types" | Ptyp_any -> Location.raise_errorf ~loc:typ.ptyp_loc @@ -879,7 +884,8 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct ~onrecord:(self#on_record_declaration ~loc ~is_self_rec ~mutual_decls tdecl) ~onopen:(fun () -> []) - method virtual on_record_declaration + method + virtual on_record_declaration : loc:loc -> is_self_rec:(core_type -> [ `Nonrecursive | `Nonregular | `Regular ]) -> mutual_decls:type_declaration list @@ -947,7 +953,8 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct (if is_mutal then "_stub" else "") (* only for non-recursive types *) - method virtual make_trans_function_body + method + virtual make_trans_function_body : loc:loc -> ?rec_typenames:string list -> string -> type_declaration -> Exp.t method is_combinatorial tdecl = @@ -955,10 +962,11 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct (* let cmb_attr = List.find tdecl.ptype_attributes ~f:(fun {attr_name={txt}} -> String.equal txt "combinatorial") in *) - if (* Option.is_some cmb_attr &&*) - Stdlib.( = ) tdecl.ptype_kind Ptype_abstract - && (not (is_polyvariant_tdecl tdecl)) - && not (is_tuple_tdecl tdecl) + if + (* Option.is_some cmb_attr &&*) + Stdlib.( = ) tdecl.ptype_kind Ptype_abstract + && (not (is_polyvariant_tdecl tdecl)) + && not (is_tuple_tdecl tdecl) then ( match tdecl.ptype_manifest with | Some t -> Some t @@ -977,6 +985,7 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct | Ptyp_package _ | Ptyp_extension _ | Ptyp_alias _ + | Ptyp_open _ | Ptyp_any -> () | Ptyp_poly (_, _) | Ptyp_class (_, _) -> failwith "not implemented" | Ptyp_tuple ts -> List.iter ts ~f:helper @@ -1094,7 +1103,7 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct ~rec_:false [ ( Pat.tuple ~loc @@ List.mapi tdecls ~f:(fun i _ -> - if i = n then Pat.var ~loc "f" else Pat.any ~loc) + if i = n then Pat.var ~loc "f" else Pat.any ~loc) , Exp.app_list ~loc (Exp.ident ~loc @@ Naming.make_fix_name tdecls) @@ -1205,7 +1214,7 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct let mut_funcs = Exp.tuple ~loc @@ List.map tdecls ~f:(fun { ptype_name = { txt } } -> - Exp.ident ~loc @@ Naming.trf_function self#plugin_name txt) + Exp.ident ~loc @@ Naming.trf_function self#plugin_name txt) in let params = self#plugin_class_params_tdecl tdecl in Str.class_single @@ -1233,7 +1242,8 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct (mut_funcs :: self#apply_fas_in_new_object ~loc tdecl) ]) - method virtual on_record_constr + method + virtual on_record_constr : loc:loc -> is_self_rec:(core_type -> [ `Nonrecursive | `Nonregular | `Regular ]) -> mutual_decls:type_declaration list @@ -1246,7 +1256,8 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct -> label_declaration list -> Exp.t - method virtual on_tuple_constr + method + virtual on_tuple_constr : loc:loc -> is_self_rec:(core_type -> [ `Nonrecursive | `Nonregular | `Regular ]) -> mutual_decls:type_declaration list @@ -1259,47 +1270,47 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct method on_variant ~loc tdecl ~mutual_decls ~is_self_rec cds k = k @@ List.map cds ~f:(fun cd -> - let good_constr_name = - Naming.meth_name_for_constructor cd.pcd_attributes cd.pcd_name.txt - in - match cd.pcd_args with - | Pcstr_tuple ts -> - let loc = loc_from_caml cd.pcd_loc in - let inhp, inhe = self#make_inh ~loc in - let bindings = List.map ts ~f:(fun ts -> gen_symbol (), ts) in - let bind_pats = List.map bindings ~f:(fun (s, _) -> Pat.var ~loc s) in - Cf.method_concrete ~loc good_constr_name - @@ Exp.fun_ ~loc inhp - @@ Exp.fun_ ~loc (Pat.any ~loc) - @@ Exp.fun_list ~loc bind_pats - @@ self#on_tuple_constr - ~loc - ~mutual_decls - ~is_self_rec - ~inhe - tdecl - (Option.some @@ `Normal cd.pcd_name.txt) - bindings - | Pcstr_record ls -> - let loc = loc_from_caml cd.pcd_loc in - let inhp, inhe = self#make_inh ~loc in - let bindings = - List.map ls ~f:(fun l -> gen_symbol (), l.pld_name.txt, l.pld_type) - in - let bind_pats = List.map bindings ~f:(fun (s, _, _) -> Pat.var ~loc s) in - Cf.method_concrete ~loc good_constr_name - @@ Exp.fun_ ~loc inhp - @@ Exp.fun_ ~loc (Pat.any ~loc) - @@ Exp.fun_list ~loc bind_pats - @@ self#on_record_constr - ~loc - ~mutual_decls - ~is_self_rec - ~inhe - tdecl - (`Normal cd.pcd_name.txt) - bindings - ls) + let good_constr_name = + Naming.meth_name_for_constructor cd.pcd_attributes cd.pcd_name.txt + in + match cd.pcd_args with + | Pcstr_tuple ts -> + let loc = loc_from_caml cd.pcd_loc in + let inhp, inhe = self#make_inh ~loc in + let bindings = List.map ts ~f:(fun ts -> gen_symbol (), ts) in + let bind_pats = List.map bindings ~f:(fun (s, _) -> Pat.var ~loc s) in + Cf.method_concrete ~loc good_constr_name + @@ Exp.fun_ ~loc inhp + @@ Exp.fun_ ~loc (Pat.any ~loc) + @@ Exp.fun_list ~loc bind_pats + @@ self#on_tuple_constr + ~loc + ~mutual_decls + ~is_self_rec + ~inhe + tdecl + (Option.some @@ `Normal cd.pcd_name.txt) + bindings + | Pcstr_record ls -> + let loc = loc_from_caml cd.pcd_loc in + let inhp, inhe = self#make_inh ~loc in + let bindings = + List.map ls ~f:(fun l -> gen_symbol (), l.pld_name.txt, l.pld_type) + in + let bind_pats = List.map bindings ~f:(fun (s, _, _) -> Pat.var ~loc s) in + Cf.method_concrete ~loc good_constr_name + @@ Exp.fun_ ~loc inhp + @@ Exp.fun_ ~loc (Pat.any ~loc) + @@ Exp.fun_list ~loc bind_pats + @@ self#on_record_constr + ~loc + ~mutual_decls + ~is_self_rec + ~inhe + tdecl + (`Normal cd.pcd_name.txt) + bindings + ls) (* should be overriden in show_typed *) method generate_for_variable ~loc varname = Exp.sprintf ~loc "f%s" varname @@ -1561,12 +1572,14 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct method virtual fancy_app : loc:loc -> Exp.t -> Exp.t -> Exp.t -> Exp.t method virtual app_gcata : loc:loc -> Exp.t -> Exp.t - method virtual make_typ_of_self_trf + method + virtual make_typ_of_self_trf : loc:loc -> ?in_class:bool -> type_declaration -> Typ.t (* method virtual inh_of_main : loc:loc -> Ppxlib.type_declaration -> Typ.t *) - method virtual make_RHS_typ_of_transformation + method + virtual make_RHS_typ_of_transformation : loc:AstHelpers.loc -> ?subj_t:Typ.t -> ?syn_t:Typ.t -> type_declaration -> Typ.t method compose_apply_transformations ~loc ~left right typ : Exp.t = @@ -1587,7 +1600,8 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct inherit generator args _tdecls method virtual plugin_name : string - method virtual syn_of_main + method + virtual syn_of_main : loc:loc -> ?in_class:bool -> Ppxlib.type_declaration -> Typ.t method virtual inh_of_main : loc:loc -> Ppxlib.type_declaration -> Typ.t @@ -1619,14 +1633,14 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct * k @@ (fun arg -> chain (Typ.arrow ~loc subj_t syn_t) arg) *) method make_typ_of_class_argument - : 'a. - loc:loc - -> type_declaration - -> (Typ.t -> 'a -> 'a) - -> string - -> (('a -> 'a) -> 'a -> 'a) - -> 'a - -> 'a = + : 'a. + loc:loc + -> type_declaration + -> (Typ.t -> 'a -> 'a) + -> string + -> (('a -> 'a) -> 'a -> 'a) + -> 'a + -> 'a = fun ~loc tdecl chain name k -> let inh_t = self#inh_of_param ~loc tdecl name in let subj_t = Typ.var ~loc name in @@ -1641,15 +1655,15 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct method app_gcata ~loc egcata = Exp.app ~loc egcata (Exp.unit ~loc) method on_record_constr - : loc:loc - -> is_self_rec:(core_type -> [ `Nonrecursive | `Nonregular | `Regular ]) - -> mutual_decls:type_declaration list - -> inhe:Exp.t - -> type_declaration - -> [ `Normal of string | `Poly of string ] - -> (string * string * core_type) list - -> label_declaration list - -> Exp.t = + : loc:loc + -> is_self_rec:(core_type -> [ `Nonrecursive | `Nonregular | `Regular ]) + -> mutual_decls:type_declaration list + -> inhe:Exp.t + -> type_declaration + -> [ `Normal of string | `Poly of string ] + -> (string * string * core_type) list + -> label_declaration list + -> Exp.t = fun ~loc ~is_self_rec ~mutual_decls ~inhe _ _ _ -> failwiths "handling record constructors in plugin `%s`" self#plugin_name () @@ -1681,17 +1695,17 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct (* val name: -> -> ... -> -> <_not_ this> * fot a type ('a,'b,....'z) being generated - * *) + *) method! make_typ_of_class_argument - : 'a. - loc:loc - -> type_declaration - -> (Typ.t -> 'a -> 'a) - -> string - -> (('a -> 'a) -> 'a -> 'a) - -> 'a - -> 'a = + : 'a. + loc:loc + -> type_declaration + -> (Typ.t -> 'a -> 'a) + -> string + -> (('a -> 'a) -> 'a -> 'a) + -> 'a + -> 'a = fun ~loc tdecl chain name k -> let inh_t = self#inh_of_param ~loc tdecl name in let subj_t = Typ.var ~loc name in @@ -1763,8 +1777,8 @@ module Make (AstHelpers : GTHELPERS_sig.S) = struct tdecl (Exp.app_list ~loc (Exp.new_ ~loc @@ Lident class_name) @@ List.map rec_typenames ~f:(fun name -> - Exp.fun_ ~loc (Pat.unit ~loc) - @@ Exp.sprintf ~loc "%s_%s" self#plugin_name name) + Exp.fun_ ~loc (Pat.unit ~loc) + @@ Exp.sprintf ~loc "%s_%s" self#plugin_name name) @ self#apply_fas_in_new_object ~loc tdecl) method fancy_app ~loc trf (inh : Exp.t) subj = Exp.app ~loc trf subj diff --git a/dune-project b/dune-project index 68d154b1..8d5c28f2 100644 --- a/dune-project +++ b/dune-project @@ -33,10 +33,10 @@ (< "5.0.0")) (and (>= "5.2.0") - (<= "5.4.0")))) + (< "5.6.0")))) dune (ppxlib - (<= "0.34.0")) + (>= "0.38.0")) (camlp5 (>= "8.04.00")) ocamlgraph diff --git a/ppx/PpxHelpers.ml b/ppx/PpxHelpers.ml index 35f21268..a4b32d15 100644 --- a/ppx/PpxHelpers.ml +++ b/ppx/PpxHelpers.ml @@ -277,7 +277,7 @@ module Typ = struct ;; let variant_of_t ~loc t = [%type: [> [%t t] ]] - let alias ~loc t s = ptyp_alias ~loc t s + let alias ~loc t s = ptyp_alias ~loc t (Located.mk ~loc s) let poly ~loc names t = ptyp_poly ~loc (List.map names ~f:(Located.mk ~loc)) t let map ~onvar t = HelpersBase.map_core_type ~onvar t @@ -328,13 +328,13 @@ module Str = struct type t = structure_item let single_class - ~loc - ?(virt = Asttypes.Virtual) - ?(pat = [%pat? _]) - ?(wrap = fun x -> x) - ~name - ~params - body + ~loc + ?(virt = Asttypes.Virtual) + ?(pat = [%pat? _]) + ?(wrap = fun x -> x) + ~name + ~params + body = pstr_class [ Ast_helper.Ci.mk ~virt ~params (Located.mk ~loc name) @@ -403,8 +403,8 @@ module Str = struct ~name:(Located.mk ~loc name) ~params: (List.map params ~f:(function - | None -> ptyp_any ~loc, (NoVariance, NoInjectivity) - | Some s -> ptyp_var ~loc s, (NoVariance, NoInjectivity))) + | None -> ptyp_any ~loc, (NoVariance, NoInjectivity) + | Some s -> ptyp_var ~loc s, (NoVariance, NoInjectivity))) ~cstrs:[] ~kind:Ptype_abstract ~private_:Public @@ -427,7 +427,7 @@ module Str = struct let simple_gadt : loc:loc -> name:string -> params_count:int -> (string * Typ.t) list -> t = - fun ~loc ~name ~params_count xs -> + fun ~loc ~name ~params_count xs -> pstr_type ~loc Recursive @@ -447,7 +447,7 @@ module Str = struct ~args:(Pcstr_tuple []) ~res:(Some typ)))) ] - ;; + ;; let module_ ~loc name me = pstr_module ~loc @@ module_binding ~loc ~name:(Located.mk ~loc (Some name)) ~expr:me @@ -461,7 +461,7 @@ module Me = struct type t = module_expr let structure ~loc sis = pmod_structure ~loc sis - let ident ~loc lident = pmod_ident ~loc (Located.mk ~loc lident) + let ident ~loc (lident : Ppxlib.longident) = pmod_ident ~loc (Located.mk ~loc lident) let apply ~loc = pmod_apply ~loc let functor_ ~loc name argt body = @@ -526,8 +526,8 @@ module Sig = struct ~name:(Located.mk ~loc name) ~params: (List.map params ~f:(function - | None -> ptyp_any ~loc, (NoVariance, NoInjectivity) - | Some s -> ptyp_var ~loc s, (NoVariance, NoInjectivity))) + | None -> ptyp_any ~loc, (NoVariance, NoInjectivity) + | Some s -> ptyp_var ~loc s, (NoVariance, NoInjectivity))) ~cstrs:[] ~kind:Ptype_abstract ~private_:Public @@ -550,7 +550,7 @@ module Sig = struct let simple_gadt : loc:loc -> name:string -> params_count:int -> (string * Typ.t) list -> t = - fun ~loc ~name ~params_count xs -> + fun ~loc ~name ~params_count xs -> psig_type ~loc Recursive @@ -570,7 +570,7 @@ module Sig = struct ~args:(Pcstr_tuple []) ~res:(Some typ)))) ] - ;; + ;; let module_ ~loc md = psig_module ~loc md let modtype ~loc = psig_modtype ~loc @@ -664,7 +664,7 @@ module Cl = struct ;; let fun_ ~loc = pcl_fun ~loc Nolabel None - let constr ~loc (lid : longident) ts = pcl_constr ~loc (Located.mk ~loc lid) ts + let constr ~loc (lid : Ppxlib.longident) ts = pcl_constr ~loc (Located.mk ~loc lid) ts let structure ~loc = pcl_structure ~loc let let_ ~loc ?(flg = Nonrecursive) = Cl.let_ ~loc flg end @@ -699,13 +699,13 @@ let map_type_param_names ~f ps = ;; let prepare_param_triples - ~loc - ~extra - ?(inh = fun ~loc s -> Typ.var ~loc @@ "i" ^ s) - ?(syn = fun ~loc s -> Typ.var ~loc @@ "s" ^ s) - ?(default_inh = [%type: 'inh]) - ?(default_syn = [%type: 'syn]) - names + ~loc + ~extra + ?(inh = fun ~loc s -> Typ.var ~loc @@ "i" ^ s) + ?(syn = fun ~loc s -> Typ.var ~loc @@ "s" ^ s) + ?(default_inh = [%type: 'inh]) + ?(default_syn = [%type: 'syn]) + names = let ps = List.concat_map names ~f:(fun n -> [ inh ~loc n; Typ.var ~loc n; syn ~loc n ]) diff --git a/regression/dune.tests b/regression/dune.tests index fa3aacf2..ea5d25b4 100644 --- a/regression/dune.tests +++ b/regression/dune.tests @@ -697,6 +697,15 @@ (modules test840garrique) (libraries GT) (instrumentation (backend bisect_ppx))(preprocess (pps GT.ppx_all))) + +(cram + (applies_to test841) + (deps test841mut.exe)) +(executable + (name test841mut) + (modules test841mut) + (libraries GT) + (instrumentation (backend bisect_ppx))(preprocess (pps GT.ppx_all))) ; ppx+rectypes (cram From 394f3489e5e16b41ae6ca107b7b73ddae743eed6 Mon Sep 17 00:00:00 2001 From: Kakadu Date: Wed, 5 Aug 2026 10:12:13 +0300 Subject: [PATCH 3/6] Promote formatting tests in OCaml 5.5 Signed-off-by: Kakadu --- regression/test827_2.t | 8 ++++---- regression/test830pp.t | 8 ++++---- regression/test841.t | 1 + regression/test841mut.ml | 11 +++++++++++ 4 files changed, 20 insertions(+), 8 deletions(-) create mode 100644 regression/test841.t create mode 100644 regression/test841mut.ml diff --git a/regression/test827_2.t b/regression/test827_2.t index d58b71a2..f20b4ff0 100644 --- a/regression/test827_2.t +++ b/regression/test827_2.t @@ -68,8 +68,8 @@ method c_BBB () _ _x__009_ _x__010_ = BBB ((fa () _x__009_), - ((fun () -> fun subj -> GT.gmap GT.option (gmap_bbb fa ()) subj) - () _x__010_)) + ((fun () subj -> GT.gmap GT.option (gmap_bbb fa ()) subj) () + _x__010_)) end class ['a,'a_2,'extra_bbb,'syn_bbb] gmap_bbb_t_stub ((_, _fself_bbb) as _mutuals_pack) @@ -81,8 +81,8 @@ method c_AAA () _ _x__011_ _x__012_ = AAA ((fa () _x__011_), - ((fun () -> fun subj -> GT.gmap GT.list (_fself_bbb fa ()) subj) - () _x__012_)) + ((fun () subj -> GT.gmap GT.list (_fself_bbb fa ()) subj) () + _x__012_)) end let gmap_aaa_0 eta = (new gmap_aaa_t_stub) eta let gmap_bbb_0 eta = (new gmap_bbb_t_stub) eta diff --git a/regression/test830pp.t b/regression/test830pp.t index 4f585579..b39a992d 100644 --- a/regression/test830pp.t +++ b/regression/test830pp.t @@ -68,8 +68,8 @@ method c_BBB () _ _x__009_ _x__010_ = BBB ((fa () _x__009_), - ((fun () -> fun subj -> GT.gmap GT.option (gmap_bbb fa ()) subj) - () _x__010_)) + ((fun () subj -> GT.gmap GT.option (gmap_bbb fa ()) subj) () + _x__010_)) end class ['a,'a_2,'extra_bbb,'syn_bbb] gmap_bbb_t_stub ((_, _fself_bbb) as _mutuals_pack) @@ -81,8 +81,8 @@ method c_AAA () _ _x__011_ _x__012_ = AAA ((fa () _x__011_), - ((fun () -> fun subj -> GT.gmap GT.list (_fself_bbb fa ()) subj) - () _x__012_)) + ((fun () subj -> GT.gmap GT.list (_fself_bbb fa ()) subj) () + _x__012_)) end let gmap_aaa_0 eta = (new gmap_aaa_t_stub) eta let gmap_bbb_0 eta = (new gmap_bbb_t_stub) eta diff --git a/regression/test841.t b/regression/test841.t new file mode 100644 index 00000000..7eb4a6c2 --- /dev/null +++ b/regression/test841.t @@ -0,0 +1 @@ + $ ./test841mut.exe diff --git a/regression/test841mut.ml b/regression/test841mut.ml new file mode 100644 index 00000000..60478207 --- /dev/null +++ b/regression/test841mut.ml @@ -0,0 +1,11 @@ +type lam = + Var of GT.string +| Abs of GT.string * lam +| App of lam * lam + + [@@deriving gt ~plugins:{show}] + + +type value = Closure of env * lam +and env = (GT.string * value) GT.list + [@@deriving gt ~plugins:{show}] \ No newline at end of file From f2fc18f921fe0fc2f894688612ede2e701cfc224 Mon Sep 17 00:00:00 2001 From: Kakadu Date: Wed, 5 Aug 2026 10:37:12 +0300 Subject: [PATCH 4/6] Repair benchmarks Signed-off-by: Kakadu --- .gitignore | 1 + GT-bench.opam | 4 ++-- bench/bench2.ml | 34 +++++++++++++++++++++------------- dune-project | 2 +- 4 files changed, 25 insertions(+), 16 deletions(-) diff --git a/.gitignore b/.gitignore index d7da55ac..8d2fb636 100644 --- a/.gitignore +++ b/.gitignore @@ -15,3 +15,4 @@ Makefile *.install _coverage +/*.sexp diff --git a/GT-bench.opam b/GT-bench.opam index 67ad11b9..3969851c 100644 --- a/GT-bench.opam +++ b/GT-bench.opam @@ -8,8 +8,8 @@ license: "LGPL-2.1-or-later" homepage: "https://github.com/PLTools/GT" bug-reports: "https://github.com/PLTools/GT/issues" depends: [ - "dune" {>= "3.16"} - "benchmark" {< "1.7"} + "dune" {>= "3.18"} + "benchmark" {>= "1.7"} "odoc" {with-doc} ] build: [ diff --git a/bench/bench2.ml b/bench/bench2.ml index 2612415e..35ff6a11 100644 --- a/bench/bench2.ml +++ b/bench/bench2.ml @@ -4,24 +4,32 @@ let () = ;; module MySamples = struct - type t = Benchmark.t = - { wall : GT.float - ; utime : GT.float - ; stime : GT.float - ; cutime : GT.float - ; cstime : GT.float - ; iters : GT.int64 + type t = Benchmark.t + + let t = + { GT.plugins = + object + method fmt ppf b = + Format.fprintf + ppf + "{ utime = %f; minor = %.0f; major = %.0f }" + b.Benchmark.utime + b.Benchmark.minor_words + b.Benchmark.major_words + end + ; gcata = (fun _ _ -> assert false) + ; fix = (fun _ _ -> assert false) } - [@@deriving gt ~plugins:{ show }] + ;; [@@@ocaml.warning "-34"] - type samples = (GT.string * t GT.list) GT.list [@@deriving gt ~plugins:{ show }] + type samples = (GT.string * t GT.list) GT.list [@@deriving gt ~plugins:{ fmt }] let save res filename = - let ch = Stdlib.open_out filename in - Stdlib.Printf.fprintf ch "%s\n" (GT.show samples res); - Stdlib.close_out ch + Out_channel.with_open_text filename (fun ch -> + let ppf = Format.formatter_of_out_channel ch in + Format.fprintf ppf "%a\n" (GT.fmt samples) res) ;; end @@ -177,7 +185,7 @@ module Lambda = struct end module PP = struct - let name = "lambda formatting" + let name = "lambda fmting" let create n = Id.create n module D = struct diff --git a/dune-project b/dune-project index 8d5c28f2..b3e76f03 100644 --- a/dune-project +++ b/dune-project @@ -62,4 +62,4 @@ (depends dune (benchmark - (< "1.7")))) + (>= "1.7")))) From ef38a0ad260e37e619de316a2d435b7abd4ce0be Mon Sep 17 00:00:00 2001 From: Kakadu Date: Wed, 5 Aug 2026 10:40:06 +0300 Subject: [PATCH 5/6] Fix OPAM files Signed-off-by: Kakadu --- GT-bench.opam | 3 ++- GT.opam | 7 ++++--- dune-project | 10 ++++++---- 3 files changed, 12 insertions(+), 8 deletions(-) diff --git a/GT-bench.opam b/GT-bench.opam index 3969851c..d7eea186 100644 --- a/GT-bench.opam +++ b/GT-bench.opam @@ -2,7 +2,7 @@ opam-version: "2.0" version: "0.1" synopsis: "Some benchmarks. Should not be installed" -maintainer: ["Kakadu@pm.me"] +maintainer: ["kakadu.hafanana@gmail.com"] authors: ["Dmitrii Kosarev a.k.a. Kakadu"] license: "LGPL-2.1-or-later" homepage: "https://github.com/PLTools/GT" @@ -27,3 +27,4 @@ build: [ ] ] dev-repo: "git+https://github.com/PLTools/GT.git" +x-maintenance-intent: ["(latest)"] diff --git a/GT.opam b/GT.opam index b4f79547..8c293387 100644 --- a/GT.opam +++ b/GT.opam @@ -1,6 +1,6 @@ # This file is generated by dune, edit dune-project instead opam-version: "2.0" -version: "0.5.5" +version: "0.5.6" synopsis: "Generic programming with extensible transformations" description: """ Yet another library for generic programming. Provides syntax extensions @@ -16,14 +16,14 @@ the decision opposite to the one used in `visitors`. P.S. Since 2023 development team is no longer associated with JetBrains Research""" -maintainer: ["Kakadu@pm.me"] +maintainer: ["kakadu.hafanana@gmail.com"] authors: ["https://github.com/dboulytchev" "https://github.com/Kakadu"] license: "LGPL-2.1-or-later" homepage: "https://github.com/PLTools/GT" bug-reports: "https://github.com/PLTools/GT/issues" depends: [ "ocaml" {>= "4.14" & < "5.0.0" | >= "5.2.0" & < "5.6.0"} - "dune" {>= "3.16"} + "dune" {>= "3.18"} "ppxlib" {>= "0.38.0"} "camlp5" {>= "8.04.00"} "ocamlgraph" @@ -52,3 +52,4 @@ build: [ ] ] dev-repo: "git+https://github.com/PLTools/GT.git" +x-maintenance-intent: ["(latest)"] diff --git a/dune-project b/dune-project index b3e76f03..a0a21dd7 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,4 @@ -(lang dune 3.16) +(lang dune 3.18) (generate_opam_files true) @@ -14,6 +14,8 @@ (homepage "https://github.com/PLTools/GT") +(maintenance_intent "(latest)") + (source (github PLTools/GT)) @@ -23,8 +25,8 @@ (description "Yet another library for generic programming. Provides syntax extensions\nboth for camlp5 and PPX which allow decoration of type declarations with\nfollowing compile-time code generation. Provides the way for creating\nplugins (compiled separately from the library) for enchancing supported\ntype transformations.\n\nStrongly reminds the `visitors` library from François Pottier.\nDuring desing of a library of these kind there many possible\ndesign decision and in many cases we decided to implement\nthe decision opposite to the one used in `visitors`.\n\n\nP.S. Since 2023 development team is no longer associated with JetBrains Research") (authors "https://github.com/dboulytchev" "https://github.com/Kakadu") - (maintainers "Kakadu@pm.me") - (version 0.5.5) + (maintainers "kakadu.hafanana@gmail.com") + (version 0.5.6) (depends (ocaml (or @@ -58,7 +60,7 @@ (version 0.1) (allow_empty) (authors "Dmitrii Kosarev a.k.a. Kakadu") - (maintainers "Kakadu@pm.me") + (maintainers "kakadu.hafanana@gmail.com") (depends dune (benchmark From 970a715b90ea5f61f1828a049b25eeb7919ac1de Mon Sep 17 00:00:00 2001 From: Kakadu Date: Wed, 5 Aug 2026 16:50:59 +0300 Subject: [PATCH 6/6] Don't use inline_tests in GTCommon Signed-off-by: Kakadu --- common/GTCommon_tests.ml | 11 +++++++++++ common/HelpersBase.ml | 10 ---------- common/dune | 11 +++++++++-- 3 files changed, 20 insertions(+), 12 deletions(-) create mode 100644 common/GTCommon_tests.ml diff --git a/common/GTCommon_tests.ml b/common/GTCommon_tests.ml new file mode 100644 index 00000000..af127370 --- /dev/null +++ b/common/GTCommon_tests.ml @@ -0,0 +1,11 @@ +open GTCommon.HelpersBase + +let%test _ = + let loc = Location.none in + [ "a" ] = (vars_from_core_type [%type: 'a list] |> SS.elements) +;; + +let%test _ = + let loc = Location.none in + [] = (vars_from_core_type [%type: int list] |> SS.elements) +;; diff --git a/common/HelpersBase.ml b/common/HelpersBase.ml index 6a447401..080b0db2 100644 --- a/common/HelpersBase.ml +++ b/common/HelpersBase.ml @@ -186,16 +186,6 @@ let vars_from_core_type = fun root -> helper SS.empty root ;; -let%test _ = - let loc = Location.none in - [ "a" ] = (vars_from_core_type [%type: 'a list] |> SS.elements) -;; - -let%test _ = - let loc = Location.none in - [] = (vars_from_core_type [%type: int list] |> SS.elements) -;; - let vars_from_tdecl tdecl = let ans = match tdecl.ptype_manifest with diff --git a/common/dune b/common/dune index 81d485c9..0e2e138e 100644 --- a/common/dune +++ b/common/dune @@ -12,11 +12,18 @@ "Actual code that perform codegeneration. Will used for creating new plugins") (flags (:standard -w -32-9 -warn-error -A)) - ;(inline_tests) (instrumentation (backend bisect_ppx)) (preprocess - (pps ppx_inline_test_nobase ppxlib.metaquot)) + (pps ppxlib.metaquot)) (foreign_stubs (language c) (names common_stubs))) + +(library + (name GTCommon_tests) + (modules GTCommon_tests) + (inline_tests) + (libraries GTCommon) + (preprocess + (pps ppxlib.metaquot ppx_inline_test_nobase)))