{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# 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 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 = 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 = forall (f :: * -> *) a. GValidity f => f a -> Validation
gValidate forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidationChain] -> ShowS
$cshowList :: [ValidationChain] -> ShowS
show :: ValidationChain -> String
$cshow :: ValidationChain -> String
showsPrec :: Int -> ValidationChain -> ShowS
$cshowsPrec :: Int -> ValidationChain -> ShowS
Show, ValidationChain -> ValidationChain -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidationChain -> ValidationChain -> Bool
$c/= :: ValidationChain -> ValidationChain -> Bool
== :: ValidationChain -> ValidationChain -> Bool
$c== :: ValidationChain -> ValidationChain -> Bool
Eq, 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
$cto :: forall x. Rep ValidationChain x -> ValidationChain
$cfrom :: forall x. ValidationChain -> Rep ValidationChain x
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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Validation] -> ShowS
$cshowList :: [Validation] -> ShowS
show :: Validation -> String
$cshow :: Validation -> String
showsPrec :: Int -> Validation -> ShowS
$cshowsPrec :: Int -> Validation -> ShowS
Show, Validation -> Validation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Validation -> Validation -> Bool
$c/= :: Validation -> Validation -> Bool
== :: Validation -> Validation -> Bool
$c== :: Validation -> Validation -> Bool
Eq, 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
$cto :: forall x. Rep Validation x -> Validation
$cfrom :: forall x. Validation -> Rep Validation x
Generic)

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

instance Monoid Validation where
  mempty :: Validation
mempty = [ValidationChain] -> Validation
Validation []
  mappend :: Validation -> Validation -> Validation
mappend = 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 = seq :: forall a b. a -> b -> b
seq a
a 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 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 = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Validity a => a -> String -> Validation
annotate

-- | Decorate a validation with a location
decorate :: String -> Validation -> Validation
decorate :: String -> Validation -> Validation
decorate = 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 = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$
  forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map (forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0 ..] [a]
as) forall a b. (a -> b) -> a -> b
$ \(Integer
i, a
a) ->
    String -> Validation -> Validation
decorate ([String] -> String
unwords [String
"The element at index", forall a. Show a => a -> String
show (Integer
i :: Integer), String
"in the list"]) 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 = 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 = 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) =
    forall a. Monoid a => [a] -> a
mconcat
      [ forall a. Validity a => a -> String -> Validation
annotate a
a String
"The first element of the tuple",
        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) = forall a. Validity a => a -> String -> Validation
annotate a
a String
"The 'Left'"
  validate (Right b
b) = 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) =
    forall a. Monoid a => [a] -> a
mconcat
      [ forall a. Validity a => a -> String -> Validation
annotate a
a String
"The first element of the triple",
        forall a. Validity a => a -> String -> Validation
annotate b
b String
"The second element of the triple",
        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) =
    forall a. Monoid a => [a] -> a
mconcat
      [ forall a. Validity a => a -> String -> Validation
annotate a
a String
"The first element of the quadruple",
        forall a. Validity a => a -> String -> Validation
annotate b
b String
"The second element of the quadruple",
        forall a. Validity a => a -> String -> Validation
annotate c
c String
"The third element of the quadruple",
        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) =
    forall a. Monoid a => [a] -> a
mconcat
      [ forall a. Validity a => a -> String -> Validation
annotate a
a String
"The first element of the quintuple",
        forall a. Validity a => a -> String -> Validation
annotate b
b String
"The second element of the quintuple",
        forall a. Validity a => a -> String -> Validation
annotate c
c String
"The third element of the quintuple",
        forall a. Validity a => a -> String -> Validation
annotate d
d String
"The fourth element of the quintuple",
        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) =
    forall a. Monoid a => [a] -> a
mconcat
      [ forall a. Validity a => a -> String -> Validation
annotate a
a String
"The first element of the sextuple",
        forall a. Validity a => a -> String -> Validation
annotate b
b String
"The second element of the sextuple",
        forall a. Validity a => a -> String -> Validation
annotate c
c String
"The third element of the sextuple",
        forall a. Validity a => a -> String -> Validation
annotate d
d String
"The fourth element of the sextuple",
        forall a. Validity a => a -> String -> Validation
annotate e
e String
"The fifth element of the sextuple",
        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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. [a] -> (a -> Validation) -> Validation
decorateList 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) =
    forall a. Monoid a => [a] -> a
mconcat
      [ forall a. Validity a => a -> String -> Validation
annotate a
e String
"The first element of the nonempty list",
        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 = forall a. Monoid a => a
mempty
  validate (Just a
a) = forall a. Validity a => a -> String -> Validation
annotate a
a String
"The 'Just'"

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

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

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

-- | Trivially valid
instance Validity Char where
  validate :: Char -> Validation
validate (C# Char#
c#) =
    forall a. Monoid a => [a] -> a
mconcat
      [ String -> Bool -> Validation
declare String
"The contained value is positive" 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" 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" forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not 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 forall a. Bits a => a -> a -> a
.&. Int
0x1ff800 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" forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not 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 = forall a. [a] -> (a -> Validation) -> Validation
decorateList String
s Char -> Validation
validateCharNotLineSeparator

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

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

#if MIN_VERSION_base(4,16,0)
instance Validity Int8 where validate :: Int8 -> Validation
validate = forall a. a -> Validation
trivialValidation
instance Validity Int16 where validate :: Int16 -> Validation
validate = forall a. a -> Validation
trivialValidation
instance Validity Int32 where validate :: Int32 -> Validation
validate = 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 = forall a. a -> Validation
trivialValidation

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

#if MIN_VERSION_base(4,16,0)
instance Validity Word8 where validate :: Word8 -> Validation
validate = forall a. a -> Validation
trivialValidation
instance Validity Word16 where validate :: Word16 -> Validation
validate = forall a. a -> Validation
trivialValidation
instance Validity Word32 where validate :: Word32 -> Validation
validate = 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 = forall a. a -> Validation
trivialValidation

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

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

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." forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (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." forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (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." 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." 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." forall a b. (a -> b) -> a -> b
$
  case a
d of
    a
0 -> Bool
False
    a
_ ->
      let g :: a
g = forall a. Integral a => a -> a -> a
gcd a
n a
d
          gcdOverflows :: Bool
gcdOverflows = a
g forall a. Ord a => a -> a -> Bool
< a
0
          a
n' :% a
d' = (a
n forall a. Integral a => a -> a -> a
`quot` a
g) forall a. a -> a -> Ratio a
:% (a
d forall a. Integral a => a -> a -> a
`quot` a
g)
          valueIsNormalised :: Bool
valueIsNormalised = a
n' forall a. a -> a -> Ratio a
:% a
d' forall a. Eq a => a -> a -> Bool
== a
n 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 = 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." 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) =
    forall a. Monoid a => [a] -> a
mconcat
      [ forall a. Validity a => a -> String -> Validation
annotate a
n String
"The numerator",
        forall a. Validity a => a -> String -> Validation
annotate a
d String
"The denominator",
        String -> Bool -> Validation
declare String
"The denominator is strictly positive." forall a b. (a -> b) -> a -> b
$ a
d forall a. Ord a => a -> a -> Bool
> a
0,
        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) = 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 forall a b. (a -> b) -> a -> b
$ 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 = forall a. a -> Validation
trivialValidation

instance GValidity V1 where
  gValidate :: forall a. V1 a -> Validation
gValidate = 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) = forall (f :: * -> *) a. GValidity f => f a -> Validation
gValidate a a
a forall a. Monoid a => a -> a -> a
`mappend` 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) = forall (f :: * -> *) a. GValidity f => f a -> Validation
gValidate a a
x
  gValidate (R1 b a
x) = 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 = forall (f :: * -> *) a. GValidity f => f a -> Validation
gValidate (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 = forall (f :: * -> *) a. GValidity f => f a -> Validation
gValidate (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` forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
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 = forall (f :: * -> *) a. GValidity f => f a -> Validation
gValidate (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` forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s 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) = 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 = forall a b. Either a b -> Bool
isRight forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Validity a => a -> Bool
isValid a
p
    then forall a. a -> Maybe a
Just a
p
    else 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 =
  forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show a
p forall a. [a] -> [a] -> [a]
++ String
" is not valid") forall a b. (a -> b) -> a -> b
$ 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 forall a. Validity a => a -> Validation
validate a
a of
    Validation [] -> forall a b. b -> Either a b
Right a
a
    Validation [ValidationChain]
errs -> 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 forall a b. (a -> b) -> a -> b
$ forall a. Validity a => a -> Validation
validate a
a of
  Just String
e -> forall a b. a -> Either a b
Left String
e
  Maybe String
Nothing -> 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 [] -> forall a. Maybe a
Nothing
    Validation [ValidationChain]
errs -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ([String] -> String
errCascade 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: " forall a. [a] -> [a] -> [a]
++ String
s]
    toStrings (Location String
s ValidationChain
vc) = String
s forall a. a -> [a] -> [a]
: ValidationChain -> [String]
toStrings ValidationChain
vc
    errCascade :: [String] -> String
errCascade [String]
errList =
      forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" forall a b. (a -> b) -> a -> b
$
        forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [String]
errList) forall a b. (a -> b) -> a -> b
$ \(Int
i, String
segment) ->
          case Int
i of
            Int
0 -> String
segment
            Int
_ -> forall a. Int -> a -> [a]
replicate Int
i Char
' ' forall a. [a] -> [a] -> [a]
++ String
"\\ " forall a. [a] -> [a] -> [a]
++ String
segment