packages feed

validity 0.9.0.1 → 0.9.0.2

raw patch · 3 files changed

+96/−30 lines, 3 files

Files

src/Data/Validity.hs view
@@ -51,8 +51,17 @@     , decorateList     , invalid     , valid+    -- ** Helpers for specific types+    -- *** Char+    , validateCharNotUtf16SurrogateCodePoint+    , isUtf16SurrogateCodePoint+    -- *** RealFloat (Double)     , validateNotNaN     , validateNotInfinite+    -- *** Ratio+    , validateRatioNotNaN+    , validateRatioNotInfinite+    , validateRatioNormalised     -- * Utilities     -- ** Utilities for validity checking     , isValid@@ -85,6 +94,8 @@ import Data.Monoid import Data.Ratio #endif+import Data.Bits ((.&.))+import Data.Char (Char, ord) import Data.Int (Int16, Int32, Int64, Int8) #if MIN_VERSION_base(4,8,0) import Data.Word (Word16, Word32, Word64, Word8)@@ -95,7 +106,7 @@ #if MIN_VERSION_base(4,8,0) import GHC.Natural #endif-import GHC.Real (Ratio(..))+import GHC.Real (Ratio(..), reduce)  -- | A class of types that have additional invariants defined upon them @@ -388,6 +399,13 @@ instance Validity Char where     validate = trivialValidation +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+ -- | Trivially valid instance Validity Int where     validate = trivialValidation@@ -437,11 +455,27 @@     validate = trivialValidation  validateNotNaN :: RealFloat a => a -> Validation-validateNotNaN d = declare "The Double is not NaN." $ not (isNaN d)+validateNotNaN d = declare "The RealFloat is not NaN." $ not (isNaN d)  validateNotInfinite :: RealFloat a => a -> Validation-validateNotInfinite d = declare "The Double is not infinite." $ not (isInfinite d)+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 r@(n :% d) = declare "The Ratio is normalised." $ reduce n d == r+ -- | Trivially valid -- -- Integer is not trivially valid under the hood, but instantiating@@ -542,7 +576,7 @@ -- 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 map want to use 'prettyValidation' instead, if you want to+-- 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 =
test/Data/ValiditySpec.hs view
@@ -2,45 +2,77 @@ {-# LANGUAGE CPP #-}  module Data.ValiditySpec-    ( spec-    ) where+  ( spec+  ) where  import GHC.Generics (Generic) #if !MIN_VERSION_base(4,7,0) import Data.Monoid #endif+import Data.Maybe import Data.Validity-import GHC.Real (Ratio(..))+import GHC.Real (Ratio(..), infinity, notANumber)  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)+  = Wrong+  | Fine+  deriving (Show, Eq)  instance Validity Wrong where-    validate w =-        case w of-            Wrong -> invalid "Wrong"-            Fine -> valid+  validate w =+    case w of+      Wrong -> invalid "Wrong"+      Fine -> valid  data GeneratedValidity =-    G Rational-      Rational-    deriving (Show, Eq, Generic)+  G Rational Rational+  deriving (Show, Eq, Generic)  instance Validity GeneratedValidity  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 = 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+  describe "Weird Chars" $ 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 "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
validity.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.1.+-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack ----- hash: ea622d10d177b4be018cdfc126d397fdf597d052e886eb69bc3a7d334f8bcfca+-- hash: c5fd8a29bca818acb5b12b926b6d1143f48fcf0d4dbe5ab886a92c7d0492ab08  name:           validity-version:        0.9.0.1+version:        0.9.0.2 synopsis:       Validity typeclass description:    For more info, see <https://github.com/NorfairKing/validity the readme>.                 .