{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE ViewPatterns #-}
module Simple.UI.Core.UIApp (
runUIApp,
runMainLoop,
runDialogLoop,
mainLoopQuit,
mainSchedule,
mainScheduleAfter,
mainScheduleRepeat,
UIApp,
UIApp',
UIAppEvent (..),
liftUIApp,
liftUIApp',
appUserData,
uniqueIdNew
) where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Lens
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Data.Maybe
import GHC.Stack
import qualified Graphics.Vty as Vty
import Simple.UI.Core.Draw
import Simple.UI.Core.Internal.UIApp
import Simple.UI.Core.ListenerList
import Simple.UI.Widgets.Widget
import Simple.UI.Widgets.Window
newtype UIAppException = UIAppWindowIsNotTopLevelException CallStack
instance Show UIAppException where
show (UIAppWindowIsNotTopLevelException stack) = "UIAppWindowIsNotTopLevelException\n\n" ++ prettyCallStack stack
instance Exception UIAppException
runUIApp :: u -> UIApp u () -> IO ()
runUIApp userData app = do
appConfig <- initAppConfig
appState <- initAppState
void $ _runUIApp appConfig appState app `finally` Vty.shutdown (appConfig ^. appVty)
where
initAppConfig = do
c <- liftIO Vty.standardIOConfig
v <- liftIO $ Vty.mkVty c
tasks <- liftIO $ atomically newTChan
liftIO $ Vty.hideCursor (Vty.outputIface v)
return AppConfig
{ _appVty = v
, _appTasks = tasks
, _appUserData = userData
}
initAppState = do
d <- drawingNew 0 0
return AppState
{ _appIdCounter = 0
, _appWidth = 0
, _appHeight = 0
, _appDrawing = d
, _appRoot = Nothing
}
runMainLoop :: (HasCallStack, WindowClass w) => w a -> UIApp u ()
runMainLoop (castToWindow -> root) = do
when (windowType root /= WindowTypeTopLevel) $ throwM $ UIAppWindowIsNotTopLevelException ?callStack
appRoot .= (Just $ castToWidget root)
vty <- view appVty
tasks <- view appTasks
(width, height) <- Vty.displayBounds (Vty.outputIface vty)
mainResize width height
mainDraw
mainEventThreadRun tasks vty
runDialogLoop root
mainEventThreadRun :: MonadIO m => UIAppTasks -> Vty.Vty -> m ()
mainEventThreadRun tasks vty = void $ liftIO $ forkIO $ forever $ do
event <- Vty.nextEvent vty
case event of
Vty.EvKey key modifiers -> atomically $ writeTChan tasks $ UIAppEventKeyPressed key modifiers
Vty.EvResize width height -> atomically $ writeTChan tasks $ UIAppEventResize width height
_ -> return ()
mainDraw :: UIApp u ()
mainDraw = do
root <- fromJust <$> use appRoot
vty <- view appVty
drawing <- use appDrawing
(width, height) <- drawingRun drawing drawingGetSize
fire root draw (drawing, width, height)
pic <- drawingToPicture drawing
liftIO $ Vty.update vty pic
mainResize :: Int -> Int -> UIApp u ()
mainResize width height = do
d <- drawingNew width height
appWidth .= width
appHeight .= height
appDrawing .= d
runDialogLoop :: WidgetClass w => w -> UIApp u ()
runDialogLoop (castToWidget -> widget) = do
vty <- view appVty
tasks <- view appTasks
dialogLoop vty tasks
where
dialogLoop vty tasks = do
event <- liftIO . atomically $ readTChan tasks
case event of
UIAppEventResize width height -> mainResize width height
UIAppEventKeyPressed key modifiers -> fire widget keyPressed (key, modifiers)
UIAppEventAction action -> liftUIApp' action
UIAppEventQuit -> return ()
mainDraw
if event == UIAppEventQuit
then return ()
else dialogLoop vty tasks
mainLoopQuit :: UIApp u ()
mainLoopQuit = do
tasks <- view appTasks
liftIO . atomically $ writeTChan tasks UIAppEventQuit
mainSchedule :: UIApp' () -> UIApp u ()
mainSchedule action = do
tasks <- view appTasks
mainSchedule' tasks action
mainSchedule' :: MonadIO m => UIAppTasks -> UIApp' () -> m ()
mainSchedule' tasks action = liftIO $
atomically $ writeTChan tasks $ UIAppEventAction action
mainScheduleAfter :: Int -> UIApp' () -> UIApp u ()
mainScheduleAfter timeInMillis action = do
tasks <- view appTasks
void $ liftIO $ forkIO $ do
threadDelay (timeInMillis * 1000)
mainSchedule' tasks action
mainScheduleRepeat :: Int -> UIApp' () -> UIApp u ()
mainScheduleRepeat timeInMillis action = do
tasks <- view appTasks
void $ liftIO $ forkIO $ forever $ do
mainSchedule' tasks action
threadDelay (timeInMillis * 1000)