{-# LANGUAGE OverloadedStrings, FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module BrickUI where
import Prelude hiding (fail)
import System.Environment (getArgs)
import Control.Applicative ((<|>))
import Control.Monad (void, (>>))
import Control.Monad.Fail (MonadFail (..))
import Control.Monad.IO.Class (liftIO)
import Data.Either (fromRight)
import Data.List (sortOn)
import Data.Maybe (listToMaybe, catMaybes)
import Lens.Micro
import Brick
( App (..), BrickEvent (..), EventM, Next, Widget (..)
, CursorLocation (..), cursorLocationName, cursorsL
, VisibilityRequest (..), visibilityRequestsL
, hSize, vSize
, continue, halt
, str, vBox, hBox
)
import Brick.Focus (focusRingCursor, focusGetCurrent)
import Brick.Themes (loadCustomizations, themeToAttrMap)
import qualified Brick as B
import qualified Brick.Forms as Bf
import qualified Brick.Widgets.Center as C
import qualified Graphics.Vty as V
import Gen
import Types
import Pretty
runTerminal :: forall term. Diff term => FilePath -> IO ()
runTerminal ftheme = do
let dtheme = defaultTheme (userStyles @term)
theme <- fromRight dtheme <$> loadCustomizations ftheme dtheme
args <- getArgs
case args of
[fname] -> do
hist <- readHistory @term fname
void $ B.customMain
(V.mkVty $ V.defaultConfig { V.vtime = Just 100, V.vmin = Just 1 })
Nothing
(app @term (themeToAttrMap theme))
(createVizStates @term hist)
_ -> error "Usage: clash-term <history_file>"
app :: Diff term => B.AttrMap -> App (VizStates term) NoCustomEvent Name
app attrMap = App
{ appDraw = drawUI
, appChooseCursor = chooseCursor
, appHandleEvent = handleStart
, appStartEvent = (lookupSize <*>) . return
, appAttrMap = const attrMap
}
chooseCursor :: VizStates term -> [Cursor] -> Maybe Cursor
chooseCursor st ls
= (listToMaybe $ filter isSearch ls)
<|> (focusRingCursor (Bf.formFocus . _form) st ls)
where
isSearch :: Cursor -> Bool
isSearch = \case
CursorLocation {cursorLocationName = Just (SearchResult _)} -> True
_ -> False
drawUI :: forall term. Diff term
=> VizStates term -> [Widget Name]
drawUI vs =
[ B.translateBy (B.Location controlsOffset) controls
| vs^.showBot
]
++
[ vBox
[ B.vLimitPercent 20 $
C.hCenter $
hBoxSpaced 2 (drawBndr <$> vs^.binders)
, diff
, B.vLimitPercent 10 $
hBox
[ inputForm
, searchMatches
]
]
]
where
drawBndr :: Binder -> Widget Name
drawBndr bndr
= wb (show curN ++ "/" ++ show totN ++ " (" ++ stepName ++ ")")
$ str (fillSize 50 bndr)
where
(curN, totN, stepName) = getStep vs bndr
wb | bndr == vs^.curBinder = withBorderSelected
| otherwise = withBorder
diff :: Widget Name
diff
| v@(VizState (st:_) _ curE _ curO _ _) <- getCurrentState vs
= let
showE = showCode (vs^.scroll)
(min 80 $ getCodeWidth vs)
(vs^.formData^.opts)
(st^.ctx)
(getSearchString vs)
nextE = step v ^. curExpr
(visL, visR) | v^.curOccur < v^.leftN
= (visibleCursors curO, invisibleCursors)
| otherwise
= (invisibleCursors, visibleCursors (curO - v^.leftN))
in
hBoxSpaced 2
[ B.viewport LeftViewport B.Both $
visL $
withBorder "Before" $ showE curE
, B.viewport RightViewport B.Both $
visR $
withBorder "After" $ showE nextE
]
| otherwise
= C.center $ title "THE END"
inputForm :: Widget Name
inputForm = withBorder "Input"
$ Bf.renderForm
$ Bf.setFormConcat (hBoxSpaced 10)
$ vs^.form
searchMatches :: Widget Name
searchMatches = C.vCenter $ str (n ++ " out of " ++ tot ++ " matches")
where
(n, tot)
| v@(VizState (_:_) _ _ _ _ _ _) <- getCurrentState vs
, let lr = v^.leftN + v^.rightN
, lr > 0
= (show (v^.curOccur + 1), show lr)
| otherwise
= ("-", "-")
controlsOffset :: (Int, Int)
controlsOffset = ( (vs^.width `div` 2) - 25
, (vs^.height `div` 2) - 15
)
controls :: Widget Name
controls = withBorder "Controls" $ vBoxSpaced
[ "→ / ← (Ctrl-l / Ctrl-k)" .- "next/previous binder"
, "↓ / ↑" .- "next/previous step"
, "r" .- "reset"
, "Escape" .- "quit"
, "Shift-<dir>" .- "scroll left pane"
, "Ctrl-<dir>" .- "scroll right pane"
, "PageUp/Down" .- "scroll both panes (up/down)"
, "Home/End" .- "(vertically) scroll to start/end"
, "Ins/Del" .- "scroll both panes (left/right)"
, "Ctrl-p" .- "show/hide keyboard controls"
, "(Shift-)Tab" .- "cycle through input fields"
, "Enter" .- "submit move action (forward)"
, "KBS/Ctrl-b" .- "submit move action (backward)"
, "Space" .- "toggle flag"
]
where
button .- desc = hBox [emph button, str $ " : " ++ desc]
instance MonadFail (EventM Name) where
fail = liftIO . fail
lookupSize :: EventM Name (VizStates term -> VizStates term)
lookupSize = do
out <- V.outputIface <$> B.getVtyHandle
(w, h) <- V.displayBounds out
return $ (width .~ w) . (height .~ h)
updateOcc :: Diff term => VizStates term -> VizStates term
updateOcc vs
| v@(VizState (_:_) _ curE _ _ _ _) <- getCurrentState vs
, let ln = countOcc (vs^.formData^.opts) (getSearchString vs) curE
rn = countOcc (vs^.formData^.opts) (getSearchString vs) (step v ^. curExpr)
, ln + rn > 0
= updateState vs $ v & leftN .~ ln
& rightN .~ rn
& curOccur .~ ((v^.curOccur) `mod` (ln + rn))
| otherwise
= vs
handleStart :: forall term. Diff term
=> VizStates term
-> BrickEvent Name NoCustomEvent
-> EventM Name (Next (VizStates term))
handleStart vs ev = do
pre <- lookupSize
vs' <- handleEvent (pre vs) ev
post <- lookupSize
return (updateOcc . post <$> vs')
handleEvent :: Diff term
=> VizStates term
-> BrickEvent Name NoCustomEvent
-> EventM Name (Next (VizStates term))
handleEvent vs ev@(VtyEvent (V.EvKey key mods))
| [] <- mods
, focusGetCurrent (Bf.formFocus (vs^.form)) /= Just (FormField "Command")
= sometimes
| [] <- mods
= always
| [V.MShift] <- mods
= shiftScroll
| [V.MCtrl] <- mods
= case key of
V.KChar 'p' -> continue (vs & showBot %~ not)
V.KChar 'b' -> action Backward
V.KChar 'l' -> contT (stepBinder vs)
V.KChar 'k' -> contT (unstepBinder vs)
_ -> ctrlScroll
| otherwise
= continue vs
where
contT = continue . (scroll .~ True)
contF = (>> continue (vs & scroll .~ False))
bottom fg = continue $ updateState vs (fg $ getCurrentState vs)
& scroll .~ True
action dir = case vs^.formData.com of
Step n -> bottom $ moveTo n
Trans s -> bottom $ nextTrans dir s
Search _ -> bottom $ nextOccur dir
sometimes = case key of
V.KChar 'r' -> bottom reset
V.KBS -> action Backward
V.KRight -> contT (stepBinder vs)
V.KLeft -> contT (unstepBinder vs)
_ -> always
always = case key of
V.KEsc -> halt vs
V.KDown -> bottom step
V.KUp -> bottom unstep
V.KPageDown -> contF (vScrollL >> vScrollR)
V.KPageUp -> contF (vScrollL' >> vScrollR')
V.KHome -> contF (vScrollHomeL >> vScrollHomeR)
V.KEnd -> contF (vScrollEndL >> vScrollEndR)
V.KDel -> contF (hScrollL >> hScrollR)
V.KIns -> contF (hScrollL' >> hScrollR')
V.KEnter -> action Forward
_ -> formHandler
shiftScroll = contF $ case key of
V.KDown -> vScrollL
V.KUp -> vScrollL'
V.KRight -> hScrollL
V.KLeft -> hScrollL'
_ -> return ()
ctrlScroll = contF $ case key of
V.KDown -> vScrollR
V.KUp -> vScrollR'
V.KRight -> hScrollR
V.KLeft -> hScrollR'
_ -> return ()
formHandler = do
fm' <- Bf.handleFormEvent ev (vs^.form)
let cm = (Bf.formState fm')^.com
(_, tot, _) = getStep vs (vs^.curBinder)
valid = case cm of Step n -> n > 0 && n <= tot
_ -> True
continue $ vs & form .~ Bf.setFieldValid valid (FormField "Command") fm'
handleEvent vs _ = continue vs
scrollStep :: Int
scrollStep = 5
l, r :: B.ViewportScroll Name
l = B.viewportScroll LeftViewport
r = B.viewportScroll RightViewport
vScrollL, vScrollR, hScrollL, hScrollR, vScrollL', vScrollR', hScrollL', hScrollR',
vScrollHomeL, vScrollHomeR, vScrollEndL, vScrollEndR :: EventM Name ()
vScrollL = B.vScrollBy l scrollStep
vScrollL' = B.vScrollBy l (-scrollStep)
vScrollR = B.vScrollBy r scrollStep
vScrollR' = B.vScrollBy r (-scrollStep)
hScrollL = B.hScrollBy l scrollStep
hScrollL' = B.hScrollBy l (-scrollStep)
hScrollR = B.hScrollBy r scrollStep
hScrollR' = B.hScrollBy r (-scrollStep)
vScrollHomeL = B.vScrollToBeginning l
vScrollHomeR = B.vScrollToBeginning r
vScrollEndL = B.vScrollToEnd l
vScrollEndR = B.vScrollToEnd r
visibleCursors :: Int -> Widget Name -> Widget Name
visibleCursors n p = Widget (hSize p) (vSize p) $ do
res <- B.render p
let crs = map fst
$ sortOn ((\case {SearchResult i -> i; _ -> 0}) . snd)
$ catMaybes
$ map (\c -> case cursorLocationName c of
Just s@(SearchResult _) -> Just (c, s)
_ -> Nothing)
$ (res^.cursorsL)
if null crs then
return res
else do
let c = crs !! (n `mod` length crs)
return $ res & visibilityRequestsL .~ [VR { vrPosition = cursorLocation c
, vrSize = (1, 1)
}]
& cursorsL .~ [c]
invisibleCursors :: Widget n -> Widget n
invisibleCursors p = Widget (hSize p) (vSize p) $ do
res <- B.render p
return $ res & cursorsL .~ []