diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,10 @@ +## Changes in 0.4.2 + - `Functor` instances for `Handler` + - `Functor`. `Applicative`, `Alternative`, and `MonadPlus` instances for + `ArrowMonad` + - Expose `Read` and `Show` instances for `Down` on GHCs before 7.8 + - `Bits`, `Bounded`, and `Integral` instances for `CDev` + ## Changes in 0.4.1 - Fixed imports on GHC < 7.8 on Windows diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -17,8 +17,10 @@ ## What is covered * Added `Applicative` and `Alternative` instances for `ReadP` and `ReadPrec` + * Added `Bits`, `Bounded`, and `Integral` instances for `CDev` * Added `Eq` and `Ord` instances for `Control.Exception.ErrorCall` * Added `Eq`, `Ord`, `Read`, and `Show` instances for data types in `GHC.Generics` + * Added `Functor`, `Applicative`, `Alternative`, and `MonadPlus` instances for `ArrowMonad` * Added `Functor`, `Applicative`, and `Monad` instances for `First` and `Last` * Added `Monoid`, `Eq`, `Ord`, `Read`, and `Show` instances for `Const` * Added `Read` and `Show` instances for `Down` @@ -28,7 +30,7 @@ * `Applicative` instance for strict and lazy `ST` * `Bits` instance for `Bool` * `Foldable` instance for `Either`, `(,)` and `Const` - * `Functor` instance for `ArgOrder`, `OptDescr`, and `ArgDescr` + * `Functor` instance for `Handler`, `ArgOrder`, `OptDescr`, and `ArgDescr` * `Num` instance for `Sum` and `Product` * `Read` instance for `Fixed` * `Show` instance for `Fingerprint` @@ -46,6 +48,7 @@ ## Supported versions of GHC/`base` + * `ghc-7.10.2` / `base-4.8.1.0` * `ghc-7.10.1` / `base-4.8.0.0` * `ghc-7.8.4` / `base-4.7.0.2` * `ghc-7.8.3` / `base-4.7.0.1` diff --git a/base-orphans.cabal b/base-orphans.cabal --- a/base-orphans.cabal +++ b/base-orphans.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: base-orphans -version: 0.4.1 +version: 0.4.2 synopsis: Backwards-compatible orphan instances for base homepage: https://github.com/haskell-compat/base-orphans#readme bug-reports: https://github.com/haskell-compat/base-orphans/issues @@ -53,6 +53,7 @@ base >= 4.3 && < 5 , base-orphans , hspec == 2.* + , QuickCheck other-modules: Control.Applicative.OrphansSpec Control.Exception.OrphansSpec @@ -63,4 +64,5 @@ Data.Version.OrphansSpec Foreign.Storable.OrphansSpec GHC.Fingerprint.OrphansSpec + System.Posix.Types.OrphansSpec default-language: Haskell2010 diff --git a/src/Data/Orphans.hs b/src/Data/Orphans.hs --- a/src/Data/Orphans.hs +++ b/src/Data/Orphans.hs @@ -31,7 +31,6 @@ module Data.Orphans () where #if MIN_VERSION_base(4,4,0) && !(MIN_VERSION_base(4,7,0)) -import Data.Word (Word64) import Numeric (showHex) #endif @@ -63,27 +62,37 @@ import GHC.Stats #endif +#if !(MIN_VERSION_base(4,5,0)) +import Unsafe.Coerce (unsafeCoerce) +#endif + #if MIN_VERSION_base(4,6,0) && __GLASGOW_HASKELL__ < 710 -import Data.Bits -import Data.Ord import GHC.ForeignPtr import GHC.GHCi import GHC.TypeLits import System.Posix.Internals #endif +#if !(MIN_VERSION_base(4,6,0)) || (__GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710) +import Control.Arrow +#endif + #if !(MIN_VERSION_base(4,6,0)) -import Control.Monad (ap, mplus, mzero) +import Control.Monad (MonadPlus(..), ap) +import System.Posix.Types #endif #if MIN_VERSION_base(4,7,0) && __GLASGOW_HASKELL__ < 710 import Control.Concurrent.QSem import Data.Proxy import Text.Read.Lex (Number) -# endif +#endif +#if !(MIN_VERSION_base(4,7,0)) +import Data.Word +#endif + #if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 -import Control.Arrow import Control.Category hiding ((.)) import Control.Monad import Control.Monad.Fix @@ -92,7 +101,6 @@ import Data.Type.Coercion import Data.Type.Equality import Data.Typeable.Internal -import GHC.Exts as Exts import GHC.IO.BufferedIO import GHC.IO.Device (IODevice, RawIO) import GHC.IO.Handle @@ -112,6 +120,7 @@ import Control.Applicative import Control.Exception as Exception import Control.Monad.ST.Lazy as Lazy +import Data.Bits import Data.Char import Data.Data as Data import Data.Foldable @@ -123,7 +132,8 @@ import Foreign.Storable import GHC.Base import GHC.Conc -import GHC.Desugar +import GHC.Desugar (AnnotationWrapper) +import GHC.Exts as Exts import GHC.IO.Buffer import GHC.IO.Device (IODeviceType(..)) import GHC.IO.Encoding @@ -142,6 +152,8 @@ # endif #endif +#include "HsBaseConfig.h" + ------------------------------------------------------------------------------- #if MIN_VERSION_base(4,4,0) && !(MIN_VERSION_base(4,7,0)) @@ -217,12 +229,45 @@ popCount False = 0 popCount True = 1 - -deriving instance Read a => Read (Down a) -deriving instance Show a => Show (Down a) #endif #if !(MIN_VERSION_base(4,6,0)) +# if MIN_VERSION_base(4,5,0) +deriving instance Bits CDev +deriving instance Bounded CDev +deriving instance Integral CDev +# else +type HDev = HTYPE_DEV_T + +instance Bits CDev where + (.&.) = unsafeCoerce ((.&.) :: HDev -> HDev -> HDev) + (.|.) = unsafeCoerce ((.|.) :: HDev -> HDev -> HDev) + xor = unsafeCoerce (xor :: HDev -> HDev -> HDev) + shift = unsafeCoerce (shift :: HDev -> Int -> HDev) + rotate = unsafeCoerce (rotate :: HDev -> Int -> HDev) + setBit = unsafeCoerce (setBit :: HDev -> Int -> HDev) + clearBit = unsafeCoerce (clearBit :: HDev -> Int -> HDev) + complementBit = unsafeCoerce (complementBit :: HDev -> Int -> HDev) + testBit = unsafeCoerce (testBit :: HDev -> Int -> Bool) + complement = unsafeCoerce (complement :: HDev -> HDev) + bit = unsafeCoerce (bit :: Int -> HDev) + bitSize = unsafeCoerce (bitSize :: HDev -> Int) + isSigned = unsafeCoerce (isSigned :: HDev -> Bool) + +instance Bounded CDev where + minBound = unsafeCoerce (minBound :: HDev) + maxBound = unsafeCoerce (maxBound :: HDev) + +instance Integral CDev where + quot = unsafeCoerce (quot :: HDev -> HDev -> HDev) + rem = unsafeCoerce (rem :: HDev -> HDev -> HDev) + div = unsafeCoerce (div :: HDev -> HDev -> HDev) + mod = unsafeCoerce (mod :: HDev -> HDev -> HDev) + quotRem = unsafeCoerce (quotRem :: HDev -> HDev -> (HDev, HDev)) + divMod = unsafeCoerce (divMod :: HDev -> HDev -> (HDev, HDev)) + toInteger = unsafeCoerce (toInteger :: HDev -> Integer) +# endif + instance Applicative ReadP where pure = return (<*>) = ap @@ -238,6 +283,42 @@ instance Alternative ReadPrec where empty = mzero (<|>) = mplus + +instance Functor Exception.Handler where + fmap f (Exception.Handler h) = Exception.Handler (fmap f . h) + +instance +# if MIN_VERSION_base(4,4,0) + Arrow a +# else + ArrowApply a +# endif + => Functor (ArrowMonad a) where + fmap f (ArrowMonad m) = ArrowMonad $ m >>> arr f + +instance +# if MIN_VERSION_base(4,4,0) + Arrow a +# else + ArrowApply a +# endif + => Applicative (ArrowMonad a) where + pure x = ArrowMonad (arr (const x)) + ArrowMonad f <*> ArrowMonad x = ArrowMonad (f &&& x >>> arr (uncurry id)) + +instance +# if MIN_VERSION_base(4,4,0) + ArrowPlus a +# else + (ArrowApply a, ArrowPlus a) +# endif + => Alternative (ArrowMonad a) where + empty = ArrowMonad zeroArrow + ArrowMonad x <|> ArrowMonad y = ArrowMonad (x <+> y) + +instance (ArrowApply a, ArrowPlus a) => MonadPlus (ArrowMonad a) where + mzero = ArrowMonad zeroArrow + ArrowMonad x `mplus` ArrowMonad y = ArrowMonad (x <+> y) #endif #if !(MIN_VERSION_base(4,7,0)) @@ -248,13 +329,15 @@ instance Foldable ((,) a) where foldMap f (_, y) = f y - + foldr f z (_, y) = f y z instance Traversable ((,) a) where traverse f (x, y) = (,) x <$> f y deriving instance Monoid a => Monoid (Const a b) +deriving instance Read a => Read (Down a) +deriving instance Show a => Show (Down a) deriving instance Eq ErrorCall deriving instance Ord ErrorCall deriving instance Num a => Num (Sum a) diff --git a/test/System/Posix/Types/OrphansSpec.hs b/test/System/Posix/Types/OrphansSpec.hs new file mode 100644 --- /dev/null +++ b/test/System/Posix/Types/OrphansSpec.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} +module System.Posix.Types.OrphansSpec (main, spec) where + +import Control.Applicative (liftA2) + +import Data.Bits (Bits(..)) +import Data.Orphans () +import Data.Word + +import System.Posix.Types + +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (NonZero(..)) + +#include "HsBaseConfig.h" + +type HDev = HTYPE_DEV_T + +main :: IO () +main = hspec spec + +spec :: Spec +spec = describe "CDev" $ do + describe "Bits instance" $ do + prop "implements (.&.)" $ + pred2HDevHDev (.&.) (.&.) + prop "implements (.|.)" $ + pred2HDevHDev (.|.) (.|.) + prop "implements xor" $ + pred2HDevHDev xor xor + prop "implements shift" $ + pred2IntHDev shift shift + prop "implements rotate" $ + pred2IntHDev rotate rotate + prop "implements setBit" $ + pred2IntHDev setBit setBit + prop "implements clearBit" $ + pred2IntHDev clearBit clearBit + prop "implements complementBit" $ + pred2IntHDev complementBit complementBit + prop "implements testBit" $ + pred2IntEq testBit testBit + prop "implements complement" $ + pred1HDevHDev complement complement + prop "implements bit" $ + pred1IntHDev bit bit + prop "implements bitSize" $ + pred1HDevEq bitSize bitSize + prop "implements isSigned" $ + pred1HDevEq isSigned isSigned + describe "Bounded instance" $ do + it "implements minBound" $ + toInteger (minBound :: CDev) `shouldBe` toInteger (minBound :: HDev) + it "implements maxBound" $ + toInteger (maxBound :: CDev) `shouldBe` toInteger (maxBound :: HDev) + describe "Integral instance" $ do + prop "implements quot" $ + pred2HDevHDev quot quot + prop "implements rem" $ + pred2HDevHDev rem rem + prop "implements div" $ + pred2HDevHDev div div + prop "implements mod" $ + pred2HDevHDev mod mod + prop "implements quotRem" $ + pred2HDevPair quotRem quotRem + prop "implements divMod" $ + pred2HDevPair divMod divMod + prop "implements toInteger" $ + pred1HDevEq toInteger toInteger + +eqCDevHDev :: CDev -> HDev -> Bool +eqCDevHDev cDev hDev = toInteger cDev == toInteger hDev + +pred1Common :: (b -> c -> d) + -> (a -> b) + -> (a -> c) + -> a -> d +pred1Common = liftA2 + +pred1HDev :: (b -> c -> Bool) + -> (CDev -> b) + -> (HDev -> c) + -> HDev -> Bool +pred1HDev p f = pred1Common p (f . fromIntegral) + +pred1HDevEq :: Eq a => (CDev -> a) -> (HDev -> a) -> HDev -> Bool +pred1HDevEq = pred1HDev (==) + +pred1HDevHDev :: (CDev -> CDev) -> (HDev -> HDev) -> HDev -> Bool +pred1HDevHDev = pred1HDev eqCDevHDev + +pred1IntHDev :: (Int -> CDev) -> (Int -> HDev) -> Int -> Bool +pred1IntHDev = pred1Common eqCDevHDev + +pred2Common :: (c -> d -> e) + -> (a -> b -> c) + -> (a -> b -> d) + -> a -> b -> e +pred2Common p f g x y = p (f x y) (g x y) + +pred2HDev :: (a -> b -> Bool) + -> (CDev -> CDev -> a) + -> (HDev -> HDev -> b) + -> NonZero HDev -> NonZero HDev -> Bool +pred2HDev eqv cDevPred hDevPred = + pred2Common eqv (\nz1 nz2 -> cDevPred (fromIntegral $ getNonZero nz1) + (fromIntegral $ getNonZero nz2)) + (\nz1 nz2 -> hDevPred (getNonZero nz1) + (getNonZero nz2)) + +pred2HDevHDev :: (CDev -> CDev -> CDev) + -> (HDev -> HDev -> HDev) + -> NonZero HDev -> NonZero HDev -> Bool +pred2HDevHDev = pred2HDev eqCDevHDev + +pred2HDevPair :: (CDev -> CDev -> (CDev, CDev)) + -> (HDev -> HDev -> (HDev, HDev)) + -> NonZero HDev -> NonZero HDev -> Bool +pred2HDevPair = pred2HDev $ \(cDev1, cDev2) (hDev1, hDev2) -> + toInteger cDev1 == toInteger hDev1 + && toInteger cDev2 == toInteger hDev2 + +pred2Int :: (a -> b -> Bool) + -> (CDev -> Int -> a) + -> (HDev -> Int -> b) + -> HDev -> Int -> Bool +pred2Int eqv cDevPred = pred2Common eqv (cDevPred . fromIntegral) + +pred2IntHDev :: (CDev -> Int -> CDev) + -> (HDev -> Int -> HDev) + -> HDev -> Int -> Bool +pred2IntHDev = pred2Int eqCDevHDev + +pred2IntEq :: Eq a + => (CDev -> Int -> a) + -> (HDev -> Int -> a) + -> HDev -> Int -> Bool +pred2IntEq = pred2Int (==)