diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ The MIT License (MIT) -Copyright (c) 2016-2020 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 diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple - -main = defaultMain diff --git a/src/Data/RelativeValidity.hs b/src/Data/RelativeValidity.hs deleted file mode 100644 --- a/src/Data/RelativeValidity.hs +++ /dev/null @@ -1,23 +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 diff --git a/src/Data/Validity.hs b/src/Data/Validity.hs --- a/src/Data/Validity.hs +++ b/src/Data/Validity.hs @@ -1,14 +1,14 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} - -#if MIN_VERSION_base(4,9,0) {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} -#endif -- | -- @@ -51,6 +51,7 @@ delve, decorate, decorateList, + decorateString, invalid, valid, @@ -91,41 +92,33 @@ -- * Re-exports Monoid (..), -#if MIN_VERSION_base(4,11,0) - Semigroup(..), -#endif + Semigroup (..), ) where -#if MIN_VERSION_base(4,9,0) -import Data.List.NonEmpty (NonEmpty((:|))) -#endif - -#if MIN_VERSION_base(4,8,0) -#else -import Data.Monoid -import Data.Ratio -#endif 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,8,0) -import GHC.Word (Word8(..), Word16(..), Word32(..), Word64(..)) +#if MIN_VERSION_base(4,16,0) +import GHC.Exts (Char (..), isTrue#, ord#, (<=#), (>=#)) #else -import Data.Word (Word) -import GHC.Word (Word8(..), Word16(..), Word32(..), Word64(..)) -#endif import GHC.Exts (Char (..), isTrue#, leWord#, ord#, (<=#), (>=#)) +#endif +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 (..)) -#if MIN_VERSION_base(4,8,0) import GHC.Natural -#endif import GHC.Real (Ratio (..)) +import GHC.Word (Word16 (..), Word32 (..), Word64 (..), Word8 (..)) -- | A class of types that have additional invariants defined upon them @@ -230,20 +223,12 @@ } deriving (Show, Eq, Generic) -#if MIN_VERSION_base(4,11,0) instance Semigroup Validation where - (Validation v1) <> (Validation v2) = Validation $ v1 ++ v2 -#endif + (Validation v1) <> (Validation v2) = Validation $ v1 ++ v2 -#if MIN_VERSION_base(4,11,0) instance Monoid Validation where mempty = Validation [] mappend = (<>) -#else -instance Monoid Validation where - mempty = Validation [] - mappend (Validation v1) (Validation v2) = Validation $ v1 ++ v2 -#endif -- | Declare any value to be valid in validation -- @@ -281,11 +266,11 @@ -- > [ annotate a "The first element of the tuple" -- > , annotate b "The second element of the tuple" -- > ] -annotate :: Validity a => a -> String -> Validation +annotate :: (Validity a) => a -> String -> Validation annotate = annotateValidation . validate -- | 'annotate', but with the arguments flipped. -delve :: Validity a => String -> a -> Validation +delve :: (Validity a) => String -> a -> Validation delve = flip annotate -- | Decorate a validation with a location @@ -299,6 +284,12 @@ 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: @@ -394,26 +385,24 @@ -- 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 +instance (Validity a) => Validity [a] where validate = flip decorateList validate -#if MIN_VERSION_base(4,9,0) -- | 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" - ] -#endif +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 +instance (Validity a) => Validity (Maybe a) where validate Nothing = mempty validate (Just a) = annotate a "The 'Just'" @@ -464,6 +453,11 @@ instance Validity Int where 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#) = @@ -487,6 +481,7 @@ [ 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 Int64 where @@ -496,6 +491,11 @@ 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 validate (W8# w#) = @@ -510,6 +510,7 @@ 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 @@ -523,26 +524,50 @@ instance Validity Double where validate = trivialValidation -validateNotNaN :: RealFloat a => a -> Validation +-- | 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 :: (RealFloat a) => a -> Validation validateNotInfinite d = declare "The RealFloat is not infinite." $ not (isInfinite d) -validateRatioNotNaN :: Integral a => Ratio a -> Validation +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 :: (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 :: (Integral a) => Ratio a -> Validation validateRatioNormalised (n :% d) = declare "The Ratio is normalised." $ case d of 0 -> False @@ -564,13 +589,9 @@ instance Validity Integer where validate = trivialValidation -#if MIN_VERSION_base(4,8,0) -- | Valid according to 'isValidNatural' --- --- Only available with @base >= 4.8@. instance Validity Natural where - validate = declare "The Natural is valid." . isValidNatural -#endif + validate = declare "The Natural is valid." . isValidNatural -- | Valid if the contained numbers are valid and the denominator is -- strictly positive. @@ -584,7 +605,7 @@ ] -- | Valid according to the contained 'Integer'. -instance HasResolution a => Validity (Fixed a) where +instance (HasResolution a) => Validity (Fixed a) where validate (MkFixed i) = validate i annotateValidation :: Validation -> String -> Validation @@ -621,17 +642,17 @@ gValidate (K1 x) = validate x -- | Check whether a value is valid. -isValid :: Validity a => a -> Bool +isValid :: (Validity a) => a -> Bool isValid = isRight . checkValidity -- | Check whether a value is not valid. -- -- > isInvalid = not . isValid -isInvalid :: Validity a => a -> Bool +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 @@ -651,7 +672,7 @@ -- -- 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 :: (Validity a) => a -> Either [ValidationChain] a checkValidity a = case validate a of Validation [] -> Right a @@ -668,7 +689,7 @@ -- 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 :: (Validity a) => a -> Either String a prettyValidate a = case prettyValidation $ validate a of Just e -> Left e Nothing -> Right a diff --git a/test/Data/ValiditySpec.hs b/test/Data/ValiditySpec.hs --- a/test/Data/ValiditySpec.hs +++ b/test/Data/ValiditySpec.hs @@ -1,16 +1,12 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MagicHash #-} --- {-# LANGUAGE CPP #-} - module Data.ValiditySpec ( spec, ) where --- #if !MIN_VERSION_base(4,7,0) --- import Data.Monoid --- #endif import Data.Maybe import Data.Validity import GHC.Exts (Char (..), chr#) @@ -56,30 +52,48 @@ 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 @@ -132,7 +146,7 @@ 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 @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: validity -version: 0.11.0.1 +version: 0.12.1.0 synopsis: Validity typeclass description: For more info, see . . @@ -39,6 +39,9 @@ license: MIT license-file: LICENSE build-type: Simple +extra-source-files: + LICENSE + CHANGELOG.md source-repository head type: git @@ -46,7 +49,6 @@ library exposed-modules: - Data.RelativeValidity Data.Validity other-modules: Paths_validity @@ -54,7 +56,7 @@ src ghc-options: -Wno-redundant-constraints build-depends: - base >=4.7 && <5 + base >=4.13 && <5 default-language: Haskell2010 test-suite validity-test @@ -67,7 +69,7 @@ test ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: - base >=4.7 && <5 + base >=4.13 && <5 , hspec , validity default-language: Haskell2010