{-# 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,

  -- * Re-exports
  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

-- | The environment for LightT monad.
data LightEnv = LightEnv
  { LightEnv -> Maybe Renderer
renderer :: Maybe SDL.Renderer  -- ^ Renderer for SDL2
  , LightEnv -> FontMap
fontCache :: FontMap  -- ^ System font information
  , LightEnv -> LogQueue
logger :: Caster.LogQueue  -- ^ Logger connected stdout
  }

makeClassy_ ''LightEnv

data LoopEnv = LoopEnv
  { LoopEnv -> HashMap Scancode Int
keyStates :: HM.HashMap SDL.Scancode Int  -- ^ Current state of keys, represents how many frames the key down has been down
  , LoopEnv -> MVar [Event]
events :: MVar [Event]  -- ^ Event queue
  , LoopEnv -> IORef [Event]
signalQueue :: IORef [Event]  -- ^ Signals emitted from components are stored in the queue and poll in the next frame.
  }

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