{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE UndecidableInstances #-}
module MiniLight.Light (
HasLightEnv (..),
LightT (..),
LightEnv (..),
MiniLight,
liftMiniLight,
envLightT,
mapLightT,
HasLoopEnv (..),
LoopEnv (..),
FontDescriptor(..),
FontStyle(..),
loadFontCache,
loadFont,
withFont,
MonadIO(..),
) where
import Control.Concurrent.MVar
import Control.Lens
import Control.Monad.IO.Class
import qualified Control.Monad.Caster as Caster
import Control.Monad.Catch
import Control.Monad.Reader
import Data.Hashable (Hashable(..))
import qualified Data.HashMap.Strict as HM
import Data.IORef
import Graphics.Text.TrueType
import MiniLight.Event
import qualified SDL
import qualified SDL.Font
instance Hashable FontDescriptor where
hashWithSalt n fd = let style = _descriptorStyle fd in hashWithSalt n (_descriptorFamilyName fd, _fontStyleBold style, _fontStyleItalic style)
type FontMap = HM.HashMap FontDescriptor FilePath
data LightEnv = LightEnv
{ renderer :: SDL.Renderer
, fontCache :: FontMap
, logger :: Caster.LogQueue
}
makeClassy_ ''LightEnv
data LoopEnv = LoopEnv
{ keyStates :: HM.HashMap SDL.Scancode Int
, events :: MVar [Event]
, signalQueue :: IORef [Event]
}
makeClassy_ ''LoopEnv
newtype LightT env m a = LightT { runLightT' :: ReaderT env m a }
deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadMask, MonadCatch)
instance Monad m => MonadReader env (LightT env m) where
ask = LightT ask
local f = LightT . local f . runLightT'
instance (Monad m, HasLightEnv env) => Caster.MonadLogger (LightT env m) where
getLogger = view _logger
type MiniLight = LightT LightEnv IO
liftMiniLight :: (HasLightEnv env, MonadIO m) => MiniLight a -> LightT env m a
liftMiniLight m = do
env <- view lightEnv
LightT $ ReaderT $ \_ -> liftIO $ runReaderT (runLightT' m) env
{-# INLINE liftMiniLight #-}
envLightT :: (env' -> env) -> LightT env m a -> LightT env' m a
envLightT f m = LightT $ ReaderT $ runReaderT (runLightT' m) . f
{-# INLINE envLightT #-}
mapLightT :: (m a -> n a) -> LightT env m a -> LightT env n a
mapLightT f m = LightT $ ReaderT $ f . runReaderT (runLightT' m)
{-# INLINE mapLightT #-}
loadFontCache :: MonadIO m => m FontMap
loadFontCache = do
fc <- liftIO buildCache
return $ foldl
( \fm fd -> HM.insert
fd
(maybe (error $ "Font not found: " ++ show fd) id (findFontInCache fc fd))
fm
)
HM.empty
(enumerateFonts fc)
loadFont
:: (HasLightEnv env, MonadIO m)
=> FontDescriptor
-> Int
-> LightT env m SDL.Font.Font
loadFont fd size = do
fc <- view _fontCache
let path = fc HM.! fd
SDL.Font.load path size
withFont
:: (HasLightEnv env, MonadIO m, MonadMask m)
=> FontDescriptor
-> Int
-> (SDL.Font.Font -> LightT env m a)
-> LightT env m a
withFont fd n = bracket (loadFont fd n) SDL.Font.free