{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

-- |
--
--    @Validity@ is used to specify additional invariants upon values that are not
--    enforced by the type system.
--
--    Let's take an example.
--    Suppose we were to implement a type @Prime@ that represents prime integers.
--
--    If you were to completely enforce the invariant that the represented number is
--    a prime, then we could use 'Natural' and only store the index of the
--    given prime in the infinite sequence of prime numbers.
--    This is very safe but also very expensive if we ever want to use the number,
--    because we would have to calculcate all the prime numbers until that index.
--
--    Instead we choose to implement @Prime@ by a @newtype Prime = Prime Int@.
--    Now we have to maintain the invariant that the @Int@ that we use to represent
--    the prime is in fact positive and a prime.
--
--    The @Validity@ typeclass allows us to specify this invariant (and enables
--    testing via the @genvalidity@ libraries:
--    https://hackage.haskell.org/package/genvalidity ):
--
--    > instance Validity Prime where
--    >     validate (Prime n) = check (isPrime n) "The 'Int' is prime."
--
--    If certain typeclass invariants exist, you can make these explicit in the
--    validity instance as well.
--    For example, 'Fixed a' is only valid if 'a' has an 'HasResolution' instance,
--    so the correct validity instance is @HasResolution a => Validity (Fixed a)@.
module Data.Validity
  ( Validity (..),

    -- * Helper functions to define 'validate'
    trivialValidation,
    genericValidate,
    check,
    declare,
    annotate,
    delve,
    decorate,
    decorateList,
    decorateString,
    invalid,
    valid,

    -- ** Helpers for specific types

    -- *** Char
    validateCharNotUtf16SurrogateCodePoint,
    isUtf16SurrogateCodePoint,
    validateCharNotLineSeparator,
    isLineSeparator,
    validateStringSingleLine,
    isSingleLine,

    -- *** RealFloat (Double)
    validateNotNaN,
    validateNotInfinite,

    -- *** Ratio
    validateRatioNotNaN,
    validateRatioNotInfinite,
    validateRatioNormalised,

    -- * Utilities

    -- ** Utilities for validity checking
    isValid,
    isInvalid,
    constructValid,
    constructValidUnsafe,

    -- ** Utilities for validation
    Validation (..),
    ValidationChain (..),
    checkValidity,
    validationIsValid,
    prettyValidate,
    prettyValidation,

    -- * Re-exports
    Monoid (..),
    Semigroup (..),
  )
where

import Data.Bits ((.&.))
import Data.Char (ord)
import Data.Either (isRight)
import Data.Fixed (Fixed (MkFixed), HasResolution)
import Data.Int (Int64)
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Maybe (fromMaybe)
#if MIN_VERSION_base(4,16,0)
import GHC.Exts (Char (..), isTrue#, ord#, (<=#), (>=#))
#else
import GHC.Exts (Char (..), isTrue#, leWord#, ord#, (<=#), (>=#))
#endif
import Data.Functor.Const (Const (Const))
import Data.Functor.Identity (Identity (Identity))
import Data.Monoid (Alt, Dual)
import qualified Data.Monoid as Monoid
import qualified Data.Semigroup as Semigroup
import GHC.Generics
import GHC.Int (Int16 (..), Int32 (..), Int8 (..))
import GHC.Natural
import GHC.Real (Ratio (..))
import GHC.Word (Word16 (..), Word32 (..), Word64 (..), Word8 (..))

-- | A class of types that have additional invariants defined upon them

--
-- === Purpose
--
-- 'validate' checks whether a given value is a valid value and reports all
-- reasons why the given value is not valid if that is the case.
--
-- 'isValid' only checks whether a given value is a valid value of its type.
-- It is a helper function that checks that 'validate' says that there are
-- no reasons why the value is invalid.
--
-- === Instantiating 'Validity'
--
-- To instantiate 'Validity', one has to implement only 'validate'.
-- Use the helper functions below to define all the reasons why a given
-- value would be a valid value of its type.
--
-- Example:
--
-- > newtype Even = Even Int
-- >
-- > instance Validity Even
-- >     validate (Event i)
-- >       even i <?@> "The contained 'Int' is even."
--
-- === Semantics
--
-- 'validate' should be an underapproximation of actual validity.
--
-- This means that if 'isValid' is not a perfect representation of actual
-- validity, for safety reasons, it should never return 'True' for invalid
-- values, but it may return 'False' for valid values.
--
-- For example:
--
-- > validate = const $ invalid "always"
--
-- is a valid implementation for any type, because now 'isValid' never returns
-- 'True' for invalid values.
--
-- > validate (Even i) = declare "The integer is equal to two" $ i == 2
--
-- is a valid implementation for @newtype Even = Even Int@, but
--
-- > validate (Even i) = declare "The integer is even or equal to one" $ even i || i == 1
--
-- is not because then `isValid` returns 'True' for an invalid value: '1'.
--
-- === Automatic instances with 'Generic'
--
-- An instance of this class can be made automatically if the type in question
-- has a 'Generic' instance. This instance will try to use 'valid' to
-- on all structural sub-parts of the value that is being checked for validity.
--
-- Example:
--
-- > {-# LANGUAGE DeriveGeneric #-}
-- >
-- > data MyType = MyType
-- >     { myDouble :: Double
-- >     { myString :: String
-- >     } deriving (Show, Eq, Generic)
-- >
-- > instance Validity MyType
--
-- generates something like:
--
-- > instance Validity MyType where
-- >     validate (MyType d s)
-- >         = annotate d "myDouble"
-- >        <> annotate s "myString"
class Validity a where
  validate :: a -> Validation
  default validate ::
    (Generic a, GValidity (Rep a)) =>
    a ->
    Validation
  validate = a -> Validation
forall a. (Generic a, GValidity (Rep a)) => a -> Validation
genericValidate

genericValidate :: (Generic a, GValidity (Rep a)) => a -> Validation
genericValidate :: forall a. (Generic a, GValidity (Rep a)) => a -> Validation
genericValidate = Rep a Any -> Validation
forall a. Rep a a -> Validation
forall (f :: * -> *) a. GValidity f => f a -> Validation
gValidate (Rep a Any -> Validation) -> (a -> Rep a Any) -> a -> Validation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from

data ValidationChain
  = Violated String
  | Location
      String
      ValidationChain
  deriving (Int -> ValidationChain -> ShowS
[ValidationChain] -> ShowS
ValidationChain -> String
(Int -> ValidationChain -> ShowS)
-> (ValidationChain -> String)
-> ([ValidationChain] -> ShowS)
-> Show ValidationChain
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValidationChain -> ShowS
showsPrec :: Int -> ValidationChain -> ShowS
$cshow :: ValidationChain -> String
show :: ValidationChain -> String
$cshowList :: [ValidationChain] -> ShowS
showList :: [ValidationChain] -> ShowS
Show, ValidationChain -> ValidationChain -> Bool
(ValidationChain -> ValidationChain -> Bool)
-> (ValidationChain -> ValidationChain -> Bool)
-> Eq ValidationChain
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValidationChain -> ValidationChain -> Bool
== :: ValidationChain -> ValidationChain -> Bool
$c/= :: ValidationChain -> ValidationChain -> Bool
/= :: ValidationChain -> ValidationChain -> Bool
Eq, (forall x. ValidationChain -> Rep ValidationChain x)
-> (forall x. Rep ValidationChain x -> ValidationChain)
-> Generic ValidationChain
forall x. Rep ValidationChain x -> ValidationChain
forall x. ValidationChain -> Rep ValidationChain x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ValidationChain -> Rep ValidationChain x
from :: forall x. ValidationChain -> Rep ValidationChain x
$cto :: forall x. Rep ValidationChain x -> ValidationChain
to :: forall x. Rep ValidationChain x -> ValidationChain
Generic)

instance Validity ValidationChain

-- | The result of validating a value.
--
-- `mempty` means the value was valid.
--
-- This type intentionally doesn't have a `Validity` instance to make sure
-- you can never accidentally use `annotate` or `delve` twice.
newtype Validation = Validation
  { Validation -> [ValidationChain]
unValidation :: [ValidationChain]
  }
  deriving (Int -> Validation -> ShowS
[Validation] -> ShowS
Validation -> String
(Int -> Validation -> ShowS)
-> (Validation -> String)
-> ([Validation] -> ShowS)
-> Show Validation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Validation -> ShowS
showsPrec :: Int -> Validation -> ShowS
$cshow :: Validation -> String
show :: Validation -> String
$cshowList :: [Validation] -> ShowS
showList :: [Validation] -> ShowS
Show, Validation -> Validation -> Bool
(Validation -> Validation -> Bool)
-> (Validation -> Validation -> Bool) -> Eq Validation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Validation -> Validation -> Bool
== :: Validation -> Validation -> Bool
$c/= :: Validation -> Validation -> Bool
/= :: Validation -> Validation -> Bool
Eq, (forall x. Validation -> Rep Validation x)
-> (forall x. Rep Validation x -> Validation) -> Generic Validation
forall x. Rep Validation x -> Validation
forall x. Validation -> Rep Validation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Validation -> Rep Validation x
from :: forall x. Validation -> Rep Validation x
$cto :: forall x. Rep Validation x -> Validation
to :: forall x. Rep Validation x -> Validation
Generic)

instance Semigroup Validation where
  (Validation [ValidationChain]
v1) <> :: Validation -> Validation -> Validation
<> (Validation [ValidationChain]
v2) = [ValidationChain] -> Validation
Validation ([ValidationChain] -> Validation)
-> [ValidationChain] -> Validation
forall a b. (a -> b) -> a -> b
$ [ValidationChain]
v1 [ValidationChain] -> [ValidationChain] -> [ValidationChain]
forall a. [a] -> [a] -> [a]
++ [ValidationChain]
v2

instance Monoid Validation where
  mempty :: Validation
mempty = [ValidationChain] -> Validation
Validation []
  mappend :: Validation -> Validation -> Validation
mappend = Validation -> Validation -> Validation
forall a. Semigroup a => a -> a -> a
(<>)

-- | Declare any value to be valid in validation
--
-- > trivialValidation a = seq a mempty
trivialValidation :: a -> Validation
trivialValidation :: forall a. a -> Validation
trivialValidation a
a = a -> Validation -> Validation
forall a b. a -> b -> b
seq a
a Validation
forall a. Monoid a => a
mempty

-- | Check that a given invariant holds.
--
-- The given string should describe the invariant, not the violation.
--
-- Example:
--
-- > check (x < 5) "x is strictly smaller than 5"
--
-- instead of
--
-- > check (x < 5) "x is greater than 5"
check :: Bool -> String -> Validation
check :: Bool -> String -> Validation
check Bool
b String
err =
  if Bool
b
    then Validation
forall a. Monoid a => a
mempty
    else [ValidationChain] -> Validation
Validation [String -> ValidationChain
Violated String
err]

-- | 'check', but with the arguments flipped
declare :: String -> Bool -> Validation
declare :: String -> Bool -> Validation
declare = (Bool -> String -> Validation) -> String -> Bool -> Validation
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> String -> Validation
check

-- | Declare a sub-part as a necessary part for validation, and annotate it with a name.
--
-- Example:
--
-- > validate (a, b) =
-- >     mconcat
-- >         [ annotate a "The first element of the tuple"
-- >         , annotate b "The second element of the tuple"
-- >         ]
annotate :: (Validity a) => a -> String -> Validation
annotate :: forall a. Validity a => a -> String -> Validation
annotate = Validation -> String -> Validation
annotateValidation (Validation -> String -> Validation)
-> (a -> Validation) -> a -> String -> Validation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Validation
forall a. Validity a => a -> Validation
validate

-- | 'annotate', but with the arguments flipped.
delve :: (Validity a) => String -> a -> Validation
delve :: forall a. Validity a => String -> a -> Validation
delve = (a -> String -> Validation) -> String -> a -> Validation
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate

-- | Decorate a validation with a location
decorate :: String -> Validation -> Validation
decorate :: String -> Validation -> Validation
decorate = (Validation -> String -> Validation)
-> String -> Validation -> Validation
forall a b c. (a -> b -> c) -> b -> a -> c
flip Validation -> String -> Validation
annotateValidation

-- | Decorate a piecewise validation of a list with their location in the list
decorateList :: [a] -> (a -> Validation) -> Validation
decorateList :: forall a. [a] -> (a -> Validation) -> Validation
decorateList [a]
as a -> Validation
func = [Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat ([Validation] -> Validation) -> [Validation] -> Validation
forall a b. (a -> b) -> a -> b
$
  (((Integer, a) -> Validation) -> [(Integer, a)] -> [Validation])
-> [(Integer, a)] -> ((Integer, a) -> Validation) -> [Validation]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Integer, a) -> Validation) -> [(Integer, a)] -> [Validation]
forall a b. (a -> b) -> [a] -> [b]
map ([Integer] -> [a] -> [(Integer, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0 ..] [a]
as) (((Integer, a) -> Validation) -> [Validation])
-> ((Integer, a) -> Validation) -> [Validation]
forall a b. (a -> b) -> a -> b
$ \(Integer
i, a
a) ->
    String -> Validation -> Validation
decorate ([String] -> String
unwords [String
"The element at index", Integer -> String
forall a. Show a => a -> String
show (Integer
i :: Integer), String
"in the list"]) (Validation -> Validation) -> Validation -> Validation
forall a b. (a -> b) -> a -> b
$
      a -> Validation
func a
a

-- | 'decorateList', but specifically for 'String's
--
-- > decorateString = decorateList
decorateString :: String -> (Char -> Validation) -> Validation
decorateString :: String -> (Char -> Validation) -> Validation
decorateString = String -> (Char -> Validation) -> Validation
forall a. [a] -> (a -> Validation) -> Validation
decorateList

-- | Construct a trivially invalid 'Validation'
--
-- Example:
--
-- > data Wrong
-- >     = Wrong
-- >     | Fine
-- >     deriving (Show, Eq)
-- >
-- > instance Validity Wrong where
-- >     validate w =
-- >         case w of
-- >             Wrong -> invalid "Wrong"
-- >             Fine -> valid
invalid :: String -> Validation
invalid :: String -> Validation
invalid = Bool -> String -> Validation
check Bool
False

valid :: Validation
valid :: Validation
valid = Validation
forall a. Monoid a => a
mempty

-- | Any tuple of things is valid if both of its elements are valid
instance (Validity a, Validity b) => Validity (a, b) where
  validate :: (a, b) -> Validation
validate (a
a, b
b) =
    [Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
      [ a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate a
a String
"The first element of the tuple",
        b -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate b
b String
"The second element of the tuple"
      ]

-- | Any Either of things is valid if the contents are valid in either of the cases.
instance (Validity a, Validity b) => Validity (Either a b) where
  validate :: Either a b -> Validation
validate (Left a
a) = a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate a
a String
"The 'Left'"
  validate (Right b
b) = b -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate b
b String
"The 'Right'"

-- | Any triple of things is valid if all three of its elements are valid
instance (Validity a, Validity b, Validity c) => Validity (a, b, c) where
  validate :: (a, b, c) -> Validation
validate (a
a, b
b, c
c) =
    [Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
      [ a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate a
a String
"The first element of the triple",
        b -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate b
b String
"The second element of the triple",
        c -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate c
c String
"The third element of the triple"
      ]

-- | Any quadruple of things is valid if all four of its elements are valid
instance
  (Validity a, Validity b, Validity c, Validity d) =>
  Validity (a, b, c, d)
  where
  validate :: (a, b, c, d) -> Validation
validate (a
a, b
b, c
c, d
d) =
    [Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
      [ a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate a
a String
"The first element of the quadruple",
        b -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate b
b String
"The second element of the quadruple",
        c -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate c
c String
"The third element of the quadruple",
        d -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate d
d String
"The fourth element of the quadruple"
      ]

-- | Any quintuple of things is valid if all five of its elements are valid
instance
  (Validity a, Validity b, Validity c, Validity d, Validity e) =>
  Validity (a, b, c, d, e)
  where
  validate :: (a, b, c, d, e) -> Validation
validate (a
a, b
b, c
c, d
d, e
e) =
    [Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
      [ a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate a
a String
"The first element of the quintuple",
        b -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate b
b String
"The second element of the quintuple",
        c -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate c
c String
"The third element of the quintuple",
        d -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate d
d String
"The fourth element of the quintuple",
        e -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate e
e String
"The fifth element of the quintuple"
      ]

-- | Any sextuple of things is valid if all six of its elements are valid
instance
  ( Validity a,
    Validity b,
    Validity c,
    Validity d,
    Validity e,
    Validity f
  ) =>
  Validity (a, b, c, d, e, f)
  where
  validate :: (a, b, c, d, e, f) -> Validation
validate (a
a, b
b, c
c, d
d, e
e, f
f) =
    [Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
      [ a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate a
a String
"The first element of the sextuple",
        b -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate b
b String
"The second element of the sextuple",
        c -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate c
c String
"The third element of the sextuple",
        d -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate d
d String
"The fourth element of the sextuple",
        e -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate e
e String
"The fifth element of the sextuple",
        f -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate f
f String
"The sixth element of the sextuple"
      ]

-- | A list of things is valid if all of the things are valid.
--
-- This means that the empty list is considered valid.
-- If the empty list should not be considered valid as part of your custom data
-- type, make sure to write a custom @Validity instance@
instance (Validity a) => Validity [a] where
  validate :: [a] -> Validation
validate = ([a] -> (a -> Validation) -> Validation)
-> (a -> Validation) -> [a] -> Validation
forall a b c. (a -> b -> c) -> b -> a -> c
flip [a] -> (a -> Validation) -> Validation
forall a. [a] -> (a -> Validation) -> Validation
decorateList a -> Validation
forall a. Validity a => a -> Validation
validate

-- | A nonempty list is valid if all the elements are valid.
--
-- See the instance for 'Validity [a]' for more information.
instance (Validity a) => Validity (NonEmpty a) where
  validate :: NonEmpty a -> Validation
validate (a
e :| [a]
es) =
    [Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
      [ a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate a
e String
"The first element of the nonempty list",
        [a] -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate [a]
es String
"The rest of the elements of the nonempty list"
      ]

-- | A Maybe thing is valid if the thing inside is valid or it's nothing
-- It makes sense to assume that 'Nothing' is valid.
-- If Nothing wasn't valid, you wouldn't have used a Maybe
-- in the datastructure.
instance (Validity a) => Validity (Maybe a) where
  validate :: Maybe a -> Validation
validate Maybe a
Nothing = Validation
forall a. Monoid a => a
mempty
  validate (Just a
a) = a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate a
a String
"The 'Just'"

-- | Trivially valid
instance Validity () where
  validate :: () -> Validation
validate = () -> Validation
forall a. a -> Validation
trivialValidation

-- | Trivially valid
instance Validity Bool where
  validate :: Bool -> Validation
validate = Bool -> Validation
forall a. a -> Validation
trivialValidation

-- | Trivially valid
instance Validity Ordering where
  validate :: Ordering -> Validation
validate = Ordering -> Validation
forall a. a -> Validation
trivialValidation

-- | Trivially valid
instance Validity Char where
  validate :: Char -> Validation
validate (C# Char#
c#) =
    [Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
      [ String -> Bool -> Validation
declare String
"The contained value is positive" (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$ Int# -> Bool
isTrue# (Char# -> Int#
ord# Char#
c# Int# -> Int# -> Int#
>=# Int#
0#),
        String -> Bool -> Validation
declare String
"The contained value is smaller than 0x10FFFF = 1114111" (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$ Int# -> Bool
isTrue# (Char# -> Int#
ord# Char#
c# Int# -> Int# -> Int#
<=# Int#
1114111#)
      ]

validateCharNotUtf16SurrogateCodePoint :: Char -> Validation
validateCharNotUtf16SurrogateCodePoint :: Char -> Validation
validateCharNotUtf16SurrogateCodePoint Char
c =
  String -> Bool -> Validation
declare String
"The character is not a UTF16 surrogate codepoint" (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isUtf16SurrogateCodePoint Char
c

isUtf16SurrogateCodePoint :: Char -> Bool
isUtf16SurrogateCodePoint :: Char -> Bool
isUtf16SurrogateCodePoint Char
c = Char -> Int
ord Char
c Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x1ff800 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0xd800

validateCharNotLineSeparator :: Char -> Validation
validateCharNotLineSeparator :: Char -> Validation
validateCharNotLineSeparator Char
c =
  String -> Bool -> Validation
declare String
"The character is not a line separator" (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isLineSeparator Char
c

isLineSeparator :: Char -> Bool
isLineSeparator :: Char -> Bool
isLineSeparator Char
c = case Char
c of
  Char
'\n' -> Bool
True
  Char
'\r' -> Bool
True
  Char
_ -> Bool
False

validateStringSingleLine :: String -> Validation
validateStringSingleLine :: String -> Validation
validateStringSingleLine String
s = String -> (Char -> Validation) -> Validation
forall a. [a] -> (a -> Validation) -> Validation
decorateList String
s Char -> Validation
validateCharNotLineSeparator

isSingleLine :: String -> Bool
isSingleLine :: String -> Bool
isSingleLine = Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
isLineSeparator

-- | Trivially valid
instance Validity Int where
  validate :: Int -> Validation
validate = Int -> Validation
forall a. a -> Validation
trivialValidation

#if MIN_VERSION_base(4,16,0)
instance Validity Int8 where validate :: Int8 -> Validation
validate = Int8 -> Validation
forall a. a -> Validation
trivialValidation
instance Validity Int16 where validate :: Int16 -> Validation
validate = Int16 -> Validation
forall a. a -> Validation
trivialValidation
instance Validity Int32 where validate :: Int32 -> Validation
validate = Int32 -> Validation
forall a. a -> Validation
trivialValidation
#else
-- | NOT trivially valid on GHC because small number types are represented using a 64bit structure underneath.
instance Validity Int8 where
  validate (I8# i#) =
    mconcat
      [ declare "The contained integer is smaller than 2^7 = 128" $ isTrue# (i# <=# 127#),
        declare "The contained integer is greater than or equal to -2^7 = -128" $ isTrue# (i# >=# -128#)
      ]

-- | NOT trivially valid on GHC because small number types are represented using a 64bit structure underneath.
instance Validity Int16 where
  validate (I16# i#) =
    mconcat
      [ declare "The contained integer is smaller than 2^15 = 32768" $ isTrue# (i# <=# 32767#),
        declare "The contained integer is greater than or equal to -2^15 = -32768" $ isTrue# (i# >=# -32768#)
      ]

-- | NOT trivially valid on GHC because small number types are represented using a 64bit structure underneath.
instance Validity Int32 where
  validate (I32# i#) =
    mconcat
      [ declare "The contained integer is smaller than 2^31 = 2147483648" $ isTrue# (i# <=# 2147483647#),
        declare "The contained integer is greater than or equal to -2^31 = -2147483648" $ isTrue# (i# >=# -2147483648#)
      ]
#endif

-- | Trivially valid
instance Validity Int64 where
  validate :: Int64 -> Validation
validate = Int64 -> Validation
forall a. a -> Validation
trivialValidation

-- | Trivially valid
instance Validity Word where
  validate :: Word -> Validation
validate = Word -> Validation
forall a. a -> Validation
trivialValidation

#if MIN_VERSION_base(4,16,0)
instance Validity Word8 where validate :: Word8 -> Validation
validate = Word8 -> Validation
forall a. a -> Validation
trivialValidation
instance Validity Word16 where validate :: Word16 -> Validation
validate = Word16 -> Validation
forall a. a -> Validation
trivialValidation
instance Validity Word32 where validate :: Word32 -> Validation
validate = Word32 -> Validation
forall a. a -> Validation
trivialValidation
#else
-- | NOT trivially valid on GHC because small number types are represented using a 64bit structure underneath.
instance Validity Word8 where
  validate (W8# w#) =
    declare "The contained integer is smaller than 2^8 = 256" $ isTrue# (w# `leWord#` 255##)

-- | NOT trivially valid on GHC because small number types are represented using a 64bit structure underneath.
instance Validity Word16 where
  validate (W16# w#) =
    declare "The contained integer is smaller than 2^16 = 65536" $ isTrue# (w# `leWord#` 65535##)

-- | NOT trivially valid on GHC because small number types are represented using a 64bit structure underneath.
instance Validity Word32 where
  validate (W32# w#) =
    declare "The contained integer is smaller than 2^32 = 4294967296" $ isTrue# (w# `leWord#` 4294967295##)
#endif

-- | Trivially valid
instance Validity Word64 where
  validate :: Word64 -> Validation
validate = Word64 -> Validation
forall a. a -> Validation
trivialValidation

-- | Trivially valid:
instance Validity Float where
  validate :: Float -> Validation
validate = Float -> Validation
forall a. a -> Validation
trivialValidation

-- | Trivially valid:
instance Validity Double where
  validate :: Double -> Validation
validate = Double -> Validation
forall a. a -> Validation
trivialValidation

-- | Valid values the same as it's base type:
deriving newtype instance (Validity a) => Validity (Identity a)

-- | Valid values the same as it's base type:
deriving newtype instance (Validity (f a)) => Validity (Alt f a)

-- | Valid values the same as it's base type:
deriving newtype instance (Validity a) => Validity (Dual a)

-- | Valid values the same as it's base type:
deriving newtype instance (Validity a) => Validity (Semigroup.First a)

-- | Valid values the same as it's base type:
deriving newtype instance (Validity a) => Validity (Semigroup.Last a)

-- | Valid values the same as it's base type:
deriving newtype instance (Validity a) => Validity (Monoid.First a)

-- | Valid values the same as it's base type:
deriving newtype instance (Validity a) => Validity (Monoid.Last a)

-- | Valid values the same as it's base type:
deriving newtype instance (Validity a) => Validity (Const a b)

validateNotNaN :: (RealFloat a) => a -> Validation
validateNotNaN :: forall a. RealFloat a => a -> Validation
validateNotNaN a
d = String -> Bool -> Validation
declare String
"The RealFloat is not NaN." (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
d)

validateNotInfinite :: (RealFloat a) => a -> Validation
validateNotInfinite :: forall a. RealFloat a => a -> Validation
validateNotInfinite a
d = String -> Bool -> Validation
declare String
"The RealFloat is not infinite." (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
d)

validateRatioNotNaN :: (Integral a) => Ratio a -> Validation
validateRatioNotNaN :: forall a. Integral a => Ratio a -> Validation
validateRatioNotNaN Ratio a
r = String -> Bool -> Validation
declare String
"The Ratio is not NaN." (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$
  case Ratio a
r of
    (a
0 :% a
0) -> Bool
False
    Ratio a
_ -> Bool
True

validateRatioNotInfinite :: (Integral a) => Ratio a -> Validation
validateRatioNotInfinite :: forall a. Integral a => Ratio a -> Validation
validateRatioNotInfinite Ratio a
r = String -> Bool -> Validation
declare String
"The Ratio is not infinite." (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$
  case Ratio a
r of
    (a
1 :% a
0) -> Bool
False
    ((-1) :% a
0) -> Bool
False
    Ratio a
_ -> Bool
True

validateRatioNormalised :: (Integral a) => Ratio a -> Validation
validateRatioNormalised :: forall a. Integral a => Ratio a -> Validation
validateRatioNormalised (a
n :% a
d) = String -> Bool -> Validation
declare String
"The Ratio is normalised." (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$
  case a
d of
    a
0 -> Bool
False
    a
_ ->
      let g :: a
g = a -> a -> a
forall a. Integral a => a -> a -> a
gcd a
n a
d
          gcdOverflows :: Bool
gcdOverflows = a
g a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0
          a
n' :% a
d' = (a
n a -> a -> a
forall a. Integral a => a -> a -> a
`quot` a
g) a -> a -> Ratio a
forall a. a -> a -> Ratio a
:% (a
d a -> a -> a
forall a. Integral a => a -> a -> a
`quot` a
g)
          valueIsNormalised :: Bool
valueIsNormalised = a
n' a -> a -> Ratio a
forall a. a -> a -> Ratio a
:% a
d' Ratio a -> Ratio a -> Bool
forall a. Eq a => a -> a -> Bool
== a
n a -> a -> Ratio a
forall a. a -> a -> Ratio a
:% a
d
       in Bool -> Bool
not Bool
gcdOverflows Bool -> Bool -> Bool
&& Bool
valueIsNormalised

-- | Trivially valid
--
-- Integer is not trivially valid under the hood, but instantiating
-- 'Validity' correctly would force validity to depend on a specific
-- (big integer library @integer-gmp@ versus @integer-simple@).
-- This is rather impractical so for the time being we have opted for
-- assuming that an 'Integer' is always valid.
-- Even though this is not technically sound, it is good enough for now.
instance Validity Integer where
  validate :: Integer -> Validation
validate = Integer -> Validation
forall a. a -> Validation
trivialValidation

-- | Valid according to 'isValidNatural'
instance Validity Natural where
  validate :: Natural -> Validation
validate = String -> Bool -> Validation
declare String
"The Natural is valid." (Bool -> Validation) -> (Natural -> Bool) -> Natural -> Validation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Bool
isValidNatural

-- | Valid if the contained numbers are valid and the denominator is
-- strictly positive.
instance (Validity a, Ord a, Num a, Integral a) => Validity (Ratio a) where
  validate :: Ratio a -> Validation
validate r :: Ratio a
r@(a
n :% a
d) =
    [Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
      [ a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate a
n String
"The numerator",
        a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate a
d String
"The denominator",
        String -> Bool -> Validation
declare String
"The denominator is strictly positive." (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$ a
d a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0,
        Ratio a -> Validation
forall a. Integral a => Ratio a -> Validation
validateRatioNormalised Ratio a
r
      ]

-- | Valid according to the contained 'Integer'.
instance (HasResolution a) => Validity (Fixed a) where
  validate :: Fixed a -> Validation
validate (MkFixed Integer
i) = Integer -> Validation
forall a. Validity a => a -> Validation
validate Integer
i

annotateValidation :: Validation -> String -> Validation
annotateValidation :: Validation -> String -> Validation
annotateValidation Validation
val String
s =
  case Validation
val of
    Validation [ValidationChain]
errs -> [ValidationChain] -> Validation
Validation ([ValidationChain] -> Validation)
-> [ValidationChain] -> Validation
forall a b. (a -> b) -> a -> b
$ (ValidationChain -> ValidationChain)
-> [ValidationChain] -> [ValidationChain]
forall a b. (a -> b) -> [a] -> [b]
map (String -> ValidationChain -> ValidationChain
Location String
s) [ValidationChain]
errs

class GValidity f where
  gValidate :: f a -> Validation

instance GValidity U1 where
  gValidate :: forall a. U1 a -> Validation
gValidate = U1 a -> Validation
forall a. a -> Validation
trivialValidation

instance GValidity V1 where
  gValidate :: forall a. V1 a -> Validation
gValidate = V1 a -> Validation
forall a. a -> Validation
trivialValidation

instance (GValidity a, GValidity b) => GValidity (a :*: b) where
  gValidate :: forall a. (:*:) a b a -> Validation
gValidate (a a
a :*: b a
b) = a a -> Validation
forall a. a a -> Validation
forall (f :: * -> *) a. GValidity f => f a -> Validation
gValidate a a
a Validation -> Validation -> Validation
forall a. Monoid a => a -> a -> a
`mappend` b a -> Validation
forall a. b a -> Validation
forall (f :: * -> *) a. GValidity f => f a -> Validation
gValidate b a
b

instance (GValidity a, GValidity b) => GValidity (a :+: b) where
  gValidate :: forall a. (:+:) a b a -> Validation
gValidate (L1 a a
x) = a a -> Validation
forall a. a a -> Validation
forall (f :: * -> *) a. GValidity f => f a -> Validation
gValidate a a
x
  gValidate (R1 b a
x) = b a -> Validation
forall a. b a -> Validation
forall (f :: * -> *) a. GValidity f => f a -> Validation
gValidate b a
x

instance (GValidity a, Datatype c) => GValidity (M1 D c a) where
  gValidate :: forall a. M1 D c a a -> Validation
gValidate M1 D c a a
m1 = a a -> Validation
forall a. a a -> Validation
forall (f :: * -> *) a. GValidity f => f a -> Validation
gValidate (M1 D c a a -> a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 M1 D c a a
m1)

instance (GValidity a, Constructor c) => GValidity (M1 C c a) where
  gValidate :: forall a. M1 C c a a -> Validation
gValidate M1 C c a a
m1 = a a -> Validation
forall a. a a -> Validation
forall (f :: * -> *) a. GValidity f => f a -> Validation
gValidate (M1 C c a a -> a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 M1 C c a a
m1) Validation -> String -> Validation
`annotateValidation` M1 C c a a -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> String
conName M1 C c a a
m1

instance (GValidity a, Selector c) => GValidity (M1 S c a) where
  gValidate :: forall a. M1 S c a a -> Validation
gValidate M1 S c a a
m1 = a a -> Validation
forall a. a a -> Validation
forall (f :: * -> *) a. GValidity f => f a -> Validation
gValidate (M1 S c a a -> a a
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 M1 S c a a
m1) Validation -> String -> Validation
`annotateValidation` M1 S c a a -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> String
selName M1 S c a a
m1

instance (Validity a) => GValidity (K1 R a) where
  gValidate :: forall a. K1 R a a -> Validation
gValidate (K1 a
x) = a -> Validation
forall a. Validity a => a -> Validation
validate a
x

-- | Check whether a value is valid.
isValid :: (Validity a) => a -> Bool
isValid :: forall a. Validity a => a -> Bool
isValid = Either [ValidationChain] a -> Bool
forall a b. Either a b -> Bool
isRight (Either [ValidationChain] a -> Bool)
-> (a -> Either [ValidationChain] a) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either [ValidationChain] a
forall a. Validity a => a -> Either [ValidationChain] a
checkValidity

-- | Check whether a value is not valid.
--
-- > isInvalid = not . isValid
isInvalid :: (Validity a) => a -> Bool
isInvalid :: forall a. Validity a => a -> Bool
isInvalid = Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
forall a. Validity a => a -> Bool
isValid

-- | Construct a valid element from an unchecked element
constructValid :: (Validity a) => a -> Maybe a
constructValid :: forall a. Validity a => a -> Maybe a
constructValid a
p =
  if a -> Bool
forall a. Validity a => a -> Bool
isValid a
p
    then a -> Maybe a
forall a. a -> Maybe a
Just a
p
    else Maybe a
forall a. Maybe a
Nothing

-- | Construct a valid element from an unchecked element, throwing 'error'
-- on invalid elements.
constructValidUnsafe :: (Show a, Validity a) => a -> a
constructValidUnsafe :: forall a. (Show a, Validity a) => a -> a
constructValidUnsafe a
p =
  a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is not valid") (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. Validity a => a -> Maybe a
constructValid a
p

-- | validate a given value.
--
-- This function returns either all the reasons why the given value is invalid,
-- in the form of a list of 'ValidationChain's, or it returns 'Right' with the
-- input value, as evidence that it is valid.
--
-- Note: You may want to use 'prettyValidation' instead, if you want to
-- display these 'ValidationChain's to a user.
checkValidity :: (Validity a) => a -> Either [ValidationChain] a
checkValidity :: forall a. Validity a => a -> Either [ValidationChain] a
checkValidity a
a =
  case a -> Validation
forall a. Validity a => a -> Validation
validate a
a of
    Validation [] -> a -> Either [ValidationChain] a
forall a b. b -> Either a b
Right a
a
    Validation [ValidationChain]
errs -> [ValidationChain] -> Either [ValidationChain] a
forall a b. a -> Either a b
Left [ValidationChain]
errs

-- | Check if a 'Validation' concerns a valid value.
validationIsValid :: Validation -> Bool
validationIsValid :: Validation -> Bool
validationIsValid Validation
v = case Validation
v of
  Validation [] -> Bool
True
  Validation
_ -> Bool
False

-- | Validate a given value
--
-- This function will return a nice error if the value is invalid.
-- It will return the original value in 'Right' if it was valid,
-- as evidence that it has been validated.
prettyValidate :: (Validity a) => a -> Either String a
prettyValidate :: forall a. Validity a => a -> Either String a
prettyValidate a
a = case Validation -> Maybe String
prettyValidation (Validation -> Maybe String) -> Validation -> Maybe String
forall a b. (a -> b) -> a -> b
$ a -> Validation
forall a. Validity a => a -> Validation
validate a
a of
  Just String
e -> String -> Either String a
forall a b. a -> Either a b
Left String
e
  Maybe String
Nothing -> a -> Either String a
forall a b. b -> Either a b
Right a
a

-- | Render a `Validation` in a somewhat pretty way.
--
-- This function will return 'Nothing' if the 'Validation' concerned a valid value.
prettyValidation :: Validation -> Maybe String
prettyValidation :: Validation -> Maybe String
prettyValidation Validation
v =
  case Validation
v of
    Validation [] -> Maybe String
forall a. Maybe a
Nothing
    Validation [ValidationChain]
errs -> String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (ValidationChain -> String) -> [ValidationChain] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> String
errCascade ([String] -> String)
-> (ValidationChain -> [String]) -> ValidationChain -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidationChain -> [String]
toStrings) [ValidationChain]
errs
  where
    toStrings :: ValidationChain -> [String]
toStrings (Violated String
s) = [String
"Violated: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s]
    toStrings (Location String
s ValidationChain
vc) = String
s String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ValidationChain -> [String]
toStrings ValidationChain
vc
    errCascade :: [String] -> String
errCascade [String]
errList =
      String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
        (((Int, String) -> String) -> [(Int, String)] -> [String])
-> [(Int, String)] -> ((Int, String) -> String) -> [String]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Int, String) -> String) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [String]
errList) (((Int, String) -> String) -> [String])
-> ((Int, String) -> String) -> [String]
forall a b. (a -> b) -> a -> b
$ \(Int
i, String
segment) ->
          case Int
i of
            Int
0 -> String
segment
            Int
_ -> Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
i Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\\ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
segment