module Brick.Main
( App(..)
, defaultMain
, customMain
, simpleMain
, resizeOrQuit
, continue
, halt
, suspendAndResume
, lookupViewport
, viewportScroll
, ViewportScroll
, vScrollBy
, vScrollPage
, vScrollToBeginning
, vScrollToEnd
, hScrollBy
, hScrollPage
, hScrollToBeginning
, hScrollToEnd
, setTop
, setLeft
, neverShowCursor
, showFirstCursor
, showCursorNamed
, invalidateCacheEntry
, invalidateCache
)
where
import Control.Exception (finally)
import Lens.Micro ((^.), (&), (.~))
import Control.Monad (forever)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State
import Control.Monad.Trans.Reader
import Control.Concurrent (forkIO, Chan, newChan, readChan, writeChan, killThread)
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
import Data.Monoid (mempty)
#endif
import Data.Default
import Data.Maybe (listToMaybe)
import qualified Data.Map as M
import qualified Data.Set as S
import Graphics.Vty
( Vty
, Picture(..)
, Cursor(..)
, Event(..)
, update
, outputIface
, displayBounds
, shutdown
, nextEvent
, mkVty
)
import Brick.Types (Viewport, Direction, Widget, rowL, columnL, CursorLocation(..), cursorLocationNameL, EventM(..))
import Brick.Types.Internal (ScrollRequest(..), RenderState(..), observedNamesL, Next(..), EventState(..), CacheInvalidateRequest(..))
import Brick.Widgets.Internal (renderFinal)
import Brick.AttrMap
data App s e n =
App { appDraw :: s -> [Widget n]
, appChooseCursor :: s -> [CursorLocation n] -> Maybe (CursorLocation n)
, appHandleEvent :: s -> e -> EventM n (Next s)
, appStartEvent :: s -> EventM n s
, appAttrMap :: s -> AttrMap
, appLiftVtyEvent :: Event -> e
}
defaultMain :: (Ord n)
=> App s Event n
-> s
-> IO s
defaultMain app st = do
chan <- newChan
customMain (mkVty def) chan app st
simpleMain :: (Ord n)
=> Widget n
-> IO ()
simpleMain w =
let app = App { appDraw = const [w]
, appHandleEvent = resizeOrQuit
, appStartEvent = return
, appAttrMap = def
, appLiftVtyEvent = id
, appChooseCursor = neverShowCursor
}
in defaultMain app ()
resizeOrQuit :: s -> Event -> EventM n (Next s)
resizeOrQuit s (EvResize _ _) = continue s
resizeOrQuit s _ = halt s
data InternalNext n a = InternalSuspendAndResume (RenderState n) (IO a)
| InternalHalt a
runWithNewVty :: (Ord n)
=> IO Vty
-> Chan (Either Event e)
-> App s e n
-> RenderState n
-> s
-> IO (InternalNext n s)
runWithNewVty buildVty chan app initialRS initialSt =
withVty buildVty $ \vty -> do
pid <- forkIO $ supplyVtyEvents vty chan
let runInner rs st = do
(result, newRS) <- runVty vty chan app st (rs & observedNamesL .~ S.empty)
case result of
SuspendAndResume act -> do
killThread pid
return $ InternalSuspendAndResume newRS act
Halt s -> do
killThread pid
return $ InternalHalt s
Continue s -> runInner newRS s
runInner initialRS initialSt
customMain :: (Ord n)
=> IO Vty
-> Chan e
-> App s e n
-> s
-> IO s
customMain buildVty userChan app initialAppState = do
let run rs st chan = do
result <- runWithNewVty buildVty chan app rs st
case result of
InternalHalt s -> return s
InternalSuspendAndResume newRS action -> do
newAppState <- action
run newRS newAppState chan
emptyES = ES [] []
(st, eState) <- runStateT (runReaderT (runEventM (appStartEvent app initialAppState)) M.empty) emptyES
let initialRS = RS M.empty (esScrollRequests eState) S.empty mempty
chan <- newChan
forkIO $ forever $ readChan userChan >>= (\userEvent -> writeChan chan (Right userEvent))
run initialRS st chan
supplyVtyEvents :: Vty -> Chan (Either Event e) -> IO ()
supplyVtyEvents vty chan =
forever $ do
e <- nextEvent vty
writeChan chan $ Left e
runVty :: (Ord n)
=> Vty
-> Chan (Either Event e)
-> App s e n
-> s
-> RenderState n
-> IO (Next s, RenderState n)
runVty vty chan app appState rs = do
firstRS <- renderApp vty app appState rs
e <- readChan chan
nextRS <- case e of
Left (EvResize _ _) ->
renderApp vty app appState $ firstRS & observedNamesL .~ S.empty
_ -> return firstRS
let emptyES = ES [] []
userEvent = case e of
Left e' -> appLiftVtyEvent app e'
Right e' -> e'
(next, eState) <- runStateT (runReaderT (runEventM (appHandleEvent app appState userEvent))
(viewportMap nextRS)) emptyES
return (next, nextRS { rsScrollRequests = esScrollRequests eState
, renderCache = applyInvalidations (cacheInvalidateRequests eState) $
renderCache nextRS
})
applyInvalidations :: (Ord n) => [CacheInvalidateRequest n] -> M.Map n v -> M.Map n v
applyInvalidations ns cache = foldr (.) id (mkFunc <$> ns) cache
where
mkFunc InvalidateEntire = const mempty
mkFunc (InvalidateSingle n) = M.delete n
lookupViewport :: (Ord n) => n -> EventM n (Maybe Viewport)
lookupViewport = EventM . asks . M.lookup
invalidateCacheEntry :: n -> EventM n ()
invalidateCacheEntry n = EventM $ do
lift $ modify (\s -> s { cacheInvalidateRequests = InvalidateSingle n : cacheInvalidateRequests s })
invalidateCache :: EventM n ()
invalidateCache = EventM $ do
lift $ modify (\s -> s { cacheInvalidateRequests = InvalidateEntire : cacheInvalidateRequests s })
withVty :: IO Vty -> (Vty -> IO a) -> IO a
withVty buildVty useVty = do
vty <- buildVty
useVty vty `finally` shutdown vty
renderApp :: Vty -> App s e n -> s -> RenderState n -> IO (RenderState n)
renderApp vty app appState rs = do
sz <- displayBounds $ outputIface vty
let (newRS, pic, theCursor) = renderFinal (appAttrMap app appState)
(appDraw app appState)
sz
(appChooseCursor app appState)
rs
picWithCursor = case theCursor of
Nothing -> pic { picCursor = NoCursor }
Just loc -> pic { picCursor = Cursor (loc^.columnL) (loc^.rowL) }
update vty picWithCursor
return newRS
neverShowCursor :: s -> [CursorLocation n] -> Maybe (CursorLocation n)
neverShowCursor = const $ const Nothing
showFirstCursor :: s -> [CursorLocation n] -> Maybe (CursorLocation n)
showFirstCursor = const listToMaybe
showCursorNamed :: (Eq n) => n -> [CursorLocation n] -> Maybe (CursorLocation n)
showCursorNamed name locs =
let matches loc = loc^.cursorLocationNameL == Just name
in listToMaybe $ filter matches locs
data ViewportScroll n =
ViewportScroll { viewportName :: n
, hScrollPage :: Direction -> EventM n ()
, hScrollBy :: Int -> EventM n ()
, hScrollToBeginning :: EventM n ()
, hScrollToEnd :: EventM n ()
, vScrollPage :: Direction -> EventM n ()
, vScrollBy :: Int -> EventM n ()
, vScrollToBeginning :: EventM n ()
, vScrollToEnd :: EventM n ()
, setTop :: Int -> EventM n ()
, setLeft :: Int -> EventM n ()
}
addScrollRequest :: (n, ScrollRequest) -> EventM n ()
addScrollRequest req = EventM $ do
lift $ modify (\s -> s { esScrollRequests = req : esScrollRequests s })
viewportScroll :: n -> ViewportScroll n
viewportScroll n =
ViewportScroll { viewportName = n
, hScrollPage = \dir -> addScrollRequest (n, HScrollPage dir)
, hScrollBy = \i -> addScrollRequest (n, HScrollBy i)
, hScrollToBeginning = addScrollRequest (n, HScrollToBeginning)
, hScrollToEnd = addScrollRequest (n, HScrollToEnd)
, vScrollPage = \dir -> addScrollRequest (n, VScrollPage dir)
, vScrollBy = \i -> addScrollRequest (n, VScrollBy i)
, vScrollToBeginning = addScrollRequest (n, VScrollToBeginning)
, vScrollToEnd = addScrollRequest (n, VScrollToEnd)
, setTop = \i -> addScrollRequest (n, SetTop i)
, setLeft = \i -> addScrollRequest (n, SetLeft i)
}
continue :: s -> EventM n (Next s)
continue = return . Continue
halt :: s -> EventM n (Next s)
halt = return . Halt
suspendAndResume :: IO s -> EventM n (Next s)
suspendAndResume = return . SuspendAndResume