Support camlp5 8.04.0

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.6.0"}
   "dune" {>= "3.16"}
-  "ppxlib" {<= "0.34.0"}
-  "camlp5" {>= "8.00.05"}
+  "ppxlib" {>= "0.38.0"}
+  "camlp5" {>= "8.04.00"}
   "ocamlgraph"
   "ppx_inline_test_nobase"
   "mdx" {build}

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 ->

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/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

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)
@@ -169,13 +169,20 @@ let lident_tail = function
 
 module SS = Stdlib.Set.Make (String)
 
+[%%if ocaml_version >= (5, 5, 0)]
+
+let alias_extract_ident lab = lab.txt
+
+[%%else]
+[%%endif]
+
 let vars_from_core_type =
   let rec helper acc typ =
     match typ.ptyp_desc with
     | 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 (alias_extract_ident lab) (helper acc t)
     | Ptyp_object (_, _)
     | Ptyp_class (_, _)
     | Ptyp_variant (_, _, _)
@@ -211,12 +218,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
 ;;
@@ -283,8 +289,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

common/dune

@@ -18,6 +18,7 @@
  (preprocess
   (pps
    ppx_inline_test_nobase
+   ppx_optcomp
    ;ppx_expect
    ppxlib.metaquot))
  (foreign_stubs