diff --git a/src/Data/Validity.hs b/src/Data/Validity.hs --- a/src/Data/Validity.hs +++ b/src/Data/Validity.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeOperators #-} #if MIN_VERSION_base(4,9,0) {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} @@ -96,12 +97,16 @@ #endif import Data.Bits ((.&.)) import Data.Char (ord) -import Data.Int (Int16, Int32, Int64, Int8) +import Data.Int (Int64) +import GHC.Int (Int8(..), Int16(..), Int32(..)) +import GHC.Exts (isTrue#, (<#), (>=#)) #if MIN_VERSION_base(4,8,0) -import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Word (Word8(..), Word16(..), Word32(..), Word64(..)) #else -import Data.Word (Word, Word16, Word32, Word64, Word8) +import Data.Word (Word) +import GHC.Word (Word8(..), Word16(..), Word32(..), Word64(..)) #endif +import GHC.Exts (ltWord#) import GHC.Generics #if MIN_VERSION_base(4,8,0) import GHC.Natural @@ -410,17 +415,29 @@ instance Validity Int where validate = trivialValidation --- | Trivially valid +-- | NOT trivially valid on GHC because small number types are represented using a 64bit structure underneath. instance Validity Int8 where - validate = trivialValidation + validate (I8# i#) = + mconcat + [ declare "The contained integer is smaller than 2^7 = 128" $ isTrue# (i# <# 128#) + , declare "The contained integer is greater than or equal to -128" $ isTrue# (i# >=# -128#) + ] --- | Trivially valid +-- | NOT trivially valid on GHC because small number types are represented using a 64bit structure underneath. instance Validity Int16 where - validate = trivialValidation + validate (I16# i#) = + mconcat + [ declare "The contained integer is smaller than 2^15 = 32768" $ isTrue# (i# <# 32768#) + , declare "The contained integer is greater than or equal to -32768" $ isTrue# (i# >=# -32768#) + ] --- | Trivially valid +-- | NOT trivially valid on GHC because small number types are represented using a 64bit structure underneath. instance Validity Int32 where - validate = trivialValidation + validate (I32# i#) = + mconcat + [ declare "The contained integer is smaller than 2^31 = 2147483648" $ isTrue# (i# <# 2147483648#) + , declare "The contained integer is greater than or equal to -2147483648" $ isTrue# (i# >=# -2147483648#) + ] -- | Trivially valid instance Validity Int64 where @@ -430,17 +447,20 @@ instance Validity Word where validate = trivialValidation --- | Trivially valid +-- | NOT trivially valid on GHC because small number types are represented using a 64bit structure underneath. instance Validity Word8 where - validate = trivialValidation + validate (W8# w#) = + declare "The contained integer is smaller than 2^8 = 256" $ isTrue# (w# `ltWord#` 256##) --- | Trivially valid +-- | NOT trivially valid on GHC because small number types are represented using a 64bit structure underneath. instance Validity Word16 where - validate = trivialValidation + validate (W16# w#) = + declare "The contained integer is smaller than 2^16 = 65536" $ isTrue# (w# `ltWord#` 65536##) --- | Trivially valid +-- | NOT trivially valid on GHC because small number types are represented using a 64bit structure underneath. instance Validity Word32 where - validate = trivialValidation + validate (W32# w#) = + declare "The contained integer is smaller than 2^32 = 4294967296" $ isTrue# (w# `ltWord#` 4294967296##) -- | Trivially valid instance Validity Word64 where diff --git a/test/Data/ValiditySpec.hs b/test/Data/ValiditySpec.hs --- a/test/Data/ValiditySpec.hs +++ b/test/Data/ValiditySpec.hs @@ -1,31 +1,35 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +-- {-# LANGUAGE CPP #-} + module Data.ValiditySpec - ( spec - ) where + ( spec, + ) +where -import GHC.Generics (Generic) -#if !MIN_VERSION_base(4,7,0) -import Data.Monoid -#endif +-- #if !MIN_VERSION_base(4,7,0) +-- import Data.Monoid +-- #endif import Data.Maybe import Data.Validity -import GHC.Real (Ratio(..), infinity, notANumber) - +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) +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 + [ genericValidate nr, + validateRatioNotNaN r, + validateRatioNotInfinite r, + validateRatioNormalised r ] data Wrong @@ -39,14 +43,30 @@ Wrong -> invalid "Wrong" Fine -> valid -data GeneratedValidity = - G Rational Rational +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 Int# 200 is invalid" $ isValid (I8# 200#) `shouldBe` False + it "Says that Int# -200 is invalid" $ isValid (I8# (-200#)) `shouldBe` False + describe "Validity Int16" $ do + it "Says that Int# 4000 is invalid" $ isValid (I16# 40000#) `shouldBe` False + it "Says that Int# -4000 is invalid" $ isValid (I16# (-40000#)) `shouldBe` False + describe "Validity Int32" $ do + it "Says that Int# 2200000000 is invalid" $ isValid (I32# 2200000000#) `shouldBe` False + it "Says that Int# -2200000000 is invalid" $ isValid (I32# (-2200000000#)) `shouldBe` False + describe "Validity Word8" $ do + it "Says that Word# 300 is invalid" $ isValid (W8# 300##) `shouldBe` False + describe "Validity Word16" $ do + it "Says that Word# 80000 is invalid" $ isValid (W16# 80000##) `shouldBe` False + describe "Validity Word32" $ do + it "Says that Word# 4800000000 is invalid" $ isValid (W32# 4800000000##) `shouldBe` False describe "Weird Chars" $ do describe "isUtf16SurrogateCodePoint" $ do it "Says that a is a valid char" $ isUtf16SurrogateCodePoint 'a' `shouldBe` False @@ -59,16 +79,20 @@ 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 + 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 -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) diff --git a/validity.cabal b/validity.cabal --- a/validity.cabal +++ b/validity.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: d006c09ce2c1b3a5b9614851314390ed87a2dd35f3304de883115ca80df6a853 +-- hash: 1ec9a779808bae72c15d0e6503515a33bc316727328b1986713451d1985d915d name: validity -version: 0.9.0.3 +version: 0.10.0.0 synopsis: Validity typeclass description: For more info, see . .