diff --git a/Control/DeepSeq.hs b/Control/DeepSeq.hs --- a/Control/DeepSeq.hs +++ b/Control/DeepSeq.hs @@ -1,6 +1,12 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -#if __GLASGOW_HASKELL__ >= 702 && MIN_VERSION_array(0,4,0) +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +# if MIN_VERSION_array(0,4,0) {-# LANGUAGE Safe #-} +# endif #endif ----------------------------------------------------------------------------- -- | @@ -51,6 +57,8 @@ NFData(..), ) where +import Control.Applicative +import Control.Concurrent ( ThreadId ) import Data.Int import Data.Word import Data.Ratio @@ -58,7 +66,59 @@ import Data.Array import Data.Fixed import Data.Version +import Data.Monoid +import Data.Unique ( Unique ) +import Foreign.C.Types +import System.Mem.StableName ( StableName ) +#if MIN_VERSION_base(4,6,0) +import Data.Ord ( Down(Down) ) +#endif + +#if MIN_VERSION_base(4,7,0) +import Data.Proxy ( Proxy(Proxy) ) +#endif + +#if MIN_VERSION_base(4,8,0) +import Data.Functor.Identity ( Identity(..) ) +-- NB: Data.Typeable.Internal is "Trustworthy" only starting w/ base-4.8 +import Data.Typeable.Internal ( TypeRep(..), TyCon(..) ) +import Data.Void ( Void, absurd ) +import Numeric.Natural ( Natural ) +#endif + +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Fingerprint.Type ( Fingerprint(..) ) +import GHC.Generics + +-- | Hidden internal type-class +class GNFData f where + grnf :: f a -> () + +instance GNFData V1 where + grnf = error "Control.DeepSeq.rnf: uninhabited type" + +instance GNFData U1 where + grnf U1 = () + +instance NFData a => GNFData (K1 i a) where + grnf = rnf . unK1 + {-# INLINEABLE grnf #-} + +instance GNFData a => GNFData (M1 i c a) where + grnf = grnf . unM1 + {-# INLINEABLE grnf #-} + +instance (GNFData a, GNFData b) => GNFData (a :*: b) where + grnf (x :*: y) = grnf x `seq` grnf y + {-# INLINEABLE grnf #-} + +instance (GNFData a, GNFData b) => GNFData (a :+: b) where + grnf (L1 x) = grnf x + grnf (R1 x) = grnf x + {-# INLINEABLE grnf #-} +#endif + infixr 0 $!! -- | 'deepseq': fully evaluates the first argument, before returning the @@ -108,46 +168,119 @@ -- -- /Since: 1.1.0.0/ class NFData a where - -- | rnf should reduce its argument to normal form (that is, fully + -- | 'rnf' should reduce its argument to normal form (that is, fully -- evaluate all sub-components), and then return '()'. -- - -- The default implementation of 'rnf' is + -- === 'Generic' 'NFData' deriving -- - -- > rnf a = a `seq` () + -- Starting with GHC 7.2, you can automatically derive instances + -- for types possessing a 'Generic' instance. -- - -- which may be convenient when defining instances for data types with - -- no unevaluated fields (e.g. enumerations). + -- > {-# LANGUAGE DeriveGeneric #-} + -- > + -- > import GHC.Generics (Generic) + -- > import Control.DeepSeq + -- > + -- > data Foo a = Foo a String + -- > deriving (Eq, Generic) + -- > + -- > instance NFData a => NFData (Foo a) + -- > + -- > data Colour = Red | Green | Blue + -- > deriving Generic + -- > + -- > instance NFData Colour + -- + -- Starting with GHC 7.10, the example above can be written more + -- concisely by enabling the new @DeriveAnyClass@ extension: + -- + -- > {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} + -- > + -- > import GHC.Generics (Generic) + -- > import Control.DeepSeq + -- > + -- > data Foo a = Foo a String + -- > deriving (Eq, Generic, NFData) + -- > + -- > data Colour = Red | Green | Blue + -- > deriving (Generic, NFData) + -- > + -- + -- === Compatibility with previous @deepseq@ versions + -- + -- Prior to version 1.4.0.0, the default implementation of the 'rnf' + -- method was defined as + -- + -- @'rnf' a = 'seq' a ()@ + -- + -- However, starting with @deepseq-1.4.0.0@, the default + -- implementation is based on @DefaultSignatures@ allowing for + -- more accurate auto-derived 'NFData' instances. If you need the + -- previously used exact default 'rnf' method implementation + -- semantics, use + -- + -- > instance NFData Colour where rnf x = seq x () + -- + -- or alternatively + -- + -- > {-# LANGUAGE BangPatterns #-} + -- > instance NFData Colour where rnf !_ = () + -- rnf :: a -> () - rnf a = a `seq` () -instance NFData Int -instance NFData Word -instance NFData Integer -instance NFData Float -instance NFData Double +#if __GLASGOW_HASKELL__ >= 702 + default rnf :: (Generic a, GNFData (Rep a)) => a -> () + rnf = grnf . from +#endif -instance NFData Char -instance NFData Bool -instance NFData () +instance NFData Int where rnf !_ = () +instance NFData Word where rnf !_ = () +instance NFData Integer where rnf !_ = () +instance NFData Float where rnf !_ = () +instance NFData Double where rnf !_ = () -instance NFData Int8 -instance NFData Int16 -instance NFData Int32 -instance NFData Int64 +instance NFData Char where rnf !_ = () +instance NFData Bool where rnf !_ = () +instance NFData () where rnf !_ = () -instance NFData Word8 -instance NFData Word16 -instance NFData Word32 -instance NFData Word64 +instance NFData Int8 where rnf !_ = () +instance NFData Int16 where rnf !_ = () +instance NFData Int32 where rnf !_ = () +instance NFData Int64 where rnf !_ = () +instance NFData Word8 where rnf !_ = () +instance NFData Word16 where rnf !_ = () +instance NFData Word32 where rnf !_ = () +instance NFData Word64 where rnf !_ = () + +#if MIN_VERSION_base(4,7,0) +-- |/Since: 1.4.0.0/ +instance NFData (Proxy a) where rnf Proxy = () +#endif + +#if MIN_VERSION_base(4,8,0) +-- |/Since: 1.4.0.0/ +instance NFData a => NFData (Identity a) where + rnf = rnf . runIdentity + +-- | Defined as @'rnf' = 'absurd'@. +-- +-- /Since: 1.4.0.0/ +instance NFData Void where + rnf = absurd + +-- |/Since: 1.4.0.0/ +instance NFData Natural where rnf !_ = () +#endif + -- |/Since: 1.3.0.0/ -instance NFData (Fixed a) +instance NFData (Fixed a) where rnf !_ = () -- |This instance is for convenience and consistency with 'seq'. -- This assumes that WHNF is equivalent to NF for functions. -- -- /Since: 1.3.0.0/ -instance NFData (a -> b) +instance NFData (a -> b) where rnf !_ = () --Rational and complex numbers. @@ -175,8 +308,179 @@ rnf [] = () rnf (x:xs) = rnf x `seq` rnf xs +-- |/Since: 1.4.0.0/ +instance NFData a => NFData (ZipList a) where + rnf = rnf . getZipList + +-- |/Since: 1.4.0.0/ +instance NFData a => NFData (Const a b) where + rnf = rnf . getConst + instance (Ix a, NFData a, NFData b) => NFData (Array a b) where rnf x = rnf (bounds x, Data.Array.elems x) + +#if MIN_VERSION_base(4,6,0) +-- |/Since: 1.4.0.0/ +instance NFData a => NFData (Down a) where + rnf (Down x) = rnf x +#endif + +-- |/Since: 1.4.0.0/ +instance NFData a => NFData (Dual a) where + rnf = rnf . getDual + +-- |/Since: 1.4.0.0/ +instance NFData a => NFData (First a) where + rnf = rnf . getFirst + +-- |/Since: 1.4.0.0/ +instance NFData a => NFData (Last a) where + rnf = rnf . getLast + +-- |/Since: 1.4.0.0/ +instance NFData Any where rnf = rnf . getAny + +-- |/Since: 1.4.0.0/ +instance NFData All where rnf = rnf . getAll + +-- |/Since: 1.4.0.0/ +instance NFData a => NFData (Sum a) where + rnf = rnf . getSum + +-- |/Since: 1.4.0.0/ +instance NFData a => NFData (Product a) where + rnf = rnf . getProduct + +-- |/Since: 1.4.0.0/ +instance NFData (StableName a) where + rnf !_ = () -- assumes `data StableName a = StableName (StableName# a)` + +-- |/Since: 1.4.0.0/ +instance NFData ThreadId where + rnf !_ = () -- assumes `data ThreadId = ThreadId ThreadId#` + +-- |/Since: 1.4.0.0/ +instance NFData Unique where + rnf !_ = () -- assumes `newtype Unique = Unique Integer` + +#if MIN_VERSION_base(4,8,0) +-- | __NOTE__: Only defined for @base-4.8.0.0@ and later +-- +-- /Since: 1.4.0.0/ +instance NFData TypeRep where + rnf (TypeRep _ tycon tyrep) = rnf tycon `seq` rnf tyrep + +-- | __NOTE__: Only defined for @base-4.8.0.0@ and later +-- +-- /Since: 1.4.0.0/ +instance NFData TyCon where + rnf (TyCon _ tcp tcm tcn) = rnf tcp `seq` rnf tcm `seq` rnf tcn +#endif + +---------------------------------------------------------------------------- +-- GHC Specifics + +#if __GLASGOW_HASKELL__ >= 702 +-- |/Since: 1.4.0.0/ +instance NFData Fingerprint where + rnf (Fingerprint _ _) = () +#endif + +---------------------------------------------------------------------------- +-- Foreign.C.Types + +-- |/Since: 1.4.0.0/ +instance NFData CChar where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CSChar where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CUChar where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CShort where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CUShort where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CInt where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CUInt where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CLong where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CULong where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CPtrdiff where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CSize where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CWchar where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CSigAtomic where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CLLong where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CULLong where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CIntPtr where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CUIntPtr where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CIntMax where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CUIntMax where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CClock where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CTime where rnf !_ = () + +#if MIN_VERSION_base(4,4,0) +-- |/Since: 1.4.0.0/ +instance NFData CUSeconds where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CSUSeconds where rnf !_ = () +#endif + +-- |/Since: 1.4.0.0/ +instance NFData CFloat where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CDouble where rnf !_ = () + +-- NOTE: The types `CFile`, `CFPos`, and `CJmpBuf` below are not +-- newtype wrappers rather defined as field-less single-constructor +-- types. + +-- |/Since: 1.4.0.0/ +instance NFData CFile where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CFpos where rnf !_ = () + +-- |/Since: 1.4.0.0/ +instance NFData CJmpBuf where rnf !_ = () + +---------------------------------------------------------------------------- +-- Tuples instance (NFData a, NFData b) => NFData (a,b) where rnf (x,y) = rnf x `seq` rnf y diff --git a/changelog b/changelog deleted file mode 100644 --- a/changelog +++ /dev/null @@ -1,35 +0,0 @@ --*-change-log-*- - -1.3.0.2 Nov 2013 - * Update package description to Cabal 1.10 format - * Add support for GHC 7.8 - * Drop support for GHCs older than GHC 7.0.1 - * Add `/since: .../` annotations to Haddock comments - * Add changelog - -1.3.0.1 Sep 2012 - * No changes - -1.3.0.0 Feb 2012 - * Add instances for `Fixed`, `a->b` and `Version` - -1.3.0.1 Sep 2011 - * Disable SafeHaskell for GHC 7.2 - -1.2.0.0 Sep 2011 - * New function `force` - * New operator `$!!` - * Add SafeHaskell support - * Dropped dependency on containers - -1.1.0.2 Nov 2010 - * Improve Haddock documentation - -1.1.0.1 Oct 2010 - * Enable support for containers-0.4.x - -1.1.0.0 Nov 2009 - * Major rewrite - -1.0.0.0 Nov 2009 - * Initial release diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,78 @@ +# Changelog for [`deepseq` package](http://hackage.haskell.org/package/deepseq) + +## 1.4.0.0 *Dec 2014* + + * Bundled with GHC 7.10.1 + * Switch to Generics based `DefaultSignature` `rnf` method + implementation (based on code from `deepseq-generics`) + + **Compatibility Note**: if you need the exact default-method + semantics of `deepseq` prior to 1.4, replace occurences of + + instance NFData XYZ + + by + + instance NFData XYZ where rnf x = seq x () + + * New `NFData` instances for `base` types: + + - `Control.Applicative.Const` + - `Control.Applicative.ZipList` + - `Control.Concurrent.ThreadId` + - `Data.Functor.Identity.Identity` + - `Data.Monoid.{Dual,First,Last,Any,All,Sum,Product}` + - `Data.Ord.Down` + - `Data.Proxy.Proxy` + - `Data.Typeable.Internal.TyCon` + - `Data.Typeable.Internal.TypeRep` + - `Data.Unique.Unique` + - `Data.Void.Void` + - `GHC.Fingerprint.Type.Fingerprint` + - `Numeric.Natural.Natural` + - `System.Mem.StableName.StableName` + - `Foreign.C.Types.C*` + +## 1.3.0.2 *Nov 2013* + + * Bundled with GHC 7.8.1 + * Update package description to Cabal 1.10 format + * Add support for GHC 7.8 + * Drop support for GHCs older than GHC 7.0.1 + * Add `/since: .../` annotations to Haddock comments + * Add changelog + +## 1.3.0.1 *Sep 2012* + + * No changes + +## 1.3.0.0 *Feb 2012* + + * Add instances for `Fixed`, `a->b` and `Version` + +## 1.2.0.1 *Sep 2011* + + * Disable SafeHaskell for GHC 7.2 + +## 1.2.0.0 *Sep 2011* + + * New function `force` + * New operator `$!!` + * Add SafeHaskell support + * Dropped dependency on containers + +## 1.1.0.2 *Nov 2010* + + * Improve Haddock documentation + +## 1.1.0.1 *Oct 2010* + + * Enable support for containers-0.4.x + +## 1.1.0.0 *Nov 2009* + + * Major rewrite + +## 1.0.0.0 *Nov 2009* + + * Initial release diff --git a/deepseq.cabal b/deepseq.cabal --- a/deepseq.cabal +++ b/deepseq.cabal @@ -1,10 +1,11 @@ -name: deepseq -version: 1.3.0.2 --- GHC 7.6.1 released with 1.3.0.1 -license: BSD3 -license-file: LICENSE -maintainer: libraries@haskell.org -synopsis: Deep evaluation of data structures +name: deepseq +version: 1.4.0.0 +-- NOTE: Don't forget to update ./changelog.md +license: BSD3 +license-file: LICENSE +maintainer: libraries@haskell.org +bug-reports: https://github.com/haskell/deepseq/issues +synopsis: Deep evaluation of data structures category: Control description: This package provides methods for fully evaluating data structures @@ -19,32 +20,63 @@ typeclass (\"Normal Form Data\", data structures with no unevaluated components) which defines strategies for fully evaluating different data types. - . - If you want to automatically derive 'NFData' instances via the - "GHC.Generics" facility, there is a companion package - - which builds on top of this package. build-type: Simple cabal-version: >=1.10 -tested-with: GHC==7.6.3, GHC==7.6.2, GHC==7.6.1, GHC==7.4.2, GHC==7.4.1, GHC==7.2.2, GHC==7.2.1, GHC==7.0.4, GHC==7.0.3, GHC==7.0.2, GHC==7.0.1 +tested-with: GHC==7.8.3, GHC==7.8.2, GHC==7.8.1, GHC==7.6.3, GHC==7.6.2, GHC==7.6.1, GHC==7.4.2, GHC==7.4.1, GHC==7.2.2, GHC==7.2.1, GHC==7.0.4, GHC==7.0.3, GHC==7.0.2, GHC==7.0.1 -extra-source-files: changelog +extra-source-files: changelog.md source-repository head type: git - location: http://git.haskell.org/packages/deepseq.git - -source-repository this - type: git - location: http://git.haskell.org/packages/deepseq.git - tag: deepseq-1.3.0.2-release + location: https://github.com/haskell/deepseq.git library default-language: Haskell2010 - other-extensions: CPP - if impl(ghc >= 7.2) - other-extensions: Safe - exposed-modules: Control.DeepSeq - build-depends: base >= 4.3 && < 4.8, + other-extensions: + BangPatterns + CPP + + if impl(ghc>=7.2) + -- Enable Generics-backed DefaultSignatures for `rnf` + other-extensions: + DefaultSignatures + FlexibleContexts + Safe + TypeOperators + + build-depends: ghc-prim >= 0.2 && < 0.4 + + build-depends: base >= 4.3 && < 4.9, array >= 0.3 && < 0.6 ghc-options: -Wall + + exposed-modules: Control.DeepSeq + + +test-suite deepseq-generics-tests + default-language: Haskell2010 + if !impl(ghc>=7.2) + buildable: False + type: exitcode-stdio-1.0 + hs-source-dirs: . tests + main-is: Main.hs + other-extensions: + CPP + BangPatterns + DefaultSignatures + DeriveDataTypeable + DeriveGeneric + FlexibleContexts + Safe + TupleSections + TypeOperators + + ghc-options: -Wall + + build-depends: + array, + base, + -- end of packages with inherited version constraints + test-framework == 0.8.*, + test-framework-hunit == 0.3.*, + HUnit == 1.2.* diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,152 @@ +-- Code reused from http://hackage.haskell.org/package/deepseq-generics + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TupleSections #-} + +module Main (main) where + +import Control.Concurrent.MVar +import Control.Exception +import Control.Monad +import Data.Bits +import Data.IORef +import Data.Typeable +import Data.Word +import GHC.Generics +import System.IO.Unsafe (unsafePerformIO) + +-- import Test.Framework (defaultMain, testGroup, testCase) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.HUnit + +-- IUT +import Control.DeepSeq + +-- needed for GHC-7.4 compatibility +#if !MIN_VERSION_base(4,6,0) +atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b +atomicModifyIORef' ref f = do + b <- atomicModifyIORef ref + (\x -> let (a, b) = f x + in (a, a `seq` b)) + b `seq` return b +#endif + +---------------------------------------------------------------------------- +-- simple hacky abstraction for testing forced evaluation via `rnf`-like functions + +seqStateLock :: MVar () +seqStateLock = unsafePerformIO $ newMVar () +{-# NOINLINE seqStateLock #-} + +withSeqState :: Word64 -> IO () -> IO () +withSeqState expectedState act = withMVar seqStateLock $ \() -> do + 0 <- resetSeqState + () <- act + st <- resetSeqState + unless (st == expectedState) $ + assertFailure ("withSeqState: actual seq-state ("++show st++") doesn't match expected value ("++ + show expectedState++")") + +seqState :: IORef Word64 +seqState = unsafePerformIO $ newIORef 0 +{-# NOINLINE seqState #-} + +resetSeqState :: IO Word64 +resetSeqState = atomicModifyIORef' seqState (0,) + +-- |Set flag and raise exception is flag already set +setSeqState :: Int -> IO () +setSeqState i | 0 <= i && i < 64 = atomicModifyIORef' seqState go + | otherwise = error "seqSeqState: flag index must be in [0..63]" + where + go x | testBit x i = error ("setSeqState: flag #"++show i++" already set") + | otherwise = (setBit x i, ()) + +-- weird type whose NFData instacne calls 'setSeqState' when rnf-ed +data SeqSet = SeqSet !Int | SeqIgnore + deriving Show + +instance NFData SeqSet where + rnf (SeqSet i) = unsafePerformIO $ setSeqState i + rnf (SeqIgnore) = () + {-# NOINLINE rnf #-} + +-- |Exception to be thrown for testing 'seq'/'rnf' +data RnfEx = RnfEx deriving (Eq, Show, Typeable) + +instance Exception RnfEx + +instance NFData RnfEx where rnf e = throw e + +assertRnfEx :: () -> IO () +assertRnfEx v = handleJust isWanted (const $ return ()) $ do + () <- evaluate v + assertFailure "failed to trigger expected RnfEx exception" + where isWanted = guard . (== RnfEx) + +---------------------------------------------------------------------------- + +case_1, case_2, case_3, case_4_1, case_4_2, case_4_3, case_4_4 :: Test.Framework.Test + +newtype Case1 = Case1 Int + deriving (Generic) + +instance NFData Case1 + +case_1 = testCase "Case1" $ do + assertRnfEx $ rnf $ (Case1 (throw RnfEx)) + +---- + +data Case2 = Case2 Int + deriving (Generic) + +instance NFData Case2 + +case_2 = testCase "Case2" $ do + assertRnfEx $ rnf $ (Case2 (throw RnfEx)) + +---- + +data Case3 = Case3 RnfEx + deriving (Generic) + +instance NFData Case3 + +case_3 = testCase "Case3" $ do + assertRnfEx $ rnf $ Case3 RnfEx + +---- + +data Case4 a = Case4a + | Case4b a a + | Case4c a (Case4 a) + deriving (Generic) + +instance NFData a => NFData (Case4 a) + +case_4_1 = testCase "Case4.1" $ withSeqState 0x0 $ do + evaluate $ rnf $ (Case4a :: Case4 SeqSet) + +case_4_2 = testCase "Case4.2" $ withSeqState 0x3 $ do + evaluate $ rnf $ (Case4b (SeqSet 0) (SeqSet 1) :: Case4 SeqSet) + +case_4_3 = testCase "Case4.3" $ withSeqState (bit 55) $ do + evaluate $ rnf $ (Case4b SeqIgnore (SeqSet 55) :: Case4 SeqSet) + +case_4_4 = testCase "Case4.4" $ withSeqState 0xffffffffffffffff $ do + evaluate $ rnf $ (genCase 63) + where + genCase n | n > 1 = Case4c (SeqSet n) (genCase (n-1)) + | otherwise = Case4b (SeqSet 0) (SeqSet 1) + +---------------------------------------------------------------------------- + +main :: IO () +main = defaultMain [tests] + where + tests = testGroup "" [case_1, case_2, case_3, case_4_1, case_4_2, case_4_3, case_4_4]