{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module Simple.UI.Core.Internal.UIApp where
import qualified Graphics.Vty as Vty
import Control.Concurrent.STM
import Control.Lens
import Control.Monad.IO.Class
import Control.Monad.State.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State.Strict hiding (get, put)
import Simple.UI.Core.Draw
import {-# SOURCE #-} Simple.UI.Widgets.Widget
type UIApp u = ReaderT (AppConfig u) (StateT AppState IO)
type UIApp' = UIApp ()
data UIAppEvent = UIAppEventResize Int Int
| UIAppEventKeyPressed Vty.Key [Vty.Modifier]
| UIAppEventAction (UIApp' ())
| UIAppEventQuit
type UIAppTasks = TChan UIAppEvent
data AppConfig u = AppConfig
{ AppConfig u -> Vty
_appVty :: Vty.Vty
, AppConfig u -> UIAppTasks
_appTasks :: UIAppTasks
, AppConfig u -> u
_appUserData :: u
}
data AppState = AppState
{ AppState -> Integer
_appIdCounter :: Integer
, AppState -> Int
_appWidth :: Int
, AppState -> Int
_appHeight :: Int
, AppState -> Drawing
_appDrawing :: Drawing
, AppState -> Maybe Widget
_appRoot :: Maybe Widget
}
makeLenses ''AppConfig
makeLenses ''AppState
instance Eq UIAppEvent where
UIAppEvent
UIAppEventQuit == :: UIAppEvent -> UIAppEvent -> Bool
== UIAppEvent
UIAppEventQuit = Bool
True
UIAppEvent
_ == UIAppEvent
_ = Bool
False
uniqueIdNew :: UIApp u Integer
uniqueIdNew :: UIApp u Integer
uniqueIdNew = (Integer -> (Integer, Integer)) -> AppState -> (Integer, AppState)
Lens' AppState Integer
appIdCounter ((Integer -> (Integer, Integer))
-> AppState -> (Integer, AppState))
-> Integer -> UIApp u Integer
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
LensLike' ((,) a) s a -> a -> m a
<+= Integer
1
_runUIApp :: MonadIO m => AppConfig u -> AppState -> UIApp u a -> m (a, AppState)
_runUIApp :: AppConfig u -> AppState -> UIApp u a -> m (a, AppState)
_runUIApp AppConfig u
initConfig AppState
initState UIApp u a
app = IO (a, AppState) -> m (a, AppState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (a, AppState) -> m (a, AppState))
-> IO (a, AppState) -> m (a, AppState)
forall a b. (a -> b) -> a -> b
$ StateT AppState IO a -> AppState -> IO (a, AppState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (UIApp u a -> AppConfig u -> StateT AppState IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT UIApp u a
app AppConfig u
initConfig) AppState
initState
liftUIApp' :: UIApp' a -> UIApp u a
liftUIApp' :: UIApp' a -> UIApp u a
liftUIApp' UIApp' a
app = do
AppState
s <- ReaderT (AppConfig u) (StateT AppState IO) AppState
forall s (m :: * -> *). MonadState s m => m s
get
AppConfig u
r <- ReaderT (AppConfig u) (StateT AppState IO) (AppConfig u)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
(a
x, AppState
s') <- AppConfig ()
-> AppState
-> UIApp' a
-> ReaderT (AppConfig u) (StateT AppState IO) (a, AppState)
forall (m :: * -> *) u a.
MonadIO m =>
AppConfig u -> AppState -> UIApp u a -> m (a, AppState)
_runUIApp (AppConfig u -> AppConfig ()
forall u. AppConfig u -> AppConfig ()
newConf AppConfig u
r) AppState
s UIApp' a
app
AppState -> ReaderT (AppConfig u) (StateT AppState IO) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put AppState
s'
a -> UIApp u a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
where
newConf :: AppConfig u -> AppConfig ()
newConf :: AppConfig u -> AppConfig ()
newConf AppConfig u
conf = AppConfig :: forall u. Vty -> UIAppTasks -> u -> AppConfig u
AppConfig
{ _appVty :: Vty
_appVty = AppConfig u -> Vty
forall u. AppConfig u -> Vty
_appVty AppConfig u
conf
, _appTasks :: UIAppTasks
_appTasks = AppConfig u -> UIAppTasks
forall u. AppConfig u -> UIAppTasks
_appTasks AppConfig u
conf
, _appUserData :: ()
_appUserData = ()
forall a. HasCallStack => a
undefined
}
liftUIApp :: u -> UIApp u a -> UIApp' a
liftUIApp :: u -> UIApp u a -> UIApp' a
liftUIApp u
userData UIApp u a
app = do
AppState
s <- ReaderT (AppConfig ()) (StateT AppState IO) AppState
forall s (m :: * -> *). MonadState s m => m s
get
AppConfig ()
r <- ReaderT (AppConfig ()) (StateT AppState IO) (AppConfig ())
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
let appConf :: AppConfig u
appConf = AppConfig :: forall u. Vty -> UIAppTasks -> u -> AppConfig u
AppConfig
{ _appVty :: Vty
_appVty = AppConfig () -> Vty
forall u. AppConfig u -> Vty
_appVty AppConfig ()
r
, _appTasks :: UIAppTasks
_appTasks = AppConfig () -> UIAppTasks
forall u. AppConfig u -> UIAppTasks
_appTasks AppConfig ()
r
, _appUserData :: u
_appUserData = u
userData
}
(a
x, AppState
s') <- AppConfig u
-> AppState
-> UIApp u a
-> ReaderT (AppConfig ()) (StateT AppState IO) (a, AppState)
forall (m :: * -> *) u a.
MonadIO m =>
AppConfig u -> AppState -> UIApp u a -> m (a, AppState)
_runUIApp AppConfig u
appConf AppState
s UIApp u a
app
AppState -> ReaderT (AppConfig ()) (StateT AppState IO) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put AppState
s'
a -> UIApp' a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x