module Data.Validity
( Validity(..)
, triviallyValid
, trivialValidation
, isValidByValidating
, check
, (<?!>)
, annotate
, (<?@>)
, validateByChecking
, validateByCheckingName
, validateByCheckingDefault
, isInvalid
, constructValid
, constructValidUnsafe
, Validation(..)
, ValidationChain(..)
, checkValidity
, prettyValidation
, Monoid(..)
) 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 (Maybe, fromMaybe)
#if MIN_VERSION_base(4,8,0)
#else
import Data.Monoid
#endif
import Data.Word (Word, Word16, Word32, Word64, Word8)
import GHC.Generics
#if MIN_VERSION_base(4,8,0)
import GHC.Natural (Natural, isValidNatural)
#endif
import GHC.Real (Ratio(..))
class Validity a where
validate :: a -> Validation
default validate :: (Generic a, GValidity (Rep a)) =>
a -> Validation
validate = gValidate . from
isValid :: a -> Bool
default isValid :: (Generic a, GValidity (Rep a)) =>
a -> Bool
isValid = gIsValid . from
data ValidationChain
= Violated String
| Location String
ValidationChain
deriving (Show, Eq, Generic)
instance Validity ValidationChain
newtype Validation = Validation
{ unValidation :: [ValidationChain]
} deriving (Show, Eq, Generic)
instance Validity Validation
instance Monoid Validation where
mempty = Validation []
mappend (Validation v1) (Validation v2) = Validation $ v1 ++ v2
triviallyValid :: a -> Bool
triviallyValid a = seq a True
isValidByValidating :: Validity a => a -> Bool
isValidByValidating = isRight . checkValidity
trivialValidation :: a -> Validation
trivialValidation a = seq a mempty
validateByChecking :: Validity a => String -> a -> Validation
validateByChecking s a = isValid a <?@> s
validateByCheckingName :: Validity a => String -> a -> Validation
validateByCheckingName name =
validateByChecking $ unwords ["The", name, "valid."]
validateByCheckingDefault :: Validity a => a -> Validation
validateByCheckingDefault = validateByChecking "The value is valid."
check :: Bool -> String -> Validation
check b err =
if b
then mempty
else Validation [Violated err]
(<?@>) :: Bool -> String -> Validation
(<?@>) = check
infixr 0 <?@>
annotate :: Validity a => a -> String -> Validation
annotate = annotateValidation . validate
(<?!>) :: Validity a => a -> String -> Validation
(<?!>) = annotate
infixr 0 <?!>
instance (Validity a, Validity b) => Validity (a, b) where
isValid (a, b) = isValid a && isValid b
validate (a, b) =
mconcat
[ a <?!> "The first element of the tuple"
, b <?!> "The second element of the tuple"
]
instance (Validity a, Validity b) => Validity (Either a b) where
isValid (Left a) = isValid a
isValid (Right b) = isValid b
validate (Left a) = a <?!> "The 'Left'"
validate (Right b) = b <?!> "The 'Right'"
instance (Validity a, Validity b, Validity c) => Validity (a, b, c) where
isValid (a, b, c) = isValid a && isValid b && isValid c
validate (a, b, c) =
mconcat
[ a <?!> "The first element of the triple"
, b <?!> "The second element of the triple"
, c <?!> "The third element of the triple"
]
instance (Validity a, Validity b, Validity c, Validity d) =>
Validity (a, b, c, d) where
isValid (a, b, c, d) = isValid a && isValid b && isValid c && isValid d
validate (a, b, c, d) =
mconcat
[ a <?!> "The first element of the quadruple"
, b <?!> "The second element of the quadruple"
, c <?!> "The third element of the quadruple"
, 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
isValid (a, b, c, d, e) =
isValid a && isValid b && isValid c && isValid d && isValid e
validate (a, b, c, d, e) =
mconcat
[ a <?!> "The first element of the quintuple"
, b <?!> "The second element of the quintuple"
, c <?!> "The third element of the quintuple"
, d <?!> "The fourth element of the quintuple"
, 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
isValid (a, b, c, d, e, f) =
isValid a &&
isValid b && isValid c && isValid d && isValid e && isValid f
validate (a, b, c, d, e, f) =
mconcat
[ a <?!> "The first element of the sextuple"
, b <?!> "The second element of the sextuple"
, c <?!> "The third element of the sextuple"
, d <?!> "The fourth element of the sextuple"
, e <?!> "The fifth element of the sextuple"
, f <?!> "The sixth element of the sextuple"
]
instance Validity a => Validity [a] where
isValid = all isValid
validate =
mconcat .
map
(\(ix, e) ->
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
isValid = all isValid
validate (e :| es) =
mconcat
[ e <?!> "The first element of the nonempty list"
, es <?!> "The rest of the elements of the nonempty list"
]
#endif
instance Validity a => Validity (Maybe a) where
isValid Nothing = True
isValid (Just a) = isValid a
validate Nothing = mempty
validate (Just a) = a <?!> "The 'Just'"
instance Validity () where
isValid = triviallyValid
validate = validateByCheckingName "()"
instance Validity Bool where
isValid = triviallyValid
validate = validateByCheckingName "Bool"
instance Validity Ordering where
isValid = triviallyValid
validate = validateByCheckingName "Ordering"
instance Validity Char where
isValid = triviallyValid
validate = validateByCheckingName "Char"
instance Validity Int where
isValid = triviallyValid
validate = validateByCheckingName "Int"
instance Validity Word where
isValid = triviallyValid
validate = validateByCheckingName "Word"
instance Validity Word8 where
isValid = triviallyValid
validate = validateByCheckingName "Word8"
instance Validity Word16 where
isValid = triviallyValid
validate = validateByCheckingName "Word16"
instance Validity Word32 where
isValid = triviallyValid
validate = validateByCheckingName "Word34"
instance Validity Word64 where
isValid = triviallyValid
validate = validateByCheckingName "Word64"
instance Validity Float where
isValid f = not (isNaN f) && not (isInfinite f)
validate f =
mconcat
[ not (isNaN f) <?@> "The Float is not Nan."
, not (isInfinite f) <?@> "The Float is not infinite."
]
instance Validity Double where
isValid d = not (isNaN d) && not (isInfinite d)
validate d =
mconcat
[ not (isNaN d) <?@> "The Double is not NaN."
, not (isInfinite d) <?@> "The Double is not infinite."
]
instance Validity Integer where
isValid = triviallyValid
validate = validateByCheckingName "Integer"
#if MIN_VERSION_base(4,8,0)
instance Validity Natural where
isValid = isValidNatural
validate = validateByChecking "Natural"
#endif
instance Validity Rational where
isValid (d :% n) = isValid n && isValid d && d > 0
validate (d :% n) =
mconcat
[ d <?!> "The numerator"
, n <?!> "The denominator"
, (d > 0) <?@> "The denominator is strictly positive."
]
instance HasResolution a => Validity (Fixed a) where
isValid (MkFixed i) = isValid i
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
gIsValid :: f a -> Bool
gValidate :: f a -> Validation
instance GValidity U1 where
gIsValid = triviallyValid
gValidate = trivialValidation
instance GValidity V1 where
gIsValid = triviallyValid
gValidate = trivialValidation
instance (GValidity a, GValidity b) => GValidity (a :*: b) where
gIsValid (a :*: b) = gIsValid a && gIsValid b
gValidate (a :*: b) = gValidate a `mappend` gValidate b
instance (GValidity a, GValidity b) => GValidity (a :+: b) where
gIsValid (L1 x) = gIsValid x
gIsValid (R1 x) = gIsValid x
gValidate (L1 x) = gValidate x
gValidate (R1 x) = gValidate x
instance (GValidity a, Datatype c) => GValidity (M1 D c a) where
gIsValid (M1 x) = gIsValid x
gValidate m1 = gValidate (unM1 m1)
instance (GValidity a, Constructor c) => GValidity (M1 C c a) where
gIsValid (M1 x) = gIsValid x
gValidate m1 = gValidate (unM1 m1) `annotateValidation` conName m1
instance (GValidity a, Selector c) => GValidity (M1 S c a) where
gIsValid (M1 x) = gIsValid x
gValidate m1 = gValidate (unM1 m1) `annotateValidation` selName m1
instance (Validity a) => GValidity (K1 R a) where
gIsValid (K1 x) = isValid x
gValidate (K1 x) = validate x
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