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 Graphics.Vty
( Vty
, Picture(..)
, Cursor(..)
, Event(..)
, update
, outputIface
, displayBounds
, shutdown
, nextEvent
, mkVty
)
import Brick.Types (Viewport, Direction, Widget, rowL, columnL, CursorLocation(..), cursorLocationNameL, Name(..), EventM(..))
import Brick.Types.Internal (ScrollRequest(..), RenderState(..), Next(..))
import Brick.Widgets.Internal (renderFinal)
import Brick.AttrMap
data App s e =
App { appDraw :: s -> [Widget]
, appChooseCursor :: s -> [CursorLocation] -> Maybe CursorLocation
, appHandleEvent :: s -> e -> EventM (Next s)
, appStartEvent :: s -> EventM s
, appAttrMap :: s -> AttrMap
, appLiftVtyEvent :: Event -> e
}
defaultMain :: App s Event
-> s
-> IO s
defaultMain app st = do
chan <- newChan
customMain (mkVty def) chan app st
simpleMain :: Widget
-> 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 (Next s)
resizeOrQuit s (EvResize _ _) = continue s
resizeOrQuit s _ = halt s
data InternalNext a = InternalSuspendAndResume RenderState (IO a)
| InternalHalt a
runWithNewVty :: IO Vty -> Chan e -> App s e -> RenderState -> s -> IO (InternalNext 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
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
-> 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
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 -> s -> RenderState -> IO (Next s, RenderState)
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 :: Name -> EventM (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 -> s -> RenderState -> IO RenderState
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] -> Maybe CursorLocation
neverShowCursor = const $ const Nothing
showFirstCursor :: s -> [CursorLocation] -> Maybe CursorLocation
showFirstCursor = const listToMaybe
showCursorNamed :: Name -> [CursorLocation] -> Maybe CursorLocation
showCursorNamed name locs =
let matches loc = loc^.cursorLocationNameL == Just name
in listToMaybe $ filter matches locs
data ViewportScroll =
ViewportScroll { viewportName :: Name
, hScrollPage :: Direction -> EventM ()
, hScrollBy :: Int -> EventM ()
, hScrollToBeginning :: EventM ()
, hScrollToEnd :: EventM ()
, vScrollPage :: Direction -> EventM ()
, vScrollBy :: Int -> EventM ()
, vScrollToBeginning :: EventM ()
, vScrollToEnd :: EventM ()
}
viewportScroll :: Name -> ViewportScroll
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 (Next s)
continue = return . Continue
halt :: s -> EventM (Next s)
halt = return . Halt
suspendAndResume :: IO s -> EventM (Next s)
suspendAndResume = return . SuspendAndResume