diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/src/Data/RelativeValidity.hs b/src/Data/RelativeValidity.hs --- a/src/Data/RelativeValidity.hs +++ b/src/Data/RelativeValidity.hs @@ -1,15 +1,13 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# 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 -- @@ -21,5 +19,7 @@ class RelativeValidity a b where isValidFor :: a -> b -> Bool -isInvalidFor :: RelativeValidity a b => 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,4 +1,8 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DefaultSignatures #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} {-| @@ -9,7 +13,7 @@ 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 @Numeric.Natural@ and only store the index of the + 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. @@ -24,6 +28,11 @@ > instance Validity Prime where > isValid (Prime n) = isPrime n + + 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(..) @@ -32,12 +41,19 @@ , constructValidUnsafe ) where -import Data.Maybe (fromMaybe) +import Data.Fixed (Fixed(MkFixed), HasResolution) +import Data.Maybe (Maybe, fromMaybe) +import GHC.Generics +import GHC.Natural (Natural, isValidNatural) +import GHC.Real (Ratio(..)) -- | A class of types that have additional invariants defined upon them -- that aren't enforced by the type system class Validity a where isValid :: a -> Bool -- ^ Check whether a given value is a valid value. + default isValid :: (Generic a, GValidity (Rep a)) => + a -> Bool + isValid = gIsValid . from isInvalid :: Validity a @@ -117,9 +133,30 @@ isValid d = not (isNaN d) && not (isInfinite d) -- | Trivially valid +-- +-- Integer is not trivially valid under the hood, but instantiating +-- 'Validity' correctly would force validity to depend on a specific +-- (big integer library @integer-gmp@ versus @integer-simple@). +-- This is rather impractical so for the time being we have opted for +-- 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 +-- | Valid according to 'isValidNatural' +instance Validity Natural where + isValid = isValidNatural + +-- | Valid if the contained 'Integer's are valid and the denominator is +-- strictly positive. +instance Validity Rational where + isValid (d :% n) = and [isValid n, isValid d, d > 0] + +-- | Valid according to the contained 'Integer'. +instance HasResolution a => + Validity (Fixed a) where + isValid (MkFixed i) = isValid i + -- | Construct a valid element from an unchecked element constructValid :: Validity a @@ -136,3 +173,26 @@ => 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 + +instance (GValidity a, GValidity b) => + GValidity (a :*: b) where + gIsValid (a :*: b) = gIsValid a && gIsValid b + +instance (GValidity a, GValidity b) => + GValidity (a :+: b) where + gIsValid (L1 x) = gIsValid x + gIsValid (R1 x) = gIsValid x + +instance (GValidity a) => + GValidity (M1 i c a) where + gIsValid (M1 x) = gIsValid x + +instance (Validity a) => + GValidity (K1 i a) where + gIsValid (K1 x) = isValid x diff --git a/validity.cabal b/validity.cabal --- a/validity.cabal +++ b/validity.cabal @@ -1,36 +1,40 @@ -name: validity -version: 0.3.1.1 -synopsis: Validity typeclass +name: validity +version: 0.3.2.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 . - . - Note: There are companion instance packages for this library: - . - * - . - * - . - * - . - * + For more info, see . + . + Note: There are companion instance packages for this library: + . + * + . + * + . + * + . + * + . + * +category: Validity +author: Tom Sydney Kerckhove -homepage: https://github.com/NorfairKing/validity#readme -license: MIT -license-file: LICENSE -author: Tom Sydney Kerckhove -maintainer: syd.kerckhove@gmail.com -copyright: Copyright: (c) 2016 Tom Sydney Kerckhove -category: Validity -build-type: Simple -cabal-version: >=1.10 +source-repository head + type: git + location: https://github.com/NorfairKing/validity library - hs-source-dirs: src - exposed-modules: Data.Validity - , Data.RelativeValidity - build-depends: base >= 4.8 && < 5 - default-language: Haskell2010 + exposed-modules: + Data.RelativeValidity + Data.Validity + build-depends: + base >=4.8 && <5 + default-language: Haskell2010 + hs-source-dirs: src -source-repository head - type: git - location: https://github.com/NorfairKing/validity