{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RoleAnnotations #-} module MiniLight.Light ( HasLightEnv (..), LightT (..), LightEnv (..), MiniLight, liftMiniLight, envLightT, mapLightT, HasLoopEnv (..), FontDescriptor(..), FontStyle(..), loadFontCache, loadFont, withFont, -- * Re-exports MonadIO(..), ) where import Control.Monad.IO.Class 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 Lens.Micro import Lens.Micro.Mtl import MiniLight.Event import qualified SDL import qualified SDL.Font type FontMap = HM.HashMap FontDescriptor FilePath instance Hashable FontDescriptor where hashWithSalt n fd = let style = _descriptorStyle fd in hashWithSalt n (_descriptorFamilyName fd, _fontStyleBold style, _fontStyleItalic style) class HasLightEnv env where rendererL :: Lens' env SDL.Renderer fontCacheL :: Lens' env FontMap 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' data LightEnv = LightEnv { renderer :: SDL.Renderer , fontCache :: FontMap } instance HasLightEnv LightEnv where rendererL = lens renderer (\env r -> env { renderer = r }) fontCacheL = lens fontCache (\env r -> env { fontCache = r }) type MiniLight = LightT LightEnv IO liftMiniLight :: (HasLightEnv env, MonadIO m) => MiniLight a -> LightT env m a liftMiniLight m = do renderer <- view rendererL fontCache <- view fontCacheL LightT $ ReaderT $ \_ -> liftIO $ runReaderT (runLightT' m) (LightEnv {renderer = renderer, fontCache = fontCache}) {-# 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 #-} class HasLoopEnv env where -- | Contains the number of frames that a specific keys are continuously pressing. keyStatesL :: Lens' env (HM.HashMap SDL.Scancode Int) -- | Occurred events since the last frame. eventsL :: Lens' env (IORef [Event]) -- | A queue storing the events occurred in this frame. signalQueueL :: Lens' env (IORef [Event]) 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 fontCacheL 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