diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Changelog +## [0.12.1.0 - 2024-07-18] + +### Added + +* `Validity` instances for various newtypes in base + ## [0.12.0.2] - 2023-10-09 ### Added diff --git a/src/Data/Validity.hs b/src/Data/Validity.hs --- a/src/Data/Validity.hs +++ b/src/Data/Validity.hs @@ -1,9 +1,12 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} @@ -106,6 +109,11 @@ #else 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 (..)) import GHC.Natural @@ -258,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 @@ -377,13 +385,13 @@ -- 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 -- | 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 +instance (Validity a) => Validity (NonEmpty a) where validate (e :| es) = mconcat [ annotate e "The first element of the nonempty list", @@ -394,7 +402,7 @@ -- 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'" @@ -516,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 @@ -573,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 @@ -610,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 @@ -640,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 @@ -657,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/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.35.2. +-- 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.0.2 +version: 0.12.1.0 synopsis: Validity typeclass description: For more info, see . .