sdl2-compositor 1.2 → 1.2.0.1
raw patch · 4 files changed
+203/−3 lines, 4 filesdep ~basePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base
API changes (from Hackage documentation)
Files
- SDL/Compositor/TTF.hs +80/−0
- SDL/Data/Cache.hs +73/−0
- SDL/Data/Texture.hs +44/−0
- sdl2-compositor.cabal +6/−3
+ SDL/Compositor/TTF.hs view
@@ -0,0 +1,80 @@+module SDL.Compositor.TTF+ ( -- * Interface+ FontSupport(..)+ , Alignment(..)+ -- * Texture generation+ , ColorWrapper(..)+ , FontKey(..)+ , defaultFontKey+ , textureFromKey+ )+where++import Control.Monad+import Data.Text+import Graphics.UI.SDL.TTF+import Graphics.UI.SDL.TTF.FFI (TTFFont)+import Graphics.UI.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+ s <- renderUTF8Solid font (unpack msg) color+ let surf = Surface s Nothing+ tex <- createTextureFromSurface rend surf+ freeSurface surf+ when changeStyle $ setFontStyle font oldStyle+ when changeHinting $ setFontHinting font oldHinting+ return tex
+ SDL/Data/Cache.hs view
@@ -0,0 +1,73 @@+module SDL.Data.Cache+ (+ Cacheable (..)+ , Cache+ , newCache+ , throughCache+ , emptyCache+ )+where++import Control.Concurrent.STM.TMVar+import Control.Monad.STM+import Data.Cache.LRU+import Prelude hiding (lookup)+import SDL++class Cacheable r where+ releaseResource :: r -> IO ()++instance Cacheable Texture where+ releaseResource = destroyTexture++instance Cacheable Surface where+ releaseResource = freeSurface++data Cache k a = Cache (TMVar (LRU k a)) Int++newCache :: (Ord k) => Int -> IO (Cache k a)+newCache s = Cache <$>+ atomically (newTMVar (newLRU (Just (fromIntegral s)))) <*>+ pure s++putInCache :: (Ord k, Cacheable r) => Cache k r -> k -> IO r -> IO r+putInCache (Cache var s) 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+ 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++throughCache :: (Cacheable r, Ord k) => Cache k r -> k -> IO r -> IO r+throughCache cache key action = do+ mVal <- lookupFromCache cache key+ case mVal of+ Nothing -> putInCache cache key action+ Just val -> return val++emptyCache :: (Cacheable r, Ord k) => Cache k r -> IO ()+emptyCache (Cache var _) = do+ mlru <- atomically $ tryTakeTMVar var+ mapM_ (mapM_ releaseResource) mlru
+ SDL/Data/Texture.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module SDL.Data.Texture+ ( Renderable(..)+ , Texture(..)+ )+ where++import qualified SDL+import Control.Monad (void)+import Linear.V2 (V2(..))+import Linear.Affine (Point(..))+import Linear.V3 (V3)+import Foreign.C (CDouble(..))+import Data.StateVar (StateVar)+import Data.Word (Word8)++-- | This class modells that something can be rendered to another+-- thing.+class Renderable rend tex where+ copyEx :: rend -- ^ rendering context+ -> tex -- ^ texture+ -> Maybe (SDL.Rectangle Int) -- ^ source rectangle+ -> Maybe (SDL.Rectangle Int) -- ^ destination rectangle+ -> Double -- ^ rotation+ -> Maybe (Point V2 Int) -- ^ rotation center+ -> V2 Bool -- ^ flipping+ -> IO ()++instance Renderable SDL.Renderer SDL.Texture where+ 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++class Texture tex where+ textureAlphaMod :: tex -> StateVar Word8+ textureColorMod :: tex -> StateVar (V3 Word8)+ textureBlendMode :: tex -> StateVar SDL.BlendMode++instance Texture SDL.Texture where+ textureAlphaMod = SDL.textureAlphaMod+ textureColorMod = SDL.textureColorMod+ textureBlendMode = SDL.textureBlendMode
sdl2-compositor.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: sdl2-compositor-version: 1.2+version: 1.2.0.1 synopsis: image compositing with sdl2 - declarative style description: This package provides tools for simple image composition@@ -30,8 +30,11 @@ exposed-modules: SDL.Compositor, SDL.Compositor.Manipulator, SDL.Compositor.Blender,- SDL.Compositor.Drawer- SDL.Compositor.ResIndependent+ SDL.Compositor.Drawer,+ SDL.Compositor.ResIndependent,+ SDL.Compositor.TTF,+ SDL.Data.Texture,+ SDL.Data.Cache -- other-modules: -- other-extensions: build-depends: base >=4.8 && <4.9,