{-# 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 (ltWord#)
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 = genericValidate
genericValidate :: (Generic a, GValidity (Rep a)) => a -> Validation
genericValidate = gValidate . from
data ValidationChain
= Violated String
| Location String
ValidationChain
deriving (Show, Eq, Generic)
instance Validity ValidationChain
newtype Validation = Validation
{ unValidation :: [ValidationChain]
} deriving (Show, Eq, Generic)
#if MIN_VERSION_base(4,11,0)
instance Semigroup Validation where
(Validation v1) <> (Validation v2) = Validation $ v1 ++ v2
#endif
instance Monoid Validation where
mempty = Validation []
#if MIN_VERSION_base(4,11,0)
mappend = (<>)
#else
mappend (Validation v1) (Validation v2) = Validation $ v1 ++ v2
#endif
trivialValidation :: a -> Validation
trivialValidation a = seq a mempty
check :: Bool -> String -> Validation
check b err =
if b
then mempty
else Validation [Violated err]
declare :: String -> Bool -> Validation
declare = flip check
annotate :: Validity a => a -> String -> Validation
annotate = annotateValidation . validate
delve :: Validity a => String -> a -> Validation
delve = flip annotate
decorate :: String -> Validation -> Validation
decorate = flip annotateValidation
decorateList :: [a] -> (a -> Validation) -> Validation
decorateList as func = mconcat $
flip map (zip [0..] as) $ \(i, a) ->
decorate (unwords ["The element at index", show (i :: Integer), "in the list"]) $
func a
invalid :: String -> Validation
invalid = check False
valid :: Validation
valid = mempty
instance (Validity a, Validity b) => Validity (a, b) where
validate (a, b) =
mconcat
[ annotate a "The first element of the tuple"
, annotate b "The second element of the tuple"
]
instance (Validity a, Validity b) => Validity (Either a b) where
validate (Left a) = annotate a "The 'Left'"
validate (Right b) = annotate b "The 'Right'"
instance (Validity a, Validity b, Validity c) => Validity (a, b, c) where
validate (a, b, c) =
mconcat
[ annotate a "The first element of the triple"
, annotate b "The second element of the triple"
, annotate 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) =
mconcat
[ annotate a "The first element of the quadruple"
, annotate b "The second element of the quadruple"
, annotate c "The third element of the quadruple"
, annotate 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) =
mconcat
[ annotate a "The first element of the quintuple"
, annotate b "The second element of the quintuple"
, annotate c "The third element of the quintuple"
, annotate d "The fourth element of the quintuple"
, annotate 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) =
mconcat
[ annotate a "The first element of the sextuple"
, annotate b "The second element of the sextuple"
, annotate c "The third element of the sextuple"
, annotate d "The fourth element of the sextuple"
, annotate e "The fifth element of the sextuple"
, annotate f "The sixth element of the sextuple"
]
instance Validity a => Validity [a] where
validate = flip decorateList validate
#if MIN_VERSION_base(4,9,0)
instance Validity a => Validity (NonEmpty a) where
validate (e :| es) =
mconcat
[ annotate e "The first element of the nonempty list"
, annotate es "The rest of the elements of the nonempty list"
]
#endif
instance Validity a => Validity (Maybe a) where
validate Nothing = mempty
validate (Just a) = annotate a "The 'Just'"
instance Validity () where
validate = trivialValidation
instance Validity Bool where
validate = trivialValidation
instance Validity Ordering where
validate = trivialValidation
instance Validity Char where
validate (C# c#) = mconcat
[ declare "The contained value is positive" $ isTrue# (ord# c# >=# 0#)
, declare "The contained value is smaller than 0x10FFFF = 1114111" $ isTrue# (ord# c# <=# 1114111#)
]
validateCharNotUtf16SurrogateCodePoint :: Char -> Validation
validateCharNotUtf16SurrogateCodePoint c =
declare "The character is not a UTF16 surrogate codepoint" $ not $ isUtf16SurrogateCodePoint c
isUtf16SurrogateCodePoint :: Char -> Bool
isUtf16SurrogateCodePoint c = ord c .&. 0x1ff800 == 0xd800
instance Validity Int where
validate = trivialValidation
instance Validity Int8 where
validate (I8# i#) =
mconcat
[ declare "The contained integer is smaller than 2^7 = 128" $ isTrue# (i# <# 128#)
, declare "The contained integer is greater than or equal to -2^7 = -128" $ isTrue# (i# >=# -128#)
]
instance Validity Int16 where
validate (I16# i#) =
mconcat
[ declare "The contained integer is smaller than 2^15 = 32768" $ isTrue# (i# <# 32768#)
, declare "The contained integer is greater than or equal to -2^15 = -32768" $ isTrue# (i# >=# -32768#)
]
instance Validity Int32 where
validate (I32# i#) =
mconcat
[ declare "The contained integer is smaller than 2^31 = 2147483648" $ isTrue# (i# <# 2147483648#)
, declare "The contained integer is greater than or equal to -2^31 = -2147483648" $ isTrue# (i# >=# -2147483648#)
]
instance Validity Int64 where
validate = trivialValidation
instance Validity Word where
validate = trivialValidation
instance Validity Word8 where
validate (W8# w#) =
declare "The contained integer is smaller than 2^8 = 256" $ isTrue# (w# `ltWord#` 256##)
instance Validity Word16 where
validate (W16# w#) =
declare "The contained integer is smaller than 2^16 = 65536" $ isTrue# (w# `ltWord#` 65536##)
instance Validity Word32 where
validate (W32# w#) =
declare "The contained integer is smaller than 2^32 = 4294967296" $ isTrue# (w# `ltWord#` 4294967296##)
instance Validity Word64 where
validate = trivialValidation
instance Validity Float where
validate = trivialValidation
instance Validity Double where
validate = trivialValidation
validateNotNaN :: RealFloat a => a -> Validation
validateNotNaN d = declare "The RealFloat is not NaN." $ not (isNaN d)
validateNotInfinite :: RealFloat a => a -> Validation
validateNotInfinite d = declare "The RealFloat is not infinite." $ not (isInfinite d)
validateRatioNotNaN :: Integral a => Ratio a -> Validation
validateRatioNotNaN r = declare "The Ratio is not NaN." $
case r of
(0 :% 0) -> False
_ -> True
validateRatioNotInfinite :: Integral a => Ratio a -> Validation
validateRatioNotInfinite r = declare "The Ratio is not infinite." $
case r of
(1 :% 0) -> False
((-1) :% 0) -> False
_ -> True
validateRatioNormalised :: Integral a => Ratio a -> Validation
validateRatioNormalised (n :% d) = declare "The Ratio is normalised." $
case d of
0 -> False
_ ->
let g = gcd n d
gcdOverflows = g < 0
n' :% d' = (n `quot` g) :% (d `quot` g)
valueIsNormalised = n' :% d' == n :% d
in not gcdOverflows && valueIsNormalised
instance Validity Integer where
validate = trivialValidation
#if MIN_VERSION_base(4,8,0)
instance Validity Natural where
validate = declare "The Natural is valid." . isValidNatural
#endif
instance (Validity a, Ord a, Num a, Integral a) => Validity (Ratio a) where
validate r@(n :% d) =
mconcat
[ annotate n "The numerator"
, annotate d "The denominator"
, declare "The denominator is strictly positive." $ d > 0
, validateRatioNormalised r
]
instance HasResolution a => Validity (Fixed a) where
validate (MkFixed i) = validate i
annotateValidation :: Validation -> String -> Validation
annotateValidation val s =
case val of
Validation errs -> Validation $ map (Location s) errs
class GValidity f where
gValidate :: f a -> Validation
instance GValidity U1 where
gValidate = trivialValidation
instance GValidity V1 where
gValidate = trivialValidation
instance (GValidity a, GValidity b) => GValidity (a :*: b) where
gValidate (a :*: b) = gValidate a `mappend` gValidate b
instance (GValidity a, GValidity b) => GValidity (a :+: b) where
gValidate (L1 x) = gValidate x
gValidate (R1 x) = gValidate x
instance (GValidity a, Datatype c) => GValidity (M1 D c a) where
gValidate m1 = gValidate (unM1 m1)
instance (GValidity a, Constructor c) => GValidity (M1 C c a) where
gValidate m1 = gValidate (unM1 m1) `annotateValidation` conName m1
instance (GValidity a, Selector c) => GValidity (M1 S c a) where
gValidate m1 = gValidate (unM1 m1) `annotateValidation` selName m1
instance (Validity a) => GValidity (K1 R a) where
gValidate (K1 x) = validate x
isValid :: Validity a => a -> Bool
isValid = isRight . checkValidity
isInvalid :: Validity a => a -> Bool
isInvalid = not . isValid
constructValid :: Validity a => a -> Maybe a
constructValid p =
if isValid p
then Just p
else Nothing
constructValidUnsafe :: (Show a, Validity a) => a -> a
constructValidUnsafe p =
fromMaybe (error $ show p ++ " is not valid") $ constructValid p
checkValidity :: Validity a => a -> Either [ValidationChain] a
checkValidity a =
case validate a of
Validation [] -> Right a
Validation errs -> Left errs
validationIsValid :: Validation -> Bool
validationIsValid v = case v of
Validation [] -> True
_ -> False
prettyValidate :: Validity a => a -> Either String a
prettyValidate a = case prettyValidation $ validate a of
Just e -> Left e
Nothing -> Right a
prettyValidation :: Validation -> Maybe String
prettyValidation v =
case v of
Validation [] -> Nothing
Validation errs -> Just $ intercalate "\n" $ map (errCascade . toStrings) errs
where
toStrings (Violated s) = ["Violated: " ++ s]
toStrings (Location s vc) = s : toStrings vc
errCascade errList =
intercalate "\n" $
flip map (zip [0 ..] errList) $ \(i, segment) ->
case i of
0 -> segment
_ -> replicate i ' ' ++ "\\ " ++ segment