diff --git a/SDL/Compositor/TTF.hs b/SDL/Compositor/TTF.hs deleted file mode 100644 --- a/SDL/Compositor/TTF.hs +++ /dev/null @@ -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 diff --git a/SDL/Data/Cache.hs b/SDL/Data/Cache.hs --- a/SDL/Data/Cache.hs +++ b/SDL/Data/Cache.hs @@ -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 diff --git a/dist/build/unittestsStub/unittestsStub-tmp/unittestsStub.hs b/dist/build/unittestsStub/unittestsStub-tmp/unittestsStub.hs new file mode 100644 --- /dev/null +++ b/dist/build/unittestsStub/unittestsStub-tmp/unittestsStub.hs @@ -0,0 +1,5 @@ +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.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 diff --git a/tests/Cache.hs b/tests/Cache.hs new file mode 100644 --- /dev/null +++ b/tests/Cache.hs @@ -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)