module Brick.Main
( App(..)
, defaultMain
, customMain
, simpleMain
, resizeOrQuit
, continue
, halt
, suspendAndResume
, lookupViewport
, viewportScroll
, ViewportScroll
, vScrollBy
, vScrollPage
, vScrollToBeginning
, vScrollToEnd
, hScrollBy
, hScrollPage
, hScrollToBeginning
, hScrollToEnd
, neverShowCursor
, showFirstCursor
, showCursorNamed
)
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)
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(..))
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 :: App s Event n
-> s
-> IO s
defaultMain app st = do
chan <- newChan
customMain (mkVty def) chan app st
simpleMain :: 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 :: IO Vty -> Chan 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 (appLiftVtyEvent app) 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 :: IO Vty
-> Chan e
-> App s e n
-> s
-> IO s
customMain buildVty chan app initialAppState = do
let run rs st = do
result <- runWithNewVty buildVty chan app rs st
case result of
InternalHalt s -> return s
InternalSuspendAndResume newRS action -> do
newAppState <- action
run newRS newAppState
(st, initialScrollReqs) <- runStateT (runReaderT (runEventM (appStartEvent app initialAppState)) M.empty) []
let initialRS = RS M.empty initialScrollReqs S.empty
run initialRS st
supplyVtyEvents :: Vty -> (Event -> e) -> Chan e -> IO ()
supplyVtyEvents vty mkEvent chan =
forever $ do
e <- nextEvent vty
writeChan chan $ mkEvent e
runVty :: Vty -> Chan 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
(next, scrollReqs) <- runStateT (runReaderT (runEventM (appHandleEvent app appState e)) (viewportMap rs)) []
return (next, firstRS { scrollRequests = scrollReqs })
lookupViewport :: (Ord n) => n -> EventM n (Maybe Viewport)
lookupViewport = EventM . asks . M.lookup
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 ()
}
viewportScroll :: n -> ViewportScroll n
viewportScroll n =
ViewportScroll { viewportName = n
, hScrollPage = \dir -> EventM $ lift $ modify ((n, HScrollPage dir) :)
, hScrollBy = \i -> EventM $ lift $ modify ((n, HScrollBy i) :)
, hScrollToBeginning = EventM $ lift $ modify ((n, HScrollToBeginning) :)
, hScrollToEnd = EventM $ lift $ modify ((n, HScrollToEnd) :)
, vScrollPage = \dir -> EventM $ lift $ modify ((n, VScrollPage dir) :)
, vScrollBy = \i -> EventM $ lift $ modify ((n, VScrollBy i) :)
, vScrollToBeginning = EventM $ lift $ modify ((n, VScrollToBeginning) :)
, vScrollToEnd = EventM $ lift $ modify ((n, VScrollToEnd) :)
}
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