open! Import
open Std_internal
open Validated_intf

module type Raw = Raw

type ('raw, 'witness) t = 'raw

module type S = S with type ('a, 'b) validated := ('a, 'b) t

module type S_allowing_substitution =
  S_allowing_substitution with type ('a, 'b) validated := ('a, 'b) t

module type S_bin_io = S_bin_io with type ('a, 'b) validated := ('a, 'b) t

module type S_bin_io_compare_hash_sexp =
  S_bin_io_compare_hash_sexp with type ('a, 'b) validated := ('a, 'b) t

let raw t = t

module Make (Raw : Raw) = struct
  type witness
  type t = Raw.t [@@deriving sexp_of]

  let validation_failed t error =
    Error.create
      "validation failed"
      (t, error, Raw.here)
      [%sexp_of: Raw.t * Error.t * Source_code_position.t]
  ;;

  let create_exn t =
    match Validate.result (Raw.validate t) with
    | Ok () -> t
    | Error error -> Error.raise (validation_failed t error)
  ;;

  let create t =
    match Validate.result (Raw.validate t) with
    | Ok () -> Ok t
    | Error error -> Error (validation_failed t error)
  ;;

  let t_of_sexp sexp = create_exn (Raw.t_of_sexp sexp)
  let raw t = t

  let create_stable_witness raw_stable_witness =
    Stable_witness.of_serializable raw_stable_witness create_exn raw
  ;;

  let type_equal = Type_equal.T
end

module Add_bin_io (Raw : sig
    type t [@@deriving bin_io]

    include Raw_bin_io with type t := t
  end)
    (Validated : S with type raw := Raw.t) =
struct
  include
    Binable.Of_binable_without_uuid [@alert "-legacy"]
      (Raw)
      (struct
        type t = Raw.t

        let of_binable raw =
          if Raw.validate_binio_deserialization then Validated.create_exn raw else raw
        ;;

        let to_binable = Fn.id
      end)
end

module Add_compare (Raw : sig
    type t [@@deriving compare]

    include Raw with type t := t
  end)
    (_ : S with type raw := Raw.t) =
struct
  let compare t1 t2 = [%compare: Raw.t] (raw t1) (raw t2)
end

module Add_hash (Raw : sig
    type t [@@deriving hash]

    include Raw with type t := t
  end)
    (Validated : S with type raw := Raw.t) =
struct
  let hash_fold_t state t = Raw.hash_fold_t state (Validated.raw t)
  let hash t = Raw.hash (Validated.raw t)
end

module Add_typerep (Raw : sig
    type t [@@deriving typerep]

    include Raw with type t := t
  end)
    (_ : S with type raw := Raw.t) =
struct
  type t = Raw.t [@@deriving typerep]
end

module Make_binable (Raw : Raw_bin_io) = struct
  module T0 = Make (Raw)
  include T0
  include Add_bin_io (Raw) (T0)
end

module Make_bin_io_compare_hash_sexp (Raw : sig
    type t [@@deriving compare, hash]

    include Raw_bin_io with type t := t
  end) =
struct
  module T = Make_binable (Raw)
  include T
  include Add_compare (Raw) (T)

  include (
    Add_hash (Raw) (T) :
    sig
      type t [@@deriving hash]
    end
    with type t := t)
end
