diff --git a/SDL/Compositor.hs b/SDL/Compositor.hs --- a/SDL/Compositor.hs +++ b/SDL/Compositor.hs @@ -207,7 +207,8 @@ bm = lens _blendMode (\st b -> st{_blendMode=b}) -- | Render a composed image. -runRenderer :: forall tex rend . (Texture tex, Renderer rend, Renderable rend tex) => +runRenderer :: forall tex rend . + (Texture tex, Renderer rend, Renderable rend tex) => rend -> CompositingNode tex -> IO () runRenderer target node = do currentDrawColor <- SDL.get (rendererDrawColor target) @@ -265,12 +266,10 @@ tex <- createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fromIntegral <$> dims) rendererRenderTarget rend $= Just tex rendererDrawColor rend $= V4 0 0 0 0 - clear rend rendererDrawColor rend $= fromIntegral <$> colors drawRect rend (Just (SDL.Rectangle 0 (fromIntegral <$> dims))) present rend rendererRenderTarget rend $= oldTarget - -- render created texture renderNode env (Sized dims tex) destroyTexture tex renderNode env (Line dims colors) = do @@ -286,15 +285,13 @@ (dims*flippingVector) rendererRenderTarget rend $= Just tex rendererDrawColor rend $= V4 0 0 0 0 - clear rend rendererDrawColor rend $= fromIntegral <$> colors drawLine rend 0 (P $ fromIntegral <$> dims) - present rend rendererRenderTarget rend $= oldTarget -- render created texture renderNode env (Sized dims tex) destroyTexture tex -renderNode env(FilledRectangle dims colors) = do +renderNode env (FilledRectangle dims colors) = do let rend = view renderTarget env -- get old values oldTarget <- get $ rendererRenderTarget rend :: IO (Maybe tex) @@ -303,7 +300,6 @@ tex <- createTexture rend SDL.RGBA8888 SDL.TextureAccessTarget (fromIntegral <$> dims) rendererRenderTarget rend $= Just tex clear rend - present rend rendererRenderTarget rend $= oldTarget -- render created texture renderNode env (Sized dims tex) diff --git a/SDL/Data/Cache.hs b/SDL/Data/Cache.hs --- a/SDL/Data/Cache.hs +++ b/SDL/Data/Cache.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} + -- | This module provides a simple caching implementation based on the -- LRU caching strategy. The cache is implemented via software -- transactional memory, which means that you can use the cache from @@ -12,11 +14,8 @@ ) where -import Control.Concurrent.STM.TMVar - (TMVar,newTMVar,tryReadTMVar,tryTakeTMVar,putTMVar) -import Control.Monad.STM (atomically) import Data.Cache.LRU (insertInforming, newLRU, maxSize, toList) -import Data.Cache.LRU.IO (newAtomicLRU,insert,lookup) +import Data.Cache.LRU.IO (newAtomicLRU,lookup) import Data.Cache.LRU.IO.Internal (AtomicLRU(C),modifyMVar') import Prelude hiding (lookup) import qualified SDL as SDL (Texture, destroyTexture, Surface,freeSurface) @@ -58,7 +57,8 @@ newCache s = Cache <$> newAtomicLRU (Just . fromIntegral $ s) -putInCache :: (Ord k, Cacheable r) => Cache k r -> k -> IO r -> IO r +putInCache :: forall k r . + (Ord k, Cacheable r) => Cache k r -> k -> IO r -> IO r putInCache (Cache (C c)) key action = do newResource <- action mOldResource <- modifyMVar' c (return . insertInforming key newResource) @@ -74,7 +74,7 @@ throughCache :: (Cacheable r, Ord k) => Cache k r -- ^ cache instance -> k -- ^ cache key - -> IO r -- ^ action to generate the rsource + -> IO r -- ^ action to generate the resource -> IO r throughCache cache key action = do mVal <- lookupFromCache cache key @@ -87,5 +87,5 @@ emptyCache :: (Cacheable r, Ord k) => Cache k r -> IO () emptyCache (Cache (C c)) = do res <- modifyMVar' c $ \ lru -> - return (newLRU (maxSize lru), map snd . toList $ lru) + return (newLRU (maxSize lru), map snd . Data.Cache.LRU.toList $ lru) mapM_ releaseResource res diff --git a/SDL/Data/Texture.hs b/SDL/Data/Texture.hs --- a/SDL/Data/Texture.hs +++ b/SDL/Data/Texture.hs @@ -14,8 +14,6 @@ import Data.StateVar (StateVar, makeStateVar) import Data.Word (Word8,Word32) import Foreign.C (CDouble(..),CInt) -import Foreign.C.String -import Foreign.ForeignPtr import Foreign.Marshal.Alloc (malloc, free) import Foreign.Marshal.Utils (with, maybeWith) import Foreign.Ptr (Ptr, nullPtr) @@ -47,8 +45,7 @@ rendererRenderTarget :: rend -> StateVar (Maybe tex) instance Renderable SDL.Renderer SDL.Texture where - copyEx rend tex sourceRect destRect rot center flipping = - void $ + copyEx rend tex sourceRect destRect rot center flipping = void $ SDL.copyEx rend tex (fmap fromIntegral <$> sourceRect) (fmap fromIntegral <$> destRect) (CDouble rot) (fmap fromIntegral <$> center) flipping diff --git a/dist/build/unittestsStub/unittestsStub-tmp/unittestsStub.hs b/dist/build/unittestsStub/unittestsStub-tmp/unittestsStub.hs deleted file mode 100644 --- a/dist/build/unittestsStub/unittestsStub-tmp/unittestsStub.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main ( main ) where -import Distribution.Simple.Test.LibV09 ( stubMain ) -import Cache ( tests ) -main :: IO () -main = stubMain tests diff --git a/sdl2-compositor.cabal b/sdl2-compositor.cabal --- a/sdl2-compositor.cabal +++ b/sdl2-compositor.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: sdl2-compositor -version: 1.2.0.5 +version: 1.2.0.6 synopsis: image compositing with sdl2 - declarative style description: This package provides tools for simple image composition @@ -72,9 +72,9 @@ location: http://hub.darcs.net/seppeljordan/sdl2-compositor test-suite unittests - type: detailed-0.9 - test-module: Cache + type: exitcode-stdio-1.0 + main-is: Cache.hs hs-source-dirs: tests build-depends: base, QuickCheck, hspec, hspec-core, - Cabal, sdl2-compositor + Cabal, sdl2-compositor, stm, lrucache default-language: Haskell2010 diff --git a/tests/Cache.hs b/tests/Cache.hs --- a/tests/Cache.hs +++ b/tests/Cache.hs @@ -1,8 +1,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} -module Cache where +module Main where +import Data.Cache.LRU +import Control.Concurrent.STM import Distribution.TestSuite as TestSuite import Test.Hspec as Hspec import Test.Hspec.Core.Runner @@ -11,32 +14,8 @@ import SDL.Data.Cache -tests :: IO [Test] -tests = return . map (uncurry hspecToTest) $ - [ (functionTest,"cache functional tests") ] - -hspecToTest :: Spec -> String -> Test -hspecToTest s = Test . hspecToTestInstance s - -hspecToTestInstance :: Spec -> String -> TestInstance -hspecToTestInstance tests name = - progressToTestInstance name . - fmap (Finished . summaryToResult) $ - hspecResult tests - where - summaryToResult summary - | fails == 0 = Pass - | otherwise = Fail $ show fails ++ "of " ++ show runs ++ " FAILED." - where fails = summaryFailures summary - runs = summaryExamples summary - progressToTestInstance n progressAction = - TestInstance { TestSuite.run = progressAction - , name = n - , tags = [] - , options = [] - , setOption = (const . const) - (Right $ hspecToTestInstance tests name) - } +main :: IO () +main = hspec functionTest newtype CacheInteger = CacheInteger { fromCacheInteger :: Integer } deriving (Eq,Ord,Num,Arbitrary,Show) @@ -44,14 +23,56 @@ instance Cacheable CacheInteger where releaseResource _ = return () +data StatefulBool a = StatefulBool { fromStatefulBool :: TVar Bool + , sbVal :: a + } + +instance Cacheable (StatefulBool a) where + releaseResource b = atomically $ writeTVar (fromStatefulBool b) True + +isReleased :: StatefulBool a -> IO Bool +isReleased b = atomically $ readTVar (fromStatefulBool b) + +newStatefulBool :: a -> IO (StatefulBool a) +newStatefulBool x = StatefulBool <$> (atomically $ newTVar False) <*> pure x + functionTest :: Spec functionTest = - describe "SDL.Data.Cache.Cache" $ - it "produces the same result as without the Cache" $ - property $ \ (n :: CacheInteger) -> - monadicIO $ QC.run $ do - let calc x = return (2*x) - res <- calc n - cache <- newCache 1 - resCached <- throughCache cache n (calc n) - return (res == resCached) + describe "Data.Cache.LRU" $ do + it "drops the least recently added item" $ do + property $ \ (Positive (cacheSize :: Int)) -> + snd $ + foldl + (\ (lru,ok) n -> + if not ok + then (lru, False) + else case insertInforming n n lru of + (lru', Nothing) -> (lru', True) + (lru', Just (m,_)) -> + if m == n - cacheSize + then (lru', True) + else (lru', False) + ) + (newLRU (Just (fromIntegral cacheSize)), True) + [1..cacheSize * 2] + + describe "SDL.Data.Cache.Cache" $ do + it "produces the same result as without the Cache" $ + property $ \ (n :: CacheInteger) -> + monadicIO $ assert =<< QC.run + (do let calc x = return (2*x) + res <- calc n + cache <- newCache 1 + resCached <- throughCache cache n (calc n) + return (res == resCached) + ) + it "releases all resources when emptying the cache" $ + property $ \ (Positive (cacheSize :: Int)) (Positive (differentElements :: Int)) -> + monadicIO $ assert =<< QC.run + (do cache <- newCache cacheSize + bs <- mapM + (\n -> throughCache cache n (newStatefulBool n)) + [1..differentElements] + emptyCache cache + and <$> mapM isReleased bs + )