{-# LANGUAGE OverloadedStrings #-}
module BrickUI (runTerminal) where
import System.Environment (getArgs)
import Control.Monad (void, (>>))
import Lens.Micro
import Brick
( App (..), BrickEvent (..), EventM, Next, Widget
, 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
res <- loadCustomizations ftheme (defaultTheme $ userStyles @term)
case res of
Left err ->
error $ "[theme.ini] Configuration file is malformed: " ++ err
Right theme -> do
[fname] <- getArgs
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)
app :: forall term. Diff term
=> B.AttrMap -> App (VizStates term) NoCustomEvent Name
app attrMap = App { appDraw = drawUI
, appChooseCursor = focusRingCursor (Bf.formFocus . _form)
, appHandleEvent = handleStart
, appStartEvent = (lookupSize <*>) . return
, appAttrMap = const attrMap
}
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 inputForm
]
]
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 _) <- getCurrentState vs
= let
showE = showCode (vs^.scroll)
(min 80 $ getCodeWidth vs)
(vs^.formData^.opts)
(case vs^.formData.trans of {Search s -> s; _ -> ""})
(st^.ctx)
nextE = step v ^. curExpr
in
hBoxSpaced 2
[ B.viewport LeftViewport B.Both $
withBorder "Before" $ showE curE
, B.viewport RightViewport B.Both $
withBorder "After" $ showE nextE
]
| otherwise
= C.center $ title "THE END"
inputForm :: Widget Name
inputForm = withBorder "Input"
$ Bf.renderForm
$ Bf.setFormConcat (hBoxSpaced 10)
$ vs^.form
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"
, "Space" .- "toggle flag"
]
where
button .- desc = hBox [emph button, str $ " : " ++ desc]
lookupSize :: EventM Name (VizStates term -> VizStates term)
lookupSize = do
out <- V.outputIface <$> B.getVtyHandle
(w, h) <- V.displayBounds out
return $ (width .~ w) . (height .~ h)
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 (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 "Trans")
= sometimes
| [] <- mods
= always
| [V.MShift] <- mods
= case key of
V.KEnter -> search unstep
_ -> shiftScroll
| [V.MCtrl] <- mods
= case key of
V.KChar 'p' -> continue (vs & showBot %~ not)
V.KEnter -> search unstep
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
search f = case vs^.formData.trans of
Step n -> bottom $ moveTo n
Name s -> bottom $ nextTrans f s
_ -> continue vs
sometimes = case key of
V.KChar 'r' -> bottom reset
V.KBS -> search unstep
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 -> search step
_ -> 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 tr = (Bf.formState fm')^.trans
(_, tot, _) = getStep vs (vs^.curBinder)
valid = case tr of Step n -> n > 0 && n <= tot
_ -> True
continue $ vs & form .~ Bf.setFieldValid valid (FormField "Trans") fm'
handleEvent vs _ = continue vs
l, r :: B.ViewportScroll Name
l = B.viewportScroll LeftViewport
r = B.viewportScroll RightViewport
scrollStep :: Int
scrollStep = 5
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