diff --git a/Control/DeepSeq/Generics.hs b/Control/DeepSeq/Generics.hs new file mode 100644 --- /dev/null +++ b/Control/DeepSeq/Generics.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE BangPatterns, TypeOperators, FlexibleContexts #-} + +-- | +-- Module: Control.DeepSeq.Generics +-- Copyright: (c) 2012, Herbert Valerio Riedel +-- License: BSD-style (see the LICENSE file) +-- +-- Maintainer: Herbert Valerio Riedel +-- Stability: stable +-- Portability: GHC +-- +-- Note: Beyond the primary scope of providing the 'genericRnf' +-- helper, this module also re-exports the definitions from +-- "Control.DeepSeq" for convenience. If this poses any +-- problems, just use qualified or explicit import statements +-- (see code usage example in the 'genericRnf' description) + +module Control.DeepSeq.Generics + ( genericRnf + -- * "Control.DeepSeq" re-exports + , deepseq + , force + , NFData(rnf) + , ($!!) + ) where + +import Control.DeepSeq +import GHC.Generics + +-- | "GHC.Generics"-based 'rnf' implementation +-- +-- This provides a generic `rnf` implementation for one type at a +-- time. If the type of the value 'genericRnf' is asked to reduce to +-- NF contains values of other types, those types have to provide +-- 'NFData' instances. This also means that recursive types can only +-- be used with 'genericRnf' if a 'NFData' instance has been defined +-- as well (see examples below). +-- +-- The typical usage for 'genericRnf' is for reducing boilerplate code +-- when defining 'NFData' instances for ordinary algebraic +-- datatypes. See the code below for some simple usage examples: +-- +-- > {-# LANGUAGE DeriveGeneric #-} +-- > +-- > import Control.DeepSeq +-- > import Control.DeepSeq.Generics (genericRnf) +-- > import GHC.Generics +-- > +-- > -- simple record +-- > data Foo = Foo AccountId Name Address +-- > deriving Generic +-- > +-- > type Address = [String] +-- > type Name = String +-- > newtype AccountId = AccountId Int +-- > +-- > instance NFData AccountId +-- > instance NFData Foo where rnf = genericRnf +-- > +-- > -- recursive list-like type +-- > data N = Z | S N deriving Generic +-- > +-- > instance NFData N where rnf = genericRnf +-- > +-- > -- parametric & recursive type +-- > data Bar a = Bar0 | Bar1 a | Bar2 (Bar a) +-- > deriving Generic +-- > +-- > instance NFData a => NFData (Bar a) where rnf = genericRnf +-- +-- Note: The 'GNFData' type-class showing up in the type-signature is +-- used internally and not exported on purpose currently. + +genericRnf :: (Generic a, GNFData (Rep a)) => a -> () +genericRnf = grnf_ . from +{-# INLINE genericRnf #-} + +-- | Hidden internal type-class +class GNFData f where + grnf_ :: f a -> () + +-- note: the V1 instance is not provided, as uninhabited types can't +-- be reduced to NF anyway + +instance GNFData U1 where + grnf_ !U1 = () + {-# INLINE grnf_ #-} + +instance NFData a => GNFData (K1 i a) where + grnf_ = rnf . unK1 + {-# INLINE grnf_ #-} + +instance GNFData a => GNFData (M1 i c a) where + grnf_ = grnf_ . unM1 + {-# INLINE grnf_ #-} + +instance (GNFData a, GNFData b) => GNFData (a :*: b) where + grnf_ (x :*: y) = grnf_ x `seq` grnf_ y + {-# INLINE grnf_ #-} + +instance (GNFData a, GNFData b) => GNFData (a :+: b) where + grnf_ (L1 x) = grnf_ x + grnf_ (R1 x) = grnf_ x + {-# INLINE grnf_ #-} diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Herbert Valerio Riedel + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Herbert Valerio Riedel nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/deepseq-generics.cabal b/deepseq-generics.cabal new file mode 100644 --- /dev/null +++ b/deepseq-generics.cabal @@ -0,0 +1,61 @@ +-- Initial deepseq-generics.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: deepseq-generics +version: 0.1.0.0 +synopsis: GHC.Generics-based Control.DeepSeq.rnf implementation +homepage: https://github.com/hvr/deepseq-generics +license: BSD3 +license-file: LICENSE +author: Herbert Valerio Riedel +maintainer: hvr@gnu.org +copyright: 2012, Herbert Valerio Riedel +category: Control +build-type: Simple +cabal-version: >=1.10 +tested-with: GHC >=7.4.1 +description: + This package provides a "GHC.Generics"-based + 'Control.DeepSeq.Generics.genericRnf' function which can be used + for providing a 'rnf' implementation. See the documentation for + the 'genericRnf' function in the "Control.DeepSeq.Generics" module + to get started. + . + The original idea was pioneered in the @generic-deepseq@ package + (see + for more information). + . + This package differs from the @generic-deepseq@ package by working + in combination with the existing @deepseq@ package as opposed to defining a + conflicting drop-in replacement for @deepseq@'s @Control.Deepseq@ module. + +source-repository head + type: git + location: https://github.com/hvr/deepseq-generics.git + +library + default-language: Haskell2010 + exposed-modules: Control.DeepSeq.Generics + build-depends: base >= 4.5 && < 4.7, ghc-prim >= 0.2 && < 0.4, deepseq >= 1.2.0.1 && < 1.4 + other-extensions: BangPatterns, TypeOperators, FlexibleContexts + ghc-options: -Wall + +test-suite tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Suite.hs + hs-source-dirs: test + other-extensions: CPP, TupleSections, DeriveDataTypeable + ghc-options: -Wall + + build-depends: + base, + deepseq, + deepseq-generics, + ghc-prim, + -- end of packages with inherited version constraints + test-framework, + test-framework-hunit, + HUnit + + diff --git a/test/Suite.hs b/test/Suite.hs new file mode 100644 --- /dev/null +++ b/test/Suite.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE CPP, TupleSections, DeriveDataTypeable, DeriveGeneric #-} + +module Main (main) where + +import Control.Concurrent.MVar +import Control.DeepSeq +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.Generics + +-- 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 +case_1 = testCase "Case1" $ do + assertRnfEx $ genericRnf $ (Case1 (throw RnfEx)) + +---- + +data Case2 = Case2 Int + deriving Generic +case_2 = testCase "Case2" $ do + assertRnfEx $ genericRnf $ (Case2 (throw RnfEx)) + +---- + +data Case3 = Case3 RnfEx + deriving Generic +case_3 = testCase "Case3" $ do + assertRnfEx $ genericRnf $ Case3 RnfEx + +---- + +data Case4 a = Case4a + | Case4b a a + | Case4c a (Case4 a) + deriving Generic +instance NFData a => NFData (Case4 a) where rnf = genericRnf + +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]