{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TypeOperators #-}
#if MIN_VERSION_base(4,9,0)
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
#endif
module Data.Validity
( Validity(..)
, trivialValidation
, genericValidate
, check
, declare
, annotate
, delve
, decorate
, decorateList
, invalid
, valid
, validateCharNotUtf16SurrogateCodePoint
, isUtf16SurrogateCodePoint
, validateNotNaN
, validateNotInfinite
, validateRatioNotNaN
, validateRatioNotInfinite
, validateRatioNormalised
, isValid
, isInvalid
, constructValid
, constructValidUnsafe
, Validation(..)
, ValidationChain(..)
, checkValidity
, validationIsValid
, prettyValidate
, prettyValidation
, Monoid(..)
#if MIN_VERSION_base(4,11,0)
, Semigroup(..)
#endif
) where
import Data.Either (isRight)
import Data.Fixed (Fixed(MkFixed), HasResolution)
import Data.List (intercalate)
#if MIN_VERSION_base(4,9,0)
import Data.List.NonEmpty (NonEmpty((:|)))
#endif
import Data.Maybe (fromMaybe)
#if MIN_VERSION_base(4,8,0)
#else
import Data.Monoid
import Data.Ratio
#endif
import Data.Bits ((.&.))
import Data.Char (ord)
import Data.Int (Int64)
import GHC.Int (Int8(..), Int16(..), Int32(..))
import GHC.Exts (Char(..), ord#, isTrue#, (<=#), (>=#), (>=#))
#if MIN_VERSION_base(4,8,0)
import GHC.Word (Word8(..), Word16(..), Word32(..), Word64(..))
#else
import Data.Word (Word)
import GHC.Word (Word8(..), Word16(..), Word32(..), Word64(..))
#endif
import GHC.Exts (leWord#)
import GHC.Generics
#if MIN_VERSION_base(4,8,0)
import GHC.Natural
#endif
import GHC.Real (Ratio(..))
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 :: a -> Validation
genericValidate = Rep a Any -> 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 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
showList :: [ValidationChain] -> ShowS
$cshowList :: [ValidationChain] -> ShowS
show :: ValidationChain -> String
$cshow :: ValidationChain -> String
showsPrec :: Int -> ValidationChain -> ShowS
$cshowsPrec :: Int -> ValidationChain -> ShowS
Show, ValidationChain -> ValidationChain -> Bool
(ValidationChain -> ValidationChain -> Bool)
-> (ValidationChain -> ValidationChain -> Bool)
-> Eq ValidationChain
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. 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
$cto :: forall x. Rep ValidationChain x -> ValidationChain
$cfrom :: forall x. ValidationChain -> Rep ValidationChain x
Generic)
instance Validity ValidationChain
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
showList :: [Validation] -> ShowS
$cshowList :: [Validation] -> ShowS
show :: Validation -> String
$cshow :: Validation -> String
showsPrec :: Int -> Validation -> ShowS
$cshowsPrec :: Int -> Validation -> ShowS
Show, Validation -> Validation -> Bool
(Validation -> Validation -> Bool)
-> (Validation -> Validation -> Bool) -> Eq Validation
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. 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
$cto :: forall x. Rep Validation x -> Validation
$cfrom :: forall x. Validation -> Rep Validation x
Generic)
#if MIN_VERSION_base(4,11,0)
instance Semigroup Validation where
(Validation v1 :: [ValidationChain]
v1) <> :: Validation -> Validation -> Validation
<> (Validation v2 :: [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
#endif
instance Monoid Validation where
mempty :: Validation
mempty = [ValidationChain] -> Validation
Validation []
#if MIN_VERSION_base(4,11,0)
mappend :: Validation -> Validation -> Validation
mappend = Validation -> Validation -> Validation
forall a. Semigroup a => a -> a -> a
(<>)
#else
mappend (Validation v1) (Validation v2) = Validation $ v1 ++ v2
#endif
trivialValidation :: a -> Validation
trivialValidation :: a -> Validation
trivialValidation a :: a
a = a -> Validation -> Validation
forall a b. a -> b -> b
seq a
a Validation
forall a. Monoid a => a
mempty
check :: Bool -> String -> Validation
check :: Bool -> String -> Validation
check b :: Bool
b err :: String
err =
if Bool
b
then Validation
forall a. Monoid a => a
mempty
else [ValidationChain] -> Validation
Validation [String -> ValidationChain
Violated String
err]
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
annotate :: Validity a => a -> String -> Validation
annotate :: 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
delve :: Validity a => String -> a -> Validation
delve :: 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 :: 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
decorateList :: [a] -> (a -> Validation) -> Validation
decorateList :: [a] -> (a -> Validation) -> Validation
decorateList as :: [a]
as func :: 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 [0..] [a]
as) (((Integer, a) -> Validation) -> [Validation])
-> ((Integer, a) -> Validation) -> [Validation]
forall a b. (a -> b) -> a -> b
$ \(i :: Integer
i, a :: a
a) ->
String -> Validation -> Validation
decorate ([String] -> String
unwords ["The element at index", Integer -> String
forall a. Show a => a -> String
show (Integer
i :: Integer), "in the list"]) (Validation -> Validation) -> Validation -> Validation
forall a b. (a -> b) -> a -> b
$
a -> Validation
func a
a
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
instance (Validity a, Validity b) => Validity (a, b) where
validate :: (a, b) -> Validation
validate (a :: a
a, b :: b
b) =
[Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
[ a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate a
a "The first element of the tuple"
, b -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate b
b "The second element of the tuple"
]
instance (Validity a, Validity b) => Validity (Either a b) where
validate :: Either a b -> Validation
validate (Left a :: a
a) = a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate a
a "The 'Left'"
validate (Right b :: b
b) = b -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate b
b "The 'Right'"
instance (Validity a, Validity b, Validity c) => Validity (a, b, c) where
validate :: (a, b, c) -> Validation
validate (a :: a
a, b :: b
b, c :: c
c) =
[Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
[ a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate a
a "The first element of the triple"
, b -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate b
b "The second element of the triple"
, c -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate c
c "The third element of the triple"
]
instance (Validity a, Validity b, Validity c, Validity d) =>
Validity (a, b, c, d) where
validate :: (a, b, c, d) -> Validation
validate (a :: a
a, b :: b
b, c :: c
c, d :: d
d) =
[Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
[ a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate a
a "The first element of the quadruple"
, b -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate b
b "The second element of the quadruple"
, c -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate c
c "The third element of the quadruple"
, d -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate d
d "The fourth element of the quadruple"
]
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
a, b :: b
b, c :: c
c, d :: d
d, e :: e
e) =
[Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
[ a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate a
a "The first element of the quintuple"
, b -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate b
b "The second element of the quintuple"
, c -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate c
c "The third element of the quintuple"
, d -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate d
d "The fourth element of the quintuple"
, e -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate e
e "The fifth element of the quintuple"
]
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
a, b :: b
b, c :: c
c, d :: d
d, e :: e
e, f :: f
f) =
[Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
[ a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate a
a "The first element of the sextuple"
, b -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate b
b "The second element of the sextuple"
, c -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate c
c "The third element of the sextuple"
, d -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate d
d "The fourth element of the sextuple"
, e -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate e
e "The fifth element of the sextuple"
, f -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate f
f "The sixth element of the sextuple"
]
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
#if MIN_VERSION_base(4,9,0)
instance Validity a => Validity (NonEmpty a) where
validate :: NonEmpty a -> Validation
validate (e :: a
e :| es :: [a]
es) =
[Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
[ a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate a
e "The first element of the nonempty list"
, [a] -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate [a]
es "The rest of the elements of the nonempty list"
]
#endif
instance Validity a => Validity (Maybe a) where
validate :: Maybe a -> Validation
validate Nothing = Validation
forall a. Monoid a => a
mempty
validate (Just a :: a
a) = a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate a
a "The 'Just'"
instance Validity () where
validate :: () -> Validation
validate = () -> Validation
forall a. a -> Validation
trivialValidation
instance Validity Bool where
validate :: Bool -> Validation
validate = Bool -> Validation
forall a. a -> Validation
trivialValidation
instance Validity Ordering where
validate :: Ordering -> Validation
validate = Ordering -> Validation
forall a. a -> Validation
trivialValidation
instance Validity Char where
validate :: Char -> Validation
validate (C# c# :: Char#
c#) = [Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
[ String -> Bool -> Validation
declare "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#
>=# 0#)
, String -> Bool -> Validation
declare "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#
<=# 1114111#)
]
validateCharNotUtf16SurrogateCodePoint :: Char -> Validation
validateCharNotUtf16SurrogateCodePoint :: Char -> Validation
validateCharNotUtf16SurrogateCodePoint c :: Char
c =
String -> Bool -> Validation
declare "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 c :: Char
c = Char -> Int
ord Char
c Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. 0x1ff800 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0xd800
instance Validity Int where
validate :: Int -> Validation
validate = Int -> Validation
forall a. a -> Validation
trivialValidation
instance Validity Int8 where
validate :: Int8 -> Validation
validate (I8# i# :: Int#
i#) =
[Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
[ String -> Bool -> Validation
declare "The contained integer is smaller than 2^7 = 128" (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$ Int# -> Bool
isTrue# (Int#
i# Int# -> Int# -> Int#
<=# 127#)
, String -> Bool -> Validation
declare "The contained integer is greater than or equal to -2^7 = -128" (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$ Int# -> Bool
isTrue# (Int#
i# Int# -> Int# -> Int#
>=# -128#)
]
instance Validity Int16 where
validate :: Int16 -> Validation
validate (I16# i# :: Int#
i#) =
[Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
[ String -> Bool -> Validation
declare "The contained integer is smaller than 2^15 = 32768" (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$ Int# -> Bool
isTrue# (Int#
i# Int# -> Int# -> Int#
<=# 32767#)
, String -> Bool -> Validation
declare "The contained integer is greater than or equal to -2^15 = -32768" (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$ Int# -> Bool
isTrue# (Int#
i# Int# -> Int# -> Int#
>=# -32768#)
]
instance Validity Int32 where
validate :: Int32 -> Validation
validate (I32# i# :: Int#
i#) =
[Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
[ String -> Bool -> Validation
declare "The contained integer is smaller than 2^31 = 2147483648" (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$ Int# -> Bool
isTrue# (Int#
i# Int# -> Int# -> Int#
<=# 2147483647#)
, String -> Bool -> Validation
declare "The contained integer is greater than or equal to -2^31 = -2147483648" (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$ Int# -> Bool
isTrue# (Int#
i# Int# -> Int# -> Int#
>=# -2147483648#)
]
instance Validity Int64 where
validate :: Int64 -> Validation
validate = Int64 -> Validation
forall a. a -> Validation
trivialValidation
instance Validity Word where
validate :: Word -> Validation
validate = Word -> Validation
forall a. a -> Validation
trivialValidation
instance Validity Word8 where
validate :: Word8 -> Validation
validate (W8# w# :: Word#
w#) =
String -> Bool -> Validation
declare "The contained integer is smaller than 2^8 = 256" (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$ Int# -> Bool
isTrue# (Word#
w# Word# -> Word# -> Int#
`leWord#` 255##)
instance Validity Word16 where
validate :: Word16 -> Validation
validate (W16# w# :: Word#
w#) =
String -> Bool -> Validation
declare "The contained integer is smaller than 2^16 = 65536" (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$ Int# -> Bool
isTrue# (Word#
w# Word# -> Word# -> Int#
`leWord#` 65535##)
instance Validity Word32 where
validate :: Word32 -> Validation
validate (W32# w# :: Word#
w#) =
String -> Bool -> Validation
declare "The contained integer is smaller than 2^32 = 4294967296" (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$ Int# -> Bool
isTrue# (Word#
w# Word# -> Word# -> Int#
`leWord#` 4294967295##)
instance Validity Word64 where
validate :: Word64 -> Validation
validate = Word64 -> Validation
forall a. a -> Validation
trivialValidation
instance Validity Float where
validate :: Float -> Validation
validate = Float -> Validation
forall a. a -> Validation
trivialValidation
instance Validity Double where
validate :: Double -> Validation
validate = Double -> Validation
forall a. a -> Validation
trivialValidation
validateNotNaN :: RealFloat a => a -> Validation
validateNotNaN :: a -> Validation
validateNotNaN d :: a
d = String -> Bool -> Validation
declare "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 :: a -> Validation
validateNotInfinite d :: a
d = String -> Bool -> Validation
declare "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 :: Ratio a -> Validation
validateRatioNotNaN r :: Ratio a
r = String -> Bool -> Validation
declare "The Ratio is not NaN." (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$
case Ratio a
r of
(0 :% 0) -> Bool
False
_ -> Bool
True
validateRatioNotInfinite :: Integral a => Ratio a -> Validation
validateRatioNotInfinite :: Ratio a -> Validation
validateRatioNotInfinite r :: Ratio a
r = String -> Bool -> Validation
declare "The Ratio is not infinite." (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$
case Ratio a
r of
(1 :% 0) -> Bool
False
((-1) :% 0) -> Bool
False
_ -> Bool
True
validateRatioNormalised :: Integral a => Ratio a -> Validation
validateRatioNormalised :: Ratio a -> Validation
validateRatioNormalised (n :: a
n :% d :: a
d) = String -> Bool -> Validation
declare "The Ratio is normalised." (Bool -> Validation) -> Bool -> Validation
forall a b. (a -> b) -> a -> b
$
case a
d of
0 -> Bool
False
_ ->
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
< 0
n' :: a
n' :% d' :: 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
instance Validity Integer where
validate :: Integer -> Validation
validate = Integer -> Validation
forall a. a -> Validation
trivialValidation
#if MIN_VERSION_base(4,8,0)
instance Validity Natural where
validate :: Natural -> Validation
validate = String -> Bool -> Validation
declare "The Natural is valid." (Bool -> Validation) -> (Natural -> Bool) -> Natural -> Validation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Natural -> Bool
isValidNatural
#endif
instance (Validity a, Ord a, Num a, Integral a) => Validity (Ratio a) where
validate :: Ratio a -> Validation
validate r :: Ratio a
r@(n :: a
n :% d :: a
d) =
[Validation] -> Validation
forall a. Monoid a => [a] -> a
mconcat
[ a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate a
n "The numerator"
, a -> String -> Validation
forall a. Validity a => a -> String -> Validation
annotate a
d "The denominator"
, String -> Bool -> Validation
declare "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
> 0
, Ratio a -> Validation
forall a. Integral a => Ratio a -> Validation
validateRatioNormalised Ratio a
r
]
instance HasResolution a => Validity (Fixed a) where
validate :: Fixed a -> Validation
validate (MkFixed i :: Integer
i) = Integer -> Validation
forall a. Validity a => a -> Validation
validate Integer
i
annotateValidation :: Validation -> String -> Validation
annotateValidation :: Validation -> String -> Validation
annotateValidation val :: Validation
val s :: String
s =
case Validation
val of
Validation errs :: [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 :: U1 a -> Validation
gValidate = U1 a -> Validation
forall a. a -> Validation
trivialValidation
instance GValidity V1 where
gValidate :: V1 a -> Validation
gValidate = V1 a -> Validation
forall a. a -> Validation
trivialValidation
instance (GValidity a, GValidity b) => GValidity (a :*: b) where
gValidate :: (:*:) a b a -> Validation
gValidate (a :: a a
a :*: b :: b a
b) = 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 (f :: * -> *) a. GValidity f => f a -> Validation
gValidate b a
b
instance (GValidity a, GValidity b) => GValidity (a :+: b) where
gValidate :: (:+:) a b a -> Validation
gValidate (L1 x :: a a
x) = a a -> Validation
forall (f :: * -> *) a. GValidity f => f a -> Validation
gValidate a a
x
gValidate (R1 x :: b a
x) = 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 :: M1 D c a a -> Validation
gValidate m1 :: M1 D c a a
m1 = a a -> Validation
forall (f :: * -> *) a. GValidity f => f a -> Validation
gValidate (M1 D c a a -> a a
forall i (c :: Meta) k (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 :: M1 C c a a -> Validation
gValidate m1 :: M1 C c a a
m1 = a a -> Validation
forall (f :: * -> *) a. GValidity f => f a -> Validation
gValidate (M1 C c a a -> a a
forall i (c :: Meta) k (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
conName M1 C c a a
m1
instance (GValidity a, Selector c) => GValidity (M1 S c a) where
gValidate :: M1 S c a a -> Validation
gValidate m1 :: M1 S c a a
m1 = a a -> Validation
forall (f :: * -> *) a. GValidity f => f a -> Validation
gValidate (M1 S c a a -> a a
forall i (c :: Meta) k (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
selName M1 S c a a
m1
instance (Validity a) => GValidity (K1 R a) where
gValidate :: K1 R a a -> Validation
gValidate (K1 x :: a
x) = a -> Validation
forall a. Validity a => a -> Validation
validate a
x
isValid :: Validity a => a -> Bool
isValid :: 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
isInvalid :: Validity a => a -> Bool
isInvalid :: 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
constructValid :: Validity a => a -> Maybe a
constructValid :: a -> Maybe a
constructValid p :: 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
constructValidUnsafe :: (Show a, Validity a) => a -> a
constructValidUnsafe :: a -> a
constructValidUnsafe p :: 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]
++ " 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
checkValidity :: Validity a => a -> Either [ValidationChain] a
checkValidity :: a -> Either [ValidationChain] a
checkValidity a :: 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 errs :: [ValidationChain]
errs -> [ValidationChain] -> Either [ValidationChain] a
forall a b. a -> Either a b
Left [ValidationChain]
errs
validationIsValid :: Validation -> Bool
validationIsValid :: Validation -> Bool
validationIsValid v :: Validation
v = case Validation
v of
Validation [] -> Bool
True
_ -> Bool
False
prettyValidate :: Validity a => a -> Either String a
prettyValidate :: a -> Either String a
prettyValidate a :: 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 e :: String
e -> String -> Either String a
forall a b. a -> Either a b
Left String
e
Nothing -> a -> Either String a
forall a b. b -> Either a b
Right a
a
prettyValidation :: Validation -> Maybe String
prettyValidation :: Validation -> Maybe String
prettyValidation v :: Validation
v =
case Validation
v of
Validation [] -> Maybe String
forall a. Maybe a
Nothing
Validation errs :: [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 "\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 s :: String
s) = ["Violated: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s]
toStrings (Location s :: String
s vc :: ValidationChain
vc) = String
s String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ValidationChain -> [String]
toStrings ValidationChain
vc
errCascade :: [String] -> String
errCascade errList :: [String]
errList =
String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\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 [0 ..] [String]
errList) (((Int, String) -> String) -> [String])
-> ((Int, String) -> String) -> [String]
forall a b. (a -> b) -> a -> b
$ \(i :: Int
i, segment :: String
segment) ->
case Int
i of
0 -> String
segment
_ -> Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
i ' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\\ " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
segment