sdl2-compositor 1.2.0.5 → 1.2.0.6

raw patch · 6 files changed

+72/−63 lines, 6 filesdep ~lrucachedep ~stmPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: lrucache, stm

API changes (from Hackage documentation)

Files

• SDL/Compositor.hs +3/−7
• SDL/Data/Cache.hs +7/−7
• SDL/Data/Texture.hs +1/−4
• dist/build/unittestsStub/unittestsStub-tmp/unittestsStub.hs +0/−5
• sdl2-compositor.cabal +4/−4
• tests/Cache.hs +57/−36

@@ -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)

@@ -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

@@ -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

@@ -1,5 +0,0 @@-module Main ( main ) where-import Distribution.Simple.Test.LibV09 ( stubMain )-import Cache ( tests )-main :: IO ()-main = stubMain tests

@@ -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

@@ -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+      )