aztecs-sdl-text 0.4.0 → 0.6.0
raw patch · 2 files changed
+76/−45 lines, 2 filesdep ~aztecsdep ~aztecs-sdldep ~base
Dependency ranges changed: aztecs, aztecs-sdl, base
Files
- aztecs-sdl-text.cabal +4/−4
- src/Aztecs/SDL/Text.hs +72/−41
aztecs-sdl-text.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: aztecs-sdl-text-version: 0.4.0+version: 0.6.0 license: BSD-3-Clause license-file: LICENSE maintainer: matt@hunzinger.me@@ -25,9 +25,9 @@ default-language: Haskell2010 ghc-options: -Wall build-depends:- base >=4.6 && <5,- aztecs >= 0.7 && <0.8,- aztecs-sdl >= 0.4 && <0.5,+ base >=4 && <5,+ aztecs >= 0.9 && <0.10,+ aztecs-sdl >= 0.6 && <0.7, containers >=0.6, deepseq >=1, mtl >=2,
src/Aztecs/SDL/Text.hs view
@@ -3,15 +3,19 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-} +-- |+-- Module : Aztecs.SDL.Text+-- Copyright : (c) Matt Hunzinger, 2025+-- License : BSD-style (see the LICENSE file in the distribution)+--+-- Maintainer : matt@hunzinger.me+-- Stability : provisional+-- Portability : non-portable (GHC extensions) module Aztecs.SDL.Text ( Font (..), Text (..),@@ -29,73 +33,100 @@ import qualified Aztecs.ECS.Query as Q import qualified Aztecs.ECS.System as S import Aztecs.SDL (Surface (..))-import Control.Arrow (returnA, (>>>))+import Control.Arrow import Control.DeepSeq import Control.Monad.IO.Class-import Data.Maybe (mapMaybe)+import Data.Maybe import qualified Data.Text as T-import GHC.Generics (Generic)+import GHC.Generics import SDL hiding (Surface, Texture, Window, windowTitle) import qualified SDL.Font as F -#if !MIN_VERSION_base(4,20,0)-import Data.Foldable (foldl')-#endif--newtype Font = Font {unFont :: F.Font}+-- | Font asset.+--+-- @since 0.6+newtype Font = Font+ { -- | Unwrap the raw SDL font.+ --+ -- @since 0.6+ unFont :: F.Font+ } deriving (Eq, Show) +-- | @since 0.6 instance Asset Font where type AssetConfig Font = Int loadAsset fp size = Font <$> F.load fp size -data Text = Text {textContent :: !T.Text, textFont :: !(Handle Font)}+-- | Text component.+--+-- @since 0.6+data Text = Text+ { -- | Text content.+ --+ -- @since 0.6+ textContent :: !T.Text,+ -- | Text font handle.+ --+ -- @since 0.6+ textFont :: !(Handle Font)+ } deriving (Eq, Show, Generic, NFData) +-- | @since 0.6 instance Component Text +-- | Draw text to a surface.+--+-- @since 0.6 drawText :: T.Text -> Font -> IO Surface drawText content f = do !s <- F.solid (unFont f) (V4 255 255 255 255) content return Surface {sdlSurface = s, surfaceBounds = Nothing} -- | Setup SDL TrueType-Font (TTF) support.-setup :: (MonadIO m) => Schedule m () ()-setup = system (Asset.setup @Font) >>> access (const F.initialize)+--+-- @since 0.6+setup :: (MonadAccess b m, MonadIO m) => m ()+setup = do+ liftIO F.initialize+ Asset.setup @_ @_ @Font -- | Load font assets.-load :: (MonadIO m) => Schedule m () ()+--+-- @since 0.6+load :: (MonadIO m, ArrowQuery m q, MonadSystem q s) => s () load = Asset.loadAssets @Font -- | Draw text components.-draw :: (MonadIO m) => Schedule m () ()-draw = proc () -> do+--+-- @since 0.6+draw :: (ArrowDynamicQueryReader qr, ArrowQueryReader qr, MonadReaderSystem qr s, MonadIO s, MonadAccess b ma) => s (ma ())+draw = do !texts <-- reader $- S.all- ( proc () -> do- e <- Q.entity -< ()- t <- Q.fetch -< ()- s <- Q.fetchMaybe -< ()- returnA -< (e, t, s)- )- -<- ()- !assetServer <- reader $ S.single Q.fetch -< ()+ S.all+ ()+ ( proc () -> do+ e <- Q.entity -< ()+ t <- Q.fetch -< ()+ s <- Q.fetchMaybe -< ()+ returnA -< (e, t, s)+ )++ !assetServer <- S.single () Q.fetch let !textFonts = mapMaybe (\(eId, t, maybeSurface) -> (eId,textContent t,maybeSurface,) <$> lookupAsset (textFont t) assetServer) texts !draws <-- access $- mapM- ( \(eId, content, maybeSurface, font) -> do- case maybeSurface of- Just lastSurface -> freeSurface $ sdlSurface lastSurface- Nothing -> return ()- surface <- liftIO $ drawText content font- return (eId, surface)- )- -<- textFonts- access . mapM_ $ uncurry A.insert -< draws+ mapM+ ( \(eId, content, maybeSurface, font) -> do+ case maybeSurface of+ Just lastSurface -> freeSurface $ sdlSurface lastSurface+ Nothing -> return ()+ surface <- liftIO $ drawText content font+ return (eId, surface)+ )+ textFonts+ let go (eId, surface) = A.insert eId $ bundle surface+ return $ mapM_ go draws