{-# 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 :: Int -> FontDescriptor -> Int
hashWithSalt n :: Int
n fd :: FontDescriptor
fd = let style :: FontStyle
style = FontDescriptor -> FontStyle
_descriptorStyle FontDescriptor
fd in Int -> (Text, Bool, Bool) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
n (FontDescriptor -> Text
_descriptorFamilyName FontDescriptor
fd, FontStyle -> Bool
_fontStyleBold FontStyle
style, FontStyle -> Bool
_fontStyleItalic FontStyle
style)
type FontMap = HM.HashMap FontDescriptor FilePath
data LightEnv = LightEnv
{ LightEnv -> Maybe Renderer
renderer :: Maybe SDL.Renderer
, LightEnv -> FontMap
fontCache :: FontMap
, LightEnv -> LogQueue
logger :: Caster.LogQueue
}
makeClassy_ ''LightEnv
data LoopEnv = LoopEnv
{ LoopEnv -> HashMap Scancode Int
keyStates :: HM.HashMap SDL.Scancode Int
, LoopEnv -> MVar [Event]
events :: MVar [Event]
, LoopEnv -> IORef [Event]
signalQueue :: IORef [Event]
}
makeClassy_ ''LoopEnv
newtype LightT env m a = LightT { LightT env m a -> ReaderT env m a
runLightT' :: ReaderT env m a }
deriving (a -> LightT env m b -> LightT env m a
(a -> b) -> LightT env m a -> LightT env m b
(forall a b. (a -> b) -> LightT env m a -> LightT env m b)
-> (forall a b. a -> LightT env m b -> LightT env m a)
-> Functor (LightT env m)
forall a b. a -> LightT env m b -> LightT env m a
forall a b. (a -> b) -> LightT env m a -> LightT env m b
forall env (m :: * -> *) a b.
Functor m =>
a -> LightT env m b -> LightT env m a
forall env (m :: * -> *) a b.
Functor m =>
(a -> b) -> LightT env m a -> LightT env m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> LightT env m b -> LightT env m a
$c<$ :: forall env (m :: * -> *) a b.
Functor m =>
a -> LightT env m b -> LightT env m a
fmap :: (a -> b) -> LightT env m a -> LightT env m b
$cfmap :: forall env (m :: * -> *) a b.
Functor m =>
(a -> b) -> LightT env m a -> LightT env m b
Functor, Functor (LightT env m)
a -> LightT env m a
Functor (LightT env m) =>
(forall a. a -> LightT env m a)
-> (forall a b.
LightT env m (a -> b) -> LightT env m a -> LightT env m b)
-> (forall a b c.
(a -> b -> c)
-> LightT env m a -> LightT env m b -> LightT env m c)
-> (forall a b. LightT env m a -> LightT env m b -> LightT env m b)
-> (forall a b. LightT env m a -> LightT env m b -> LightT env m a)
-> Applicative (LightT env m)
LightT env m a -> LightT env m b -> LightT env m b
LightT env m a -> LightT env m b -> LightT env m a
LightT env m (a -> b) -> LightT env m a -> LightT env m b
(a -> b -> c) -> LightT env m a -> LightT env m b -> LightT env m c
forall a. a -> LightT env m a
forall a b. LightT env m a -> LightT env m b -> LightT env m a
forall a b. LightT env m a -> LightT env m b -> LightT env m b
forall a b.
LightT env m (a -> b) -> LightT env m a -> LightT env m b
forall a b c.
(a -> b -> c) -> LightT env m a -> LightT env m b -> LightT env m c
forall env (m :: * -> *). Applicative m => Functor (LightT env m)
forall env (m :: * -> *) a. Applicative m => a -> LightT env m a
forall env (m :: * -> *) a b.
Applicative m =>
LightT env m a -> LightT env m b -> LightT env m a
forall env (m :: * -> *) a b.
Applicative m =>
LightT env m a -> LightT env m b -> LightT env m b
forall env (m :: * -> *) a b.
Applicative m =>
LightT env m (a -> b) -> LightT env m a -> LightT env m b
forall env (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> LightT env m a -> LightT env m b -> LightT env m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: LightT env m a -> LightT env m b -> LightT env m a
$c<* :: forall env (m :: * -> *) a b.
Applicative m =>
LightT env m a -> LightT env m b -> LightT env m a
*> :: LightT env m a -> LightT env m b -> LightT env m b
$c*> :: forall env (m :: * -> *) a b.
Applicative m =>
LightT env m a -> LightT env m b -> LightT env m b
liftA2 :: (a -> b -> c) -> LightT env m a -> LightT env m b -> LightT env m c
$cliftA2 :: forall env (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> LightT env m a -> LightT env m b -> LightT env m c
<*> :: LightT env m (a -> b) -> LightT env m a -> LightT env m b
$c<*> :: forall env (m :: * -> *) a b.
Applicative m =>
LightT env m (a -> b) -> LightT env m a -> LightT env m b
pure :: a -> LightT env m a
$cpure :: forall env (m :: * -> *) a. Applicative m => a -> LightT env m a
$cp1Applicative :: forall env (m :: * -> *). Applicative m => Functor (LightT env m)
Applicative, Applicative (LightT env m)
a -> LightT env m a
Applicative (LightT env m) =>
(forall a b.
LightT env m a -> (a -> LightT env m b) -> LightT env m b)
-> (forall a b. LightT env m a -> LightT env m b -> LightT env m b)
-> (forall a. a -> LightT env m a)
-> Monad (LightT env m)
LightT env m a -> (a -> LightT env m b) -> LightT env m b
LightT env m a -> LightT env m b -> LightT env m b
forall a. a -> LightT env m a
forall a b. LightT env m a -> LightT env m b -> LightT env m b
forall a b.
LightT env m a -> (a -> LightT env m b) -> LightT env m b
forall env (m :: * -> *). Monad m => Applicative (LightT env m)
forall env (m :: * -> *) a. Monad m => a -> LightT env m a
forall env (m :: * -> *) a b.
Monad m =>
LightT env m a -> LightT env m b -> LightT env m b
forall env (m :: * -> *) a b.
Monad m =>
LightT env m a -> (a -> LightT env m b) -> LightT env m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> LightT env m a
$creturn :: forall env (m :: * -> *) a. Monad m => a -> LightT env m a
>> :: LightT env m a -> LightT env m b -> LightT env m b
$c>> :: forall env (m :: * -> *) a b.
Monad m =>
LightT env m a -> LightT env m b -> LightT env m b
>>= :: LightT env m a -> (a -> LightT env m b) -> LightT env m b
$c>>= :: forall env (m :: * -> *) a b.
Monad m =>
LightT env m a -> (a -> LightT env m b) -> LightT env m b
$cp1Monad :: forall env (m :: * -> *). Monad m => Applicative (LightT env m)
Monad, Monad (LightT env m)
Monad (LightT env m) =>
(forall a. IO a -> LightT env m a) -> MonadIO (LightT env m)
IO a -> LightT env m a
forall a. IO a -> LightT env m a
forall env (m :: * -> *). MonadIO m => Monad (LightT env m)
forall env (m :: * -> *) a. MonadIO m => IO a -> LightT env m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> LightT env m a
$cliftIO :: forall env (m :: * -> *) a. MonadIO m => IO a -> LightT env m a
$cp1MonadIO :: forall env (m :: * -> *). MonadIO m => Monad (LightT env m)
MonadIO, Monad (LightT env m)
e -> LightT env m a
Monad (LightT env m) =>
(forall e a. Exception e => e -> LightT env m a)
-> MonadThrow (LightT env m)
forall e a. Exception e => e -> LightT env m a
forall env (m :: * -> *). MonadThrow m => Monad (LightT env m)
forall env (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> LightT env m a
forall (m :: * -> *).
Monad m =>
(forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: e -> LightT env m a
$cthrowM :: forall env (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> LightT env m a
$cp1MonadThrow :: forall env (m :: * -> *). MonadThrow m => Monad (LightT env m)
MonadThrow, MonadCatch (LightT env m)
MonadCatch (LightT env m) =>
(forall b.
((forall a. LightT env m a -> LightT env m a) -> LightT env m b)
-> LightT env m b)
-> (forall b.
((forall a. LightT env m a -> LightT env m a) -> LightT env m b)
-> LightT env m b)
-> (forall a b c.
LightT env m a
-> (a -> ExitCase b -> LightT env m c)
-> (a -> LightT env m b)
-> LightT env m (b, c))
-> MonadMask (LightT env m)
LightT env m a
-> (a -> ExitCase b -> LightT env m c)
-> (a -> LightT env m b)
-> LightT env m (b, c)
((forall a. LightT env m a -> LightT env m a) -> LightT env m b)
-> LightT env m b
((forall a. LightT env m a -> LightT env m a) -> LightT env m b)
-> LightT env m b
forall b.
((forall a. LightT env m a -> LightT env m a) -> LightT env m b)
-> LightT env m b
forall a b c.
LightT env m a
-> (a -> ExitCase b -> LightT env m c)
-> (a -> LightT env m b)
-> LightT env m (b, c)
forall env (m :: * -> *). MonadMask m => MonadCatch (LightT env m)
forall env (m :: * -> *) b.
MonadMask m =>
((forall a. LightT env m a -> LightT env m a) -> LightT env m b)
-> LightT env m b
forall env (m :: * -> *) a b c.
MonadMask m =>
LightT env m a
-> (a -> ExitCase b -> LightT env m c)
-> (a -> LightT env m b)
-> LightT env m (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: LightT env m a
-> (a -> ExitCase b -> LightT env m c)
-> (a -> LightT env m b)
-> LightT env m (b, c)
$cgeneralBracket :: forall env (m :: * -> *) a b c.
MonadMask m =>
LightT env m a
-> (a -> ExitCase b -> LightT env m c)
-> (a -> LightT env m b)
-> LightT env m (b, c)
uninterruptibleMask :: ((forall a. LightT env m a -> LightT env m a) -> LightT env m b)
-> LightT env m b
$cuninterruptibleMask :: forall env (m :: * -> *) b.
MonadMask m =>
((forall a. LightT env m a -> LightT env m a) -> LightT env m b)
-> LightT env m b
mask :: ((forall a. LightT env m a -> LightT env m a) -> LightT env m b)
-> LightT env m b
$cmask :: forall env (m :: * -> *) b.
MonadMask m =>
((forall a. LightT env m a -> LightT env m a) -> LightT env m b)
-> LightT env m b
$cp1MonadMask :: forall env (m :: * -> *). MonadMask m => MonadCatch (LightT env m)
MonadMask, MonadThrow (LightT env m)
MonadThrow (LightT env m) =>
(forall e a.
Exception e =>
LightT env m a -> (e -> LightT env m a) -> LightT env m a)
-> MonadCatch (LightT env m)
LightT env m a -> (e -> LightT env m a) -> LightT env m a
forall e a.
Exception e =>
LightT env m a -> (e -> LightT env m a) -> LightT env m a
forall env (m :: * -> *). MonadCatch m => MonadThrow (LightT env m)
forall env (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
LightT env m a -> (e -> LightT env m a) -> LightT env m a
forall (m :: * -> *).
MonadThrow m =>
(forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: LightT env m a -> (e -> LightT env m a) -> LightT env m a
$ccatch :: forall env (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
LightT env m a -> (e -> LightT env m a) -> LightT env m a
$cp1MonadCatch :: forall env (m :: * -> *). MonadCatch m => MonadThrow (LightT env m)
MonadCatch)
instance Monad m => MonadReader env (LightT env m) where
ask :: LightT env m env
ask = ReaderT env m env -> LightT env m env
forall env (m :: * -> *) a. ReaderT env m a -> LightT env m a
LightT ReaderT env m env
forall r (m :: * -> *). MonadReader r m => m r
ask
local :: (env -> env) -> LightT env m a -> LightT env m a
local f :: env -> env
f = ReaderT env m a -> LightT env m a
forall env (m :: * -> *) a. ReaderT env m a -> LightT env m a
LightT (ReaderT env m a -> LightT env m a)
-> (LightT env m a -> ReaderT env m a)
-> LightT env m a
-> LightT env m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (env -> env) -> ReaderT env m a -> ReaderT env m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local env -> env
f (ReaderT env m a -> ReaderT env m a)
-> (LightT env m a -> ReaderT env m a)
-> LightT env m a
-> ReaderT env m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LightT env m a -> ReaderT env m a
forall env (m :: * -> *) a. LightT env m a -> ReaderT env m a
runLightT'
instance (Monad m, HasLightEnv env) => Caster.MonadLogger (LightT env m) where
getLogger :: LightT env m LogQueue
getLogger = Getting LogQueue env LogQueue -> LightT env m LogQueue
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting LogQueue env LogQueue
forall c. HasLightEnv c => Lens' c LogQueue
_logger
type MiniLight = LightT LightEnv IO
liftMiniLight :: (HasLightEnv env, MonadIO m) => MiniLight a -> LightT env m a
liftMiniLight :: MiniLight a -> LightT env m a
liftMiniLight m :: MiniLight a
m = do
LightEnv
env <- Getting LightEnv env LightEnv -> LightT env m LightEnv
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting LightEnv env LightEnv
forall c. HasLightEnv c => Lens' c LightEnv
lightEnv
ReaderT env m a -> LightT env m a
forall env (m :: * -> *) a. ReaderT env m a -> LightT env m a
LightT (ReaderT env m a -> LightT env m a)
-> ReaderT env m a -> LightT env m a
forall a b. (a -> b) -> a -> b
$ (env -> m a) -> ReaderT env m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((env -> m a) -> ReaderT env m a)
-> (env -> m a) -> ReaderT env m a
forall a b. (a -> b) -> a -> b
$ \_ -> IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ ReaderT LightEnv IO a -> LightEnv -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (MiniLight a -> ReaderT LightEnv IO a
forall env (m :: * -> *) a. LightT env m a -> ReaderT env m a
runLightT' MiniLight a
m) LightEnv
env
{-# INLINE liftMiniLight #-}
envLightT :: (env' -> env) -> LightT env m a -> LightT env' m a
envLightT :: (env' -> env) -> LightT env m a -> LightT env' m a
envLightT f :: env' -> env
f m :: LightT env m a
m = ReaderT env' m a -> LightT env' m a
forall env (m :: * -> *) a. ReaderT env m a -> LightT env m a
LightT (ReaderT env' m a -> LightT env' m a)
-> ReaderT env' m a -> LightT env' m a
forall a b. (a -> b) -> a -> b
$ (env' -> m a) -> ReaderT env' m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((env' -> m a) -> ReaderT env' m a)
-> (env' -> m a) -> ReaderT env' m a
forall a b. (a -> b) -> a -> b
$ ReaderT env m a -> env -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (LightT env m a -> ReaderT env m a
forall env (m :: * -> *) a. LightT env m a -> ReaderT env m a
runLightT' LightT env m a
m) (env -> m a) -> (env' -> env) -> env' -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. env' -> env
f
{-# INLINE envLightT #-}
mapLightT :: (m a -> n a) -> LightT env m a -> LightT env n a
mapLightT :: (m a -> n a) -> LightT env m a -> LightT env n a
mapLightT f :: m a -> n a
f m :: LightT env m a
m = ReaderT env n a -> LightT env n a
forall env (m :: * -> *) a. ReaderT env m a -> LightT env m a
LightT (ReaderT env n a -> LightT env n a)
-> ReaderT env n a -> LightT env n a
forall a b. (a -> b) -> a -> b
$ (env -> n a) -> ReaderT env n a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((env -> n a) -> ReaderT env n a)
-> (env -> n a) -> ReaderT env n a
forall a b. (a -> b) -> a -> b
$ m a -> n a
f (m a -> n a) -> (env -> m a) -> env -> n a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT env m a -> env -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (LightT env m a -> ReaderT env m a
forall env (m :: * -> *) a. LightT env m a -> ReaderT env m a
runLightT' LightT env m a
m)
{-# INLINE mapLightT #-}
loadFontCache :: MonadIO m => m FontMap
loadFontCache :: m FontMap
loadFontCache = do
FontCache
fc <- IO FontCache -> m FontCache
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FontCache
buildCache
FontMap -> m FontMap
forall (m :: * -> *) a. Monad m => a -> m a
return (FontMap -> m FontMap) -> FontMap -> m FontMap
forall a b. (a -> b) -> a -> b
$ (FontMap -> FontDescriptor -> FontMap)
-> FontMap -> [FontDescriptor] -> FontMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
( \fm :: FontMap
fm fd :: FontDescriptor
fd -> FontDescriptor -> FilePath -> FontMap -> FontMap
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert
FontDescriptor
fd
(FilePath -> (FilePath -> FilePath) -> Maybe FilePath -> FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
error (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ "Font not found: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FontDescriptor -> FilePath
forall a. Show a => a -> FilePath
show FontDescriptor
fd) FilePath -> FilePath
forall a. a -> a
id (FontCache -> FontDescriptor -> Maybe FilePath
findFontInCache FontCache
fc FontDescriptor
fd))
FontMap
fm
)
FontMap
forall k v. HashMap k v
HM.empty
(FontCache -> [FontDescriptor]
enumerateFonts FontCache
fc)
loadFont
:: (HasLightEnv env, MonadIO m)
=> FontDescriptor
-> Int
-> LightT env m SDL.Font.Font
loadFont :: FontDescriptor -> Int -> LightT env m Font
loadFont fd :: FontDescriptor
fd size :: Int
size = do
FontMap
fc <- Getting FontMap env FontMap -> LightT env m FontMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting FontMap env FontMap
forall c. HasLightEnv c => Lens' c FontMap
_fontCache
let path :: FilePath
path = FontMap
fc FontMap -> FontDescriptor -> FilePath
forall k v. (Eq k, Hashable k) => HashMap k v -> k -> v
HM.! FontDescriptor
fd
FilePath -> Int -> LightT env m Font
forall (m :: * -> *). MonadIO m => FilePath -> Int -> m Font
SDL.Font.load FilePath
path Int
size
withFont
:: (HasLightEnv env, MonadIO m, MonadMask m)
=> FontDescriptor
-> Int
-> (SDL.Font.Font -> LightT env m a)
-> LightT env m a
withFont :: FontDescriptor -> Int -> (Font -> LightT env m a) -> LightT env m a
withFont fd :: FontDescriptor
fd n :: Int
n = LightT env m Font
-> (Font -> LightT env m ())
-> (Font -> LightT env m a)
-> LightT env m a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (FontDescriptor -> Int -> LightT env m Font
forall env (m :: * -> *).
(HasLightEnv env, MonadIO m) =>
FontDescriptor -> Int -> LightT env m Font
loadFont FontDescriptor
fd Int
n) Font -> LightT env m ()
forall (m :: * -> *). MonadIO m => Font -> m ()
SDL.Font.free