validity 0.3.3.0 → 0.12.1.0
raw patch · 8 files changed
Files
- CHANGELOG.md +90/−0
- LICENSE +1/−1
- Setup.hs +0/−3
- src/Data/RelativeValidity.hs +0/−25
- src/Data/Validity.hs +614/−133
- test/Data/ValiditySpec.hs +165/−0
- test/Spec.hs +1/−0
- validity.cabal +71/−37
+ CHANGELOG.md view
@@ -0,0 +1,90 @@+# Changelog++## [0.12.1.0 - 2024-07-18]++### Added++* `Validity` instances for various newtypes in base++## [0.12.0.2] - 2023-10-09++### Added++* `decorateString`++## [0.12.0.1] - 2022-04-26++### Added++* Compatibility with `GHC >= 9.0.0`++## [0.12.0.0] - 2021-11-20++### Removed++* `RelativeValidity`, it was a misfeature.++## [0.11.0.0] - 2020-04-17++### Changed++* Made it so that Char is no longer trivially valid.++## [0.10.0.0] - 2020-04-12++### Changed++* Made it so that Word8, Word16, Word32 and Int8, Int16, Int32 are no longer trivially valid.++## [0.9.0.3] - 2020-02-10++### Changed++* Improved the 'validateRatioNormalised' to not crash on certain extreme values.++## [0.9.0.2] - 2019-09-27++### Added++* `isUtf16SurrogateCodePoint` and `validateCharNotUtf16SurrogateCodePoint`++### Changed++* The contents of the error message when using `validateNotNan` or `validateNotInfinite` is now more accurate.++### Added++* `validateRatioNotNan`+* `validateRatioNotInfinite`+* `validateRatioNormalised`++## [0.9.0.1] - 2018-12-05++### Changed++* The validity instance of `Ratio a` now disallows unnormalised values.+ So `0 %: 1` is valid, but `0 %: 2` is not.++## [0.9.0.0] - 2018-10-07++### Added++* `prettyValidate`, `validationIsValid`, `prettyValidation`+* `validateNotNaN`, `validateNotInfinite`++### Changed++* Renamed `prettyValidation` to `prettyValidate` before adding the new `prettyValidation`.+* `NaN`, `+Infinity` and `-Infinity` are now considered valid for both `Double` and `Float`.++## [0.8.0.0] - 2018-08-25++### Added+* `decorateList` in `Data.Validity`++### Changed+* `-0` is now a valid value for `Double` and `Float`.++## Older versions++No history before version 0.8.0.0
LICENSE view
@@ -1,6 +1,6 @@ The MIT License (MIT) -Copyright (c) 2016 Tom Sydney Kerckhove+Copyright (c) 2016-2021 Tom Sydney Kerckhove Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal
− Setup.hs
@@ -1,3 +0,0 @@-import Distribution.Simple--main = defaultMain
− src/Data/RelativeValidity.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--{-| Relative validity- -}-module Data.RelativeValidity- ( RelativeValidity(..)- , isInvalidFor- ) where---- | A class of types that have additional invariants defined upon them--- that aren't enforced by the type system------ If there is a @Validity a@ instance as well, then @a `isValidFor` b@--- should imply @isValid a@ for any @b@.------ If there is a @Validity b@ instance as well, then @a `isValidFor` b@--- should imply @isValid b@ for any @a@.-class RelativeValidity a b where- isValidFor :: a -> b -> Bool--isInvalidFor- :: RelativeValidity a b- => a -> b -> Bool-isInvalidFor a b = not $ isValidFor a b
src/Data/Validity.hs view
@@ -1,169 +1,583 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DefaultSignatures #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -{-|+-- |+--+-- @Validity@ is used to specify additional invariants upon values that are not+-- enforced by the type system.+--+-- Let's take an example.+-- Suppose we were to implement a type @Prime@ that represents prime integers.+--+-- If you were to completely enforce the invariant that the represented number is+-- a prime, then we could use 'Natural' and only store the index of the+-- given prime in the infinite sequence of prime numbers.+-- This is very safe but also very expensive if we ever want to use the number,+-- because we would have to calculcate all the prime numbers until that index.+--+-- Instead we choose to implement @Prime@ by a @newtype Prime = Prime Int@.+-- Now we have to maintain the invariant that the @Int@ that we use to represent+-- the prime is in fact positive and a prime.+--+-- The @Validity@ typeclass allows us to specify this invariant (and enables+-- testing via the @genvalidity@ libraries:+-- https://hackage.haskell.org/package/genvalidity ):+--+-- > instance Validity Prime where+-- > validate (Prime n) = check (isPrime n) "The 'Int' is prime."+--+-- If certain typeclass invariants exist, you can make these explicit in the+-- validity instance as well.+-- For example, 'Fixed a' is only valid if 'a' has an 'HasResolution' instance,+-- so the correct validity instance is @HasResolution a => Validity (Fixed a)@.+module Data.Validity+ ( Validity (..), - @Validity@ is used to specify additional invariants upon values that are not- enforced by the type system.+ -- * Helper functions to define 'validate'+ trivialValidation,+ genericValidate,+ check,+ declare,+ annotate,+ delve,+ decorate,+ decorateList,+ decorateString,+ invalid,+ valid, - Let's take an example.- Suppose we were to implement a type @Prime@ that represents prime integers.+ -- ** Helpers for specific types - If you were to completely enforce the invariant that the represented number is- a prime, then we could use 'Natural' and only store the index of the- given prime in the infinite sequence of prime numbers.- This is very safe but also very expensive if we ever want to use the number,- because we would have to calculcate all the prime numbers until that index.+ -- *** Char+ validateCharNotUtf16SurrogateCodePoint,+ isUtf16SurrogateCodePoint,+ validateCharNotLineSeparator,+ isLineSeparator,+ validateStringSingleLine,+ isSingleLine, - Instead we choose to implement @Prime@ by a @newtype Prime = Prime Int@.- Now we have to maintain the invariant that the @Int@ that we use to represent- the prime is in fact positive and a prime.+ -- *** RealFloat (Double)+ validateNotNaN,+ validateNotInfinite, - The @Validity@ typeclass allows us to specify this invariant (and enables- testing via the @genvalidity@ libraries:- https://hackage.haskell.org/package/genvalidity ):+ -- *** Ratio+ validateRatioNotNaN,+ validateRatioNotInfinite,+ validateRatioNormalised, - > instance Validity Prime where- > isValid (Prime n) = isPrime n+ -- * Utilities - If certain typeclass invariants exist, you can make these explicit in the- validity instance as well.- For example, 'Fixed a' is only valid if 'a' has an 'HasResolution' instance,- so the correct validity instance is @HasResolution a => Validity (Fixed a)@.- -}-module Data.Validity- ( Validity(..)- , isInvalid- , constructValid- , constructValidUnsafe- ) where+ -- ** Utilities for validity checking+ isValid,+ isInvalid,+ constructValid,+ constructValidUnsafe, -import Data.Fixed (Fixed(MkFixed), HasResolution)-import Data.Maybe (Maybe, fromMaybe)-import Data.Word (Word, Word8, Word16)-import GHC.Generics-#if MIN_VERSION_base(4,8,0)-import GHC.Natural (Natural, isValidNatural)+ -- ** Utilities for validation+ Validation (..),+ ValidationChain (..),+ checkValidity,+ validationIsValid,+ prettyValidate,+ prettyValidation,++ -- * Re-exports+ Monoid (..),+ Semigroup (..),+ )+where++import Data.Bits ((.&.))+import Data.Char (ord)+import Data.Either (isRight)+import Data.Fixed (Fixed (MkFixed), HasResolution)+import Data.Int (Int64)+import Data.List (intercalate)+import Data.List.NonEmpty (NonEmpty ((:|)))+import Data.Maybe (fromMaybe)+#if MIN_VERSION_base(4,16,0)+import GHC.Exts (Char (..), isTrue#, ord#, (<=#), (>=#))+#else+import GHC.Exts (Char (..), isTrue#, leWord#, ord#, (<=#), (>=#)) #endif-import GHC.Real (Ratio(..))+import Data.Functor.Const (Const (Const))+import Data.Functor.Identity (Identity (Identity))+import Data.Monoid (Alt, Dual)+import qualified Data.Monoid as Monoid+import qualified Data.Semigroup as Semigroup+import GHC.Generics+import GHC.Int (Int16 (..), Int32 (..), Int8 (..))+import GHC.Natural+import GHC.Real (Ratio (..))+import GHC.Word (Word16 (..), Word32 (..), Word64 (..), Word8 (..)) -- | A class of types that have additional invariants defined upon them--- that aren't enforced by the type system+ ----- 'isValid' should be an underapproximation of actual validity.+-- === Purpose --+-- 'validate' checks whether a given value is a valid value and reports all+-- 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 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:+--+-- > newtype Even = Even Int+-- >+-- > instance Validity Even+-- > validate (Event i)+-- > even i <?@> "The contained 'Int' is even."+--+-- === Semantics+--+-- 'validate' should be an underapproximation of actual validity.+-- -- This means that if 'isValid' is not a perfect representation of actual -- validity, for safety reasons, it should never return 'True' for invalid -- values, but it may return 'False' for valid values. -- -- For example: ----- > isValid = const False+-- > validate = const $ invalid "always" ----- is a valid implementation for any type, because it never returns 'True'--- for invalid values.+-- is a valid implementation for any type, because now 'isValid' never returns+-- 'True' for invalid values. ----- > isValid (Even i) = i == 2+-- > validate (Even i) = declare "The integer is equal to two" $ i == 2 -- -- is a valid implementation for @newtype Even = Even Int@, but ----- > isValid (Even i) = even i || i == 1+-- > validate (Even i) = declare "The integer is even or equal to one" $ even i || i == 1 ----- is not because it returns 'True' for an invalid value: '1'.+-- is not because then `isValid` returns 'True' for an invalid value: '1'.+--+-- === 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 'valid' to+-- on all structural sub-parts of the value that is being checked for validity.+--+-- Example:+--+-- > {-# LANGUAGE DeriveGeneric #-}+-- >+-- > data MyType = MyType+-- > { myDouble :: Double+-- > { myString :: String+-- > } deriving (Show, Eq, Generic)+-- >+-- > instance Validity MyType+--+-- generates something like:+--+-- > instance Validity MyType where+-- > validate (MyType d s)+-- > = annotate d "myDouble"+-- > <> annotate s "myString" class Validity a where- isValid :: a -> Bool- default isValid :: (Generic a, GValidity (Rep a)) =>- a -> Bool- isValid = gIsValid . from+ validate :: a -> Validation+ default validate ::+ (Generic a, GValidity (Rep a)) =>+ a ->+ Validation+ validate = genericValidate -isInvalid- :: Validity a- => a -> Bool-isInvalid = not . isValid+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++-- | The result of validating a value.+--+-- `mempty` means the value was valid.+--+-- This type intentionally doesn't have a `Validity` instance to make sure+-- you can never accidentally use `annotate` or `delve` twice.+newtype Validation = Validation+ { unValidation :: [ValidationChain]+ }+ deriving (Show, Eq, Generic)++instance Semigroup Validation where+ (Validation v1) <> (Validation v2) = Validation $ v1 ++ v2++instance Monoid Validation where+ mempty = Validation []+ mappend = (<>)++-- | Declare any value to be valid in validation+--+-- > trivialValidation a = seq a mempty+trivialValidation :: a -> Validation+trivialValidation a = seq a mempty++-- | Check that a given invariant holds.+--+-- The given string should describe the invariant, not the violation.+--+-- Example:+--+-- > check (x < 5) "x is strictly smaller than 5"+--+-- instead of+--+-- > check (x < 5) "x is greater than 5"+check :: Bool -> String -> Validation+check b err =+ if b+ then mempty+ else Validation [Violated err]++-- | 'check', but with the arguments flipped+declare :: String -> Bool -> Validation+declare = flip check++-- | Declare a sub-part as a necessary part for validation, and annotate it with a name.+--+-- Example:+--+-- > validate (a, b) =+-- > mconcat+-- > [ annotate a "The first element of the tuple"+-- > , annotate b "The second element of the tuple"+-- > ]+annotate :: (Validity a) => a -> String -> Validation+annotate = annotateValidation . validate++-- | 'annotate', but with the arguments flipped.+delve :: (Validity a) => String -> a -> Validation+delve = flip annotate++-- | Decorate a validation with a location+decorate :: String -> Validation -> Validation+decorate = flip annotateValidation++-- | Decorate a piecewise validation of a list with their location in the list+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++-- | 'decorateList', but specifically for 'String's+--+-- > decorateString = decorateList+decorateString :: String -> (Char -> Validation) -> Validation+decorateString = decorateList++-- | Construct a trivially invalid 'Validation'+--+-- Example:+--+-- > 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++valid :: Validation+valid = mempty+ -- | 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+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"+ ] -- | 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+instance (Validity a, Validity b) => Validity (Either a b) where+ validate (Left a) = annotate a "The 'Left'"+ validate (Right b) = annotate b "The 'Right'" --- | Any tuple 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+-- | 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+ 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"+ ] +-- | 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+ 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"+ ]++-- | 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+ 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"+ ]++-- | Any sextuple of things is valid if all six of its elements are valid+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"+ ]+ -- | A list of things is valid if all of the things are valid. -- -- This means that the empty list is considered valid. -- 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+instance (Validity a) => Validity [a] where+ validate = flip decorateList validate +-- | A nonempty list is valid if all the elements are valid.+--+-- See the instance for 'Validity [a]' for more information.+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"+ ]+ -- | A Maybe thing is valid if the thing inside is valid or it's nothing -- It makes sense to assume that 'Nothing' is valid. -- 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+instance (Validity a) => Validity (Maybe a) where+ validate Nothing = mempty+ validate (Just a) = annotate a "The 'Just'" -- | Trivially valid instance Validity () where- isValid = const True+ validate = trivialValidation -- | Trivially valid instance Validity Bool where- isValid = const True+ validate = trivialValidation -- | Trivially valid instance Validity Ordering where- isValid = const True+ validate = trivialValidation -- | Trivially valid instance Validity Char where- isValid = const True+ 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++validateCharNotLineSeparator :: Char -> Validation+validateCharNotLineSeparator c =+ declare "The character is not a line separator" $ not $ isLineSeparator c++isLineSeparator :: Char -> Bool+isLineSeparator c = case c of+ '\n' -> True+ '\r' -> True+ _ -> False++validateStringSingleLine :: String -> Validation+validateStringSingleLine s = decorateList s validateCharNotLineSeparator++isSingleLine :: String -> Bool+isSingleLine = not . any isLineSeparator+ -- | Trivially valid instance Validity Int where- isValid = const True+ validate = trivialValidation +#if MIN_VERSION_base(4,16,0)+instance Validity Int8 where validate = trivialValidation+instance Validity Int16 where validate = trivialValidation+instance Validity Int32 where validate = trivialValidation+#else+-- | NOT trivially valid on GHC because small number types are represented using a 64bit structure underneath.+instance Validity Int8 where+ validate (I8# i#) =+ mconcat+ [ declare "The contained integer is smaller than 2^7 = 128" $ isTrue# (i# <=# 127#),+ declare "The contained integer is greater than or equal to -2^7 = -128" $ isTrue# (i# >=# -128#)+ ]++-- | NOT trivially valid on GHC because small number types are represented using a 64bit structure underneath.+instance Validity Int16 where+ validate (I16# i#) =+ mconcat+ [ declare "The contained integer is smaller than 2^15 = 32768" $ isTrue# (i# <=# 32767#),+ declare "The contained integer is greater than or equal to -2^15 = -32768" $ isTrue# (i# >=# -32768#)+ ]++-- | NOT trivially valid on GHC because small number types are represented using a 64bit structure underneath.+instance Validity Int32 where+ validate (I32# i#) =+ mconcat+ [ declare "The contained integer is smaller than 2^31 = 2147483648" $ isTrue# (i# <=# 2147483647#),+ declare "The contained integer is greater than or equal to -2^31 = -2147483648" $ isTrue# (i# >=# -2147483648#)+ ]+#endif+ -- | Trivially valid-instance Validity Word where- isValid = const True+instance Validity Int64 where+ validate = trivialValidation -- | Trivially valid+instance Validity Word where+ validate = trivialValidation++#if MIN_VERSION_base(4,16,0)+instance Validity Word8 where validate = trivialValidation+instance Validity Word16 where validate = trivialValidation+instance Validity Word32 where validate = trivialValidation+#else+-- | NOT trivially valid on GHC because small number types are represented using a 64bit structure underneath. instance Validity Word8 where- isValid = const True+ validate (W8# w#) =+ declare "The contained integer is smaller than 2^8 = 256" $ isTrue# (w# `leWord#` 255##) --- | Trivially valid+-- | NOT trivially valid on GHC because small number types are represented using a 64bit structure underneath. instance Validity Word16 where- isValid = const True+ validate (W16# w#) =+ declare "The contained integer is smaller than 2^16 = 65536" $ isTrue# (w# `leWord#` 65535##) --- | NOT trivially valid:------ * NaN is not valid.--- * Infinite values are not valid.+-- | NOT trivially valid on GHC because small number types are represented using a 64bit structure underneath.+instance Validity Word32 where+ validate (W32# w#) =+ declare "The contained integer is smaller than 2^32 = 4294967296" $ isTrue# (w# `leWord#` 4294967295##)+#endif++-- | Trivially valid+instance Validity Word64 where+ validate = trivialValidation++-- | Trivially valid: instance Validity Float where- isValid d = not (isNaN d) && not (isInfinite d)+ validate = trivialValidation --- | NOT trivially valid:------ * NaN is not valid.--- * Infinite values are not valid.+-- | Trivially valid: instance Validity Double where- isValid d = not (isNaN d) && not (isInfinite d)+ validate = trivialValidation +-- | Valid values the same as it's base type:+deriving newtype instance (Validity a) => Validity (Identity a)++-- | Valid values the same as it's base type:+deriving newtype instance (Validity (f a)) => Validity (Alt f a)++-- | Valid values the same as it's base type:+deriving newtype instance (Validity a) => Validity (Dual a)++-- | Valid values the same as it's base type:+deriving newtype instance (Validity a) => Validity (Semigroup.First a)++-- | Valid values the same as it's base type:+deriving newtype instance (Validity a) => Validity (Semigroup.Last a)++-- | Valid values the same as it's base type:+deriving newtype instance (Validity a) => Validity (Monoid.First a)++-- | Valid values the same as it's base type:+deriving newtype instance (Validity a) => Validity (Monoid.Last a)++-- | Valid values the same as it's base type:+deriving newtype instance (Validity a) => Validity (Const a b)++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+ -- | Trivially valid -- -- Integer is not trivially valid under the hood, but instantiating@@ -173,60 +587,127 @@ -- 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 = const True-#if MIN_VERSION_base(4,8,0)+ validate = trivialValidation+ -- | Valid according to 'isValidNatural'------ Only available with @base >= 4.8@. instance Validity Natural where- isValid = isValidNatural-#endif--- | Valid if the contained 'Integer's are valid and the denominator is+ validate = declare "The Natural is valid." . isValidNatural++-- | Valid if the contained numbers are valid and the denominator is -- strictly positive.-instance Validity Rational where- isValid (d :% n) = and [isValid n, isValid d, d > 0]+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+ ] -- | Valid according to the contained 'Integer'.-instance HasResolution a =>- Validity (Fixed a) where- isValid (MkFixed i) = isValid i+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++-- | Check whether a value is valid.+isValid :: (Validity a) => a -> Bool+isValid = isRight . checkValidity++-- | Check whether a value is not valid.+--+-- > isInvalid = not . isValid+isInvalid :: (Validity a) => a -> Bool+isInvalid = not . isValid+ -- | Construct a valid element from an unchecked element-constructValid- :: Validity a- => a -> Maybe a+constructValid :: (Validity a) => a -> Maybe a constructValid p =- if isValid p- then Just p- else Nothing+ if isValid p+ then Just p+ else Nothing -- | Construct a valid element from an unchecked element, throwing 'error' -- on invalid elements.-constructValidUnsafe- :: (Show a, Validity a)- => a -> a+constructValidUnsafe :: (Show a, Validity a) => a -> a constructValidUnsafe p =- fromMaybe (error $ show p ++ " is not valid") $ constructValid p--class GValidity f where- gIsValid :: f a -> Bool--instance GValidity U1 where- gIsValid U1 = True+ fromMaybe (error $ show p ++ " is not valid") $ constructValid p -instance (GValidity a, GValidity b) =>- GValidity (a :*: b) where- gIsValid (a :*: b) = gIsValid a && gIsValid b+-- | validate a given value.+--+-- This function returns either all the reasons why the given value is invalid,+-- in the form of a list of 'ValidationChain's, or it returns 'Right' with the+-- input value, as evidence that it is valid.+--+-- Note: You may want to use 'prettyValidation' instead, if you want to+-- display these 'ValidationChain's to a user.+checkValidity :: (Validity a) => a -> Either [ValidationChain] a+checkValidity a =+ case validate a of+ Validation [] -> Right a+ Validation errs -> Left errs -instance (GValidity a, GValidity b) =>- GValidity (a :+: b) where- gIsValid (L1 x) = gIsValid x- gIsValid (R1 x) = gIsValid x+-- | Check if a 'Validation' concerns a valid value.+validationIsValid :: Validation -> Bool+validationIsValid v = case v of+ Validation [] -> True+ _ -> False -instance (GValidity a) =>- GValidity (M1 i c a) where- gIsValid (M1 x) = gIsValid x+-- | Validate a given value+--+-- This function will return a nice error if the value is invalid.+-- It will return the original value in 'Right' if it was valid,+-- as evidence that it has been validated.+prettyValidate :: (Validity a) => a -> Either String a+prettyValidate a = case prettyValidation $ validate a of+ Just e -> Left e+ Nothing -> Right a -instance (Validity a) =>- GValidity (K1 i a) where- gIsValid (K1 x) = isValid x+-- | Render a `Validation` in a somewhat pretty way.+--+-- This function will return 'Nothing' if the 'Validation' concerned a valid value.+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
+ test/Data/ValiditySpec.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MagicHash #-}++module Data.ValiditySpec+ ( spec,+ )+where++import Data.Maybe+import Data.Validity+import GHC.Exts (Char (..), chr#)+import GHC.Generics (Generic)+import GHC.Int (Int16 (..), Int32 (..), Int8 (..))+import GHC.Real (Ratio (..), infinity, notANumber)+import GHC.Word (Word16 (..), Word32 (..), Word8 (..))+import Test.Hspec++newtype NormalisedRatio a+ = NormalisedRatio (Ratio a)+ deriving (Show, Eq, Generic)++instance (Validity a, Integral a) => Validity (NormalisedRatio a) where+ validate nr@(NormalisedRatio r) =+ mconcat+ [ genericValidate nr,+ validateRatioNotNaN r,+ validateRatioNotInfinite r,+ validateRatioNormalised r+ ]++data Wrong+ = Wrong+ | Fine+ deriving (Show, Eq)++instance Validity Wrong where+ validate w =+ case w of+ Wrong -> invalid "Wrong"+ Fine -> valid++data GeneratedValidity+ = G Rational Rational+ deriving (Show, Eq, Generic)++instance Validity GeneratedValidity++spec :: Spec+spec = do+ describe "Small numbers" $ do+ describe "Validity Int8" $ do+ it "Says that minBound is valid" $ isValid (minBound :: Int8) `shouldBe` True+ it "Says that maxBound is valid" $ isValid (maxBound :: Int8) `shouldBe` True+#if MIN_VERSION_base(4,16,0)+#else+ it "Says that Int# 200 is invalid" $ isValid (I8# 200#) `shouldBe` False+ it "Says that Int# -200 is invalid" $ isValid (I8# (-200#)) `shouldBe` False+#endif+ describe "Validity Int16" $ do+ it "Says that minBound is valid" $ isValid (minBound :: Int16) `shouldBe` True+ it "Says that maxBound is valid" $ isValid (maxBound :: Int16) `shouldBe` True+#if MIN_VERSION_base(4,16,0)+#else+ it "Says that Int# 4000 is invalid" $ isValid (I16# 40000#) `shouldBe` False+ it "Says that Int# -4000 is invalid" $ isValid (I16# (-40000#)) `shouldBe` False+#endif+ describe "Validity Int32" $ do+ it "Says that minBound is valid" $ isValid (minBound :: Int32) `shouldBe` True+ it "Says that maxBound is valid" $ isValid (maxBound :: Int32) `shouldBe` True+#if MIN_VERSION_base(4,16,0)+#else+ it "Says that Int# 2200000000 is invalid" $ isValid (I32# 2200000000#) `shouldBe` False+ it "Says that Int# -2200000000 is invalid" $ isValid (I32# (-2200000000#)) `shouldBe` False+#endif+ describe "Validity Word8" $ do+ it "Says that minBound is valid" $ isValid (minBound :: Word8) `shouldBe` True+ it "Says that maxBound is valid" $ isValid (maxBound :: Word8) `shouldBe` True+#if MIN_VERSION_base(4,16,0)+#else+ it "Says that Word# 300 is invalid" $ isValid (W8# 300##) `shouldBe` False+#endif+ describe "Validity Word16" $ do+ it "Says that minBound is valid" $ isValid (minBound :: Word16) `shouldBe` True+ it "Says that maxBound is valid" $ isValid (maxBound :: Word16) `shouldBe` True+#if MIN_VERSION_base(4,16,0)+#else+ it "Says that Word# 80000 is invalid" $ isValid (W16# 80000##) `shouldBe` False+#endif+ describe "Validity Word32" $ do+ it "Says that minBound is valid" $ isValid (minBound :: Word32) `shouldBe` True+ it "Says that maxBound is valid" $ isValid (maxBound :: Word32) `shouldBe` True+#if MIN_VERSION_base(4,16,0)+#else+ it "Says that Word# 4800000000 is invalid" $ isValid (W32# 4800000000##) `shouldBe` False+#endif+ describe "Chars" $ do+ describe "Small" $ do+ describe "Validity Char" $ do+ it "Says that minBound is valid" $ isValid (minBound :: Char) `shouldBe` True+ it "Says that maxBound is valid" $ isValid (maxBound :: Char) `shouldBe` True+ it "Says that 2147483647 is invalid" $ isValid (C# (chr# 2147483647#)) `shouldBe` False+ it "Says that a negative char is invalid" $ isValid (C# (chr# -1#)) `shouldBe` False+ it "Says that a very positive char is invalid" $ isValid (C# (chr# 9223372036854775807#)) `shouldBe` False+ it "Says that a very negative char is invalid" $ isValid (C# (chr# -9223372036854775808#)) `shouldBe` False+ describe "Weird" $ do+ describe "isUtf16SurrogateCodePoint" $ do+ it "Says that a is a valid char" $ isUtf16SurrogateCodePoint 'a' `shouldBe` False+ it "Says that \\55810 is an invalid char" $ isUtf16SurrogateCodePoint '\55810' `shouldBe` True+ describe "validateCharNotUtf16SurrogateCodePoint" $ do+ it "Says that a is a valid char" $+ prettyValidation (validateCharNotUtf16SurrogateCodePoint 'a') `shouldSatisfy` isNothing+ it "Says that \\55810 is an invalid char" $+ prettyValidation (validateCharNotUtf16SurrogateCodePoint '\55810') `shouldSatisfy` isJust+ describe "Lines" $ do+ describe "isLineSeparator" $ do+ it "Says that a is not a line separator" $ isLineSeparator 'a' `shouldBe` False+ it "Says that '\\n' is a line separator " $ isLineSeparator '\n' `shouldBe` True+ it "Says that '\\r' is a line separator " $ isLineSeparator '\r' `shouldBe` True+ describe "validateCharNotLineSeparator" $ do+ it "Says that a is not a line separator" $+ prettyValidation (validateCharNotLineSeparator 'a') `shouldSatisfy` isNothing+ it "Says that '\\n' is a line separator" $+ prettyValidation (validateCharNotLineSeparator '\n') `shouldSatisfy` isJust+ it "Says that '\\r' is a line separator" $+ prettyValidation (validateCharNotLineSeparator '\r') `shouldSatisfy` isJust+ describe "isSingleLine" $ do+ it "says that \"abc\" is a single line" $ isSingleLine "abc" `shouldBe` True+ it "says that \"d\ne\" is a single line" $ isSingleLine "d\ne" `shouldBe` False+ describe "validateStringSingleLine" $ do+ it "says that \"abc\" is a single line" $ prettyValidation (validateStringSingleLine "abc") `shouldSatisfy` isNothing+ it "says that \"d\ne\" is a single line" $ prettyValidation (validateStringSingleLine "d\ne") `shouldSatisfy` isJust+ describe "Ratio" $ do+ it "says that 0 is valid" $ NormalisedRatio (0 :% 1 :: Ratio Int) `shouldSatisfy` isValid+ it "says that 1 is valid" $ NormalisedRatio (1 :% 1 :: Ratio Int) `shouldSatisfy` isValid+ it "says that minBound is valid" $+ NormalisedRatio (minBound :% 1 :: Ratio Int) `shouldSatisfy` isValid+ it "says that maxBound is valid" $+ NormalisedRatio (maxBound :% 1 :: Ratio Int) `shouldSatisfy` isValid+ it "says that maxBound / minBound is invalid" $+ NormalisedRatio (maxBound :% minBound :: Ratio Int) `shouldSatisfy` (not . isValid)+ it "says that minBound / maxBound is invalid" $+ NormalisedRatio (minBound :% maxBound :: Ratio Int) `shouldSatisfy` (not . isValid)+ it "says that minBound / 2957808295740799111 is valid" $+ NormalisedRatio (minBound :% (2957808295740799111) :: Ratio Int) `shouldSatisfy` isValid+ describe "NormalisedRatio" $ do+ it "says that NaN is invalid" $ NormalisedRatio notANumber `shouldSatisfy` (not . isValid)+ it "says that +Inf is invalid" $ NormalisedRatio infinity `shouldSatisfy` (not . isValid)+ it "says that -Inf is invalid" $ NormalisedRatio (-infinity) `shouldSatisfy` (not . isValid)+ it "says that these non-normalised numbers are invalid" $ do+ NormalisedRatio ((5 :: Integer) :% 5) `shouldSatisfy` (not . isValid)+ NormalisedRatio ((1 :: Integer) :% (-5)) `shouldSatisfy` (not . isValid)+ NormalisedRatio ((6 :: Integer) :% 2) `shouldSatisfy` (not . isValid)+ NormalisedRatio ((2 :: Integer) :% 6) `shouldSatisfy` (not . isValid)+ NormalisedRatio ((2 :: Integer) :% 0) `shouldSatisfy` (not . isValid)+ NormalisedRatio ((0 :: Integer) :% 5) `shouldSatisfy` (not . isValid)+ NormalisedRatio ((0 :: Integer) :% 0) `shouldSatisfy` (not . isValid)+ 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 = 1 :% 0+ it "says G (1:%0) 0 is not valid" $ G nan 0 `shouldSatisfy` (not . isValid)+ it "says G 0 (1:%0) 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
@@ -1,41 +1,75 @@-name: validity-version: 0.3.3.0-cabal-version: >=1.10-build-type: Simple-license: MIT-license-file: LICENSE-copyright: Copyright: (c) 2016 Tom Sydney Kerckhove-maintainer: syd.kerckhove@gmail.com-homepage: https://github.com/NorfairKing/validity#readme-synopsis: Validity typeclass-description:- For more info, see <https://github.com/NorfairKing/validity the readme>.- .- Note: There are companion instance packages for this library:- .- * <https://hackage.haskell.org/package/validity-text validity-text>- .- * <https://hackage.haskell.org/package/validity-path validity-path>- .- * <https://hackage.haskell.org/package/validity-time validity-time>- .- * <https://hackage.haskell.org/package/validity-containers validity-containers>- .- * <https://hackage.haskell.org/package/validity-bytestring validity-bytestring>-category: Validity-author: Tom Sydney Kerckhove+cabal-version: 1.12 +-- This file has been generated from package.yaml by hpack version 0.36.0.+--+-- see: https://github.com/sol/hpack++name: validity+version: 0.12.1.0+synopsis: Validity typeclass+description: For more info, see <https://github.com/NorfairKing/validity the readme>.+ .+ Note: There are companion instance packages for this library:+ .+ * <https://hackage.haskell.org/package/validity-aeson validity-aeson>+ .+ * <https://hackage.haskell.org/package/validity-bytestring validity-bytestring>+ .+ * <https://hackage.haskell.org/package/validity-containers validity-containers>+ .+ * <https://hackage.haskell.org/package/validity-path validity-path>+ .+ * <https://hackage.haskell.org/package/validity-scientific validity-scientific>+ .+ * <https://hackage.haskell.org/package/validity-text validity-text>+ .+ * <https://hackage.haskell.org/package/validity-time validity-time>+ .+ * <https://hackage.haskell.org/package/validity-unordered-containers validity-unordered-containers>+ .+ * <https://hackage.haskell.org/package/validity-uuid validity-uuid>+ .+ * <https://hackage.haskell.org/package/validity-vector validity-vector>+category: Validity+homepage: https://github.com/NorfairKing/validity#readme+bug-reports: https://github.com/NorfairKing/validity/issues+author: Tom Sydney Kerckhove+maintainer: syd@cs-syd.eu+copyright: Copyright: (c) 2016-2021 Tom Sydney Kerckhove+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ LICENSE+ CHANGELOG.md+ source-repository head- type: git- location: https://github.com/NorfairKing/validity+ type: git+ location: https://github.com/NorfairKing/validity library- exposed-modules:- Data.RelativeValidity- Data.Validity- build-depends:- base >=4.7 && <5- default-language: Haskell2010- hs-source-dirs: src- if impl(ghc >= 8.0.0)- ghc-options: -Wno-redundant-constraints+ exposed-modules:+ Data.Validity+ other-modules:+ Paths_validity+ hs-source-dirs:+ src+ ghc-options: -Wno-redundant-constraints+ build-depends:+ base >=4.13 && <5+ default-language: Haskell2010++test-suite validity-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Data.ValiditySpec+ Paths_validity+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ build-depends:+ base >=4.13 && <5+ , hspec+ , validity+ default-language: Haskell2010