Source file check.ml

(* Copyright (c) 2026, Cargocut and the Pidgin developers.
   All rights reserved.

   SPDX-License-Identifier: BSD-3-Clause *)

type value_error =
  | Unexpected_kind of
      { expected : Kind.t
      ; given : Kind.t
      ; value : Repr.t
      }
  | Invalid_list of
      { errors : (int * value_error) Nel.t
      ; value : Repr.t
      }
  | Invalid_record of
      { errors : record_error Nel.t
      ; value : Repr.t
      }
  | Unexpected_value of
      { value : Repr.t option
      ; message : string
      }

and record_error =
  | Invalid_field of
      { field : string Nel.t
      ; error : value_error
      }
  | Missing_field of string Nel.t
  | Invalid_subrecord of value_error

type 'a value = ('a, value_error) result
type ('a, 'b) fn = 'a -> 'b value
type 'a t = (Repr.t, 'a) fn
type 'a record = ('a, record_error Nel.t) result

module type CHECKABLE = sig
  type t

  val from_pidgin : (Repr.t, t) fn
end

let from (type a) (module C : CHECKABLE with type t = a) repr =
  C.from_pidgin repr
;;

module Infix = struct
  let ( <$> ) = Result.map
  let ( $ ) l f x = Result.map f (l x)
  let ( & ) l r x = Result.bind (l x) r
  let ( / ) l r x = Result.fold ~ok:Result.ok ~error:(fun _ -> r x) (l x)
end

module Syntax = struct
  let ( let+ ) x f = Result.map f x
  let ( let* ) = Result.bind

  let ( and+ ) a b =
    match a, b with
    | Ok x, Ok y -> Ok (x, y)
    | Error a, Error b -> Error (Nel.append a b)
    | Error err, _ | _, Error err -> Error err
  ;;

  let ( and* ) = ( and+ )
end

include Infix
include Syntax

let const x _ = Ok x

let raise_unexpected_kind expected value =
  let given = Kind.infer value in
  Unexpected_kind { given; expected; value } |> Result.error
;;

let map_expected_kind expected =
  Result.map_error (function
    | Unexpected_kind err -> Unexpected_kind { err with expected }
    | err -> err)
;;

let invalid_list value errors = Invalid_list { errors = Nel.rev errors; value }

let invalid_record value errors =
  Invalid_record { errors = Nel.rev errors; value }
;;

let missing_field ?(alt = []) field =
  Nel.singleton @@ Missing_field Nel.(make field alt)
;;

let invalid_field ?(alt = []) field error =
  Nel.singleton @@ Invalid_field { field = Nel.(make field alt); error }
;;

let invalid_subrecord err = Nel.singleton @@ Invalid_subrecord err
let unexpected_value ?value message = Unexpected_value { value; message }

let fail_with ?value message =
  message |> unexpected_value ?value |> Result.error
;;

let null = function
  | Repr.Null -> Ok ()
  | x -> raise_unexpected_kind Kind.null x
;;

let bool = function
  | Repr.Bool b -> Ok b
  | x -> raise_unexpected_kind Kind.bool x
;;

let int = function
  | Repr.Int i -> Ok i
  | x -> raise_unexpected_kind Kind.int x
;;

let float = function
  | Repr.Float f -> Ok f
  | Repr.Int i ->
    (* KLUDGE: Ugly trick because of the infamouse [number] type in
       JavaScript *)
    Ok (float_of_int i)
  | x -> raise_unexpected_kind Kind.float x
;;

let rec string ?(strict = true) = function
  | Repr.String s -> Ok s
  | Repr.Bool b when not strict -> Ok (if b then "true" else "false")
  | Repr.Int x when not strict -> Ok (string_of_int x)
  | Repr.Float x when not strict -> Ok (string_of_float x)
  | Repr.List [ x ] when not strict -> string ~strict x
  | x -> raise_unexpected_kind Kind.string x
;;

let list = function
  | Repr.List xs -> Ok xs
  | x ->
    (* NOTE: Since it can handle every repr, we probably do not want
       to build a complicated kind here. *)
    raise_unexpected_kind Kind.(list any) x
;;

let guard_nel = function
  | x :: xs -> Ok (Nel.make x xs)
  | [] -> fail_with ~value:(Repr.list []) "The list should not be empty"
;;

let nel = list & guard_nel

let list_of v = function
  | Repr.List xs as value ->
    let _i, mapped_result =
      List.fold_left
        (fun (i, acc) value ->
           let acc =
             match acc, v value with
             | Ok xs, Ok x -> Ok (x :: xs)
             | Error xs, Error x -> Error (Nel.cons (i, x) xs)
             | Error e, _ -> Error e
             | _, Error e -> Error (Nel.singleton (i, e))
           in
           i + 1, acc)
        (0, Ok [])
        xs
    in
    mapped_result
    |> Result.map List.rev
    |> Result.map_error (invalid_list value)
  | x ->
    (* NOTE: we cannot inspect the validator [v] here, so we lose the
       kind information. *)
    raise_unexpected_kind Kind.(list any) x
;;

let nel_of v = list_of v & guard_nel

let option some = function
  | Repr.Null -> Ok None
  | value -> Option.some <$> some value
;;

let k_sum_or_any constrs =
  match constrs with
  | [] ->
    (* KLUDGE: We can relay on non-empty list but it looks heavy.
       There is no [Kind.absurd] because it is an internal
       representation. *)
    Kind.record [ "absurd", Kind.any ]
  | x :: xs ->
    (* KLUDGE: since kind are not deductible from validators, we
       lose that information. *)
    Kind.sum Nel.(map (fun (c, _) -> c, Kind.any) (x :: xs))
;;

let record v = function
  | Repr.Record fields as value ->
    fields |> v |> Result.map_error (invalid_record value)
  | x ->
    (* NOTE: we cannot inspect the validator [v] here, so we lose the
       kind information for record classification. *)
    raise_unexpected_kind Kind.(record []) x
;;

let opt ?(normalize_keys = true) ?(alt = []) fields key v =
  let rec aux = function
    | [] -> Ok None
    | x :: xs ->
      (match Misc.find_assoc ~normalize_keys fields x with
       | None -> aux xs
       | Some Repr.Null -> Ok None
       | Some value ->
         (* NOTE: If the field exists we perform the validation. We
            don't skip the result if the validation is invalid
            because... it's optional, sure, but not lax!*)
         value
         |> v
         |> Result.map Option.some
         |> Result.map_error (invalid_field ~alt key))
  in
  aux (key :: alt)
;;

let handle_null ~alt key v =
  (* HACK: We want to handle optional field inside requirement
     validation. *)
  Repr.Null |> v |> Result.map_error (fun _ -> missing_field ~alt key)
;;

let req ?(normalize_keys = true) ?(alt = []) fields key v =
  let rec aux = function
    | [] -> handle_null ~alt key v
    | x :: xs ->
      (match Misc.find_assoc ~normalize_keys fields x with
       | None -> aux xs
       | Some Repr.Null -> handle_null ~alt key v
       | Some value -> value |> v |> Result.map_error (invalid_field ~alt key))
  in
  aux (key :: alt)
;;

let guard ?normalize_keys ?alt fields key v =
  req ?normalize_keys ?alt fields key (v & const ())
;;

let use_record fields v =
  Repr.record fields |> v |> Result.map_error invalid_subrecord
;;

let rec sum constrs = function
  (* Deal with real records *)
  | ( Repr.Record [ ("constr", String constr); ("value", value) ]
    | Repr.Record [ ("value", value); ("constr", String constr) ] ) as repr ->
    constr
    |> Misc.find_assoc constrs
    |> Option.fold
         ~none:(raise_unexpected_kind (k_sum_or_any constrs) repr)
         ~some:(fun v -> v value)
  (* Deal with desugaring *)
  | Repr.String constr
  | Repr.List [ String constr ]
  | Repr.List [ String constr; Null ]
  | Repr.Record [ ("constr", String constr) ] ->
    sum constrs ((Repr.sum (fun () -> constr, Repr.null ())) ())
  | Repr.List [ String constr; v ] ->
    sum constrs ((Repr.sum (fun () -> constr, v)) ())
  | repr ->
    (* Error handling *)
    raise_unexpected_kind (k_sum_or_any constrs) repr
;;

let result ~ok ~error =
  sum [ "ok", ok $ Result.ok; "error", error $ Result.error ]
;;

let either ~left ~right =
  sum [ "left", left $ Either.left; "right", right $ Either.right ]
;;

let rec pair fst snd = function
  | Repr.Record [ _; _ ] as repr ->
    record
      (fun fields ->
         let+ a = req fields "first" ~alt:[ "fst" ] fst
         and+ b = req fields "second" ~alt:[ "snd" ] snd in
         a, b)
      repr
  | List [ a; b ] -> pair fst snd (Repr.pair Fun.id Fun.id (a, b))
  | List [ a ] -> pair fst snd (Repr.pair Fun.id Repr.null (a, ()))
  | List [] ->
    pair fst snd Repr.(record [ "first", null (); "second", null () ])
  | repr -> raise_unexpected_kind Kind.(pair any any) repr
;;

let rec triple f s t = function
  | Repr.List [ a; b; c ] ->
    triple f s t (Repr.triple Fun.id Fun.id Fun.id (a, b, c))
  | Repr.List [ a; b ] ->
    triple f s t Repr.(triple Fun.id Fun.id null (a, b, ()))
  | Repr.List [ a ] -> triple f s t Repr.(triple Fun.id null null (a, (), ()))
  | repr ->
    repr
    |> (pair f (pair s t) $ fun (a, (b, c)) -> a, b, c)
    |> map_expected_kind Kind.(pair any (pair any any))
;;

let where ?value ?(message = "Predicate not satisfied") predicate x =
  if predicate x then Ok x else fail_with ?value message
;;

let unless ?value ?(message = "Predicate satisfied") predicate x =
  if not (predicate x) then Ok x else fail_with ?value message
;;

let where_opt ?value ?(message = "Predicate not satisfied") predicate x =
  match predicate x with
  | Some x -> Ok x
  | None -> fail_with ?value message
;;

let int32 = function
  | Repr.Int x -> Ok (Int32.of_int x)
  | repr ->
    repr
    |> sum
         [ ( "int32"
           , string ~strict:false
             & where_opt
                 ~value:repr
                 ~message:"int32 expected"
                 Int32.of_string_opt )
         ]
    |> map_expected_kind Kind.(or_ int (branch "int32" string))
;;

let int64 = function
  | Repr.Int x -> Ok (Int64.of_int x)
  | repr ->
    repr
    |> (int32 $ Int64.of_int32)
       / sum
           [ ( "int64"
             , string ~strict:false
               & where_opt
                   ~value:repr
                   ~message:"int64 expected"
                   Int64.of_string_opt )
           ]
    |> map_expected_kind
         Kind.(
           unify Nel.(int :: [ branch "int32" string; branch "int64" string ]))
;;

let number = function
  | Repr.Int x -> Ok (Float.of_int x)
  | Repr.Float x -> Ok x
  | repr ->
    repr
    |> (int32 $ Int32.to_float) / (int64 $ Int64.to_float)
    |> map_expected_kind
         Kind.(
           unify
             Nel.(
               int :: [ float; branch "int32" string; branch "int64" string ]))
;;

let char = function
  | Repr.String s when Int.equal (Stdlib.String.length s) 1 -> Ok s.[0]
  | Repr.Int i as repr ->
    (try Ok (Char.chr i) with
     | _ -> fail_with ~value:repr "char expected")
  | repr -> fail_with ~value:repr "char expected"
;;

let make_to_string to_repr to_string =
  match to_string, to_repr with
  | Some ts, _ -> Some ts
  | None, Some tr -> Some (fun x -> x |> tr |> Repr.to_string)
  | None, None -> None
;;

let equal ?to_repr ?to_string ?(eq = Stdlib.( = )) a b =
  if eq a b
  then Ok b
  else (
    let value = Option.map (fun f -> f b) to_repr in
    let to_string = make_to_string to_repr to_string in
    let message =
      match to_string with
      | None -> "The two values are not equal"
      | Some f -> "`" ^ f a ^ "` is not equal to `" ^ f b ^ "`"
    in
    fail_with ?value message)
;;

let not_equal ?to_repr ?to_string ?(eq = Stdlib.( = )) a b =
  if not (eq a b)
  then Ok b
  else (
    let value = Option.map (fun f -> f b) to_repr in
    let to_string = make_to_string to_repr to_string in
    let message =
      match to_string with
      | None -> "The two values are equal"
      | Some f -> "`" ^ f a ^ "` is equal to `" ^ f b ^ "`"
    in
    fail_with ?value message)
;;

let one_of ?to_repr ?to_string ?(eq = Stdlib.( = )) xs x =
  match List.find_opt (eq x) xs with
  | Some x -> Ok x
  | None ->
    let value = Option.map (fun f -> f x) to_repr in
    let to_string = make_to_string to_repr to_string in
    let message =
      match to_string with
      | None -> "The given value is not included in the given list"
      | Some f ->
        "`"
        ^ f x
        ^ "` is not included into `["
        ^ Misc.concat_with ~sep:"; " f xs
        ^ "]`"
    in
    fail_with ?value message
;;

let gt ?to_repr ?to_string ?(cmp = Stdlib.compare) a b =
  if cmp b a > 0
  then Ok b
  else (
    let value = Option.map (fun f -> f b) to_repr in
    let to_string = make_to_string to_repr to_string in
    let message =
      match to_string with
      | None -> "The given value is not greater than the expected value"
      | Some f -> "`" ^ f b ^ "` is not greater than `" ^ f a ^ "`"
    in
    fail_with ?value message)
;;

let ge ?to_repr ?to_string ?(cmp = Stdlib.compare) a b =
  if cmp b a >= 0
  then Ok b
  else (
    let value = Option.map (fun f -> f b) to_repr in
    let to_string = make_to_string to_repr to_string in
    let message =
      match to_string with
      | None ->
        "The given value is noit greater or equal than the expected value"
      | Some f -> "`" ^ f b ^ "` is not greater or equal than `" ^ f a ^ "`"
    in
    fail_with ?value message)
;;

let lt ?to_repr ?to_string ?(cmp = Stdlib.compare) a b =
  if cmp b a < 0
  then Ok b
  else (
    let value = Option.map (fun f -> f b) to_repr in
    let to_string = make_to_string to_repr to_string in
    let message =
      match to_string with
      | None -> "The given value is not lower than the expected value"
      | Some f -> "`" ^ f b ^ "` is not lower than `" ^ f a ^ "`"
    in
    fail_with ?value message)
;;

let le ?to_repr ?to_string ?(cmp = Stdlib.compare) a b =
  if cmp b a <= 0
  then Ok b
  else (
    let value = Option.map (fun f -> f b) to_repr in
    let to_string = make_to_string to_repr to_string in
    let message =
      match to_string with
      | None -> "The given value is not lower or equal than the expected value"
      | Some f -> "`" ^ f b ^ "` is not lower or equal than `" ^ f a ^ "`"
    in
    fail_with ?value message)
;;

let contains ?to_repr ?to_string ?(cmp = Stdlib.compare) ~min ~max x =
  let min = Stdlib.min min max
  and max = Stdlib.max min max in
  if cmp x min >= 0 && cmp x max <= 0
  then Ok x
  else (
    let value = Option.map (fun f -> f x) to_repr in
    let to_string = make_to_string to_repr to_string in
    let message =
      match to_string with
      | None -> "The given value is not included in the given range"
      | Some f ->
        "`"
        ^ f x
        ^ "` is not included in the range [`"
        ^ f min
        ^ "` .. `"
        ^ f max
        ^ "`]"
    in
    fail_with ?value message)
;;

module type EQUATABLE = sig
  type t

  val to_repr : t Repr.conv
  val to_string : t -> string
  val equal : t -> t -> bool
end

module type NUM = sig
  include EQUATABLE

  val compare : t -> t -> int
  val zero : t
  val one : t
  val two : t
  val rem : t -> t -> t
end

module Make_eq (E : EQUATABLE) = struct
  let equal = equal ~to_repr:E.to_repr ~to_string:E.to_string ~eq:E.equal

  let not_equal =
    not_equal ~to_repr:E.to_repr ~to_string:E.to_string ~eq:E.equal
  ;;

  let one_of = one_of ~to_repr:E.to_repr ~to_string:E.to_string ~eq:E.equal
  let where ?message pred x = where ~value:(E.to_repr x) ?message pred x
  let where_opt ?message pred x = where_opt ~value:(E.to_repr x) ?message pred x
end

module Make_num (N : NUM) = struct
  include Make_eq (N)

  let gt = gt ~to_repr:N.to_repr ~to_string:N.to_string ~cmp:N.compare
  let ge = ge ~to_repr:N.to_repr ~to_string:N.to_string ~cmp:N.compare
  let lt = lt ~to_repr:N.to_repr ~to_string:N.to_string ~cmp:N.compare
  let le = le ~to_repr:N.to_repr ~to_string:N.to_string ~cmp:N.compare

  let contains =
    contains ~to_repr:N.to_repr ~to_string:N.to_string ~cmp:N.compare
  ;;

  let is_positive x =
    if N.compare x N.zero >= 0
    then Ok x
    else
      fail_with ~value:(N.to_repr x) ("`" ^ N.to_string x ^ "` is not positive")
  ;;

  let is_negative x =
    if N.compare x N.zero < 0
    then Ok x
    else
      fail_with ~value:(N.to_repr x) ("`" ^ N.to_string x ^ "` is not negative")
  ;;

  let is_odd x =
    if N.equal (N.rem x N.two) N.one
    then Ok x
    else fail_with ~value:(N.to_repr x) ("`" ^ N.to_string x ^ "` is not odd")
  ;;

  let is_even x =
    if N.equal (N.rem x N.two) N.zero
    then Ok x
    else fail_with ~value:(N.to_repr x) ("`" ^ N.to_string x ^ "` is not even")
  ;;
end

module Int = Make_num (struct
    type t = int

    let to_repr = Repr.int
    let to_string = string_of_int
    let equal = Stdlib.Int.equal
    let compare = Stdlib.Int.compare
    let zero = 0
    let one = 1
    let two = 2
    let rem a b = a mod b
  end)

module Int32 = Make_num (struct
    type t = int32

    let to_repr = Repr.int32
    let to_string = Int32.to_string
    let equal = Int32.equal
    let compare = Int32.compare
    let zero = 0l
    let one = 1l
    let two = 2l
    let rem a b = Int32.rem a b
  end)

module Int64 = Make_num (struct
    type t = int64

    let to_repr = Repr.int64
    let to_string = Int64.to_string
    let equal = Int64.equal
    let compare = Int64.compare
    let zero = 0L
    let one = 1L
    let two = 2L
    let rem a b = Int64.rem a b
  end)

module Float = Make_num (struct
    type t = float

    let to_repr = Repr.float
    let to_string = Stdlib.string_of_float
    let equal = Float.equal
    let compare = Float.compare
    let zero = 0.0
    let one = 1.0
    let two = 2.0
    let rem a b = Float.rem a b
  end)

module String = struct
  include Make_eq (struct
      type t = string

      let to_repr = Repr.string
      let to_string x = x
      let equal = String.equal
    end)

  let not_empty = function
    | "" -> fail_with ~value:(Repr.string "") "the given string is empty"
    | xs -> Ok xs
  ;;

  let not_blank x =
    match String.trim x with
    | "" -> fail_with ~value:(Repr.string x) "the given string is blank"
    | _ -> Ok x
  ;;

  let has_length n x =
    let len = Stdlib.String.length x in
    if Stdlib.Int.equal n len
    then Ok x
    else
      fail_with
        ~value:(Repr.string x)
        ("`"
         ^ x
         ^ "` has length `"
         ^ string_of_int len
         ^ "` and not `"
         ^ string_of_int n
         ^ "`")
  ;;

  let minimal_length m x =
    let len = Stdlib.String.length x in
    if len >= m
    then Ok x
    else
      fail_with
        ~value:(Repr.string x)
        ("`"
         ^ x
         ^ "` has length `"
         ^ string_of_int len
         ^ "` which is not greater or equal to `"
         ^ string_of_int m
         ^ "`")
  ;;

  let maximal_length m x =
    let len = Stdlib.String.length x in
    if len <= m
    then Ok x
    else
      fail_with
        ~value:(Repr.string x)
        ("`"
         ^ x
         ^ "` has length `"
         ^ string_of_int len
         ^ "` which is not lower or equal to `"
         ^ string_of_int m
         ^ "`")
  ;;

  let length_between ~min ~max =
    let min = Stdlib.min min max
    and max = Stdlib.max min max in
    minimal_length min & maximal_length max
  ;;

  let has_prefix prefix x =
    if Stdlib.String.starts_with ~prefix x
    then Ok x
    else
      fail_with
        ~value:(Repr.string x)
        ("`" ^ x ^ "` does not have the prefix `" ^ prefix ^ "`")
  ;;

  let has_suffix suffix x =
    if Stdlib.String.ends_with ~suffix x
    then Ok x
    else
      fail_with
        ~value:(Repr.string x)
        ("`" ^ x ^ "` does not have the suffix `" ^ suffix ^ "`")
  ;;
end

module Char = struct
  include Make_eq (struct
      type t = char

      let to_string x = Stdlib.String.make 1 x
      let to_repr x = Repr.string (to_string x)
      let equal = Char.equal
    end)

  let is_digit = one_of [ '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9' ]
  let as_digit = is_digit $ fun x -> Char.(code x - code '0')

  let is_hex_digit =
    one_of
      [ '0'
      ; '1'
      ; '2'
      ; '3'
      ; '4'
      ; '5'
      ; '6'
      ; '7'
      ; '8'
      ; '9'
      ; 'a'
      ; 'b'
      ; 'c'
      ; 'd'
      ; 'e'
      ; 'f'
      ; 'A'
      ; 'B'
      ; 'C'
      ; 'D'
      ; 'E'
      ; 'F'
      ]
  ;;

  let as_hex_digit =
    is_hex_digit
    $ function
    | '0' .. '9' as x -> Char.(code x - code '0')
    | 'a' .. 'f' as x -> Char.(code x - code 'a') + 10
    | 'A' .. 'F' as x -> Char.(code x - code 'A') + 10
    | _ -> 0 (* unreachable *)
  ;;

  let is_alpha c =
    where
      ~message:("`" ^ Stdlib.String.make 1 c ^ "` is not a letter")
      (function
        | 'a' .. 'z' | 'A' .. 'Z' -> true
        | _ -> false)
      c
  ;;

  let is_alphanumeric c =
    where
      ~message:("`" ^ Stdlib.String.make 1 c ^ "` is not alphanumeric")
      (function
        | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' -> true
        | _ -> false)
      c
  ;;

  let is_lowercase c =
    where
      ~message:("`" ^ Stdlib.String.make 1 c ^ "` is not lowercase")
      (function
        | 'a' .. 'z' -> true
        | _ -> false)
      c
  ;;

  let is_uppercase c =
    where
      ~message:("`" ^ Stdlib.String.make 1 c ^ "` is not uppercase")
      (function
        | 'a' .. 'z' -> true
        | _ -> false)
      c
  ;;

  let is_whitespace c =
    where
      ~message:("`" ^ Stdlib.String.make 1 c ^ "` is not a whitespace")
      (function
        | ' ' | '\t' | '\n' | '\011' | '\012' | '\r' -> true
        | _ -> false)
      c
  ;;

  let is_newline c =
    where
      ~message:("`" ^ Stdlib.String.make 1 c ^ "` is not a newline")
      (function
        | '\n' | '\r' -> true
        | _ -> false)
      c
  ;;
end