{-# 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
{ _appVty :: Vty.Vty
, _appTasks :: UIAppTasks
, _appUserData :: u
}
data AppState = AppState
{ _appIdCounter :: Integer
, _appWidth :: Int
, _appHeight :: Int
, _appDrawing :: Drawing
, _appRoot :: Maybe Widget
}
makeLenses ''AppConfig
makeLenses ''AppState
instance Eq UIAppEvent where
UIAppEventQuit == UIAppEventQuit = True
_ == _ = False
uniqueIdNew :: UIApp u Integer
uniqueIdNew = appIdCounter <+= 1
_runUIApp :: MonadIO m => AppConfig u -> AppState -> UIApp u a -> m (a, AppState)
_runUIApp initConfig initState app = liftIO $ runStateT (runReaderT app initConfig) initState
liftUIApp' :: UIApp' a -> UIApp u a
liftUIApp' app = do
s <- get
r <- ask
(x, s') <- _runUIApp (newConf r) s app
put s'
return x
where
newConf :: AppConfig u -> AppConfig ()
newConf conf = AppConfig
{ _appVty = _appVty conf
, _appTasks = _appTasks conf
, _appUserData = undefined
}
liftUIApp :: u -> UIApp u a -> UIApp' a
liftUIApp userData app = do
s <- get
r <- ask
let appConf = AppConfig
{ _appVty = _appVty r
, _appTasks = _appTasks r
, _appUserData = userData
}
(x, s') <- _runUIApp appConf s app
put s'
return x