diff --git a/GT.opam b/GT.opam index a1d0b9c0..b4f79547 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.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} 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 575a69de..36d2ed13 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) @@ -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 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..e70a9ceb 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) @@ -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 diff --git a/common/dune b/common/dune index d4e55fc7..54b1a5ed 100644 --- a/common/dune +++ b/common/dune @@ -18,6 +18,7 @@ (preprocess (pps ppx_inline_test_nobase + ppx_optcomp ;ppx_expect ppxlib.metaquot)) (foreign_stubs diff --git a/common/expander.ml b/common/expander.ml index edf25787..3b287efe 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_ (alias_extract_ident new_name) 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 @@ -669,15 +667,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 +711,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 +859,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 +907,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 +939,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 +996,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..a86f67dc 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_ (alias_extract_ident aname) 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 @@ -879,7 +882,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 +951,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 +960,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 @@ -1094,7 +1100,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 +1211,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 +1239,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 +1253,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 +1267,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 +1569,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 +1597,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 +1630,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 +1652,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 +1692,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 +1774,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 5648ccbe..8d5c28f2 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.6.0")))) dune (ppxlib - (<= "0.34.0")) + (>= "0.38.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")))) - 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