Merge pull request #104 from patricoferris/quadruples

Add quadruples

CHANGES.md

@@ -1,5 +1,7 @@
 ### Unreleased
 
+ - Add quadruples as another type combinator (#104, @patricoferris)
+
  - Expose the underlying `Jsonm.decoder` for custom JSON serialisation in
    functions like `Repr.like`. (#103, @patricoferris)
 

src/ppx_repr/lib/engine.ml

@@ -136,6 +136,7 @@ module Located (Attributes : Attributes.S) (A : Ast_builder.S) : S = struct
           (match List.length args with
           | 2 -> "pair"
           | 3 -> "triple"
+          | 4 -> "quad"
           | n -> Raise.Unsupported.tuple_size ~loc n)
           |> in_lib ~lib
           |> evar

src/ppx_repr/lib/raise.ml

@@ -21,7 +21,7 @@ let name = "ppx_repr"
 module Unsupported = struct
   let tuple_size ~loc count =
     Location.raise_errorf ~loc
-      "%s: tuple types must have 2 or 3 components. Found %d." name count
+      "%s: tuple types must have 2, 3 or 4 components. Found %d." name count
 
   let type_arrow ~loc ctyp =
     Location.raise_errorf ~loc

src/repr/binary.ml

@@ -522,3 +522,25 @@ module Triple = struct
       <+> using (fun (_, x, _) -> x) b
       <+> using (fun (_, _, x) -> x) c)
 end
+
+module Quad = struct
+  let encode a b c d (w, x, y, z) k =
+    a w k;
+    b x k;
+    c y k;
+    d z k
+
+  let decode a b c d buf pos_ref =
+    let a = a buf pos_ref in
+    let b = b buf pos_ref in
+    let c = c buf pos_ref in
+    let d = d buf pos_ref in
+    (a, b, c, d)
+
+  let sizer a b c d =
+    Sizer.(
+      using (fun (w, _, _, _) -> w) a
+      <+> using (fun (_, x, _, _) -> x) b
+      <+> using (fun (_, _, y, _) -> y) c
+      <+> using (fun (_, _, _, z) -> z) d)
+end

src/repr/binary_intf.ml

@@ -57,13 +57,35 @@ module type S3 = sig
   val sizer : 'a sizer -> 'b sizer -> 'c sizer -> ('a, 'b, 'c) t sizer
 end
 
+module type S4 = sig
+  type ('a, 'b, 'c, 'd) t
+
+  val encode :
+    'a encoder ->
+    'b encoder ->
+    'c encoder ->
+    'd encoder ->
+    ('a, 'b, 'c, 'd) t encoder
+
+  val decode :
+    'a decoder ->
+    'b decoder ->
+    'c decoder ->
+    'd decoder ->
+    ('a, 'b, 'c, 'd) t decoder
+
+  val sizer :
+    'a sizer -> 'b sizer -> 'c sizer -> 'd sizer -> ('a, 'b, 'c, 'd) t sizer
+end
+
 module type Intf = sig
   include module type of Types
 
   module type S = S
   module type S1 = S1
   module type S2 = S2
   module type S3 = S3
+  module type S4 = S4
 
   module Unit : S with type t := unit
   module Bool : S with type t := bool
@@ -83,4 +105,5 @@ module type Intf = sig
   module Option : S1 with type 'a t := 'a option
   module Pair : S2 with type ('a, 'b) t := 'a * 'b
   module Triple : S3 with type ('a, 'b, 'c) t := 'a * 'b * 'c
+  module Quad : S4 with type ('a, 'b, 'c, 'd) t := 'a * 'b * 'c * 'd
 end

src/repr/type.ml

@@ -36,6 +36,7 @@ let list ?(len = `Int) v = List { v; len }
 let array ?(len = `Int) v = Array { v; len }
 let pair a b = Tuple (Pair (a, b))
 let triple a b c = Tuple (Triple (a, b, c))
+let quad a b c d = Tuple (Quad (a, b, c, d))
 let option a = Option a
 let boxed t = Boxed t
 

src/repr/type_binary.ml

@@ -44,6 +44,10 @@ module Encode = struct
     let a = unstage a and b = unstage b and c = unstage c in
     stage (Bin.Triple.encode a b c)
 
+  let quad a b c d =
+    let a = unstage a and b = unstage b and c = unstage c and d = unstage d in
+    stage (Bin.Quad.encode a b c d)
+
   let option o =
     let o = unstage o in
     stage (Bin.Option.encode o)
@@ -92,6 +96,7 @@ module Encode = struct
   and tuple : type a. a tuple -> a encoder = function
     | Pair (x, y) -> pair (t x) (t y)
     | Triple (x, y, z) -> triple (t x) (t y) (t z)
+    | Quad (w, x, y, z) -> quad (t w) (t x) (t y) (t z)
 
   and map : type a b. boxed:bool -> (a, b) map -> b encoder =
    fun ~boxed { x; g; _ } ->
@@ -152,6 +157,10 @@ module Decode = struct
     let a = unstage a and b = unstage b and c = unstage c in
     stage (Bin.Triple.decode a b c)
 
+  let quad a b c d =
+    let a = unstage a and b = unstage b and c = unstage c and d = unstage d in
+    stage (Bin.Quad.decode a b c d)
+
   let option o =
     let o = unstage o in
     stage (Bin.Option.decode o)
@@ -204,6 +213,7 @@ module Decode = struct
   and tuple : type a. a tuple -> a decoder = function
     | Pair (x, y) -> pair (t x) (t y)
     | Triple (x, y, z) -> triple (t x) (t y) (t z)
+    | Quad (w, x, y, z) -> quad (t w) (t x) (t y) (t z)
 
   and map : type a b. boxed:bool -> (a, b) map -> b decoder =
    fun ~boxed { x; f; _ } ->
@@ -276,6 +286,7 @@ module Pre_hash = struct
   and tuple : type a. a tuple -> a pre_hash = function
     | Pair (x, y) -> Encode.pair (t x) (t y)
     | Triple (x, y, z) -> Encode.triple (t x) (t y) (t z)
+    | Quad (w, x, y, z) -> Encode.quad (t w) (t x) (t y) (t z)
 
   and map : type a b. (a, b) map -> b pre_hash =
    fun { x; g; _ } ->

src/repr/type_core_intf.ml

@@ -76,6 +76,7 @@ module Types = struct
   and 'a tuple =
     | Pair : 'a t * 'b t -> ('a * 'b) tuple
     | Triple : 'a t * 'b t * 'c t -> ('a * 'b * 'c) tuple
+    | Quad : 'a t * 'b t * 'c t * 'd t -> ('a * 'b * 'c * 'd) tuple
 
   and 'a record = {
     rwit : 'a Witness.t;

src/repr/type_intf.ml

@@ -70,6 +70,9 @@ module type DSL = sig
   val triple : 'a t -> 'b t -> 'c t -> ('a * 'b * 'c) t
   (** [triple x y z] is a representation of values of type [x * y * z]. *)
 
+  val quad : 'a t -> 'b t -> 'c t -> 'd t -> ('a * 'b * 'c * 'd) t
+  (** [quad w x y z] is a representation of values of type [w * x * y * z]. *)
+
   val result : 'a t -> 'b t -> ('a, 'b) result t
   (** [result a b] is a representation of values of type [(a, b) result]. *)
 

src/repr/type_json.ml

@@ -79,6 +79,14 @@ module Encode = struct
     c e z;
     lexeme e `Ae
 
+  let quad a b c d e (w, x, y, z) =
+    lexeme e `As;
+    a e w;
+    b e x;
+    c e y;
+    d e z;
+    lexeme e `Ae
+
   let boxed_option o e = function
     | None -> lexeme e `Null
     | Some x ->
@@ -106,6 +114,7 @@ module Encode = struct
   and tuple : type a. a tuple -> a encode_json = function
     | Pair (x, y) -> pair (t x) (t y)
     | Triple (x, y, z) -> triple (t x) (t y) (t z)
+    | Quad (w, x, y, z) -> quad (t w) (t x) (t y) (t z)
 
   and map : type a b. (a, b) map -> b encode_json =
    fun { x; g; _ } ->
@@ -287,6 +296,14 @@ module Decode = struct
     c e >>= fun z ->
     expect_lexeme e `Ae >|= fun () -> (x, y, z)
 
+  let quad a b c d e =
+    expect_lexeme e `As >>= fun () ->
+    a e >>= fun w ->
+    b e >>= fun x ->
+    c e >>= fun y ->
+    d e >>= fun z ->
+    expect_lexeme e `Ae >|= fun () -> (w, x, y, z)
+
   let unboxed_option o e = o e >|= fun v -> Some v
 
   let boxed_option o e =
@@ -323,6 +340,7 @@ module Decode = struct
   and tuple : type a. a tuple -> a decode_json = function
     | Pair (x, y) -> pair (t x) (t y)
     | Triple (x, y, z) -> triple (t x) (t y) (t z)
+    | Quad (w, x, y, z) -> quad (t w) (t x) (t y) (t z)
 
   and map : type a b. (a, b) map -> b decode_json =
    fun { x; f; _ } ->

src/repr/type_ordered.ml

@@ -79,6 +79,10 @@ module Refl = struct
         match (t a0 b0, t a1 b1, t a2 b2) with
         | Some Refl, Some Refl, Some Refl -> Some Refl
         | _ -> None)
+    | Quad (a0, a1, a2, a3), Quad (b0, b1, b2, b3) -> (
+        match (t a0 b0, t a1 b1, t a2 b2, t a3 b3) with
+        | Some Refl, Some Refl, Some Refl, Some Refl -> Some Refl
+        | _ -> None)
     | _ -> None
 end
 
@@ -122,6 +126,14 @@ module Equal = struct
     stage @@ fun ((x1, y1, z1) as a) ((x2, y2, z2) as b) ->
     a == b || (ex x1 x2 && ey y1 y2 && ez z1 z2)
 
+  let quad ew ex ey ez =
+    let ew = unstage ew
+    and ex = unstage ex
+    and ey = unstage ey
+    and ez = unstage ez in
+    stage @@ fun ((w1, x1, y1, z1) as a) ((w2, x2, y2, z2) as b) ->
+    a == b || (ew w1 w2 && ex x1 x2 && ey y1 y2 && ez z1 z2)
+
   let option e =
     let e = unstage e in
     stage @@ fun x y ->
@@ -156,6 +168,7 @@ module Equal = struct
   and tuple : type a. a tuple -> a equal staged = function
     | Pair (a, b) -> pair (t a) (t b)
     | Triple (a, b, c) -> triple (t a) (t b) (t c)
+    | Quad (a, b, c, d) -> quad (t a) (t b) (t c) (t d)
 
   and map : type a b. (a, b) map -> b equal staged =
    fun { x; g; _ } ->
@@ -260,6 +273,13 @@ module Compare = struct
     if a == b then 0
     else match cx x1 x2 with 0 -> pair (y1, z1) (y2, z2) | i -> i
 
+  let quad cw cx cy cz =
+    let cw = unstage cw in
+    let triple = unstage (triple cx cy cz) in
+    stage @@ fun ((w1, x1, y1, z1) as a) ((w2, x2, y2, z2) as b) ->
+    if a == b then 0
+    else match cw w1 w2 with 0 -> triple (x1, y1, z1) (x2, y2, z2) | i -> i
+
   let option c =
     let c = unstage c in
     stage @@ fun x y ->
@@ -307,6 +327,7 @@ module Compare = struct
   and tuple : type a. a tuple -> a compare staged = function
     | Pair (x, y) -> pair (t x) (t y)
     | Triple (x, y, z) -> triple (t x) (t y) (t z)
+    | Quad (w, x, y, z) -> quad (t w) (t x) (t y) (t z)
 
   and map : type a b. (a, b) map -> b compare staged =
    fun { x; g; _ } ->

src/repr/type_pp.ml

@@ -101,6 +101,17 @@ let dump t =
             ++ using (fun (_, b, _) -> b) (box (aux tb))
             ++ comma
             ++ using (fun (_, _, c) -> c) (box (aux tc))))
+    | Quad (ta, tb, tc, td) ->
+        (* There is no built-in formatter for quadruples in [Fmt.Dump]. *)
+        Fmt.(
+          parens
+            (using (fun (a, _, _, _) -> a) (box (aux ta))
+            ++ comma
+            ++ using (fun (_, b, _, _) -> b) (box (aux tb))
+            ++ comma
+            ++ using (fun (_, _, c, _) -> c) (box (aux tc))
+            ++ comma
+            ++ using (fun (_, _, _, d) -> d) (box (aux td))))
   and record : type a. a record -> a pp =
    fun t ->
     fields t
@@ -175,6 +186,8 @@ let ty : type a. a t Fmt.t =
     | Array a -> Fmt.pf ppf "@[%a array%a@]" ty a.v len a.len
     | Tuple (Pair (a, b)) -> Fmt.pf ppf "@[(%a * %a)@]" ty a ty b
     | Tuple (Triple (a, b, c)) -> Fmt.pf ppf "@[(%a * %a * %a)@]" ty a ty b ty c
+    | Tuple (Quad (a, b, c, d)) ->
+        Fmt.pf ppf "@[(%a * %a * %a * %a)@]" ty a ty b ty c ty d
     | Option t -> Fmt.pf ppf "@[%a option@]" ty t
     | Record { rname; rfields = Fields (fields, _); _ } ->
         Fmt.pf ppf "(@[<hv>%a>@] as %s)" pp_fields fields rname

src/repr/type_random.ml

@@ -101,6 +101,9 @@ and tuple : type a. a tuple -> a random = function
   | Triple (a, b, c) ->
       let+ a = t a and+ b = t b and+ c = t c in
       fun s -> (a s, b s, c s)
+  | Quad (a, b, c, d) ->
+      let+ a = t a and+ b = t b and+ c = t c and+ d = t d in
+      fun s -> (a s, b s, c s, d s)
 
 and option : type a. a t -> a option random =
  fun elt ->

src/repr/type_size.ml

@@ -90,6 +90,7 @@ and self : type a. a self -> a Sizer.t * a Sizer.t =
 and tuple : type a. a tuple -> a Sizer.t = function
   | Pair (x, y) -> Bin.Pair.sizer (t x) (t y)
   | Triple (x, y, z) -> Bin.Triple.sizer (t x) (t y) (t z)
+  | Quad (w, x, y, z) -> Bin.Quad.sizer (t w) (t x) (t y) (t z)
 
 and map : type a b. boxed:bool -> (a, b) map -> b Sizer.t =
  fun ~boxed { x; g; _ } -> Sizer.using g (if boxed then t x else unboxed x)

test/ppx_repr/deriver/errors/unsupported_tuple_size.expected

@@ -1,2 +1,2 @@
-File "unsupported_tuple_size.ml", line 1, characters 0-52:
-Error: ppx_repr: tuple types must have 2 or 3 components. Found 4.
+File "unsupported_tuple_size.ml", line 1, characters 0-59:
+Error: ppx_repr: tuple types must have 2, 3 or 4 components. Found 5.

test/ppx_repr/deriver/errors/unsupported_tuple_size.ml

@@ -1 +1 @@
-type t = unit * unit * unit * unit [@@deriving repr]
+type t = unit * unit * unit * unit * unit [@@deriving repr]

test/ppx_repr/deriver/passing/basic.expected

@@ -72,6 +72,12 @@ module Composite : sig  end =
       struct
         let test_triple_t = Repr.triple Repr.string Repr.int32 Repr.bool
       end[@@ocaml.doc "@inline"][@@merlin.hide ]
+    type test_quad = (string * int32 * bool * float)[@@deriving repr]
+    include
+      struct
+        let test_quad_t =
+          Repr.quad Repr.string Repr.int32 Repr.bool Repr.float
+      end[@@ocaml.doc "@inline"][@@merlin.hide ]
     type test_result = (int32 lazy_t, string) result[@@deriving repr]
     include
       struct
@@ -83,6 +89,7 @@ module Composite : sig  end =
     let (_ : test_option Repr.t) = test_option_t
     let (_ : test_pair Repr.t) = test_pair_t
     let (_ : test_triple Repr.t) = test_triple_t
+    let (_ : test_quad Repr.t) = test_quad_t
     let (_ : test_result Repr.t) = test_result_t
   end 
 module Inside_modules :

test/ppx_repr/deriver/passing/basic.ml

@@ -33,6 +33,7 @@ module Composite : sig end = struct
   type test_option = unit option [@@deriving repr]
   type test_pair = string * int32 [@@deriving repr]
   type test_triple = string * int32 * bool [@@deriving repr]
+  type test_quad = string * int32 * bool * float [@@deriving repr]
   type test_result = (int32 lazy_t, string) result [@@deriving repr]
 
   let (_ : test_list1 Repr.t) = test_list1_t
@@ -41,6 +42,7 @@ module Composite : sig end = struct
   let (_ : test_option Repr.t) = test_option_t
   let (_ : test_pair Repr.t) = test_pair_t
   let (_ : test_triple Repr.t) = test_triple_t
+  let (_ : test_quad Repr.t) = test_quad_t
   let (_ : test_result Repr.t) = test_result_t
 end
 

test/repr/main.ml

@@ -350,6 +350,9 @@ let test_to_string () =
   test "(int * string * bool)"
     T.(triple int string bool)
     (1, "foo", true) "[1,\"foo\",true]";
+  test "(int * string * bool * int)"
+    T.(quad int string bool int)
+    (1, "foo", true, 1) "[1,\"foo\",true,1]";
   test "(string, bool) result{ok}"
     T.(result string bool)
     (Ok "foo") "{\"ok\":\"foo\"}";