gotta-go-fast 0.1.4.0 → 0.3.0.0
raw patch · 4 files changed
+300/−167 lines, 4 filesdep +file-embeddep +splitdep ~base
Dependencies added: file-embed, split
Dependency ranges changed: base
Files
- gotta-go-fast.cabal +7/−5
- src/GottaGoFast.hs +69/−46
- src/Main.hs +133/−46
- src/UI.hs +91/−70
gotta-go-fast.cabal view
@@ -1,13 +1,13 @@ name: gotta-go-fast-version: 0.1.4.0+version: 0.3.0.0 synopsis: A command line utility for practicing typing description:- A command line utility for practicing typing and measuring your WPM and accuracy. See the project <https://github.com/hot-leaf-juice/gotta-go-fast/blob/master/README.md README> for details.+ A command line utility for practicing typing and measuring your WPM and accuracy. See the project <https://github.com/callum-oakley/gotta-go-fast/blob/master/README.md README> for details. category: Application author: Callum Oakley-maintainer: c.oakley108@gmail.com-homepage: https://github.com/hot-leaf-juice/gotta-go-fast+maintainer: hello@callumoakley.net+homepage: https://github.com/callum-oakley/gotta-go-fast license: BSD3 license-file: LICENSE build-type: Simple@@ -19,7 +19,7 @@ , UI main-is: Main.hs ghc-options: -threaded- build-depends: base >=4.9 && <4.11+ build-depends: base >=4.7 && <5 , brick >= 0.21 , word-wrap >= 0.4.1 , text@@ -28,4 +28,6 @@ , random , time , vty+ , split+ , file-embed default-language: Haskell2010
src/GottaGoFast.hs view
@@ -7,16 +7,14 @@ , applyBackspace , applyBackspaceWord , applyChar- , applyEnter- , applyTab+ , applyWhitespace , atEndOfLine , cursor+ , countChars , hasEnded , hasStarted , initialState , isComplete- , isErrorFree- , noOfChars , onLastLine , page , seconds@@ -25,36 +23,45 @@ , wpm ) where -import Data.List (isPrefixOf)-import Data.Maybe (isJust, fromJust)-import Data.Time (UTCTime, diffUTCTime)+import Data.Char (isSpace)+import Data.List (groupBy, isPrefixOf)+import Data.Maybe (fromJust, isJust)+import Data.Time (UTCTime, diffUTCTime) -- It is often useful to know whether the line / character etc we are -- considering is "BeforeCursor" or "AfterCursor". More granularity turns out -- to be unnecessary.-data Position = BeforeCursor | AfterCursor+data Position+ = BeforeCursor+ | AfterCursor -data State = State- { target :: String- , input :: String- , start :: Maybe UTCTime- , end :: Maybe UTCTime- , strokes :: Integer- , hits :: Integer- }+data State =+ State+ { target :: String+ , input :: String+ , start :: Maybe UTCTime+ , end :: Maybe UTCTime+ , strokes :: Integer+ , hits :: Integer+ } -- For ease of rendering a character in the UI, we tag it as a Hit, Miss, or -- Empty. Corresponding to the cases of being correctly typed, incorrectly -- typed (or skipped), or not yet typed.-data Character = Hit Char | Miss Char | Empty Char+data Character+ = Hit Char+ | Miss Char+ | Empty Char+ type Line = [Character]+ type Page = [Line] startClock :: UTCTime -> State -> State-startClock now s = s { start = Just now }+startClock now s = s {start = Just now} stopClock :: UTCTime -> State -> State-stopClock now s = s { end = Just now }+stopClock now s = s {end = Just now} hasStarted :: State -> Bool hasStarted = isJust . start@@ -84,40 +91,54 @@ isErrorFree s = input s `isPrefixOf` target s applyChar :: Char -> State -> State-applyChar c s = s' { hits = hits s' + if isErrorFree s' then 1 else 0 }+applyChar c s =+ s'+ { hits =+ hits s' ++ if isErrorFree s'+ then 1+ else 0+ } where- s' = s { input = input s ++ [c] , strokes = strokes s + 1 }--applyEnter :: State -> State-applyEnter = applyTab . applyChar '\n'--backspace :: String -> String-backspace "" = ""-backspace xs = init xs+ s' = s {input = input s ++ [c], strokes = strokes s + 1} applyBackspace :: State -> State-applyBackspace s = s { input = backspace $ input s }--backspaceWord :: String -> String-backspaceWord xs = reverse $ dropWhile (/= ' ') $ reverse $ backspace xs+applyBackspace s = s {input = reverse . drop n . reverse $ input s}+ where+ n =+ case takeWhile (\(i, t) -> isSpace i && isSpace t) . reverse $+ zip (input s) (target s) of+ [] -> 1+ ws -> length ws applyBackspaceWord :: State -> State-applyBackspaceWord s = s { input = backspaceWord $ input s }+applyBackspaceWord s = s {input = reverse . drop n . reverse $ input s}+ where+ n = toWordBeginning . reverse $ input s+ toWordBeginning "" = 0+ toWordBeginning [c] = 1+ toWordBeginning (x:y:ys)+ | not (isSpace x) && isSpace y = 1+ | otherwise = 1 + toWordBeginning (y : ys) -applyTab :: State -> State-applyTab s = s { input = input s ++ drop (cursorCol s) leadingSpaces }+applyWhitespace :: State -> State+applyWhitespace s = s {input = input s ++ whitespace} where- leadingSpaces = takeWhile (== ' ') $ lines (target s) !! cursorRow s+ whitespace =+ case takeWhile isSpace . drop (length $ input s) $ target s of+ "" -> " "+ ws -> ws initialState :: String -> State-initialState t = applyTab State- { target = t- , input = ""- , start = Nothing- , end = Nothing- , strokes = 0- , hits = 0- }+initialState t =+ State+ { target = t+ , input = takeWhile isSpace t+ , start = Nothing+ , end = Nothing+ , strokes = 0+ , hits = 0+ } character :: Position -> (Maybe Char, Maybe Char) -> Character character _ (Just t, Just i)@@ -147,12 +168,14 @@ -- The following functions are only safe to use when both hasStarted and -- hasEnded hold.- seconds :: State -> Rational seconds s = toRational $ diffUTCTime (fromJust $ end s) (fromJust $ start s) +countChars :: State -> Int+countChars = length . groupBy (\x y -> isSpace x && isSpace y) . target+ wpm :: State -> Rational-wpm s = fromIntegral (length $ target s) / (5 * seconds s / 60)+wpm s = fromIntegral (countChars s) / (5 * seconds s / 60) accuracy :: State -> Rational accuracy s = fromIntegral (hits s) / fromIntegral (strokes s)
src/Main.hs view
@@ -1,27 +1,39 @@ {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TemplateHaskell #-} module Main where -import Control.Monad (filterM)-import Data.Word (Word8)-import Data.Char (isAscii, isPrint)-import System.Console.CmdArgs- (Data, Typeable, args, cmdArgs, def, help, program, summary, typ, (&=))-import System.Directory (doesFileExist)-import System.Random (randomRIO)-import Text.Wrap (wrapText, WrapSettings(..))-import qualified Data.Text as T+import Control.Monad (filterM)+import Data.Char (isAscii, isPrint)+import Data.FileEmbed (embedStringFile)+import Data.List.Split (splitOn)+import qualified Data.Text as T+import Data.Word (Word8)+import System.Console.CmdArgs (Data, Typeable, args, cmdArgs, def,+ details, help, name, program, summary,+ typ, (&=))+import System.Directory (doesFileExist)+import System.Random (randomRIO)+import Text.Wrap (WrapSettings (..), wrapText) -import UI (run)+import UI (run) -data Config = Config- { height :: Int- , width :: Int- , tab :: Int- , files :: [FilePath]- , fg_empty :: Word8- , fg_error :: Word8- } deriving (Show, Data, Typeable)+data Config =+ Config+ { fg_empty :: Maybe Word8+ , fg_error :: Maybe Word8+ , files :: [FilePath]+ , height :: Int+ , max_paragraph_len :: Int+ , min_paragraph_len :: Int+ , nonsense_len :: Int+ , paragraph :: Bool+ , reflow_ :: Bool+ , tab :: Int+ , width :: Int+ }+ deriving (Show, Data, Typeable) toAscii :: Int -> String -> String toAscii tabWidth = concatMap toAscii'@@ -41,42 +53,117 @@ f = reverse . dropWhile (== '\n') config :: Config-config = Config- { height = 20 &= typ "LINES" &=- help "The maximum number of lines to sample (default: 20)"- , width = 80 &= typ "CHARS" &=- help "The width at which to wrap lines (default: 80)"- , tab = 4 &= typ "SIZE" &=- help "The size of a tab in spaces (default: 4)"- , fg_empty = 8 &= typ "COLOUR" &=- help "The ISO colour code for empty (not yet typed) characters (default: 8)"- , fg_error = 1 &= typ "COLOUR" &=- help "The ISO colour code for errors (default: 1)"- , files = def &= args &= typ "FILES"- }- &= summary "Gotta Go Fast 0.1.4.0"- &= help "Practice typing and measure your WPM and accuracy"- &= program "gotta-go-fast"+config =+ Config+ { fg_empty =+ def &= typ "COLOUR" &=+ help "The ANSI colour code for empty (not yet typed) text"+ , fg_error = def &= typ "COLOUR" &= help "The ANSI colour code for errors"+ , height =+ 20 &= typ "LINES" &=+ help "The maximum number of lines to sample (default: 20)"+ , max_paragraph_len =+ 750 &= typ "WORDS" &=+ help "The maximum length of a sampled paragraph (default: 750)"+ , min_paragraph_len =+ 250 &= typ "WORDS" &=+ help "The minimum length of a sampled paragraph (default: 250)"+ , nonsense_len =+ 500 &= name "l" &= typ "WORDS" &=+ help "The length of nonsense to generate (default: 500)"+ , paragraph = def &= help "Sample a paragraph from the input files"+ , reflow_ = def &= help "Reflow paragraph to the target width"+ , tab = 4 &= typ "SIZE" &= help "The size of a tab in spaces (default: 4)"+ , width =+ 80 &= typ "CHARS" &=+ help "The width at which to wrap lines (default: 80)"+ , files = def &= args &= typ "FILES"+ } &=+ summary "Gotta Go Fast 0.3.0.0" &=+ help "Practice typing and measure your WPM and accuracy." &=+ program "gotta-go-fast" &=+ (details $ lines $(embedStringFile "details.txt")) +wrap :: Int -> String -> String+wrap width = T.unpack . wrapText wrapSettings width . T.pack++wrapSettings = WrapSettings {preserveIndentation = True, breakLongWords = True}++-- wordWeights.txt is taken from+-- https://en.wiktionary.org/wiki/Wiktionary:Frequency_lists#TV_and_movie_scripts+-- (and cleaned up a little with some throwaway sed)+wordWeights :: [(String, Int)]+wordWeights =+ map ((\[w, f] -> (w, read f)) . words) . lines $+ $(embedStringFile "wordWeights.txt")++totalWeight :: Int+totalWeight = sum . map snd $ wordWeights++weightedRandomWord :: IO String+weightedRandomWord = do+ r <- randomRIO (0, totalWeight - 1)+ return $ go r wordWeights+ where+ go r ((w, f):rest)+ | r < f = w+ | otherwise = go (r - f) rest++-- Generates nonsense which is superficially similar to English. Similar in the+-- sense that the frequency of words in the generated text is approximately the+-- same as the frequency of words in actual usage.+nonsense :: Config -> IO String+nonsense c = do+ words <- go $ nonsense_len c+ return $ (wrap (width c) . unwords $ words) ++ "\n"+ where+ go :: Int -> IO [String]+ go n+ | n <= 0 = return []+ | otherwise = do+ word <- weightedRandomWord+ rest <- go (n - length word - 1) -- extra 1 to count the space+ return $ word : rest+ sample :: Config -> String -> IO String-sample c file = do- r <- randomRIO (0, max 0 $ length (lines ascii) - height c)- return $ trimEmptyLines $ chop $ wrap $ chop $ unlines $ drop r $ lines ascii- where- ascii = toAscii (tab c) file- chop = unlines . take (height c) . lines- wrap = T.unpack . wrapText wrapSettings (width c) . T.pack- wrapSettings = WrapSettings- { preserveIndentation = True- , breakLongWords = True- }+sample c file =+ if paragraph c+ then sampleParagraph+ else sampleLines+ where+ sampleParagraph = do+ r <- randomRIO (0, length paragraphs - 1)+ return $+ ((if reflow_ c+ then reflow+ else wrap (width c)) $+ paragraphs !! r) +++ "\n"+ sampleLines = do+ r <- randomRIO (0, max 0 $ length (lines ascii) - height c)+ return . trimEmptyLines . chop . wrap (width c) . chop . unlines . drop r $+ lines ascii+ paragraphs =+ filter+ ((\l -> l >= min_paragraph_len c && l <= max_paragraph_len c) . length) .+ map unlines . splitOn [""] . lines $+ ascii+ reflow s =+ wrap (width c) .+ map+ (\case+ '\n' -> ' '+ c -> c) $+ s+ ascii = toAscii (tab c) file+ chop = unlines . take (height c) . lines main :: IO () main = do c <- cmdArgs config fs <- filterM doesFileExist $ files c case fs of- [] -> putStrLn "Requires at least one file path"+ [] -> nonsense c >>= run (fg_empty c) (fg_error c) _ -> do r <- randomRIO (0, length fs - 1) file <- readFile $ fs !! r
src/UI.hs view
@@ -1,32 +1,40 @@-module UI (run) where+module UI+ ( run+ ) where -import Data.Word (Word8)+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 Brick- ( App(..), AttrName, BrickEvent(..), EventM, Location(..), Next, Widget- , attrMap, attrName, continue, defaultMain, emptyWidget, fg, halt, padAll- , showCursor, showFirstCursor, str, withAttr, (<+>), (<=>)- )-import Brick.Widgets.Border (border, borderAttr)-import Brick.Widgets.Center (center)-import Control.Monad.IO.Class (liftIO)-import Data.Time (getCurrentTime)-import Graphics.Vty- (Attr, Color(..), Event(..), Key(..), Modifier(..), defAttr, withStyle)+import GottaGoFast -import GottaGoFast+emptyAttrName :: AttrName+emptyAttrName = attrName "empty" -emptyAttr :: AttrName-emptyAttr = attrName "target"+errorAttrName :: AttrName+errorAttrName = attrName "error" -missAttr :: AttrName-missAttr = attrName "error"+resultAttrName :: AttrName+resultAttrName = attrName "result" drawCharacter :: Character -> Widget ()-drawCharacter (Hit c) = str [c]-drawCharacter (Miss ' ') = withAttr missAttr $ str ['_']-drawCharacter (Miss c) = withAttr missAttr $ str [c]-drawCharacter (Empty c) = withAttr emptyAttr $ str [c]+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@@ -34,73 +42,86 @@ drawLine [] = str " " drawLine ls = foldl1 (<+>) $ map drawCharacter ls -drawPage :: State -> Widget ()-drawPage s = foldl (<=>) emptyWidget $ map drawLine $ page s+drawText :: State -> Widget ()+drawText s = padBottom (Pad 2) . foldl (<=>) emptyWidget . map drawLine $ page s drawResults :: State -> Widget ()-drawResults s = str $- "You typed " ++ x ++ " characters in " ++ y ++ " seconds.\n\n" ++- "Words per minute: " ++ show (round $ wpm s) ++ "\n\n" ++- "Accuracy: " ++ show (round $ accuracy s * 100) ++ "%"- where- x = show $ noOfChars s- y = show $ round $ seconds s+drawResults s =+ withAttr resultAttrName . str $+ (show . round $ wpm s) +++ " words per minute • " ++ (show . round $ accuracy s * 100) ++ "% accuracy" draw :: State -> [Widget ()] draw s- | hasEnded s = pure $ center $ drawResults s- | isErrorFree s = pure $ center p- | otherwise = pure $ center $ border p- where- p = padAll 1 $ showCursor () (Location $ cursor s) $ drawPage s--handleEnter :: State -> EventM () (Next State)-handleEnter s- | hasEnded s = halt s- | not $ onLastLine s = continue $ applyEnter s- | isComplete $ applyChar '\n' s = do- now <- liftIO getCurrentTime- continue $ stopClock now s- | otherwise = continue 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- | c == ' ' && atEndOfLine s = handleEnter s+ | isSpace c && isComplete (applyWhitespace s) = do+ now <- liftIO getCurrentTime+ continue $ stopClock now s+ | isSpace c = continue $ applyWhitespace s | hasStarted s = continue $ applyChar c s | otherwise = do now <- liftIO getCurrentTime- continue $ applyChar c $ startClock now s+ continue . applyChar c $ startClock now s handleEvent :: State -> BrickEvent () e -> EventM () (Next State)-handleEvent s (VtyEvent (EvKey key [])) =- case key of- KChar '\t' -> continue $ applyTab s- KChar c -> handleChar c s- KEnter -> handleEnter s- KBS -> continue $ applyBackspace s- _ -> continue s handleEvent s (VtyEvent (EvKey key [MCtrl])) = case key of- KChar 'w' -> continue $ applyBackspaceWord s KChar 'c' -> halt s KChar 'd' -> halt s- _ -> continue 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+ _ -> continue s+ | otherwise =+ case key of+ KChar c -> handleChar c s+ KEnter -> handleChar '\n' s+ KBS -> continue $ applyBackspace s+ _ -> continue s handleEvent s _ = continue s -app :: Attr -> Attr -> App State e ()-app fgEmpty fgError = App- { appDraw = draw- , appChooseCursor = showFirstCursor- , appHandleEvent = handleEvent- , appStartEvent = return- , appAttrMap = const $ attrMap defAttr- [(emptyAttr, fgEmpty), (missAttr, fgError), (borderAttr, fgError)]- }+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 ()+run :: Maybe Word8 -> Maybe Word8 -> String -> IO () run fgEmptyCode fgErrorCode t = do- _ <- defaultMain (app fgEmpty fgError) $ initialState t+ _ <- defaultMain (app emptyAttr errorAttr resultAttr) $ initialState t return ()- where- fgEmpty = fg $ ISOColor fgEmptyCode- fgError = fg $ ISOColor fgErrorCode+ where+ emptyAttr = fg . ISOColor $ fromMaybe 8 fgEmptyCode+ errorAttr = flip withStyle bold . fg . ISOColor $ fromMaybe 1 fgErrorCode+ -- abusing the fgErrorCode to use as a highlight colour for the results here+ resultAttr = fg . ISOColor $ fromMaybe 1 fgErrorCode