{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# 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
, invalid
, valid
, isValid
, isInvalid
, constructValid
, constructValidUnsafe
, Validation(..)
, ValidationChain(..)
, checkValidity
, 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.Int (Int16, Int32, Int64, Int8)
#if MIN_VERSION_base(4,8,0)
import Data.Word (Word16, Word32, Word64, Word8)
#else
import Data.Word (Word, Word16, Word32, Word64, Word8)
#endif
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
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 =
mconcat .
map
(\(ix, e) ->
annotate e $
unwords
[ "The element at index"
, show (ix :: Integer)
, "in the list"
]) .
zip [0 ..]
#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 = trivialValidation
instance Validity Int where
validate = trivialValidation
instance Validity Int8 where
validate = trivialValidation
instance Validity Int16 where
validate = trivialValidation
instance Validity Int32 where
validate = trivialValidation
instance Validity Int64 where
validate = trivialValidation
instance Validity Word where
validate = trivialValidation
instance Validity Word8 where
validate = trivialValidation
instance Validity Word16 where
validate = trivialValidation
instance Validity Word32 where
validate = trivialValidation
instance Validity Word64 where
validate = trivialValidation
instance Validity Float where
validate f =
mconcat
[ declare "The Float is not Nan." $ not (isNaN f)
, declare "The Float is not infinite." $ not (isInfinite f)
, declare "The Float is not zegative zero." $ not (isNegativeZero f)
]
instance Validity Double where
validate d =
mconcat
[ declare "The Double is not NaN." $ not (isNaN d)
, declare "The Double is not infinite." $ not (isInfinite d)
, declare "The Double is not zegative zero." $ not (isNegativeZero d)
]
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 (Num a, Ord a, Validity a) => Validity (Ratio a) where
validate (n :% d) =
mconcat
[ annotate n "The numerator"
, annotate d "The denominator"
, declare "The denominator is strictly positive." $ d > 0
]
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
prettyValidation :: Validity a => a -> Either String a
prettyValidation a =
case checkValidity a of
Right a_ -> Right a_
Left errs -> Left $ 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