[commit: packages/deepseq] master, typeable-with-kinds: Add simple test-suite for Generics deriving (733f4af)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/deepseq

On branches: master,typeable-with-kinds
Link       : http://git.haskell.org/packages/deepseq.git/commitdiff/733f4af3d34d28e004e58c38451575b655efb8b8

>---------------------------------------------------------------

commit 733f4af3d34d28e004e58c38451575b655efb8b8
Author: Herbert Valerio Riedel <hvr at gnu.org>
Date:   Sat Dec 6 11:39:21 2014 +0100

    Add simple test-suite for Generics deriving
    
    This does not use ChasingBottoms as we're interested in testing each
    field is evaluated exactly once which ChasingBottoms doesn't provide
    afaics.


>---------------------------------------------------------------

733f4af3d34d28e004e58c38451575b655efb8b8
 deepseq.cabal |  29 +++++++++++
 tests/Main.hs | 152 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 181 insertions(+)

diff --git a/deepseq.cabal b/deepseq.cabal
index 261b01d..2e4aff6 100644
--- a/deepseq.cabal
+++ b/deepseq.cabal
@@ -56,3 +56,32 @@ library
   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
index 0000000..5199a17
--- /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]