module UI
( run
) where
import Brick (App (..), AttrName, BrickEvent (..),
EventM, Location (..), Next,
Padding (..), Widget, attrMap,
attrName, continue, defaultMain,
emptyWidget, fg, halt, padAll,
padBottom, showCursor, showFirstCursor,
str, withAttr, (<+>), (<=>))
import Brick.Widgets.Center (center)
import Control.Monad.IO.Class (liftIO)
import Data.Char (isSpace)
import Data.Maybe (fromMaybe)
import Data.Time (getCurrentTime)
import Data.Word (Word8)
import Graphics.Vty (Attr, Color (..), Event (..), Key (..),
Modifier (..), bold, defAttr,
withStyle)
import Text.Printf (printf)
import GottaGoFast
emptyAttrName :: AttrName
emptyAttrName = attrName "empty"
errorAttrName :: AttrName
errorAttrName = attrName "error"
resultAttrName :: AttrName
resultAttrName = attrName "result"
drawCharacter :: Character -> Widget ()
drawCharacter (Hit c) = str [c]
drawCharacter (Miss ' ') = withAttr errorAttrName $ str ['_']
drawCharacter (Miss c) = withAttr errorAttrName $ str [c]
drawCharacter (Empty c) = withAttr emptyAttrName $ str [c]
drawLine :: Line -> Widget ()
-- We display an empty line as a single space so that it still occupies
-- vertical space.
drawLine [] = str " "
drawLine ls = foldl1 (<+>) $ map drawCharacter ls
drawText :: State -> Widget ()
drawText s = padBottom (Pad 2) . foldl (<=>) emptyWidget . map drawLine $ page s
drawResults :: State -> Widget ()
drawResults s =
withAttr resultAttrName . str $
printf "%.f words per minute • %.f%% accuracy" (wpm s) (accuracy s * 100)
draw :: State -> [Widget ()]
draw s
| hasEnded s = pure . center . padAll 1 $ drawText s <=> drawResults s
| otherwise =
pure . center . padAll 1 . showCursor () (Location $ cursor s) $
drawText s <=> str " "
handleChar :: Char -> State -> EventM () (Next State)
handleChar c s
| not $ hasStarted s = do
now <- liftIO getCurrentTime
continue $ startClock now s'
| isComplete s' = do
now <- liftIO getCurrentTime
continue $ stopClock now s'
| otherwise = continue s'
where
s' = applyChar c s
handleEvent :: State -> BrickEvent () e -> EventM () (Next State)
handleEvent s (VtyEvent (EvKey key [MCtrl])) =
case key of
KChar 'c' -> halt s
KChar 'd' -> halt s
KChar 'w' -> continue $ applyBackspaceWord s
KBS -> continue $ applyBackspaceWord s
_ -> continue s
handleEvent s (VtyEvent (EvKey key [MAlt])) =
case key of
KBS -> continue $ applyBackspaceWord s
_ -> continue s
handleEvent s (VtyEvent (EvKey key [MMeta])) =
case key of
KBS -> continue $ applyBackspaceWord s
_ -> continue s
handleEvent s (VtyEvent (EvKey key []))
| hasEnded s =
case key of
KEnter -> halt s
KEsc -> halt $ s {loop = True}
_ -> continue s
| otherwise =
case key of
KChar c -> handleChar c s
KEnter -> handleChar '\n' s
KBS -> continue $ applyBackspace s
KEsc -> halt $ s {loop = True}
_ -> continue s
handleEvent s _ = continue s
app :: Attr -> Attr -> Attr -> App State e ()
app emptyAttr errorAttr resultAttr =
App
{ appDraw = draw
, appChooseCursor = showFirstCursor
, appHandleEvent = handleEvent
, appStartEvent = return
, appAttrMap =
const $
attrMap
defAttr
[ (emptyAttrName, emptyAttr)
, (errorAttrName, errorAttr)
, (resultAttrName, resultAttr)
]
}
run :: Word8 -> Word8 -> String -> IO Bool
run fgEmptyCode fgErrorCode t = do
s <- defaultMain (app emptyAttr errorAttr resultAttr) $ initialState t
return $ loop s
where
emptyAttr = fg . ISOColor $ fgEmptyCode
errorAttr = flip withStyle bold . fg . ISOColor $ fgErrorCode
-- abusing the fgErrorCode to use as a highlight colour for the results here
resultAttr = fg . ISOColor $ fgErrorCode