packages feed

deepseq-generics (empty) → 0.1.0.0

raw patch · 5 files changed

+335/−0 lines, 5 filesdep +HUnitdep +basedep +deepseqsetup-changed

Dependencies added: HUnit, base, deepseq, deepseq-generics, ghc-prim, test-framework, test-framework-hunit

Files

+ Control/DeepSeq/Generics.hs view
@@ -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 <hvr@gnu.org>+-- 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_ #-}
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ deepseq-generics.cabal view
@@ -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 <http://www.haskell.org/pipermail/haskell-cafe/2012-February/099551.html>+    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++
+ test/Suite.hs view
@@ -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]