sdl2-compositor 1.2.0.4 → 1.2.0.5
raw patch · 5 files changed
+84/−112 lines, 5 filesdep +Cabaldep +hspecdep +hspec-coredep ~basedep ~sdl2-ttf
Dependencies added: Cabal, hspec, hspec-core, sdl2-compositor
Dependency ranges changed: base, sdl2-ttf
Files
- SDL/Compositor/TTF.hs +0/−79
- SDL/Data/Cache.hs +13/−30
- dist/build/unittestsStub/unittestsStub-tmp/unittestsStub.hs +5/−0
- sdl2-compositor.cabal +9/−3
- tests/Cache.hs +57/−0
− SDL/Compositor/TTF.hs
@@ -1,79 +0,0 @@-module SDL.Compositor.TTF- ( -- * Interface- FontSupport(..)- , Alignment(..)- -- * Texture generation- , ColorWrapper(..)- , FontKey(..)- , defaultFontKey- , textureFromKey- )-where--import Control.Monad-import Data.Text-import SDL.TTF-import SDL.TTF.FFI (TTFFont)-import SDL.TTF.Types-import SDL-import SDL.Raw.Types (Color(..))--import SDL.Data.Cache--data Alignment = AlignTopLeft | AlignTopRight | AlignTopCenter- | AlignLeft | AlignRight | AlignCenter- | AlignBottomLeft | AlignBottomRight | AlignBottomCenter- deriving (Eq,Read,Show)--newtype ColorWrapper = ColorWrapper Color deriving Eq--instance Ord ColorWrapper where- compare (ColorWrapper (Color r1 g1 b1 a1))- (ColorWrapper (Color r2 g2 b2 a2)) =- compare (r1,g1,b1,a1) (r2,g2,b2,a2)--data FontKey = FontKey { fkStyle :: TTFStyle- , fkFont :: TTFFont- , fkHinting :: TTFHinting- , fkKerning :: Bool- , fkMessage :: Text- , fkColor :: ColorWrapper- }- deriving (Eq,Ord)--defaultFontKey :: TTFFont -> FontKey-defaultFontKey font =- FontKey { fkStyle = TTFNormal- , fkFont = font- , fkHinting = TTFHNormal- , fkKerning = True- , fkMessage = pack ""- , fkColor = ColorWrapper (Color 255 255 255 255)- }--class FontSupport c where- withFontStyle :: TTFStyle -> c a -> c a- withFont :: TTFFont -> c a -> c a- withFontHint :: TTFHinting -> c a -> c a- showText :: Alignment -> Color -> Text -> c a- withKerning :: Bool -> c a -> c a- withFontCache :: (Cacheable a) => Cache FontKey a -> c a -> c a--textureFromKey :: Renderer -> FontKey -> IO Texture-textureFromKey rend (FontKey style font- hints kerning msg (ColorWrapper color)) = do- oldStyle <- getFontStyle font- oldHinting <- getFontHinting font- let changeStyle = oldStyle /= style- changeHinting = oldHinting /= hints- when changeStyle $ setFontStyle font style- when changeHinting $ setFontHinting font hints- if kerning- then setFontKerning font KerningOn- else setFontKerning font KerningOff- surf <- renderUTF8Solid font (unpack msg) color- tex <- createTextureFromSurface rend surf- freeSurface surf- when changeStyle $ setFontStyle font oldStyle- when changeHinting $ setFontHinting font oldHinting- return tex
SDL/Data/Cache.hs view
@@ -15,7 +15,9 @@ import Control.Concurrent.STM.TMVar (TMVar,newTMVar,tryReadTMVar,tryTakeTMVar,putTMVar) import Control.Monad.STM (atomically)-import Data.Cache.LRU (LRU,newLRU,insert,insertInforming,lookup)+import Data.Cache.LRU (insertInforming, newLRU, maxSize, toList)+import Data.Cache.LRU.IO (newAtomicLRU,insert,lookup)+import Data.Cache.LRU.IO.Internal (AtomicLRU(C),modifyMVar') import Prelude hiding (lookup) import qualified SDL as SDL (Texture, destroyTexture, Surface,freeSurface) import qualified SDL.Raw as Raw@@ -47,45 +49,25 @@ releaseResource = mapM_ releaseResource -- | Thread safe LRU cache.-data Cache k a = Cache (TMVar (LRU k a)) Int+newtype Cache k a = Cache (AtomicLRU k a) -- | Create a new cache instance. newCache :: (Ord k) => Int -- ^ the size of the cache to be created (in elements) -> IO (Cache k a) newCache s = Cache <$>- atomically (newTMVar (newLRU (Just (fromIntegral s)))) <*>- pure s+ newAtomicLRU (Just . fromIntegral $ s) putInCache :: (Ord k, Cacheable r) => Cache k r -> k -> IO r -> IO r-putInCache (Cache var s) key action = do+putInCache (Cache (C c)) key action = do newResource <- action- mOldResource <- atomically $ do- mlru <- tryReadTMVar var- case mlru of- Nothing -> do- let lru = newLRU (Just $ fromIntegral s)- putTMVar var (insert key newResource lru)- return Nothing- Just lru -> do- let (newLru,mOld) = insertInforming key newResource lru- putTMVar var newLru- return mOld+ mOldResource <- modifyMVar' c (return . insertInforming key newResource) mapM_ (releaseResource.snd) mOldResource pure newResource lookupFromCache :: (Ord k) => Cache k r -> k -> IO (Maybe r)-lookupFromCache (Cache var s) key =- atomically $ do- mLru <- tryTakeTMVar var- case mLru of- Nothing -> do- putTMVar var (newLRU (Just $ fromIntegral s))- return Nothing- Just lru -> do- let (newLru,mVal) = lookup key lru- putTMVar var newLru- return mVal+lookupFromCache (Cache var) key =+ lookup key var -- | Check if a certain element is already cached. If not execute the -- action the generate this element.@@ -103,6 +85,7 @@ -- | Invalidate every element in the cache and release the resources -- accordingly. emptyCache :: (Cacheable r, Ord k) => Cache k r -> IO ()-emptyCache (Cache var _) = do- mlru <- atomically $ tryTakeTMVar var- mapM_ (mapM_ releaseResource) mlru+emptyCache (Cache (C c)) = do+ res <- modifyMVar' c $ \ lru ->+ return (newLRU (maxSize lru), map snd . toList $ lru)+ mapM_ releaseResource res
+ dist/build/unittestsStub/unittestsStub-tmp/unittestsStub.hs view
@@ -0,0 +1,5 @@+module Main ( main ) where+import Distribution.Simple.Test.LibV09 ( stubMain )+import Cache ( tests )+main :: IO ()+main = stubMain tests
sdl2-compositor.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: sdl2-compositor-version: 1.2.0.4+version: 1.2.0.5 synopsis: image compositing with sdl2 - declarative style description: This package provides tools for simple image composition@@ -32,7 +32,6 @@ SDL.Compositor.Blender, SDL.Compositor.Drawer, SDL.Compositor.ResIndependent,- SDL.Compositor.TTF, SDL.Data.Texture, SDL.Data.Cache -- other-modules:@@ -41,7 +40,6 @@ sdl2 >= 2.0, transformers >= 0.4, linear >= 1.19,- sdl2-ttf >= 1, stm >= 2.3, lrucache >= 1.2, text,@@ -72,3 +70,11 @@ source-repository head type: darcs location: http://hub.darcs.net/seppeljordan/sdl2-compositor++test-suite unittests+ type: detailed-0.9+ test-module: Cache+ hs-source-dirs: tests+ build-depends: base, QuickCheck, hspec, hspec-core,+ Cabal, sdl2-compositor+ default-language: Haskell2010
+ tests/Cache.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Cache where++import Distribution.TestSuite as TestSuite+import Test.Hspec as Hspec+import Test.Hspec.Core.Runner+import Test.QuickCheck+import Test.QuickCheck.Monadic as QC++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)+ }++newtype CacheInteger = CacheInteger { fromCacheInteger :: Integer }+ deriving (Eq,Ord,Num,Arbitrary,Show)++instance Cacheable CacheInteger where+ releaseResource _ = return ()++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)