validity 0.4.0.4 → 0.5.0.0
raw patch · 4 files changed
+189/−174 lines, 4 filesdep +hspecdep +validitydep ~base
Dependencies added: hspec, validity
Dependency ranges changed: base
Files
- src/Data/Validity.hs +109/−171
- test/Data/ValiditySpec.hs +61/−0
- test/Spec.hs +1/−0
- validity.cabal +18/−3
src/Data/Validity.hs view
@@ -29,7 +29,6 @@ > instance Validity Prime where > validate (Prime n) = isPrime n <?@> "The 'Int' is prime."- > isValid (Prime n) = isPrime n If certain typeclass invariants exist, you can make these explicit in the validity instance as well.@@ -38,18 +37,15 @@ -} module Data.Validity ( Validity(..)- -- * Helper functions to define 'isValid'- , triviallyValid+ , isValid -- * Helper functions to define 'validate' , trivialValidation- , isValidByValidating , check- , (<?!>)+ , declare , annotate- , (<?@>)- , validateByChecking- , validateByCheckingName- , validateByCheckingDefault+ , delve+ , invalid+ , valid -- * Utilities -- ** Utilities for validity checking , isInvalid@@ -62,6 +58,9 @@ , prettyValidation -- * Re-exports , Monoid(..)+#if MIN_VERSION_base(4,11,0)+ , Semigroup(..)+#endif ) where import Data.Either (isRight)@@ -76,6 +75,7 @@ import Data.Monoid import Data.Ratio #endif+import Data.Int (Int, Int16, Int32, Int64, Int8) import Data.Word (Word, Word16, Word32, Word64, Word8) import GHC.Generics #if MIN_VERSION_base(4,8,0)@@ -92,14 +92,14 @@ -- 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 both 'isValid' and--- 'validate'.--- Start by implementing 'validate'. Use the helper functions below to define--- all the reasons why a given value would be a valid value of its type.--- Then define `isValid = isValidbyValidating' for now.+-- 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: --@@ -108,22 +108,7 @@ -- > instance Validity Even -- > validate (Event i) -- > even i <?@> "The contained 'Int' is even."--- > isValid = isValidByValidating ----- If it turns out that, at this point, 'isValid' is too slow for your taste,--- you can replace the implementation of 'isValid' by a custom implementation.--- However, it is important that this 'isValid' implementation has exactly--- the same semantics as 'isValidbyValidating'.------ Example:------ > newtype Even = Even Int--- >--- > instance Validity Even--- > validate (Event i)--- > even i <?@> "The contained 'Int' is even."--- > isValid (Event i) = even i--- -- === Semantics -- -- 'isValid' should be an underapproximation of actual validity.@@ -150,7 +135,7 @@ -- === 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 'isValid' to+-- 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:@@ -167,8 +152,6 @@ -- generates something like: -- -- > instance Validity MyType where--- > isValid (MyType d s)--- > = isValid d && isValid s -- > validate (MyType d s) -- > = d <?!> "myDouble" -- > <> s <?!> "myString"@@ -177,10 +160,10 @@ default validate :: (Generic a, GValidity (Rep a)) => a -> Validation validate = gValidate . from- isValid :: a -> Bool- default isValid :: a -> Bool- isValid = isRight . checkValidity +isValid :: Validity a => a -> Bool+isValid = isRight . checkValidity+ data ValidationChain = Violated String | Location String@@ -194,48 +177,23 @@ } deriving (Show, Eq, Generic) instance Validity Validation-+#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---- | Declare any value to be valid.------ > triviallyValid a = seq a True-triviallyValid :: a -> Bool-triviallyValid a = seq a True---- | Implement 'isValid' by using 'validate' and checking that there are no--- reasons that the value is invalid.-isValidByValidating :: Validity a => a -> Bool-isValidByValidating = isRight . checkValidity-+#endif -- | Declare any value to be valid in validation -- -- > trivialValidation a = seq a mempty trivialValidation :: a -> Validation trivialValidation a = seq a mempty --- | Implement 'validate' by using 'isValid' and using the given string as the--- reason if the value is invalid.-validateByChecking :: Validity a => String -> a -> Validation-validateByChecking s a = isValid a <?@> s---- | Implement 'validate' by using 'isValid' and using the given name to define--- the reason if the value is invalid.------ > validateByCheckingName name = validateByChecking $ unwords ["The", name, "valid."]-validateByCheckingName :: Validity a => String -> a -> Validation-validateByCheckingName name =- validateByChecking $ unwords ["The", name, "valid."]---- | Implement 'validate' by using 'isValid' and using a default reason if the--- value is invalid.------ > validateByCheckingDefault = validateByChecking "The value is valid."-validateByCheckingDefault :: Validity a => a -> Validation-validateByCheckingDefault = validateByChecking "The value is valid."- -- | Check that a given invariant holds. -- -- The given string should describe the invariant, not the violation.@@ -253,15 +211,29 @@ then mempty else Validation [Violated err] --- | Infix operator for 'check'+-- | 'check', but with the arguments flipped+declare :: String -> Bool -> Validation+declare = flip check++-- | Construct a trivially invalid 'Validation' -- -- Example: ----- > x < 5 <?@> "x is strictly smaller than 5"-(<?@>) :: Bool -> String -> Validation-(<?@>) = check+-- > 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 = check False -infixr 0 <?@>+valid :: Validation+valid = mempty -- | Declare a sub-part as a necessary part for validation, and annotate it with a name. --@@ -275,70 +247,53 @@ annotate :: Validity a => a -> String -> Validation annotate = annotateValidation . validate --- | Infix operator for 'annotate'------ Example:------ > validate (a, b) =--- > mconcat--- > [ a <?!> "The first element of the tuple"--- > , b <?!> "The second element of the tuple"--- > ]-(<?!>) :: Validity a => a -> String -> Validation-(<?!>) = annotate--infixr 0 <?!>+-- | 'annotate', but with the arguments flipped.+delve :: Validity a => String -> a -> Validation+delve = flip annotate -- | Any tuple of things is valid if both of its elements are valid 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"+ [ annotate a "The first element of the tuple"+ , annotate b "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- isValid (Left a) = isValid a- isValid (Right b) = isValid b- validate (Left a) = a <?!> "The 'Left'"- validate (Right b) = b <?!> "The 'Right'"+ validate (Left a) = annotate a "The 'Left'"+ validate (Right b) = annotate b "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- 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"+ [ annotate a "The first element of the triple"+ , annotate b "The second element of the triple"+ , annotate c "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- 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"+ [ 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" ] -- | 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- 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"+ [ 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" ] -- | Any sextuple of things is valid if all six of its elements are valid@@ -350,17 +305,14 @@ , 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"+ [ 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" ] -- | A list of things is valid if all of the things are valid.@@ -369,12 +321,11 @@ -- 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- isValid = all isValid validate = mconcat . map (\(ix, e) ->- e <?!>+ annotate e $ unwords [ "The element at index" , show (ix :: Integer)@@ -386,11 +337,10 @@ -- -- See the instance for 'Validity [a]' for more information. 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"+ [ annotate e "The first element of the nonempty list"+ , annotate es "The rest of the elements of the nonempty list" ] #endif -- | A Maybe thing is valid if the thing inside is valid or it's nothing@@ -398,71 +348,74 @@ -- If Nothing wasn't valid, you wouldn't have used a Maybe -- in the datastructure. instance Validity a => Validity (Maybe a) where- isValid Nothing = True- isValid (Just a) = isValid a validate Nothing = mempty- validate (Just a) = a <?!> "The 'Just'"+ validate (Just a) = annotate a "The 'Just'" -- | Trivially valid instance Validity () where- isValid = triviallyValid- validate = validateByCheckingName "()"+ validate = trivialValidation -- | Trivially valid instance Validity Bool where- isValid = triviallyValid- validate = validateByCheckingName "Bool"+ validate = trivialValidation -- | Trivially valid instance Validity Ordering where- isValid = triviallyValid- validate = validateByCheckingName "Ordering"+ validate = trivialValidation -- | Trivially valid instance Validity Char where- isValid = triviallyValid- validate = validateByCheckingName "Char"+ validate = trivialValidation -- | Trivially valid instance Validity Int where- isValid = triviallyValid- validate = validateByCheckingName "Int"+ validate = trivialValidation -- | Trivially valid+instance Validity Int8 where+ validate = trivialValidation++-- | Trivially valid+instance Validity Int16 where+ validate = trivialValidation++-- | Trivially valid+instance Validity Int32 where+ validate = trivialValidation++-- | Trivially valid+instance Validity Int64 where+ validate = trivialValidation++-- | Trivially valid instance Validity Word where- isValid = triviallyValid- validate = validateByCheckingName "Word"+ validate = trivialValidation -- | Trivially valid instance Validity Word8 where- isValid = triviallyValid- validate = validateByCheckingName "Word8"+ validate = trivialValidation -- | Trivially valid instance Validity Word16 where- isValid = triviallyValid- validate = validateByCheckingName "Word16"+ validate = trivialValidation -- | Trivially valid instance Validity Word32 where- isValid = triviallyValid- validate = validateByCheckingName "Word34"+ validate = trivialValidation -- | Trivially valid instance Validity Word64 where- isValid = triviallyValid- validate = validateByCheckingName "Word64"+ validate = trivialValidation -- | NOT trivially valid: -- -- * NaN is not valid. -- * Infinite values are not valid. 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."+ [ declare "The Float is not Nan." $ not (isNaN f)+ , declare "The Float is not infinite." $ not (isInfinite f) ] -- | NOT trivially valid:@@ -470,11 +423,10 @@ -- * NaN is not valid. -- * Infinite values are not valid. 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."+ [ declare "The Double is not NaN." $ not (isNaN d)+ , declare "The Double is not infinite." $ not (isInfinite d) ] -- | Trivially valid@@ -486,30 +438,26 @@ -- assuming that an 'Integer' is always valid. -- Even though this is not technically sound, it is good enough for now. instance Validity Integer where- isValid = triviallyValid- validate = validateByCheckingName "Integer"+ validate = trivialValidation #if MIN_VERSION_base(4,8,0) -- | Valid according to 'isValidNatural' -- -- Only available with @base >= 4.8@. instance Validity Natural where- isValid = isValidNatural- validate = validateByChecking "Natural"+ validate n = check (isValidNatural n) "The Natural is valid." #endif -- | Valid if the contained numbers are valid and the denominator is -- strictly positive. instance (Num a, Ord a, Validity a) => Validity (Ratio a) where- isValid (n :% d) = isValid n && isValid d && d > 0 validate (n :% d) = mconcat- [ n <?!> "The numerator"- , d <?!> "The denominator"- , (d > 0) <?@> "The denominator is strictly positive."+ [ annotate n "The numerator"+ , annotate d "The denominator"+ , declare "The denominator is strictly positive." $ d > 0 ] -- | Valid according to the contained 'Integer'. instance HasResolution a => Validity (Fixed a) where- isValid (MkFixed i) = isValid i validate (MkFixed i) = validate i annotateValidation :: Validation -> String -> Validation@@ -518,41 +466,31 @@ 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 -- | Check whether 'isInvalid' is not valid.
+ test/Data/ValiditySpec.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE DeriveGeneric #-}++module Data.ValiditySpec+ ( spec+ ) where++import GHC.Generics (Generic)++import Data.Monoid++import Data.Validity++import Test.Hspec++data Wrong+ = Wrong+ | Fine+ deriving (Show, Eq)++instance Validity Wrong where+ validate w =+ case w of+ Wrong -> invalid "Wrong"+ Fine -> valid++data GeneratedValidity =+ G Double+ Double+ deriving (Show, Eq, Generic)++instance Validity GeneratedValidity++-- To make sure that the <?!> operator have the right fixity+data ManuallyInstantiated =+ M Double+ Double+ deriving (Show, Eq)++instance Validity ManuallyInstantiated where+ validate (M m1 m2) = annotate m1 "m1" <> annotate m2 "m2"++-- To make sure that the <?@> operator have the right fixity+data TwoEvens =+ E Int+ Int+ deriving (Show, Eq)++instance Validity TwoEvens where+ validate (E e1 e2) =+ declare "e1 is even" (even e1) <> declare "e2 is even" (even e2)++spec :: Spec+spec = do+ describe "Wrong" $ do+ it "says Wrong is invalid" $ Wrong `shouldSatisfy` (not . isValid)+ it "says Fine is valid" $ Fine `shouldSatisfy` isValid+ describe "GeneratedValidity" $ do+ let nan = read "NaN"+ it "says G nan 0 is not valid" $ G nan 0 `shouldSatisfy` (not . isValid)+ it "says G 0 nan is not valid" $ G 0 nan `shouldSatisfy` (not . isValid)+ it "says G 0 0 is valid" $ G 0 0 `shouldSatisfy` isValid
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
validity.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: d851f0e11791eff6a09f991a6e35b970714b50ddc6ee5f5f97692176076d3fc5+-- hash: a87e6dba549df499f2c199dd442f9cceacbeb4a8f99bd95f89739fbe810db31a name: validity-version: 0.4.0.4+version: 0.5.0.0 synopsis: Validity typeclass description: For more info, see <https://github.com/NorfairKing/validity the readme>. .@@ -35,7 +35,7 @@ bug-reports: https://github.com/NorfairKing/validity/issues author: Tom Sydney Kerckhove maintainer: syd.kerckhove@gmail.com-copyright: Copyright: (c) 2016 Tom Sydney Kerckhove+copyright: Copyright: (c) 2016-2018 Tom Sydney Kerckhove license: MIT license-file: LICENSE build-type: Simple@@ -56,5 +56,20 @@ Data.RelativeValidity Data.Validity other-modules:+ Paths_validity+ default-language: Haskell2010++test-suite validity-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ build-depends:+ base+ , hspec+ , validity+ other-modules:+ Data.ValiditySpec Paths_validity default-language: Haskell2010