Vendor ppx_easy_deriving

dune-project

@@ -45,7 +45,7 @@ Goblint includes analyses for assertions, overflows, deadlocks, etc and can be e
     (ppx_deriving (>= 6.0.2))
     (ppx_deriving_hash (>= 0.1.2))
     (ppx_deriving_yojson (>= 3.7.0))
-    ppx_easy_deriving
+    (ppxlib (>= 0.30.0)) ; ppx_easy_deriving
     (ounit2 :with-test)
     (qcheck-ounit :with-test)
     (odoc :with-doc)

goblint.opam

@@ -45,7 +45,7 @@ depends: [
   "ppx_deriving" {>= "6.0.2"}
   "ppx_deriving_hash" {>= "0.1.2"}
   "ppx_deriving_yojson" {>= "3.7.0"}
-  "ppx_easy_deriving"
+  "ppxlib" {>= "0.30.0"}
   "ounit2" {with-test}
   "qcheck-ounit" {with-test}
   "odoc" {with-doc}
@@ -98,7 +98,6 @@ available: os-distribution != "alpine" & arch != "arm64"
 pin-depends: [
   # published goblint-cil 2.0.3 is currently up-to-date, so no pin needed
   [ "goblint-cil.2.0.3" "git+https://github.com/goblint/cil.git#ae3a4949d478fad77e004c6fe15a7c83427df59f" ]
-  [ "ppx_easy_deriving.~dev" "git+https://github.com/sim642/ppx_easy_deriving.git#3d599fdfb231e4a1f9bad0e914068210901533a4" ]
 ]
 depexts: [
   ["libgraph-easy-perl"] {os-distribution = "ubuntu" & with-test}

goblint.opam.locked

@@ -86,7 +86,6 @@ depends: [
   "ppx_deriving" {= "6.0.2"}
   "ppx_deriving_hash" {= "0.1.2"}
   "ppx_deriving_yojson" {= "3.7.0"}
-  "ppx_easy_deriving" {= "~dev"}
   "ppxlib" {= "0.32.1"}
   "qcheck-core" {= "0.20"}
   "qcheck-ounit" {= "0.20" & with-test}
@@ -139,10 +138,6 @@ pin-depends: [
     "goblint-cil.2.0.3"
     "git+https://github.com/goblint/cil.git#ae3a4949d478fad77e004c6fe15a7c83427df59f"
   ]
-  [
-    "ppx_easy_deriving.~dev"
-    "git+https://github.com/sim642/ppx_easy_deriving.git#3d599fdfb231e4a1f9bad0e914068210901533a4"
-  ]
 ]
 depexts: ["libgraph-easy-perl"] {os-distribution = "ubuntu" & with-test}
 description: """\

goblint.opam.template

@@ -4,7 +4,6 @@ available: os-distribution != "alpine" & arch != "arm64"
 pin-depends: [
   # published goblint-cil 2.0.3 is currently up-to-date, so no pin needed
   [ "goblint-cil.2.0.3" "git+https://github.com/goblint/cil.git#ae3a4949d478fad77e004c6fe15a7c83427df59f" ]
-  [ "ppx_easy_deriving.~dev" "git+https://github.com/sim642/ppx_easy_deriving.git#3d599fdfb231e4a1f9bad0e914068210901533a4" ]
 ]
 depexts: [
   ["libgraph-easy-perl"] {os-distribution = "ubuntu" & with-test}

src/ppx/lattice/dune

@@ -4,5 +4,4 @@
  (name ppx_deriving_lattice)
  (kind ppx_deriver)
  (libraries ppxlib ppx_easy_deriving)
- (ppx_runtime_libraries ppx_easy_deriving.runtime)
  (preprocess (pps ppxlib.metaquot)))

src/ppx/printable/dune

@@ -4,5 +4,4 @@
  (name ppx_deriving_printable)
  (kind ppx_deriver)
  (libraries ppxlib ppx_easy_deriving)
- (ppx_runtime_libraries ppx_easy_deriving.runtime)
  (preprocess (pps ppxlib.metaquot)))

src/vendor/ppx_easy_deriving/README.md

@@ -0,0 +1,4 @@
+# ppx_easy_deriving
+
+Goblint vendors a subset of the unreleased [ppx_easy_deriving](https://github.com/sim642/ppx_easy_deriving) library.
+It only includes products, excluding simples and variants.

src/vendor/ppx_easy_deriving/deriver.ml

@@ -0,0 +1,100 @@
+open Ppxlib
+open Ast_builder.Default
+
+include Deriver_intf
+
+module Make (Arg: Intf.S): S =
+struct
+  let attr = Attribute.declare (Printf.sprintf "deriving.%s.%s" Arg.name Arg.name) Attribute.Context.core_type Ast_pattern.(single_expr_payload __) (fun expr -> expr)
+
+  let unit ~loc = Arg.tuple ~loc []
+
+  let rec expr ~loc ~quoter ct =
+    match Attribute.get attr ct with
+    | Some expr ->
+      Expansion_helpers.Quoter.quote quoter expr
+    | None ->
+      match ct with
+      | [%type: unit] ->
+        unit ~loc
+      | {ptyp_desc = Ptyp_constr ({txt = lid; loc}, args); _} ->
+        let ident = pexp_ident ~loc {loc; txt = Expansion_helpers.mangle_lid (Prefix Arg.name) lid} in
+        let ident = Expansion_helpers.Quoter.quote quoter ident in
+        let apply_args = List.map (fun ct ->
+            (Nolabel, expr ~loc ~quoter ct)
+          ) args
+        in
+        pexp_apply ~loc ident apply_args
+      | {ptyp_desc = Ptyp_tuple elems; _} ->
+        expr_tuple ~loc ~quoter elems
+      | {ptyp_desc = Ptyp_var name; _} ->
+        evar ~loc ("poly_" ^ name)
+      | _ ->
+        pexp_extension ~loc (Location.error_extensionf ~loc "unsupported core type")
+
+  and expr_record ~loc ~quoter (lds: label_declaration list) =
+    let les = List.map (fun {pld_name = {txt = label; _}; pld_type; _} ->
+        (Lident label, expr ~loc ~quoter pld_type)
+      ) lds
+    in
+    Arg.record ~loc les
+
+  and expr_tuple ~loc ~quoter elems =
+    let es = List.map (expr ~loc ~quoter) elems in
+    Arg.tuple ~loc es
+
+  let expr_declaration ~loc ~quoter = function
+    | {ptype_kind = Ptype_abstract; ptype_manifest = Some ct; _} ->
+      expr ~loc ~quoter ct
+    | {ptype_kind = Ptype_abstract; _} ->
+      pexp_extension ~loc (Location.error_extensionf ~loc "unsupported abstract type")
+    | {ptype_kind = Ptype_variant constrs; _} ->
+      pexp_extension ~loc (Location.error_extensionf ~loc "unsupported variant type")
+    | {ptype_kind = Ptype_open; _} ->
+      pexp_extension ~loc (Location.error_extensionf ~loc "unsupported open type")
+    | {ptype_kind = Ptype_record fields; _} ->
+      expr_record ~loc ~quoter fields
+
+  let typ ~loc td =
+    let ct = Ppx_deriving.core_type_of_type_decl td in
+    Ppx_deriving.poly_arrow_of_type_decl
+      (Arg.typ ~loc)
+      td
+      (Arg.typ ~loc ct)
+
+  let generate_impl ~ctxt (_rec_flag, type_declarations) =
+    let loc = Expansion_context.Deriver.derived_item_loc ctxt in
+    let vbs = List.map (fun td ->
+        let quoter = Expansion_helpers.Quoter.create () in
+        let expr = expr_declaration ~loc ~quoter td in
+        let expr = Expansion_helpers.Quoter.sanitize quoter expr in
+        let expr = Ppx_deriving.poly_fun_of_type_decl td expr in
+        let ct = typ ~loc td in
+        let pat = ppat_var ~loc {loc; txt = Expansion_helpers.mangle_type_decl (Prefix Arg.name) td} in
+        let pat = ppat_constraint ~loc pat ct in
+        Ast_helper.Vb.mk ~loc ~attrs:[Ppx_deriving.attr_warning [%expr "-39"]] pat expr
+      ) type_declarations
+    in
+    [Ast_helper.Str.value ~loc Recursive vbs]
+
+  let generate_intf ~ctxt (_rec_flag, type_declarations) =
+    let loc = Expansion_context.Deriver.derived_item_loc ctxt in
+    List.map (fun td ->
+        let ct = typ ~loc td in
+        let val_ = Ast_helper.Val.mk ~loc {loc; txt = Expansion_helpers.mangle_type_decl (Prefix Arg.name) td} ct in
+        Ast_helper.Sig.value ~loc val_
+      ) type_declarations
+
+  let impl_generator = Deriving.Generator.V2.make_noarg generate_impl
+  let intf_generator = Deriving.Generator.V2.make_noarg generate_intf
+  let extension ~loc ~path:_ ct =
+    let quoter = Expansion_helpers.Quoter.create () in
+    let expr = expr ~loc ~quoter ct in
+    Expansion_helpers.Quoter.sanitize quoter expr
+
+  let register () =
+    Deriving.add Arg.name
+      ~sig_type_decl:intf_generator
+      ~str_type_decl:impl_generator
+      ~extension
+end

src/vendor/ppx_easy_deriving/deriver.mli

@@ -0,0 +1,3 @@
+(** Registerable deriver. *)
+
+include Deriver_intf.Deriver (** @inline *)

src/vendor/ppx_easy_deriving/deriver_intf.ml

@@ -0,0 +1,13 @@
+module type S =
+sig
+  val register: unit -> Ppxlib.Deriving.t
+  (** Register deriver with ppxlb. *)
+end
+
+module type Deriver =
+sig
+  module type S = S
+
+  module Make (_: Intf.S): S
+  (** Make registerable deriver. *)
+end

src/vendor/ppx_easy_deriving/dune

@@ -0,0 +1,4 @@
+(library
+ (name ppx_easy_deriving)
+ (libraries ppxlib ppx_deriving.api)
+ (preprocess (pps ppxlib.metaquot)))

src/vendor/ppx_easy_deriving/intf.ml

@@ -0,0 +1,64 @@
+(** Main interfaces. *)
+
+open Ppxlib
+
+(** Deriver name interface. *)
+module type Name =
+sig
+  val name: string
+  (** Deriver name.
+
+      For example, with the name "equal":
+      + Use [[@@deriving equal]] after a type definition.
+      + The derived value/function is [val equal: ...] (if the type is named [t]) or [val equal_ty: ...] (otherwise if the type is named [ty]).
+      + Use [[@equal ...]] after a type expression to override the underlying value/function used for it.
+      + Use [[%equal: ty]] as an expression for the value/function of type [ty]. *)
+end
+
+(** Deriver base interface. *)
+module type Base =
+sig
+  include Name
+  val typ: loc:location -> core_type -> core_type
+  (** Derived value/function type for a given type.
+
+      For example, "equal" deriver would map [t] to [t -> t -> bool]. *)
+end
+
+module Tuple =
+struct
+
+  (** Tuple deriver interface. *)
+  module type S =
+  sig
+    include Base
+    val tuple: loc:location -> expression list -> expression
+    (** Compose derived values/functions for tuple elements into derived value/function for the tuple. *)
+  end
+end
+
+module Record =
+struct
+
+  (** Record deriver interface. *)
+  module type S =
+  sig
+    include Base
+    val record: loc:location -> (longident * expression) list -> expression
+    (** Compose derived values/functions for record fields into derived value/function for the record. *)
+  end
+end
+
+module Full =
+struct
+
+  (** Full deriver interface. *)
+  module type S =
+  sig
+    include Tuple.S
+    include Record.S
+  end
+end
+
+module type S = Full.S
+(** Deriver interface. *)

src/vendor/ppx_easy_deriving/pat_exp.ml

@@ -0,0 +1,46 @@
+open Ppxlib
+open Ast_builder.Default
+
+type t =
+  | Record of (longident * t) list
+  | Tuple of t list
+  | Unit
+  | Base of string
+let create_record ~prefix ls =
+  Record (List.mapi (fun i l -> (l, Base (prefix ^ string_of_int (i + 1)))) ls)
+let create_tuple ~prefix n =
+  match n with
+  | 0 -> Unit
+  | 1 -> Base (prefix ^ "1")
+  | n -> Tuple (List.init n (fun i -> Base (prefix ^ string_of_int (i + 1))))
+let rec to_pat ~loc = function
+  | Record xs ->
+    ppat_record ~loc (List.map (fun (l, x) ->
+        (Located.mk ~loc l, to_pat ~loc x)
+      ) xs) Closed
+  | Tuple xs ->
+    ppat_tuple ~loc (List.map (to_pat ~loc) xs)
+  | Unit ->
+    [%pat? ()]
+  | Base s ->
+    ppat_var ~loc (Located.mk ~loc s)
+let rec to_exps ~loc = function
+  | Record xs ->
+    List.flatten (List.map (fun (_, x) -> to_exps ~loc x) xs)
+  | Tuple xs ->
+    List.flatten (List.map (to_exps ~loc) xs)
+  | Unit ->
+    []
+  | Base s ->
+    [pexp_ident ~loc {loc; txt = Lident s}]
+let rec to_exp ~loc = function
+  | Record xs ->
+    pexp_record ~loc (List.map (fun (l, x) ->
+        (Located.mk ~loc l, to_exp ~loc x)
+      ) xs) None
+  | Tuple xs ->
+    pexp_tuple ~loc (List.map (to_exp ~loc) xs)
+  | Unit ->
+    [%expr ()]
+  | Base s ->
+    pexp_ident ~loc {loc; txt = Lident s}

src/vendor/ppx_easy_deriving/pat_exp.mli

@@ -0,0 +1,16 @@
+(** Common representation of patterns and expressions. *)
+
+open Ppxlib
+
+type t =
+  | Record of (longident * t) list
+  | Tuple of t list
+  | Unit
+  | Base of string
+
+val create_record: prefix:string -> longident list -> t
+val create_tuple: prefix:string -> int -> t
+
+val to_pat: loc:location -> t -> pattern
+val to_exps: loc:location -> t -> expression list
+val to_exp: loc:location -> t -> expression

src/vendor/ppx_easy_deriving/ppx_easy_deriving.ml

@@ -0,0 +1,15 @@
+(** Library for easily defining PPX derivers without boilerplate and runtime overhead. *)
+
+(** {1 Interfaces} *)
+
+include Intf (** @inline *)
+
+
+(** {1 Deriver} *)
+
+module Deriver = Deriver
+
+
+(** {1 Easier constructs} *)
+
+module Product = Product