Support camlp5 8.04.0

.gitignore

@@ -15,3 +15,4 @@ Makefile
 
 *.install
 _coverage
+/*.sexp

GT-bench.opam

@@ -2,14 +2,14 @@
 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"
 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: [
@@ -27,3 +27,4 @@ build: [
   ]
 ]
 dev-repo: "git+https://github.com/PLTools/GT.git"
+x-maintenance-intent: ["(latest)"]

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.6"
 synopsis: "Generic programming with extensible transformations"
 description: """
 Yet another library for generic programming. Provides syntax extensions
@@ -16,16 +16,16 @@ 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.3.0"}
-  "dune" {>= "3.16"}
-  "ppxlib" {<= "0.34.0"}
-  "camlp5" {>= "8.00.05"}
+  "ocaml" {>= "4.14" & < "5.0.0" | >= "5.2.0" & < "5.6.0"}
+  "dune" {>= "3.18"}
+  "ppxlib" {>= "0.38.0"}
+  "camlp5" {>= "8.04.00"}
   "ocamlgraph"
   "ppx_inline_test_nobase"
   "mdx" {build}
@@ -52,3 +52,4 @@ build: [
   ]
 ]
 dev-repo: "git+https://github.com/PLTools/GT.git"
+x-maintenance-intent: ["(latest)"]

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
@@ -347,7 +355,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 +441,7 @@ let () =
     tabulate ~confidence res)
 ;;
 
-let () =
+let __ () =
   let module M = Lambda.Eval in
   sizes
   |> List.iter (fun n ->

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)
@@ -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$ >>
@@ -270,7 +272,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 +284,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
@@ -291,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$ >> *)
@@ -322,7 +326,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 +440,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 +458,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 +599,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 +608,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]$ >>
@@ -685,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
@@ -779,7 +783,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

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)
+;;

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,15 +218,15 @@ 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
 
   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