open Core
module Shape = Bin_prot.Shape;;

#verbose true

module type Interface_for_types_named_t = sig
  type t [@@deriving bin_shape]
end

[%%expect
  {|
module type Interface_for_types_named_t =
  sig type t val bin_shape_t : Shape.t end
|}]

module type Interface_for_types_named_other_than_t = sig
  type my_type [@@deriving bin_shape]
end

[%%expect
  {|
module type Interface_for_types_named_other_than_t =
  sig type my_type val bin_shape_my_type : Shape.t end
|}]

module Record = struct
  type r = { x : int } [@@deriving bin_shape]
end

[%%expect
  {|
module Record : sig type r = { x : int; } val bin_shape_r : Shape.t end
|}]

module Annotation_syntax = struct
  type t = int [@@deriving bin_shape ~annotate:"my-annotation"]
end

[%%expect
  {|
module Annotation_syntax : sig type t = int val bin_shape_t : Shape.t end
|}]

module Annotation_on_multi_type_dec = struct
  type t = int
  and u = float [@@deriving bin_shape ~annotate:"this-is-not-allowed"]
end

[%%expect
  {|
Line _, characters _-_:
Error: ppx_bin_shape: unexpected [~annotate] on multi type-declaration
|}]

module Annotation_syntax_uuid = struct
  let uuid = Shape.Uuid.of_string "test-it"

  type t = int [@@deriving bin_shape ~annotate:uuid]
end

[%%expect
  {|
module Annotation_syntax_uuid :
  sig val uuid : Shape.Uuid.t type t = int val bin_shape_t : Shape.t end
|}]

module Annotation_syntax_uuid_wrong_type = struct
  let uuid = true

  type t = int [@@deriving bin_shape ~annotate:uuid]
end

[%%expect
  {|
Line _, characters _-_:
Error: This expression has type bool but an expression was expected of type
         Shape.Uuid.t
|}]

module Inheriting_from_polymorphic_variant = struct
  type t1 =
    [ `A
    | `B of int
    ]
  [@@deriving bin_shape]

  type t2 =
    [ `C
    | t1
    ]
  [@@deriving bin_shape]
end

[%%expect
  {|
module Inheriting_from_polymorphic_variant :
  sig
    type t1 = [ `A | `B of int ]
    val bin_shape_t1 : Shape.t
    type t2 = [ `A | `B of int | `C ]
    val bin_shape_t2 : Shape.t
  end
|}]

module Inheriting_from_recursive_polymorphic_variant = struct
  type t1 =
    [ `A
    | `B of t1
    ]
  [@@deriving bin_shape]

  type t2 =
    [ `C
    | t1
    ]
  [@@deriving bin_shape ~hide_locations]

  let (_ : Shape.Digest.t) = Shape.eval_to_digest bin_shape_t2
end

[%%expect
  {|
Exception:
(Failure
 "<hidden>: The shape for an inherited type is not described as a polymorphic-variant: (Application ...())").
|}]

module Inheriting_from_annotated_polymorphic_variant = struct
  type t1 =
    [ `A
    | `B of int
    ]
  [@@deriving bin_shape ~annotate:"my-t1"]

  type t2 =
    [ `C
    | t1
    ]
  [@@deriving bin_shape ~hide_locations]

  let (_ : Shape.Digest.t) = Shape.eval_to_digest bin_shape_t2
end

[%%expect
  {|
Exception:
(Failure
 "<hidden>: The shape for an inherited type is not described as a polymorphic-variant: (Annotate my-t1 ...)").
|}]

module Duplicated_variant_constructor_allowed = struct
  type t1 = T1 [@@deriving bin_shape]
  type t2 = t1 [@@deriving bin_shape]
  type v1 = [ `a of t1 ] [@@deriving bin_shape]
  type v2 = [ `a of t2 ] [@@deriving bin_shape]

  type t =
    [ v1
    | v2
    ]
  [@@deriving bin_shape]
end

[%%expect
  {|
module Duplicated_variant_constructor_allowed :
  sig
    type t1 = T1
    val bin_shape_t1 : Shape.t
    type t2 = t1
    val bin_shape_t2 : Shape.t
    type v1 = [ `a of t2 ]
    val bin_shape_v1 : Shape.t
    type v2 = [ `a of t2 ]
    val bin_shape_v2 : Shape.t
    type t = [ `a of t2 ]
    val bin_shape_t : Shape.t
  end
|}]

module Duplicated_variant_constructor_Same_type_diff_serialization = struct
  type t1 = T1 [@@deriving bin_shape]
  type t2 = t1

  let bin_shape_t2 =
    Shape.(annotate (Uuid.of_string "t2 has a special meaning") bin_shape_t1)
  ;;

  type v1 = [ `a of t1 ] [@@deriving bin_shape]
  type v2 = [ `a of t2 ] [@@deriving bin_shape]

  type t =
    [ v1
    | v2
    ]
  [@@deriving bin_shape ~hide_locations]

  let (_ : Shape.Digest.t) = Shape.eval_to_digest bin_shape_t
end

[%%expect
  {|
Exception:
(Failure
 "<hidden>: Different shapes for duplicated polymorphic constructor: `a").
|}]

module No_such_bin_shape_syntax = struct
  type t = int [@@deriving bin_shape ~floob:"X"]
end

[%%expect
  {|
Line _, characters _-_:
Error: Ppxlib.Deriving: generator 'bin_shape' doesn't accept argument 'floob'
|}]

module Shapeless = struct
  type t = int
end

[%%expect
  {|
module Shapeless : sig type t = int end
|}]

module Annotation_requires_shape_on_subtypes = struct
  type t = Shapeless.t [@@deriving bin_shape ~annotate:"my-annotation"]
end

[%%expect
  {|
Line _, characters _-_:
Error: Unbound value Shapeless.bin_shape_t
|}]

module Not_allowed_both_annotation_and_basetype_syntax = struct
  type t = int [@@deriving bin_shape ~annotate:"X" ~basetype:"X"]
end

[%%expect
  {|
Line _, characters _-_:
Error: ppx_bin_shape: cannot write both [bin_shape ~annotate] and [bin_shape ~basetype]
|}]

module Basetype_syntax = struct
  type t = Shapeless.t [@@deriving bin_shape ~basetype:"my-base"]
end

[%%expect
  {|
module Basetype_syntax : sig type t = int val bin_shape_t : Shape.t end
|}]

module Basetype_syntax_kind2 = struct
  type ('a, 'b) t = 'a * 'b [@@deriving bin_shape ~basetype:"my-base-kind2"]
end

[%%expect
  {|
module Basetype_syntax_kind2 :
  sig
    type ('a, 'b) t = 'a * 'b
    val bin_shape_t : Shape.t -> Shape.t -> Shape.t
  end
|}]

module Basetype_on_multi_type_dec = struct
  type t = int
  and u = float [@@deriving bin_shape ~basetype:"this-is-not-allowed"]
end

[%%expect
  {|
Line _, characters _-_:
Error: ppx_bin_shape: unexpected [~basetype] on multi type-declaration
|}]

module Basetype_syntax_uuid = struct
  let uuid = Shape.Uuid.of_string "test-it"

  type t = Shapeless.t [@@deriving bin_shape ~basetype:uuid]
end

[%%expect
  {|
module Basetype_syntax_uuid :
  sig val uuid : Shape.Uuid.t type t = int val bin_shape_t : Shape.t end
|}]

module Basetype_syntax_uuid_wrong_type = struct
  let uuid = true

  type t = Shapeless.t [@@deriving bin_shape ~basetype:uuid]
end

[%%expect
  {|
Line _, characters _-_:
Error: This expression has type bool but an expression was expected of type
         Shape.Uuid.t
|}]

module Cannot_evaluate_shape_containing_type_vars = struct
  let (_ : _) = [%bin_shape: 'a list]
end

[%%expect
  {|
Line _, characters _-_:
Error: ppx_bin_shape: unexpected free type variable: 'a
|}]