{-# LANGUAGE ScopedTypeVariables #-}
module Brick.Main
( App(..)
, defaultMain
, customMain
, customMainWithVty
, simpleMain
, resizeOrQuit
, simpleApp
, continue
, halt
, suspendAndResume
, lookupViewport
, lookupExtent
, findClickedExtents
, clickedExtent
, getVtyHandle
, viewportScroll
, ViewportScroll
, vScrollBy
, vScrollPage
, vScrollToBeginning
, vScrollToEnd
, hScrollBy
, hScrollPage
, hScrollToBeginning
, hScrollToEnd
, setTop
, setLeft
, neverShowCursor
, showFirstCursor
, showCursorNamed
, invalidateCacheEntry
, invalidateCache
, renderFinal
, getRenderState
, resetRenderState
)
where
import qualified Control.Exception as E
import Lens.Micro ((^.), (&), (.~), (%~), _1, _2)
import Control.Monad (forever)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State
import Control.Monad.Trans.Reader
import Control.Concurrent (forkIO, killThread)
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
import Data.Monoid (mempty)
#endif
import qualified Data.Foldable as F
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
, defaultConfig
)
import Graphics.Vty.Attributes (defAttr)
import Brick.BChan (BChan, newBChan, readBChan, readBChan2, writeBChan)
import Brick.Types (Widget, EventM(..))
import Brick.Types.Internal
import Brick.Widgets.Internal
import Brick.AttrMap
data App s e n =
App { appDraw :: s -> [Widget n]
, appChooseCursor :: s -> [CursorLocation n] -> Maybe (CursorLocation n)
, appHandleEvent :: s -> BrickEvent n e -> EventM n (Next s)
, appStartEvent :: s -> EventM n s
, appAttrMap :: s -> AttrMap
}
defaultMain :: (Ord n)
=> App s e n
-> s
-> IO s
defaultMain app st = do
let builder = mkVty defaultConfig
initialVty <- builder
customMain initialVty builder Nothing app st
simpleMain :: (Ord n)
=> Widget n
-> IO ()
simpleMain w = defaultMain (simpleApp w) ()
simpleApp :: Widget n -> App s e n
simpleApp w =
App { appDraw = const [w]
, appHandleEvent = resizeOrQuit
, appStartEvent = return
, appAttrMap = const $ attrMap defAttr []
, appChooseCursor = neverShowCursor
}
resizeOrQuit :: s -> BrickEvent n e -> EventM n (Next s)
resizeOrQuit s (VtyEvent (EvResize _ _)) = continue s
resizeOrQuit s _ = halt s
data InternalNext n a = InternalSuspendAndResume (RenderState n) (IO a)
| InternalHalt a
readBrickEvent :: BChan (BrickEvent n e) -> BChan e -> IO (BrickEvent n e)
readBrickEvent brickChan userChan = either id AppEvent <$> readBChan2 brickChan userChan
runWithVty :: (Ord n)
=> Vty
-> BChan (BrickEvent n e)
-> Maybe (BChan e)
-> App s e n
-> RenderState n
-> s
-> IO (InternalNext n s)
runWithVty vty brickChan mUserChan app initialRS initialSt = do
pid <- forkIO $ supplyVtyEvents vty brickChan
let readEvent = case mUserChan of
Nothing -> readBChan brickChan
Just uc -> readBrickEvent brickChan uc
runInner rs st = do
(result, newRS) <- runVty vty readEvent app st (resetRenderState 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 :: (Ord n)
=> Vty
-> IO Vty
-> Maybe (BChan e)
-> App s e n
-> s
-> IO s
customMain initialVty buildVty mUserChan app initialAppState = do
(s, vty) <- customMainWithVty initialVty buildVty mUserChan app initialAppState
shutdown vty
return s
customMainWithVty :: (Ord n)
=> Vty
-> IO Vty
-> Maybe (BChan e)
-> App s e n
-> s
-> IO (s, Vty)
customMainWithVty initialVty buildVty mUserChan app initialAppState = do
let run vty rs st brickChan = do
result <- runWithVty vty brickChan mUserChan app rs st
`E.catch` (\(e::E.SomeException) -> shutdown vty >> E.throw e)
case result of
InternalHalt s -> return (s, vty)
InternalSuspendAndResume newRS action -> do
shutdown vty
newAppState <- action
newVty <- buildVty
run newVty (newRS { renderCache = mempty }) newAppState brickChan
let emptyES = ES [] mempty
emptyRS = RS M.empty mempty S.empty mempty mempty
eventRO = EventRO M.empty initialVty mempty emptyRS
(st, eState) <- runStateT (runReaderT (runEventM (appStartEvent app initialAppState)) eventRO) emptyES
let initialRS = RS M.empty (esScrollRequests eState) S.empty mempty []
brickChan <- newBChan 20
run initialVty initialRS st brickChan
supplyVtyEvents :: Vty -> BChan (BrickEvent n e) -> IO ()
supplyVtyEvents vty chan =
forever $ do
e <- nextEvent vty
writeBChan chan $ VtyEvent e
runVty :: (Ord n)
=> Vty
-> IO (BrickEvent n e)
-> App s e n
-> s
-> RenderState n
-> IO (Next s, RenderState n)
runVty vty readEvent app appState rs = do
(firstRS, exts) <- renderApp vty app appState rs
e <- readEvent
(e', nextRS, nextExts) <- case e of
VtyEvent (EvResize _ _) -> do
(rs', exts') <- renderApp vty app appState $ firstRS & observedNamesL .~ S.empty
return (e, rs', exts')
VtyEvent (EvMouseDown c r button mods) -> do
let matching = findClickedExtents_ (c, r) exts
case matching of
(Extent n (Location (ec, er)) _ (Location (oC, oR)):_) ->
case n `elem` firstRS^.clickableNamesL of
True -> do
let localCoords = Location (lc, lr)
lc = c - ec + oC
lr = r - er + oR
newCoords = case M.lookup n (viewportMap firstRS) of
Nothing -> localCoords
Just vp -> localCoords & _1 %~ (+ (vp^.vpLeft))
& _2 %~ (+ (vp^.vpTop))
return (MouseDown n button mods newCoords, firstRS, exts)
False -> return (e, firstRS, exts)
_ -> return (e, firstRS, exts)
VtyEvent (EvMouseUp c r button) -> do
let matching = findClickedExtents_ (c, r) exts
case matching of
(Extent n (Location (ec, er)) _ (Location (oC, oR)):_) ->
case n `elem` firstRS^.clickableNamesL of
True -> do
let localCoords = Location (lc, lr)
lc = c - ec + oC
lr = r - er + oR
newCoords = case M.lookup n (viewportMap firstRS) of
Nothing -> localCoords
Just vp -> localCoords & _1 %~ (+ (vp^.vpLeft))
& _2 %~ (+ (vp^.vpTop))
return (MouseUp n button newCoords, firstRS, exts)
False -> return (e, firstRS, exts)
_ -> return (e, firstRS, exts)
_ -> return (e, firstRS, exts)
let emptyES = ES [] mempty
eventRO = EventRO (viewportMap nextRS) vty nextExts nextRS
(next, eState) <- runStateT (runReaderT (runEventM (appHandleEvent app appState e'))
eventRO) emptyES
return (next, nextRS { rsScrollRequests = esScrollRequests eState
, renderCache = applyInvalidations (cacheInvalidateRequests eState) $
renderCache nextRS
})
applyInvalidations :: (Ord n) => S.Set (CacheInvalidateRequest n) -> M.Map n v -> M.Map n v
applyInvalidations ns cache =
if InvalidateEntire `S.member` ns
then mempty
else foldr (.) id (mkFunc <$> F.toList ns) cache
where
mkFunc InvalidateEntire = const mempty
mkFunc (InvalidateSingle n) = M.delete n
lookupViewport :: (Ord n) => n -> EventM n (Maybe Viewport)
lookupViewport n = EventM $ asks (M.lookup n . eventViewportMap)
clickedExtent :: (Int, Int) -> Extent n -> Bool
clickedExtent (c, r) (Extent _ (Location (lc, lr)) (w, h) _) =
c >= lc && c < (lc + w) &&
r >= lr && r < (lr + h)
lookupExtent :: (Eq n) => n -> EventM n (Maybe (Extent n))
lookupExtent n = EventM $ asks (listToMaybe . filter f . latestExtents)
where
f (Extent n' _ _ _) = n == n'
findClickedExtents :: (Int, Int) -> EventM n [Extent n]
findClickedExtents pos = EventM $ asks (findClickedExtents_ pos . latestExtents)
findClickedExtents_ :: (Int, Int) -> [Extent n] -> [Extent n]
findClickedExtents_ pos = reverse . filter (clickedExtent pos)
getVtyHandle :: EventM n Vty
getVtyHandle = EventM $ asks eventVtyHandle
invalidateCacheEntry :: (Ord n) => n -> EventM n ()
invalidateCacheEntry n = EventM $ do
lift $ modify (\s -> s { cacheInvalidateRequests = S.insert (InvalidateSingle n) $ cacheInvalidateRequests s })
invalidateCache :: (Ord n) => EventM n ()
invalidateCache = EventM $ do
lift $ modify (\s -> s { cacheInvalidateRequests = S.insert InvalidateEntire $ cacheInvalidateRequests s })
getRenderState :: EventM n (RenderState n)
getRenderState = EventM $ asks oldState
resetRenderState :: RenderState n -> RenderState n
resetRenderState s =
s & observedNamesL .~ S.empty
& clickableNamesL .~ mempty
renderApp :: Vty -> App s e n -> s -> RenderState n -> IO (RenderState n, [Extent n])
renderApp vty app appState rs = do
sz <- displayBounds $ outputIface vty
let (newRS, pic, theCursor, exts) = renderFinal (appAttrMap app appState)
(appDraw app appState)
sz
(appChooseCursor app appState)
rs
picWithCursor = case theCursor of
Nothing -> pic { picCursor = NoCursor }
Just cloc -> pic { picCursor = AbsoluteCursor (cloc^.locationColumnL)
(cloc^.locationRowL)
}
update vty picWithCursor
return (newRS, exts)
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 l = l^.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