{-# LANGUAGE FunctionalDependencies #-}
module MiniLight (
module MiniLight.Light,
module MiniLight.Event,
module MiniLight.Figure,
module MiniLight.Component,
module MiniLight.Loader,
runLightT,
LoopState (..),
LoopConfig (..),
defConfig,
runMainloop,
MiniLoop,
runMiniloop,
) where
import Control.Concurrent (threadDelay, forkIO)
import Control.Concurrent.MVar
import Control.Lens
import qualified Control.Monad.Caster as Caster
import Control.Monad.Catch
import Control.Monad.Reader
import Data.Foldable (foldlM)
import Data.Hashable (Hashable(..))
import qualified Data.HashMap.Strict as HM
import Data.Maybe
import Data.IORef
import qualified Data.Registry as R
import qualified Data.Vector as V
import Graphics.Text.TrueType
import MiniLight.Component
import MiniLight.Event
import MiniLight.Figure
import MiniLight.Light
import MiniLight.Loader
import qualified System.FSNotify as Notify
import qualified SDL
import qualified SDL.Font
instance Hashable SDL.Scancode where
hashWithSalt n sc = hashWithSalt n (SDL.unwrapScancode sc)
runLightT :: (MonadIO m, MonadMask m) => LightT LightEnv m a -> m a
runLightT prog = withSDL $ withWindow $ \window -> do
renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer
fc <- loadFontCache
logger <- liftIO $ Caster.stdoutLogger Caster.LogDebug
runReaderT (runLightT' prog)
$ LightEnv {renderer = renderer, fontCache = fc, logger = logger}
where
withSDL =
bracket (SDL.initializeAll >> SDL.Font.initialize)
(\_ -> SDL.Font.quit >> SDL.quit)
. const
withWindow =
bracket (SDL.createWindow "window" SDL.defaultWindow) SDL.destroyWindow
data LoopConfig = LoopConfig {
watchKeys :: Maybe [SDL.Scancode],
appConfigFile :: Maybe FilePath,
hotConfigReplacement :: Maybe FilePath,
componentResolver :: Resolver,
additionalComponents :: [Component]
}
defConfig :: LoopConfig
defConfig = LoopConfig
{ watchKeys = Nothing
, appConfigFile = Nothing
, hotConfigReplacement = Nothing
, componentResolver = \_ _ -> undefined
, additionalComponents = []
}
data LoopState = LoopState {
light :: LightEnv,
loop :: LoopEnv,
loader :: LoaderEnv
}
makeLensesWith classyRules_ ''LoopState
type MiniLoop = LightT LoopState IO
instance HasLightEnv LoopState where
lightEnv = _light . lightEnv
instance HasLoopEnv LoopState where
loopEnv = _loop . loopEnv
instance HasLoaderEnv LoopState where
loaderEnv = _loader . loaderEnv
data ComponentState a = ComponentState {
stateL :: a,
componentEnvL :: ComponentEnv
}
makeLensesWith classyRules_ ''ComponentState
instance HasLightEnv env => HasLightEnv (ComponentState env) where
lightEnv = _stateL . lightEnv
instance HasLoopEnv env => HasLoopEnv (ComponentState env) where
loopEnv = _stateL . loopEnv
instance HasLoaderEnv env => HasLoaderEnv (ComponentState env) where
loaderEnv = _stateL . loaderEnv
instance HasComponentEnv (ComponentState env) where
componentEnv = _componentEnvL
runMiniloop :: LoopConfig -> s -> (s -> MiniLoop s) -> MiniLight ()
runMiniloop = runMainloop LoopState
runMainloop
:: ( HasLightEnv env
, HasLightEnv env'
, HasLoopEnv env'
, HasLoaderEnv env'
, MonadIO m
, MonadMask m
)
=> (env -> LoopEnv -> LoaderEnv -> env')
-> LoopConfig
-> s
-> (s -> LightT env' m s)
-> LightT env m ()
runMainloop conv conf initial userloop = do
events <- liftIO $ newMVar []
signalQueue <- liftIO $ newIORef []
reg <- R.new
conf <- liftIO $ newIORef $ AppConfig V.empty V.empty
run
(LoopEnv {keyStates = HM.empty, events = events, signalQueue = signalQueue})
(LoaderEnv {registry = reg, appConfig = conf})
initial
where
run loop loader s = do
setup loop loader
go loop loader s
setup loop loader = envLightT (\env -> conv env loop loader) $ do
case (hotConfigReplacement conf, appConfigFile conf) of
(Just dir, Just confPath) -> do
liftIO $ forkIO $ Notify.withManager $ \mgr -> do
_ <- Notify.watchDir mgr dir (const True) $ \ev -> do
modifyMVar_ (loop ^. _events) $ return . (NotifyEvent ev :)
forever $ threadDelay 1000000
loadAppConfig confPath (componentResolver conf)
_ -> return ()
forM_ (additionalComponents conf) $ \component -> do
reg <- view _registry
R.register reg (getUID component) component
go loop loader s = do
renderer <- view _renderer
liftIO $ SDL.rendererDrawColor renderer SDL.$= 255
liftIO $ SDL.clear renderer
R.forV_ (loader ^. _registry) $ \comp -> draw comp
R.modifyV_ (loader ^. _registry) $ return . propagate
R.modifyV_ (loader ^. _registry) $ \comp ->
envLightT
( \env -> ComponentState
(conv env loop loader)
(ComponentEnv (getUID comp) (getHooks comp))
)
$ update comp
s' <- envLightT (\env -> conv env loop loader) $ userloop s
liftIO $ SDL.present renderer
liftIO $ threadDelay (100000 `div` 60)
events <- SDL.pollEvents
keys <- SDL.getKeyboardState
envLightT (\env -> conv env loop loader) $ do
evref <- view _events
events <- liftIO $ modifyMVar evref (\a -> return ([], a))
R.modifyV_ (loader ^. _registry) $ \comp -> do
foldlM
( \comp ev ->
envLightT
( \env -> ComponentState
env
(ComponentEnv (getUID comp) (getHooks comp))
)
$ onSignal ev comp
)
comp
events
forM_
( catMaybes $ map
( \e -> case e of
NotifyEvent ev -> Just ev
_ -> Nothing
)
events
)
$ \ev -> patchAppConfig
(fromJust $ appConfigFile conf)
(componentResolver conf)
envLightT (\env -> conv env loop loader) $ do
evref <- view _events
sigref <- view _signalQueue
signals <- liftIO $ readIORef sigref
liftIO
$ modifyMVar_ evref
$ return
. (map RawEvent events ++)
. (signals ++)
liftIO $ writeIORef sigref []
let loop' =
loop
& _keyStates
%~ HM.mapWithKey (\k v -> if keys k then v + 1 else 0)
. maybe
id
( \specified m -> HM.fromList $ map
(\s -> (s, if HM.member s m then m HM.! s else 0))
specified
)
(watchKeys conf)
let quit = any
( \event -> case SDL.eventPayload event of
SDL.WindowClosedEvent _ -> True
SDL.QuitEvent -> True
_ -> False
)
events
unless quit $ go loop' loader s'