diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,4 +1,15 @@ # Changelog for hascard +## 0.2.1.0 +New: +- A certain chunk of a deck of cards can be reviewed using the `-c i/n` CLI option. For example `hascard -c 3/5` will split the deck into 5 chunks, and review the 3rd one. These chunks can be used with the shuffle and amount options too. +- Visual indicator in the deck selector menu for whether the deck is being shuffled or not. +- Shuffling can be toggled inside the deck selector menu using the 's' key. +- Most parsing error messages now show up as a pop-up box with nicer formattting than before. +- The maximum number of recently selected decks stored and shown can now be changed in the settings menu. + +Fixed bugs: +- Flickering when switching between menus is gone. This was done by merging the seperate Brick applications into one. + ## 0.2.0.0 New: - A new type of card is available: reorder the elements. This could break previous definition or open question cards if they had the same format as the new reorder the elements card. In that case change the 1. 2. etc. to something like 1), 2) which is not seen as a reorder type card. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -4,7 +4,6 @@ import UI import Control.Exception (displayException, try) import Control.Monad (void, when) -import Data.Functor (($>)) import Data.Version (showVersion) import Lens.Micro.Platform import Paths_hascard (version) @@ -13,13 +12,16 @@ import System.Directory (makeAbsolute) import System.FilePath (takeExtension) import System.Process (runCommand) -import System.Random.MWC (createSystemRandom, GenIO) +import System.Random.MWC (createSystemRandom) +import qualified Data.Map.Strict as Map (empty) +import qualified Stack data Opts = Opts - { _optFile :: Maybe String - , _optSubset :: Int - , _optShuffle :: Bool - , _optVersion :: Bool + { _optFile :: Maybe String + , _optSubset :: Int + , _optChunk :: Chunk + , _optShuffle :: Bool + , _optVersion :: Bool } makeLenses ''Opts @@ -38,12 +40,13 @@ opts = Opts <$> optional (argument str (metavar "FILE" <> help "A .txt file containing flashcards")) <*> option auto (long "amount" <> short 'a' <> metavar "n" <> help "Use the first n cards in the deck (most useful combined with shuffle)" <> value (-1)) + <*> option auto (long "chunk" <> short 'c' <> metavar "i/n" <> help "Split the deck into n chunks, and review the i'th one. Counting starts at 1." <> value (Chunk 1 1)) <*> switch (long "shuffle" <> short 's' <> help "Randomize card order") <*> switch (long "version" <> short 'v' <> help "Show version number") optsWithHelp :: ParserInfo Opts optsWithHelp = info (opts <**> helper) $ - fullDesc <> progDesc "Run the normal application without argument, or run it directly on a deck of flashcards by providing a text file." + fullDesc <> progDesc "Run the normal application without argument, or run it directly on a deck of flashcards by providing a text file. Options work either way." <> header "Hascard - a TUI for reviewing notes" nothingIf :: (a -> Bool) -> a -> Maybe a @@ -54,22 +57,27 @@ run :: Opts -> IO () run opts = run' (opts ^. optFile) where - mkGlobalState gen = GlobalState {_mwc=gen, _doShuffle=opts^.optShuffle, _subset=nothingIf (<0) (opts^.optSubset) } - run' Nothing = createSystemRandom >>= runBrickFlashcards . mkGlobalState + mkGlobalState gen = GlobalState {_mwc=gen, _doShuffle=opts^.optShuffle, _subset=nothingIf (<0) (opts^.optSubset), _states=Map.empty, _stack=Stack.empty, _chunk=opts^.optChunk } + run' Nothing = createSystemRandom >>= start Nothing . mkGlobalState run' (Just file) = do - let filepath = + let filepath = case takeExtension file of "" -> Just $ file <> ".txt" ".txt" -> Just file _ -> Nothing case filepath of - Nothing -> putStrLn "Incorrect file type, provide a .txt file" + Nothing -> putStrLn "Incorrect file type, provide a .txt file" Just textfile -> do valOrExc <- try (readFile textfile) :: IO (Either IOError String) case valOrExc of Left exc -> putStrLn (displayException exc) Right val -> case parseCards val of - Left parseError -> print parseError - Right result -> + Left parseError -> putStr (errorBundlePretty parseError) + Right result -> do gen <- createSystemRandom - (makeAbsolute textfile >>= addRecent) *> runCardsWithOptions (mkGlobalState gen) result $> () + makeAbsolute textfile >>= addRecent + start (Just result) (mkGlobalState gen) + +start :: Maybe [Card] -> GlobalState -> IO () +start Nothing gs = runBrickFlashcards (gs `goToState` mainMenuState) +start (Just cards) gs = runBrickFlashcards =<< (gs `goToState`) <$> cardsWithOptionsState gs cards diff --git a/hascard.cabal b/hascard.cabal --- a/hascard.cabal +++ b/hascard.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: e6105cfe9b053345660f9321206316f1bf88e4f94f56b7cde5625a5b521fc74b +-- hash: 217faba3ee5ad528be6ef3a365d0be4b6fcd322a10bead39904ac669a0869a05 name: hascard -version: 0.2.0.0 +version: 0.2.1.0 synopsis: A TUI for reviewing notes using 'flashcards' written with markdown-like syntax. description: Hascard is a text-based user interface for reviewing notes using flashcards. Cards are written in markdown-like syntax. Please see the README file on GitHub at for more information. category: Application @@ -30,10 +30,18 @@ library exposed-modules: Debug + DeckHandling + Glue Parser + Recents + Runners + Settings Stack + StateManagement + States Types UI + UI.Attributes UI.BrickHelpers UI.Cards UI.CardSelector @@ -51,12 +59,12 @@ , containers >0.6.0 && <0.7 , directory >=1.3.3 && <1.4 , filepath >=1.4.2 && <1.5 + , megaparsec >=8.0.0 && <8.1 , microlens >=0.4.11 && <0.5 , microlens-platform >=0.4.1 && <0.5 , mwc-random >=0.14 && <0.15 , optparse-applicative >=0.15.1 && <0.16 , ordered-containers >=0.2.2 && <0.3 - , parsec >=3.1.13 && <3.2 , process >=1.6.5 && <1.7 , random-fu >=0.2.7 && <0.3 , strict >=0.3.2 && <0.4 @@ -80,12 +88,12 @@ , directory >=1.3.3 && <1.4 , filepath >=1.4.2 && <1.5 , hascard + , megaparsec >=8.0.0 && <8.1 , microlens >=0.4.11 && <0.5 , microlens-platform >=0.4.1 && <0.5 , mwc-random >=0.14 && <0.15 , optparse-applicative >=0.15.1 && <0.16 , ordered-containers >=0.2.2 && <0.3 - , parsec >=3.1.13 && <3.2 , process >=1.6.5 && <1.7 , random-fu >=0.2.7 && <0.3 , strict >=0.3.2 && <0.4 @@ -110,12 +118,12 @@ , directory >=1.3.3 && <1.4 , filepath >=1.4.2 && <1.5 , hascard + , megaparsec >=8.0.0 && <8.1 , microlens >=0.4.11 && <0.5 , microlens-platform >=0.4.1 && <0.5 , mwc-random >=0.14 && <0.15 , optparse-applicative >=0.15.1 && <0.16 , ordered-containers >=0.2.2 && <0.3 - , parsec >=3.1.13 && <3.2 , process >=1.6.5 && <1.7 , random-fu >=0.2.7 && <0.3 , strict >=0.3.2 && <0.4 diff --git a/src/DeckHandling.hs b/src/DeckHandling.hs new file mode 100644 --- /dev/null +++ b/src/DeckHandling.hs @@ -0,0 +1,29 @@ +module DeckHandling where +import Data.Random +import Lens.Micro.Platform +import States +import Types + +doRandomization :: GlobalState -> [Card] -> IO [Card] +doRandomization state cards = + let n = length cards in do + cards' <- if state^.doShuffle then sampleFrom (state^.mwc) (shuffleN n cards) else return cards + return $ maybe cards' (`take` cards') (state^.subset) + +doChunking :: Chunk -> [Card] -> [Card] +doChunking (Chunk i n) cards = + splitIntoNChunks n cards !! (i-1) + +splitIntoNChunks :: Int -> [a] -> [[a]] +splitIntoNChunks n xs = + let (q, r) = length xs `quotRem` n + qs = replicate n q + rs = replicate r 1 ++ repeat 0 + chunkSizes = zipWith (+) qs rs + in makeChunksOfSizes chunkSizes xs + +makeChunksOfSizes :: [Int] -> [a] -> [[a]] +makeChunksOfSizes [] _ = [] +makeChunksOfSizes (n:ns) xs = + let (chunk, rest) = splitAt n xs + in chunk : makeChunksOfSizes ns rest diff --git a/src/Glue.hs b/src/Glue.hs new file mode 100644 --- /dev/null +++ b/src/Glue.hs @@ -0,0 +1,46 @@ +module Glue where +import Brick +import States +import StateManagement +import qualified UI.MainMenu as MM +import qualified UI.Settings as S +import qualified UI.Info as I +import qualified UI.CardSelector as CS +import qualified UI.FileBrowser as FB +import qualified UI.Cards as C + +globalApp :: App GlobalState Event Name +globalApp = App + { appDraw = drawUI + , appChooseCursor = showFirstCursor + , appHandleEvent = handleEvent + , appStartEvent = return + , appAttrMap = handleAttrMap + } + +drawUI :: GlobalState -> [Widget Name] +drawUI gs = case getState gs of + MainMenuState s -> MM.drawUI s + SettingsState s -> S.drawUI s + InfoState s -> I.drawUI s + CardSelectorState s -> CS.drawUI gs s + FileBrowserState s -> FB.drawUI s + CardsState s -> C.drawUI s + +handleEvent :: GlobalState -> BrickEvent Name Event -> EventM Name (Next GlobalState) +handleEvent gs ev = case getState gs of + MainMenuState s -> MM.handleEvent gs s ev + SettingsState s -> S.handleEvent gs s ev + InfoState s -> I.handleEvent gs s ev + CardSelectorState s -> CS.handleEvent gs s ev + FileBrowserState s -> FB.handleEvent gs s ev + CardsState s -> C.handleEvent gs s ev + +handleAttrMap :: GlobalState -> AttrMap +handleAttrMap gs = case getState gs of + MainMenuState _ -> MM.theMap + SettingsState _ -> S.theMap + InfoState _ -> I.theMap + CardSelectorState _ -> CS.theMap + FileBrowserState _ -> FB.theMap + CardsState _ -> C.theMap diff --git a/src/Parser.hs b/src/Parser.hs --- a/src/Parser.hs +++ b/src/Parser.hs @@ -1,16 +1,20 @@ -{-# LANGUAGE DataKinds, ExistentialQuantification, GADTs, KindSignatures #-} -module Parser (parseCards) where +{-# LANGUAGE DataKinds, ExistentialQuantification, GADTs, KindSignatures, OverloadedStrings #-} +module Parser (parseCards, errorBundlePretty) where +import Data.Void import qualified Data.List.NonEmpty as NE -import Text.Parsec +import Text.Megaparsec +import Text.Megaparsec.Char import Types +type Parser = Parsec Void String + uncurry3 f (a, b, c) = f a b c -parseCards :: String -> Either ParseError [Card] +parseCards :: String -> Either (ParseErrorBundle String Void) [Card] parseCards = parse pCards "failed when parsing cards" -pCards = pCard `sepEndBy1` seperator +pCards = (pCard `sepEndBy1` seperator) <* eof pCard = uncurry3 MultipleChoice<$> try pMultChoice <|> uncurry MultipleAnswer <$> try pMultAnswer <|> uncurry Reorder <$> try pReorder @@ -20,8 +24,8 @@ pHeader = do many eol char '#' - spaces - many notEOL + spaceChar + many (noneOf ['\n', '\r']) pMultChoice = do header <- pHeader @@ -31,9 +35,9 @@ return (header, correct, incorrects) pChoice = do - kind <- oneOf "*-" - space - text <- manyTill anyChar $ lookAhead (try (try choicePrefix <|> seperator <|> eof')) + kind <- oneOf ['*','-'] + spaceChar + text <- manyTill anySingle $ lookAhead (try (try choicePrefix <|> seperator <|> eof')) return (kind, text) choicePrefix = string "- " @@ -47,9 +51,9 @@ pOption = do char '[' - kind <- oneOf "*x " + kind <- oneOf ['*','x',' '] string "] " - text <- manyTill anyChar $ lookAhead (try (seperator <|> string "[" <|> eof')) + text <- manyTill anySingle $ lookAhead (try (seperator <|> string "[" <|> eof')) return $ makeOption kind text pReorder = do @@ -64,11 +68,11 @@ pReorderElement = do int <- pReorderPrefix - text <- manyTill anyChar $ lookAhead (try (try seperator <|> try pReorderPrefix <|> eof')) + text <- manyTill anySingle $ lookAhead (try (try seperator <|> try pReorderPrefix <|> eof')) return (read int, text) pReorderPrefix = do - int <- many1 digit + int <- some digitChar string ". " return int @@ -87,13 +91,13 @@ (pre, gap) <- pGap Perforated pre gap <$> pSentence -chars = escaped <|> anyChar +chars = escaped <|> anySingle escaped = char '\\' >> char '_' pGap = do pre <- manyTill chars $ lookAhead (try gappedSpecialChars) char '_' - gaps <- manyTill (noneOf "_|") (lookAhead (try gappedSpecialChars)) `sepBy1` string "|" + gaps <- manyTill (noneOf ['_','|']) (lookAhead (try gappedSpecialChars)) `sepBy1` string "|" char '_' return (pre, NE.fromList gaps) @@ -102,7 +106,7 @@ <|> string "_" pNormal = do - text <- manyTill (noneOf "_") $ lookAhead $ try $ gappedSpecialChars <|> eof' + text <- manyTill (noneOf ['_']) $ lookAhead $ try $ gappedSpecialChars <|> eof' return (Normal text) pDef = do @@ -111,12 +115,6 @@ descr <- manyTill chars $ lookAhead $ try $ seperator <|> eof' return (header, descr) -eol = try (string "\n\r") - <|> try (string "\r\n") - <|> string "\n" - <|> string "\r" - "end of line" - eof' = eof >> return [] "end of file" seperator = do @@ -124,8 +122,6 @@ many eol return sep -notEOL = noneOf "\n\r" - makeMultipleChoice :: [(Char, String)] -> (CorrectOption, [IncorrectOption]) makeMultipleChoice options = makeMultipleChoice' [] [] 0 options where @@ -138,5 +134,5 @@ makeOption :: Char -> String -> Option makeOption kind text - | kind `elem` "*x" = Option Correct text - | otherwise = Option Incorrect text + | kind `elem` ['*','x'] = Option Correct text + | otherwise = Option Incorrect text diff --git a/src/Recents.hs b/src/Recents.hs new file mode 100644 --- /dev/null +++ b/src/Recents.hs @@ -0,0 +1,102 @@ +module Recents where +import Control.Monad (filterM) +import Data.List (sort) +import Settings +import Stack (Stack) +import System.Environment (lookupEnv) +import System.FilePath ((), splitFileName, dropExtension, splitPath, joinPath) +import qualified Stack as S +import qualified System.Directory as D +import qualified System.IO.Strict as IOS (readFile) + +getRecents :: IO (Stack FilePath) +getRecents = do + rf <- getRecentsFile + exists <- D.doesFileExist rf + if exists + then removeDeletedFiles rf *> clampRecents rf + else return S.empty + +removeDeletedFiles :: FilePath -> IO (Stack FilePath) +removeDeletedFiles fp = do + contents <- IOS.readFile fp + existing <- S.fromList <$> filterM D.doesFileExist (lines contents) + writeRecents existing + return existing + +parseRecents :: String -> Stack FilePath +parseRecents = S.fromList . lines + +clampRecents :: FilePath -> IO (Stack FilePath) +clampRecents fp = do + rs <- parseRecents <$> IOS.readFile fp + maxRs <- getMaxRecents + let clamped = S.takeStack maxRs rs + writeRecents clamped + return clamped + +addRecent :: FilePath -> IO () +addRecent fp = do + rs <- getRecents + maxRecents <- getMaxRecents + let rs' = fp `S.insert` rs + rs'' = if S.size rs' <= maxRecents + then rs' + else S.removeLast rs' + writeRecents rs'' + +writeRecents :: Stack FilePath -> IO () +writeRecents stack = do + file <- getRecentsFile + writeFile file $ unlines (S.toList stack) + +getRecentsFile :: IO FilePath +getRecentsFile = do + maybeSnap <- lookupEnv "SNAP_USER_DATA" + xdg <- D.getXdgDirectory D.XdgData "hascard" + + let dir = case maybeSnap of + Just path | not (null path) -> path + | otherwise -> xdg + Nothing -> xdg + D.createDirectoryIfMissing True dir + + return (dir "recents") + +initLast :: [a] -> ([a], a) +initLast [x] = ([], x) +initLast (x:xs) = let (xs', y) = initLast xs + in (x:xs', y) + +shortenFilepaths :: [FilePath] -> [FilePath] +shortenFilepaths fps = uncurry shortenFilepaths' (unzip (map ((\(pre, fn) -> (pre, dropExtension fn)) . splitFileName) fps)) + where + shortenFilepaths' prefixes abbreviations = + let ds = duplicates abbreviations in + if null ds then abbreviations else + shortenFilepaths' + (flip map (zip [0..] prefixes) ( + \(i, pre) -> if i `elem` ds then + joinPath (init (splitPath pre)) else pre + )) + (flip map (zip [0..] abbreviations) ( + \(i, abbr) -> if i `elem` ds then + last (splitPath (prefixes !! i)) ++ abbr + else abbr) ) + + +duplicates :: Eq a => [a] -> [Int] +duplicates = sort . map fst . duplicates' 0 [] [] + where duplicates' _ _ acc [] = acc + duplicates' i seen acc (x:xs) = duplicates' (i+1) ((i, x) : seen) acc' xs + where acc' = case (getPairsWithValue x acc, getPairsWithValue x seen) of + ([], []) -> acc + ([], ys) -> (i, x) : ys ++ acc + (_, _) -> (i, x) : acc + -- acc' = if getPairsWithValue x seen then (i, x) : acc else acc + +getPairsWithValue :: Eq a => a -> [(Int, a)] -> [(Int, a)] +getPairsWithValue _ [] = [] +getPairsWithValue y ((i, x):xs) + | x == y = (i, x) : getPairsWithValue y xs + | otherwise = getPairsWithValue y xs diff --git a/src/Runners.hs b/src/Runners.hs new file mode 100644 --- /dev/null +++ b/src/Runners.hs @@ -0,0 +1,81 @@ +module Runners where +import Brick.Widgets.FileBrowser +import DeckHandling +import Data.Maybe (fromMaybe) +import Recents +import Lens.Micro.Platform +import Settings +import States +import Types +import qualified Brick.Widgets.List as L +import qualified Data.Vector as Vec +import qualified Stack as S + +cardSelectorState :: IO State +cardSelectorState = do + rs <- getRecents + maxRs <- getMaxRecents + let prettyRecents = shortenFilepaths (S.toList rs) + options = Vec.fromList (prettyRecents ++ ["Select file from system"]) + initialState = CSS + { _list = L.list Ordinary options 1 + , _exception = Nothing + , _recents = rs + , _maxRecentsToShow = maxRs } + return $ CardSelectorState initialState + +mainMenuState :: State +mainMenuState = + let options = Vec.fromList + [ "Select" + , "Info" + , "Settings" + , "Quit" ] + + initialState = MMS (L.list Ordinary options 1) in + MainMenuState initialState + +safeHead :: [a] -> Maybe a +safeHead [] = Nothing +safeHead (x:_) = Just x + +cardsState :: [Card] -> IO State +cardsState deck = do + hints <- getShowHints + controls <- getShowControls + + let mFirstCard = safeHead deck + firstCard = fromMaybe (Definition "Empty deck" "Click enter to go back.") mFirstCard + deck' = maybe [firstCard] (const deck) mFirstCard + + initialState = + CS { _cards = deck' + , _index = 0 + , _currentCard = firstCard + , _cardState = defaultCardState firstCard + , _nCards = length deck' + , _showHints = hints + , _showControls = controls } + + return $ CardsState initialState + +cardsWithOptionsState :: GlobalState -> [Card] -> IO State +cardsWithOptionsState gs cards = + let chunked = doChunking (gs^.chunk) cards + in doRandomization gs chunked >>= cardsState + +infoState :: State +infoState = InfoState () + +fileBrowserState :: IO State +fileBrowserState = do + browser <- newFileBrowser selectNonDirectories Ordinary Nothing + let filteredBrowser = setFileBrowserEntryFilter (Just (entryFilter False)) browser + return $ FileBrowserState (FBS filteredBrowser Nothing [] Nothing False) + +entryFilter :: Bool -> FileInfo -> Bool +entryFilter acceptHidden info = fileExtensionMatch "txt" info && (acceptHidden || + case fileInfoFilename info of + ".." -> True + '.' : _ -> False + _ -> True) diff --git a/src/Settings.hs b/src/Settings.hs new file mode 100644 --- /dev/null +++ b/src/Settings.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE OverloadedStrings, RankNTypes #-} +module Settings where +import Brick +import Brick.Forms +import UI.BrickHelpers +import Data.Char (isDigit) +import States +import Data.Maybe +import System.FilePath (()) +import System.Environment (lookupEnv) +import Text.Read (readMaybe) +import Lens.Micro.Platform +import qualified Data.Text as T +import qualified Graphics.Vty as V +import qualified System.Directory as D + +getShowHints :: IO Bool +getShowHints = do + settings <- getSettings + return $ settings ^. hints + +getShowControls :: IO Bool +getShowControls = do + settings <- getSettings + return $ settings ^. controls + +getUseEscapeCode :: IO Bool +getUseEscapeCode = do + settings <- getSettings + return $ settings ^. escapeCode + +getMaxRecents :: IO Int +getMaxRecents = do + settings <- getSettings + return $ settings ^. maxRecents + +getSettings :: IO Settings +getSettings = do + sf <- getSettingsFile + exists <- D.doesFileExist sf + if exists + then do + maybeSettings <- parseSettings <$> readFile sf + maybe (return defaultSettings) return maybeSettings + else return defaultSettings + +parseSettings :: String -> Maybe Settings +parseSettings = readMaybe + +getSettingsFile :: IO FilePath +getSettingsFile = do + maybeSnap <- lookupEnv "SNAP_USER_DATA" + xdg <- D.getXdgDirectory D.XdgConfig "hascard" + + let dir = case maybeSnap of + Just path | not (null path) -> path + | otherwise -> xdg + Nothing -> xdg + D.createDirectoryIfMissing True dir + return (dir "settings") + +defaultSettings :: Settings +defaultSettings = FormState { _hints=False, _controls=True, _escapeCode=False, _maxRecents=5} + +setSettings :: Settings -> IO () +setSettings settings = do + sf <- getSettingsFile + writeFile sf (show settings) + +settingsState :: IO State +settingsState = SettingsState . mkForm <$> getSettings + +mkForm :: Settings -> Form Settings e Name +mkForm = + let label s w = padBottom (Pad 1) $ padRight (Pad 2) (strWrap s) <+> w + + in newForm + [ label "Draw hints using underscores for definition cards" @@= yesnoField hints HintsField "" + , label "Show controls at the bottom of screen" @@= yesnoField controls ControlsField "" + , label "Use the '-n \\e[5 q' escape code to change the cursor to a blinking line on start" @@= yesnoField escapeCode EscapeCodeField "" + , label "Maximum number of recently selected files stored" @@= hLimit 3 @@= naturalNumberField maxRecents MaxRecentsField "" ] + +yesnoField :: (Ord n, Show n) => Lens' s Bool -> n -> T.Text -> s -> FormFieldState s e n +yesnoField stLens name label initialState = + let initVal = initialState ^. stLens + + handleEvent (MouseDown n _ _ _) s | n == name = return $ not s + handleEvent (VtyEvent (V.EvKey (V.KChar ' ') [])) s = return $ not s + handleEvent (VtyEvent (V.EvKey V.KEnter [])) s = return $ not s + handleEvent _ s = return s + + in FormFieldState { formFieldState = initVal + , formFields = [ FormField name Just True + (renderYesno label name) + handleEvent ] + , formFieldLens = stLens + , formFieldRenderHelper = id + , formFieldConcat = vBox } + +renderYesno :: T.Text -> n -> Bool -> Bool -> Widget n +renderYesno label n foc val = + let addAttr = if foc then withDefAttr focusedFormInputAttr else id + in clickable n $ (if val then addAttr (txt "Yes") else addAttr (txt "No") <+> txt " ") <+> txt label + +naturalNumberField :: (Ord n, Show n) => Lens' s Int -> n -> T.Text -> s -> FormFieldState s e n +naturalNumberField stLens name label initialState = + let initVal = initialState ^. stLens + -- clamp s = + + handleEvent (VtyEvent (V.EvKey (V.KChar c) [])) s | isDigit c = return $ if s < 100 then read (show s ++ [c]) else s + handleEvent (VtyEvent (V.EvKey V.KBS [])) s = return $ case show s of + "" -> 0 + xs -> fromMaybe 0 (readMaybe (init xs)) + handleEvent _ s = return s + + in FormFieldState { formFieldState = initVal + , formFields = [ FormField name Just True + (renderNaturalNumber label name) + handleEvent ] + , formFieldLens = stLens + , formFieldRenderHelper = id + , formFieldConcat = vBox } + +renderNaturalNumber :: T.Text -> n -> Bool -> Int -> Widget n +renderNaturalNumber label n foc val = + let addAttr = if foc then withDefAttr focusedFormInputAttr else id + val' = show val + csr = if foc then showCursor n (Location (length val',0)) else id + in csr (addAttr (str val')) <+> txt label <+> hFill ' ' diff --git a/src/Stack.hs b/src/Stack.hs --- a/src/Stack.hs +++ b/src/Stack.hs @@ -9,6 +9,9 @@ empty :: Stack a empty = OS.empty +singleton :: a -> Stack a +singleton = OS.singleton + insert :: Ord a => a -> Stack a -> Stack a insert = (|<) @@ -18,14 +21,30 @@ head :: Stack a -> a head = (`unsafeElemAt` 0) +safeHead :: Stack a -> Maybe a +safeHead = (`elemAt` 0) + last :: Stack a -> a last s = s `unsafeElemAt` (Stack.size s - 1) +pop :: Ord a => Stack a -> Stack a +pop s = OS.delete (Stack.head s) s + +popWithInfo :: Ord a => Stack a -> (Stack a, a, a) +popWithInfo s = let + top = Stack.head s + s' = OS.delete top s + top' = Stack.head s' in + (s', top, top') + tail :: Ord a => Stack a -> [a] -tail s = toList $ OS.delete (Stack.head s) s +tail = toList . pop elemAt :: Stack a -> Int -> Maybe a elemAt = OS.elemAt + +takeStack :: Ord a => Int -> Stack a -> Stack a +takeStack n = fromList . take n . toList unsafeElemAt :: Stack a -> Int -> a unsafeElemAt s = fromJust . OS.elemAt s diff --git a/src/StateManagement.hs b/src/StateManagement.hs new file mode 100644 --- /dev/null +++ b/src/StateManagement.hs @@ -0,0 +1,87 @@ +module StateManagement where +import Brick +import Control.Monad.IO.Class +import Data.Maybe (fromJust) +import Lens.Micro.Platform +import Recents +import States hiding (cardState) +import Stack hiding (head) +import qualified Brick.Widgets.List as L +import qualified Data.Vector as Vec +import qualified Data.Map.Strict as M +import qualified Stack + +getMode :: State -> Mode +getMode (MainMenuState _) = MainMenu +getMode (SettingsState _) = Settings +getMode (InfoState _) = Info +getMode (CardSelectorState _) = CardSelector +getMode (FileBrowserState _) = FileBrowser +getMode (CardsState _) = Cards + +getState :: GlobalState -> State +getState = fromJust . safeGetState + +updateState :: GlobalState -> State -> GlobalState +updateState gs s = gs & states %~ M.insert (getMode s) s + +updateMMS :: GlobalState -> MMS -> GlobalState +updateMMS gs s = updateState gs (MainMenuState s) + +updateSS :: GlobalState -> SS -> GlobalState +updateSS gs s = updateState gs (SettingsState s) + +updateIS :: GlobalState -> IS -> GlobalState +updateIS gs s = updateState gs (InfoState s) + +updateCS :: GlobalState -> CS -> GlobalState +updateCS gs s = updateState gs (CardsState s) + +updateCSS :: GlobalState -> CSS -> GlobalState +updateCSS gs s = updateState gs (CardSelectorState s) + +updateInfo :: GlobalState -> IS -> GlobalState +updateInfo gs s = updateState gs (InfoState s) + +updateFBS :: GlobalState -> FBS -> GlobalState +updateFBS gs s = updateState gs (FileBrowserState s) + +goToState :: GlobalState -> State -> GlobalState +goToState gs s = gs & states %~ M.insert (getMode s) s + & stack %~ insert (getMode s) + +moveToState :: GlobalState -> State -> GlobalState +moveToState gs = goToState (popState gs) + +popState :: GlobalState -> GlobalState +popState gs = let + s = gs ^. stack + top = Stack.head s + s' = Stack.pop s in + gs & states %~ M.delete top + & stack .~ s' + +safeGetState :: GlobalState -> Maybe State +safeGetState gs = do + key <- safeHead (gs ^. stack) + M.lookup key (gs ^. states) + +goToModeOrQuit :: GlobalState -> Mode -> EventM n (Next GlobalState) +goToModeOrQuit gs mode = + maybe (halt gs) (continue . goToState gs) $ M.lookup mode (gs ^. states) + +moveToModeOrQuit :: GlobalState -> Mode -> EventM n (Next GlobalState) +moveToModeOrQuit gs mode = + maybe (halt gs) (continue . moveToState gs) $ M.lookup mode (gs ^. states) + +moveToModeOrQuit' :: (State -> IO State) -> GlobalState -> Mode -> EventM n (Next GlobalState) +moveToModeOrQuit' f gs mode = + maybe (halt gs) (\s -> continue . moveToState gs =<< liftIO (f s)) $ M.lookup mode (gs ^. states) + +refreshRecents :: CSS -> IO CSS +refreshRecents s = do + rs <- getRecents + let prettyRecents = shortenFilepaths (toList rs) + options = Vec.fromList (prettyRecents ++ ["Select file from system"]) + return $ s & recents .~ rs + & list .~ L.list Ordinary options 1 diff --git a/src/States.hs b/src/States.hs new file mode 100644 --- /dev/null +++ b/src/States.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE TemplateHaskell #-} +module States where + +import Brick.Forms (Form) +import Brick.Widgets.FileBrowser +import Brick.Widgets.List (List) +import Data.Char (isDigit) +import Data.Map.Strict (Map) +import Lens.Micro.Platform +import System.Random.MWC (GenIO) +import Stack hiding (head) +import Types +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as M + +data Name = HintsField + | ControlsField + | EscapeCodeField + | MaxRecentsField + | Ordinary + deriving (Eq, Ord, Show) +type Event = () + +data Mode = MainMenu + | Settings + | Info + | CardSelector + | FileBrowser + | Cards + deriving (Show, Eq, Ord) + +data State = MainMenuState MMS + | SettingsState SS + | InfoState IS + | CardSelectorState CSS + | FileBrowserState FBS + | CardsState CS + +data Chunk = Chunk Int Int + +instance Show Chunk where + show (Chunk i n) = show i <> "/" <> show n + +instance Read Chunk where + readsPrec _ input = + let (i', rest1) = span isDigit input + i = read i' :: Int + (c:rest2) = rest1 + (n', rest3) = span isDigit rest2 + n = read n' :: Int + in [(Chunk i n, rest3) | c `elem` ['/', ' '] && n >= i && i >= 1] + +data GlobalState = GlobalState + { _mwc :: GenIO + , _doShuffle :: Bool + , _subset :: Maybe Int + , _chunk :: Chunk + , _stack :: Stack Mode + , _states :: Map Mode State + } + +data CardState = + DefinitionState + { _flipped :: Bool } + | MultipleChoiceState + { _highlighted :: Int + , _number :: Int + , _tried :: Map Int Bool -- indices of tried choices + } + | MultipleAnswerState + { _highlighted :: Int + , _selected :: Map Int Bool + , _number :: Int + , _entered :: Bool + } + | OpenQuestionState + { _gapInput :: Map Int String + , _highlighted :: Int + , _number :: Int + , _entered :: Bool + , _correctGaps :: Map Int Bool + } + | ReorderState + { _highlighted :: Int + , _grabbed :: Bool + , _order :: Map Int (Int, String) + , _entered :: Bool + , _number :: Int + } + +defaultCardState :: Card -> CardState +defaultCardState Definition{} = DefinitionState { _flipped = False } +defaultCardState (MultipleChoice _ _ ics) = MultipleChoiceState + { _highlighted = 0 + , _number = length ics + 1 + , _tried = M.fromList [(i, False) | i <- [0..length ics]] } +defaultCardState (OpenQuestion _ perforated) = OpenQuestionState + { _gapInput = M.empty + , _highlighted = 0 + , _number = nGapsInPerforated perforated + , _entered = False + , _correctGaps = M.fromList [(i, False) | i <- [0..nGapsInPerforated perforated - 1]] } +defaultCardState (MultipleAnswer _ answers) = MultipleAnswerState + { _highlighted = 0 + , _selected = M.fromList [(i, False) | i <- [0..NE.length answers-1]] + , _entered = False + , _number = NE.length answers } +defaultCardState (Reorder _ elements) = ReorderState + { _highlighted = 0 + , _grabbed = False + , _order = M.fromList (zip [0..] (NE.toList elements)) + , _entered = False + , _number = NE.length elements } + +data CS = CS + { _cards :: [Card] -- list of flashcards + , _index :: Int -- current card index + , _nCards :: Int -- number of cards + , _currentCard :: Card + , _cardState :: CardState + , _showHints :: Bool + , _showControls :: Bool + -- , _incorrectCards :: [Int] -- list of indices of incorrect answers + } + +newtype MMS = MMS + { _l :: List Name String } + +type IS = () + +data Settings = FormState + { _hints :: Bool + , _controls :: Bool + , _escapeCode :: Bool + , _maxRecents :: Int } + deriving (Read, Show) + +type SS = Form Settings Event Name + +data CSS = CSS + { _list :: List Name String + , _exception :: Maybe String + , _recents :: Stack FilePath + , _maxRecentsToShow :: Int + } + +data FBS = FBS + { _fb :: FileBrowser Name + , _exception' :: Maybe String + , _parsedCards :: [Card] + , _filePath :: Maybe FilePath + , _showHidden :: Bool + } + +makeLenses ''State +makeLenses ''MMS +makeLenses ''GlobalState +makeLenses ''CardState +makeLenses ''CS +makeLenses ''Settings +makeLenses ''CSS +makeLenses ''FBS diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -1,16 +1,6 @@ -{-# LANGUAGE TemplateHaskell #-} module Types where import Data.List.NonEmpty (NonEmpty) -import Lens.Micro.Platform -import System.Random.MWC (GenIO) -data GlobalState = GlobalState - { _mwc :: GenIO - , _doShuffle :: Bool - , _subset :: Maybe Int } - -makeLenses ''GlobalState - -- Word Description data Card = Definition String String | OpenQuestion String Perforated @@ -25,7 +15,6 @@ question :: String, elements :: NonEmpty (Int, String) } - deriving Show data Type = Incorrect | Correct diff --git a/src/UI.hs b/src/UI.hs --- a/src/UI.hs +++ b/src/UI.hs @@ -1,10 +1,15 @@ -module UI (module X, module UI) where +module UI (module X, runBrickFlashcards, GlobalState(..), Chunk(..), Card, goToState) where -import UI.Cards as X (runCardsUI) -import UI.CardSelector as X -import UI.MainMenu as X (runMainMenuUI) -import UI.Settings as X -import Types as X (GlobalState (..), mwc, doShuffle, subset) +import UI.CardSelector as X (addRecent) +import Settings as X (getUseEscapeCode) +import Runners as X +import Brick +import Glue +import States +import StateManagement +import Types (Card) runBrickFlashcards :: GlobalState -> IO () -runBrickFlashcards = runMainMenuUI +runBrickFlashcards gs = do + _ <- defaultMain globalApp gs + return () diff --git a/src/UI/Attributes.hs b/src/UI/Attributes.hs new file mode 100644 --- /dev/null +++ b/src/UI/Attributes.hs @@ -0,0 +1,84 @@ +module UI.Attributes where +import Brick +import Brick.Forms +import Graphics.Vty + +titleAttr :: AttrName +titleAttr = attrName "title" + +selectedAttr :: AttrName +selectedAttr = attrName "selected" + +textboxAttr :: AttrName +textboxAttr = attrName "textbox" + +highlightedChoiceAttr :: AttrName +highlightedChoiceAttr = attrName "highlighted choice" + +incorrectChoiceAttr :: AttrName +incorrectChoiceAttr = attrName "incorrect choice" + +correctChoiceAttr :: AttrName +correctChoiceAttr = attrName "correct choice" + +highlightedOptAttr :: AttrName +highlightedOptAttr = attrName "highlighted option" + +selectedOptAttr :: AttrName +selectedOptAttr = attrName "selected option" + +correctOptAttr :: AttrName +correctOptAttr = attrName "correct option" + +incorrectOptAttr :: AttrName +incorrectOptAttr = attrName "incorrect option" + +gapAttr :: AttrName +gapAttr = attrName "gap" + +incorrectGapAttr :: AttrName +incorrectGapAttr = attrName "incorrect gap" + +correctGapAttr :: AttrName +correctGapAttr = attrName "correct gap" + +highlightedElementAttr :: AttrName +highlightedElementAttr = attrName "highlighted element" + +grabbedElementAttr :: AttrName +grabbedElementAttr = attrName "grabbed element" + +correctElementAttr :: AttrName +correctElementAttr = attrName "correct element" + +incorrectElementAttr :: AttrName +incorrectElementAttr = attrName "incorrect element" + +exceptionAttr :: AttrName +exceptionAttr = attrName "exception" + +shuffledAttr :: AttrName +shuffledAttr = attrName "shuffled indicator" + +theMap :: AttrMap +theMap = attrMap defAttr + [ (titleAttr, fg yellow) + , (textboxAttr, defAttr) + , (highlightedChoiceAttr, fg yellow) + , (incorrectChoiceAttr, fg red) + , (correctChoiceAttr, fg green) + , (incorrectGapAttr, fg red `withStyle` underline) + , (correctGapAttr, fg green `withStyle` underline) + , (highlightedOptAttr, fg yellow) + , (selectedOptAttr, fg blue) + , (incorrectOptAttr, fg red) + , (correctOptAttr, fg green) + , (highlightedElementAttr, fg yellow) + , (grabbedElementAttr, fg blue) + , (correctElementAttr, fg green) + , (incorrectElementAttr, fg red) + , (gapAttr, defAttr `withStyle` underline) + , (selectedAttr, fg white `withStyle` underline) + , (exceptionAttr, fg red) + , (focusedFormInputAttr, defAttr `withStyle` underline) + , (shuffledAttr, fg red) ] diff --git a/src/UI/BrickHelpers.hs b/src/UI/BrickHelpers.hs --- a/src/UI/BrickHelpers.hs +++ b/src/UI/BrickHelpers.hs @@ -1,9 +1,12 @@ module UI.BrickHelpers where import Text.Wrap import Brick +import Brick.Widgets.Border import Brick.Widgets.Center import Data.Text (pack) +import Graphics.Vty (imageWidth, imageHeight, charFill) import Lens.Micro +import UI.Attributes hCenteredStrWrap :: String -> Widget n hCenteredStrWrap = hCenteredStrWrapWithAttr id @@ -14,3 +17,31 @@ let w = c^.availWidthL let result = vBox $ map (hCenter . attr . txt) $ wrapTextToLines (WrapSettings {preserveIndentation=False, breakLongWords=True}) w (pack p) render result + +-- Somewhat inefficient because rendering is done just to +-- determine the width and height. So don't use this if the +-- rendering is expensive. +centerPopup :: Widget n -> Widget n +centerPopup widget = Widget Fixed Fixed $ do + c <- getContext + result <- render widget + let w = result^.imageL.to imageWidth + h = result^.imageL.to imageHeight + x = (c^.availWidthL - w) `div` 2 + y = (c^.availHeightL - h) `div` 2 + render $ translateBy (Location (x, y)) widget + +drawException :: Maybe String -> Widget n +drawException Nothing = emptyWidget +drawException (Just e) = + centerPopup $ + borderWithLabel (str "Error") $ + withAttr exceptionAttr $ str e + +-- | Fill all available space with the specified character. Grows only +-- horizontally. +hFill :: Char -> Widget n +hFill ch = + Widget Greedy Fixed $ do + c <- getContext + return $ emptyResult & imageL .~ charFill (c^.attrL) ch (c^.availWidthL) 1 diff --git a/src/UI/CardSelector.hs b/src/UI/CardSelector.hs --- a/src/UI/CardSelector.hs +++ b/src/UI/CardSelector.hs @@ -1,77 +1,55 @@ -{-# LANGUAGE TemplateHaskell #-} module UI.CardSelector - (runCardSelectorUI + ( State + , drawUI + , handleEvent + , theMap , getRecents , getRecentsFile - , addRecent - , runCardsWithOptions) where + , addRecent ) where import Brick import Brick.Widgets.Border import Brick.Widgets.Border.Style import Brick.Widgets.Center import Control.Exception (displayException, try) -import Control.Monad (filterM) import Control.Monad.IO.Class -import Data.Functor (void) -import Data.List (sort) -import Data.Random import Lens.Micro.Platform import Parser -import Stack (Stack) -import System.Environment (lookupEnv) -import System.FilePath ((), splitFileName, dropExtension, splitPath, joinPath) -import Types +import Recents +import Runners +import States +import StateManagement +import UI.Attributes hiding (theMap) import UI.BrickHelpers -import UI.FileBrowser (runFileBrowserUI) -import UI.Cards (runCardsUI, Card) import qualified Brick.Widgets.List as L -import qualified Data.Vector as Vec import qualified Graphics.Vty as V import qualified Stack as S -import qualified System.Directory as D -import qualified System.IO.Strict as IOS (readFile) - -type Event = () -type Name = () -data State = State - { _list :: L.List Name String - , _exception :: Maybe String - , _recents :: Stack FilePath - , _gs :: GlobalState - } - -makeLenses ''State - -app :: App State Event Name -app = App - { appDraw = drawUI - , appChooseCursor = neverShowCursor - , appHandleEvent = handleEvent - , appStartEvent = return - , appAttrMap = const theMap - } +import qualified UI.Attributes as A -drawUI :: State -> [Widget Name] -drawUI s = - [ drawMenu s <=> drawException s ] +drawUI :: GlobalState -> CSS -> [Widget Name] +drawUI gs s = + [ drawException (s ^. exception), drawMenu gs s ] title :: Widget Name -title = withAttr titleAttr $ hCenteredStrWrap "Select a deck of flashcards" +title = withAttr titleAttr $ str "Select a deck of flashcards " -drawMenu :: State -> Widget Name -drawMenu s = +shuffledWidget :: Bool -> Widget Name +shuffledWidget shuffled = withAttr shuffledAttr $ str $ + if shuffled then "(Shuffled)" else "" + +drawMenu :: GlobalState -> CSS -> Widget Name +drawMenu gs s = joinBorders $ center $ withBorderStyle unicodeRounded $ border $ hLimitPercent 60 $ - title <=> + hCenter (title <+> shuffledWidget (gs^.doShuffle)) <=> hBorder <=> hCenter (drawList s) -drawList :: State -> Widget Name -drawList s = vLimit 6 $ +drawList :: CSS -> Widget Name +drawList s = vLimit (s ^. maxRecentsToShow + 1) $ L.renderListWithIndex (drawListElement l) True l where l = s ^. list @@ -80,171 +58,52 @@ where wAttr1 = if selected then withDefAttr selectedAttr else id wAttr2 = if i == length l - 1 then withAttr lastElementAttr else id -drawException :: State -> Widget Name -drawException s = case s ^. exception of - Nothing -> emptyWidget - Just exc -> withAttr exceptionAttr $ strWrap exc - -titleAttr :: AttrName -titleAttr = attrName "title" - -selectedAttr :: AttrName -selectedAttr = attrName "selected" - lastElementAttr :: AttrName lastElementAttr = attrName "last element" -exceptionAttr :: AttrName -exceptionAttr = attrName "exception" - theMap :: AttrMap -theMap = attrMap V.defAttr +theMap = applyAttrMappings [ (L.listAttr, V.defAttr) , (selectedAttr, fg V.white `V.withStyle` V.underline) , (titleAttr, fg V.yellow) - , (lastElementAttr, fg V.blue) - , (exceptionAttr, fg V.red) ] - -handleEvent :: State -> BrickEvent Name Event -> EventM Name (Next State) -handleEvent s@State{_list=l} (VtyEvent e) = - case e of - V.EvKey (V.KChar 'c') [V.MCtrl] -> halt s - V.EvKey V.KEsc [] -> halt s - - _ -> do l' <- L.handleListEventVi L.handleListEvent e l - let s' = (s & list .~ l') in - case e of - V.EvKey V.KEnter [] -> - case L.listSelectedElement l' of - Nothing -> continue s' - Just (_, "Select file from system") -> suspendAndResume $ runFileBrowser s' - Just (i, _) -> do - let fp = (s' ^. recents) `S.unsafeElemAt` i - fileOrExc <- liftIO (try (readFile fp) :: IO (Either IOError String)) - case fileOrExc of - Left exc -> continue (s' & exception ?~ displayException exc) - Right file -> case parseCards file of - Left parseError -> continue (s' & exception ?~ show parseError) - Right result -> suspendAndResume $ do - s'' <- addRecentInternal s' fp - _ <- runCardsWithOptions (s^.gs) result - return (s'' & exception .~ Nothing) - _ -> continue s' - -handleEvent l _ = continue l - -runCardSelectorUI :: GlobalState -> IO () -runCardSelectorUI gs = do - rs <- getRecents - let prettyRecents = shortenFilepaths (S.toList rs) - let options = Vec.fromList (prettyRecents ++ ["Select file from system"]) - let initialState = State (L.list () options 1) Nothing rs gs - _ <- defaultMain app initialState - return () - -getRecents :: IO (Stack FilePath) -getRecents = do - rf <- getRecentsFile - exists <- D.doesFileExist rf - if exists - then removeDeletedFiles rf - else return S.empty + , (lastElementAttr, fg V.blue) ] A.theMap -removeDeletedFiles :: FilePath -> IO (Stack FilePath) -removeDeletedFiles fp = do - file <- IOS.readFile fp - existing <- S.fromList <$> filterM D.doesFileExist (lines file) - writeRecents existing - return existing +handleEvent :: GlobalState -> CSS -> BrickEvent Name Event -> EventM Name (Next GlobalState) +handleEvent gs s@CSS{_list=l, _exception=exc} (VtyEvent ev) = + let update = updateCSS gs + continue' = continue . update + halt' = continue . popState in + case (exc, ev) of + (Just _, _) -> continue' $ s & exception .~ Nothing + (_, e) -> case e of + V.EvKey (V.KChar 'c') [V.MCtrl] -> halt' gs + V.EvKey V.KEsc [] -> halt' gs + V.EvKey (V.KChar 's') [] -> continue (gs & doShuffle %~ not) -maxRecents :: Int -maxRecents = 5 + _ -> do l' <- L.handleListEventVi L.handleListEvent e l + let s' = (s & list .~ l') in + case e of + V.EvKey V.KEnter [] -> + case L.listSelectedElement l' of + Nothing -> continue' s' + Just (_, "Select file from system") -> + let gs' = update s' in continue =<< (gs' `goToState`) <$> liftIO fileBrowserState + Just (i, _) -> do + let fp = (s' ^. recents) `S.unsafeElemAt` i + fileOrExc <- liftIO (try (readFile fp) :: IO (Either IOError String)) + case fileOrExc of + Left exc -> continue' (s' & exception ?~ displayException exc) + Right file -> case parseCards file of + Left parseError -> continue' (s' & exception ?~ errorBundlePretty parseError) + Right result -> continue =<< liftIO (do + s'' <- addRecentInternal s' fp + let gs' = update s'' + (gs' `goToState`) <$> cardsWithOptionsState gs' result) + _ -> continue' s' -addRecent :: FilePath -> IO () -addRecent fp = do - rs <- getRecents - let rs' = fp `S.insert` rs - rs'' = if S.size rs' <= maxRecents - then rs' - else S.removeLast rs' - writeRecents rs'' +handleEvent gs _ _ = continue gs -addRecentInternal :: State -> FilePath -> IO State +addRecentInternal :: CSS -> FilePath -> IO CSS addRecentInternal s fp = do addRecent fp refreshRecents s - -writeRecents :: Stack FilePath -> IO () -writeRecents stack = do - file <- getRecentsFile - writeFile file $ unlines (S.toList stack) - -getRecentsFile :: IO FilePath -getRecentsFile = do - maybeSnap <- lookupEnv "SNAP_USER_DATA" - xdg <- D.getXdgDirectory D.XdgData "hascard" - - let dir = case maybeSnap of - Just path | not (null path) -> path - | otherwise -> xdg - Nothing -> xdg - D.createDirectoryIfMissing True dir - - return (dir "recents") - -initLast :: [a] -> ([a], a) -initLast [x] = ([], x) -initLast (x:xs) = let (xs', y) = initLast xs - in (x:xs', y) - -shortenFilepaths :: [FilePath] -> [FilePath] -shortenFilepaths fps = uncurry shortenFilepaths' (unzip (map ((\(pre, fn) -> (pre, dropExtension fn)) . splitFileName) fps)) - where - shortenFilepaths' prefixes abbreviations = - let ds = duplicates abbreviations in - if null ds then abbreviations else - shortenFilepaths' - (flip map (zip [0..] prefixes) ( - \(i, pre) -> if i `elem` ds then - joinPath (init (splitPath pre)) else pre - )) - (flip map (zip [0..] abbreviations) ( - \(i, abbr) -> if i `elem` ds then - last (splitPath (prefixes !! i)) ++ abbr - else abbr) ) - - -duplicates :: Eq a => [a] -> [Int] -duplicates = sort . map fst . duplicates' 0 [] [] - where duplicates' _ _ acc [] = acc - duplicates' i seen acc (x:xs) = duplicates' (i+1) ((i, x) : seen) acc' xs - where acc' = case (getPairsWithValue x acc, getPairsWithValue x seen) of - ([], []) -> acc - ([], ys) -> (i, x) : ys ++ acc - (_, _) -> (i, x) : acc - -- acc' = if getPairsWithValue x seen then (i, x) : acc else acc - -getPairsWithValue :: Eq a => a -> [(Int, a)] -> [(Int, a)] -getPairsWithValue y [] = [] -getPairsWithValue y ((i, x):xs) - | x == y = (i, x) : getPairsWithValue y xs - | otherwise = getPairsWithValue y xs - -refreshRecents :: State -> IO State -refreshRecents s = do - rs <- getRecents - let prettyRecents = shortenFilepaths (S.toList rs) - options = Vec.fromList (prettyRecents ++ ["Select file from system"]) - return $ s & recents .~ rs - & list .~ L.list () options 1 - -runFileBrowser :: State -> IO State -runFileBrowser s = do - result <- runFileBrowserUI - maybe (return s) (\(cards, fp) -> addRecentInternal s fp <* runCardsWithOptions (s^.gs) cards) result - -runCardsWithOptions :: GlobalState -> [Card] -> IO () -runCardsWithOptions state cards = - let n = length cards in do - cards' <- if state^.doShuffle then sampleFrom (state^.mwc) (shuffleN n cards) else return cards - void $ maybe (runCardsUI state cards') (\n -> runCardsUI state (take n cards')) (state^.subset) diff --git a/src/UI/Cards.hs b/src/UI/Cards.hs --- a/src/UI/Cards.hs +++ b/src/UI/Cards.hs @@ -1,17 +1,18 @@ -{-# LANGUAGE TemplateHaskell #-} -module UI.Cards (runCardsUI, Card) where +module UI.Cards (Card, State(..), drawUI, handleEvent, theMap) where import Brick import Lens.Micro.Platform import Types +import States +import StateManagement import Data.Char (isSpace) import Data.List (dropWhileEnd) import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) import Text.Wrap import Data.Text (pack) +import UI.Attributes import UI.BrickHelpers -import UI.Settings (getShowHints, getShowControls) import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Data.Map.Strict as M @@ -20,107 +21,14 @@ import qualified Brick.Widgets.Center as C import qualified Graphics.Vty as V -type Event = () -type Name = () - -data CardState = - DefinitionState - { _flipped :: Bool } - | MultipleChoiceState - { _highlighted :: Int - , _number :: Int - , _tried :: Map Int Bool -- indices of tried choices - } - | MultipleAnswerState - { _highlighted :: Int - , _selected :: Map Int Bool - , _number :: Int - , _entered :: Bool - } - | OpenQuestionState - { _gapInput :: Map Int String - , _highlighted :: Int - , _number :: Int - , _entered :: Bool - , _correctGaps :: Map Int Bool - } - | ReorderState - { _highlighted :: Int - , _grabbed :: Bool - , _order :: Map Int (Int, String) - , _entered :: Bool - , _number :: Int - } - -data State = State - { _cards :: [Card] -- list of flashcards - , _index :: Int -- current card index - , _nCards :: Int -- number of cards - , _currentCard :: Card - , _cardState :: CardState - , _showHints :: Bool - , _showControls :: Bool - -- , _incorrectCards :: [Int] -- list of indices of incorrect answers - } - -makeLenses ''CardState -makeLenses ''State - -defaultCardState :: Card -> CardState -defaultCardState Definition{} = DefinitionState { _flipped = False } -defaultCardState (MultipleChoice _ _ ics) = MultipleChoiceState - { _highlighted = 0 - , _number = length ics + 1 - , _tried = M.fromList [(i, False) | i <- [0..length ics]] } -defaultCardState (OpenQuestion _ perforated) = OpenQuestionState - { _gapInput = M.empty - , _highlighted = 0 - , _number = nGapsInPerforated perforated - , _entered = False - , _correctGaps = M.fromList [(i, False) | i <- [0..nGapsInPerforated perforated - 1]] } -defaultCardState (MultipleAnswer _ answers) = MultipleAnswerState - { _highlighted = 0 - , _selected = M.fromList [(i, False) | i <- [0..NE.length answers-1]] - , _entered = False - , _number = NE.length answers } -defaultCardState (Reorder _ elements) = ReorderState - { _highlighted = 0 - , _grabbed = False - , _order = M.fromList (zip [0..] (NE.toList elements)) - , _entered = False - , _number = NE.length elements } - -app :: App State Event Name -app = App - { appDraw = drawUI - , appChooseCursor = showFirstCursor - , appHandleEvent = handleEvent - , appStartEvent = return - , appAttrMap = const theMap - } - -runCardsUI :: GlobalState -> [Card] -> IO State -runCardsUI gs deck = do - hints <- getShowHints - controls <- getShowControls - - let initialState = State { _cards = deck - , _index = 0 - , _currentCard = head deck - , _cardState = defaultCardState (head deck) - , _nCards = length deck - , _showHints = hints - , _showControls = controls } - defaultMain app initialState - --------------------------------------------------- --------------------- DRAWING --------------------- --------------------------------------------------- -drawUI :: State -> [Widget Name] +drawUI :: CS -> [Widget Name] drawUI s = [drawCardUI s <=> drawInfo s] -drawInfo :: State -> Widget Name +drawInfo :: CS -> Widget Name drawInfo s = if not (s ^. showControls) then emptyWidget else strWrap . ("ESC: quit" <>) $ case s ^. cardState of DefinitionState {} -> ", ENTER: flip card / continue" @@ -136,22 +44,32 @@ withAttr textboxAttr $ hLimitPercent 60 w -drawProgress :: State -> Widget Name +drawProgress :: CS -> Widget Name drawProgress s = C.hCenter $ str (show (s^.index + 1) ++ "/" ++ show (s^.nCards)) -drawCardUI :: State -> Widget Name +drawCardUI :: CS -> Widget Name drawCardUI s = let p = 1 in joinBorders $ drawCardBox $ (<=> drawProgress s) $ case (s ^. cards) !! (s ^. index) of - Definition title descr -> drawHeader title <=> B.hBorder <=> padLeftRight p (drawDef s descr <=> str " ") + Definition title descr -> drawHeader title + <=> B.hBorder + <=> padLeftRight p (drawDef s descr <=> str " ") - MultipleChoice question correct others -> drawHeader question <=> B.hBorder <=> padLeftRight p (drawChoices s (listMultipleChoice correct others) <=> str " ") + MultipleChoice question correct others -> drawHeader question + <=> B.hBorder + <=> padLeftRight p (drawChoices s (listMultipleChoice correct others) <=> str " ") - OpenQuestion title perforated -> drawHeader title <=> B.hBorder <=> padLeftRight p (drawPerforated s perforated <=> str " ") + OpenQuestion title perforated -> drawHeader title + <=> B.hBorder + <=> padLeftRight p (drawPerforated s perforated <=> str " ") - MultipleAnswer question options -> drawHeader question <=> B.hBorder <=> padRight (Pad p) (drawOptions s options <=> str " ") + MultipleAnswer question options -> drawHeader question + <=> B.hBorder + <=> padRight (Pad p) (drawOptions s options <=> str " ") - Reorder question elements -> drawHeader question <=> B.hBorder <=> padLeftRight p (drawReorder s elements <=> str " ") + Reorder question _ -> drawHeader question + <=> B.hBorder + <=> padLeftRight p (drawReorder s <=> str " ") drawHeader :: String -> Widget Name drawHeader title = withAttr titleAttr $ @@ -171,15 +89,15 @@ where descr' = dropWhileEnd isSpace' descr -drawDef :: State -> String -> Widget Name +drawDef :: CS -> String -> Widget Name drawDef s def = if s ^. showHints then drawHintedDef s def else drawNormalDef s def -drawHintedDef :: State -> String -> Widget Name +drawHintedDef :: CS -> String -> Widget Name drawHintedDef s def = case s ^. cardState of DefinitionState {_flipped=f} -> if f then drawDescr def else drawDescr [if isSpace' char then char else '_' | char <- def] _ -> error "impossible: " -drawNormalDef:: State -> String -> Widget Name +drawNormalDef:: CS -> String -> Widget Name drawNormalDef s def = case s ^. cardState of DefinitionState {_flipped=f} -> if f then drawDescr def @@ -201,7 +119,7 @@ then listMultipleChoice' (cStr : opts) (i+1) c' ics else listMultipleChoice' (icStr : opts) (i+1) c' ics' -drawChoices :: State -> [String] -> Widget Name +drawChoices :: CS -> [String] -> Widget Name drawChoices s options = case (s ^. cardState, s ^. currentCard) of (MultipleChoiceState {_highlighted=i, _tried=kvs}, MultipleChoice _ (CorrectOption k _) _) -> vBox formattedOptions @@ -217,7 +135,7 @@ ] _ -> error "impossible" -drawOptions :: State -> NonEmpty Option -> Widget Name +drawOptions :: CS -> NonEmpty Option -> Widget Name drawOptions s = case (s ^. cardState, s ^. currentCard) of (MultipleAnswerState {_highlighted=j, _selected=kvs, _entered=submitted}, _) -> vBox . NE.toList . NE.map drawOption . (`NE.zip` NE.fromList [0..]) @@ -235,16 +153,16 @@ _ -> error "hopefully this is never shown" -drawPerforated :: State -> Perforated -> Widget Name +drawPerforated :: CS -> Perforated -> Widget Name drawPerforated s p = drawSentence s $ perforatedToSentence p -drawSentence :: State -> Sentence -> Widget Name +drawSentence :: CS -> Sentence -> Widget Name drawSentence state sentence = Widget Greedy Fixed $ do c <- getContext let w = c^.availWidthL render $ makeSentenceWidget w state sentence -makeSentenceWidget :: Int -> State -> Sentence -> Widget Name +makeSentenceWidget :: Int -> CS -> Sentence -> Widget Name makeSentenceWidget w state = vBox . fst . makeSentenceWidget' 0 0 where makeSentenceWidget' :: Int -> Int -> Sentence -> ([Widget Name], Bool) @@ -257,7 +175,7 @@ cursor :: Widget Name -> Widget Name -- i is the index of the gap that we are drawing; j is the gap that is currently selected - cursor = if i == j then showCursor () (Location (textWidth gap, 0)) else id + cursor = if i == j then showCursor Ordinary (Location (textWidth gap, 0)) else id correct = M.findWithDefault False i cgs coloring = case (submitted, correct) of @@ -297,8 +215,8 @@ ts' = ts & _last %~ (`T.append` postfix) in (map txt (filter (/=T.empty) ts'), textWidth (last ts'), False) -drawReorder :: State -> NonEmpty (Int, String) -> Widget Name -drawReorder s elements = case (s ^. cardState, s ^. currentCard) of +drawReorder :: CS -> Widget Name +drawReorder s = case (s ^. cardState, s ^. currentCard) of (ReorderState {_highlighted=j, _grabbed=g, _order=kvs, _number=n, _entered=submitted}, Reorder _ _) -> vBox . flip map (map (\i -> (i, kvs M.! i)) [0..n-1]) $ \(i, (k, text)) -> @@ -320,162 +238,167 @@ ---------------------------------------------------- ---------------------- Events ---------------------- ---------------------------------------------------- +halt' :: GlobalState -> EventM n (Next GlobalState) +halt' = flip (moveToModeOrQuit' (\(CardSelectorState s) -> CardSelectorState <$> refreshRecents s)) CardSelector -handleEvent :: State -> BrickEvent Name Event -> EventM Name (Next State) -handleEvent s (VtyEvent e) = case e of - V.EvKey V.KEsc [] -> halt s - V.EvKey (V.KChar 'c') [V.MCtrl] -> halt s - V.EvKey V.KRight [V.MCtrl] -> next s - V.EvKey V.KLeft [V.MCtrl] -> previous s +handleEvent :: GlobalState -> CS -> BrickEvent Name Event -> EventM Name (Next GlobalState) +handleEvent gs s (VtyEvent e) = + let update = updateCS gs + continue' = continue . update in + case e of + V.EvKey V.KEsc [] -> halt' gs + V.EvKey (V.KChar 'c') [V.MCtrl] -> halt' gs + V.EvKey V.KRight [V.MCtrl] -> next gs s + V.EvKey V.KLeft [V.MCtrl] -> previous gs s - ev -> case (s ^. cardState, s ^. currentCard) of - (DefinitionState{_flipped = f}, _) -> - case ev of - V.EvKey V.KEnter [] -> - if f - then next s - else continue $ s & cardState.flipped %~ not - _ -> continue s + ev -> case (s ^. cardState, s ^. currentCard) of + (DefinitionState{_flipped = f}, _) -> + case ev of + V.EvKey V.KEnter [] -> + if f + then next gs s + else continue' $ s & cardState.flipped %~ not + _ -> continue' s - (MultipleChoiceState {_highlighted = i, _number = n, _tried = kvs}, MultipleChoice _ (CorrectOption j _) _) -> - case ev of - V.EvKey V.KUp [] -> continue up - V.EvKey (V.KChar 'k') [] -> continue up - V.EvKey V.KDown [] -> continue down - V.EvKey (V.KChar 'j') [] -> continue down + (MultipleChoiceState {_highlighted = i, _number = n, _tried = kvs}, MultipleChoice _ (CorrectOption j _) _) -> + case ev of + V.EvKey V.KUp [] -> continue' up + V.EvKey (V.KChar 'k') [] -> continue' up + V.EvKey V.KDown [] -> continue' down + V.EvKey (V.KChar 'j') [] -> continue' down - V.EvKey V.KEnter [] -> - if frozen - then next s - else continue $ s & cardState.tried %~ M.insert i True + V.EvKey V.KEnter [] -> + if frozen + then next gs s + else continue' $ s & cardState.tried %~ M.insert i True - _ -> continue s + _ -> continue' s - where frozen = M.findWithDefault False j kvs - - down = if i < n-1 && not frozen - then s & (cardState.highlighted) +~ 1 - else s + where frozen = M.findWithDefault False j kvs + + down = if i < n-1 && not frozen + then s & (cardState.highlighted) +~ 1 + else s - up = if i > 0 && not frozen - then s & (cardState.highlighted) -~ 1 - else s - - (MultipleAnswerState {_highlighted = i, _number = n, _entered = submitted}, MultipleAnswer {}) -> - case ev of - V.EvKey V.KUp [] -> continue up - V.EvKey (V.KChar 'k') [] -> continue up - V.EvKey V.KDown [] -> continue down - V.EvKey (V.KChar 'j') [] -> continue down + up = if i > 0 && not frozen + then s & (cardState.highlighted) -~ 1 + else s + + (MultipleAnswerState {_highlighted = i, _number = n, _entered = submitted}, MultipleAnswer {}) -> + case ev of + V.EvKey V.KUp [] -> continue' up + V.EvKey (V.KChar 'k') [] -> continue' up + V.EvKey V.KDown [] -> continue' down + V.EvKey (V.KChar 'j') [] -> continue' down - V.EvKey (V.KChar 'c') [] -> continue $ s & (cardState.entered) .~ True + V.EvKey (V.KChar 'c') [] -> continue' $ s & (cardState.entered) .~ True - V.EvKey V.KEnter [] -> - if frozen - then next s - else continue $ s & cardState.selected %~ M.adjust not i + V.EvKey V.KEnter [] -> + if frozen + then next gs s + else continue' $ s & cardState.selected %~ M.adjust not i - _ -> continue s + _ -> continue' s - where frozen = submitted - - down = if i < n-1 && not frozen - then s & (cardState.highlighted) +~ 1 - else s + where frozen = submitted + + down = if i < n-1 && not frozen + then s & (cardState.highlighted) +~ 1 + else s - up = if i > 0 && not frozen - then s & (cardState.highlighted) -~ 1 - else s + up = if i > 0 && not frozen + then s & (cardState.highlighted) -~ 1 + else s - (OpenQuestionState {_highlighted = i, _number = n, _gapInput = kvs, _correctGaps = cGaps}, OpenQuestion _ perforated) -> - let correct = M.foldr (&&) True cGaps in - case ev of - V.EvKey (V.KFun 1) [] -> continue $ - s & cardState.gapInput .~ correctAnswers - & cardState.entered .~ True - & cardState.correctGaps .~ M.fromAscList [(i, True) | i <- [0..n-1]] - where correctAnswers = M.fromAscList $ zip [0..] $ map NE.head (sentenceToGaps (perforatedToSentence perforated)) + (OpenQuestionState {_highlighted = i, _number = n, _gapInput = kvs, _correctGaps = cGaps}, OpenQuestion _ perforated) -> + let correct = M.foldr (&&) True cGaps in + case ev of + V.EvKey (V.KFun 1) [] -> continue' $ + s & cardState.gapInput .~ correctAnswers + & cardState.entered .~ True + & cardState.correctGaps .~ M.fromAscList [(i, True) | i <- [0..n-1]] + where correctAnswers = M.fromAscList $ zip [0..] $ map NE.head (sentenceToGaps (perforatedToSentence perforated)) - V.EvKey (V.KChar '\t') [] -> continue $ - if i < n - 1 && not correct - then s & (cardState.highlighted) +~ 1 - else s & (cardState.highlighted) .~ 0 - - V.EvKey V.KRight [] -> continue $ - if i < n - 1 && not correct - then s & (cardState.highlighted) +~ 1 - else s + V.EvKey (V.KChar '\t') [] -> continue' $ + if i < n - 1 && not correct + then s & (cardState.highlighted) +~ 1 + else s & (cardState.highlighted) .~ 0 + + V.EvKey V.KRight [] -> continue' $ + if i < n - 1 && not correct + then s & (cardState.highlighted) +~ 1 + else s - V.EvKey V.KLeft [] -> continue $ - if i > 0 && not correct - then s & (cardState.highlighted) -~ 1 - else s + V.EvKey V.KLeft [] -> continue' $ + if i > 0 && not correct + then s & (cardState.highlighted) -~ 1 + else s - V.EvKey (V.KChar c) [] -> continue $ - if correct then s else s & cardState.gapInput.at i.non "" %~ (++[c]) + V.EvKey (V.KChar c) [] -> continue' $ + if correct then s else s & cardState.gapInput.at i.non "" %~ (++[c]) - V.EvKey V.KEnter [] -> if correct then next s else continue s' - where sentence = perforatedToSentence perforated - gaps = sentenceToGaps sentence + V.EvKey V.KEnter [] -> if correct then next gs s else continue' s' + where sentence = perforatedToSentence perforated + gaps = sentenceToGaps sentence - s' = s & (cardState.correctGaps) %~ M.mapWithKey (\j _ -> M.findWithDefault "" j kvs `elem` gaps !! j) & (cardState.entered) .~ True + s' = s & (cardState.correctGaps) %~ M.mapWithKey (\j _ -> M.findWithDefault "" j kvs `elem` gaps !! j) & (cardState.entered) .~ True - V.EvKey V.KBS [] -> continue $ - if correct then s else s & cardState.gapInput.ix i %~ backspace - where backspace "" = "" - backspace xs = init xs - _ -> continue s - - (ReorderState {_highlighted = i, _entered = submitted, _grabbed=dragging, _number = n }, Reorder _ _) -> - case ev of - V.EvKey V.KUp [] -> continue up - V.EvKey (V.KChar 'k') [] -> continue up - V.EvKey V.KDown [] -> continue down - V.EvKey (V.KChar 'j') [] -> continue down + V.EvKey V.KBS [] -> continue' $ + if correct then s else s & cardState.gapInput.ix i %~ backspace + where backspace "" = "" + backspace xs = init xs + _ -> continue' s + + (ReorderState {_highlighted = i, _entered = submitted, _grabbed=dragging, _number = n }, Reorder _ _) -> + case ev of + V.EvKey V.KUp [] -> continue' up + V.EvKey (V.KChar 'k') [] -> continue' up + V.EvKey V.KDown [] -> continue' down + V.EvKey (V.KChar 'j') [] -> continue' down - V.EvKey (V.KChar 'c') [] -> continue $ s & (cardState.entered) .~ True + V.EvKey (V.KChar 'c') [] -> continue' $ s & (cardState.entered) .~ True - V.EvKey V.KEnter [] -> - if frozen - then next s - else continue $ s & cardState.grabbed %~ not + V.EvKey V.KEnter [] -> + if frozen + then next gs s + else continue' $ s & cardState.grabbed %~ not - _ -> continue s + _ -> continue' s - where frozen = submitted - - down = - case (frozen, i < n - 1, dragging) of - (True, _, _) -> s - (_, False, _) -> s - (_, _, False) -> s & (cardState.highlighted) +~ 1 - (_, _, True) -> s & (cardState.highlighted) +~ 1 - & (cardState.order) %~ interchange i (i+1) + where frozen = submitted + + down = + case (frozen, i < n - 1, dragging) of + (True, _, _) -> s + (_, False, _) -> s + (_, _, False) -> s & (cardState.highlighted) +~ 1 + (_, _, True) -> s & (cardState.highlighted) +~ 1 + & (cardState.order) %~ interchange i (i+1) - up = - case (frozen, i > 0, dragging) of - (True, _, _) -> s - (_, False, _) -> s - (_, _, False) -> s & (cardState.highlighted) -~ 1 - (_, _, True) -> s & (cardState.highlighted) -~ 1 - & (cardState.order) %~ interchange i (i-1) + up = + case (frozen, i > 0, dragging) of + (True, _, _) -> s + (_, False, _) -> s + (_, _, False) -> s & (cardState.highlighted) -~ 1 + (_, _, True) -> s & (cardState.highlighted) -~ 1 + & (cardState.order) %~ interchange i (i-1) - _ -> error "impossible" -handleEvent s _ = continue s + _ -> error "impossible" +handleEvent gs _ _ = continue gs -next :: State -> EventM Name (Next State) -next s - | s ^. index + 1 < length (s ^. cards) = continue . updateState $ s & index +~ 1 - | otherwise = halt s +next :: GlobalState -> CS -> EventM Name (Next GlobalState) +next gs s + | s ^. index + 1 < length (s ^. cards) = continue . updateCS gs . straightenState $ s & index +~ 1 + | otherwise = halt' gs -previous :: State -> EventM Name (Next State) -previous s | s ^. index > 0 = continue . updateState $ s & index -~ 1 - | otherwise = continue s +previous :: GlobalState -> CS -> EventM Name (Next GlobalState) +previous gs s | s ^. index > 0 = continue . updateCS gs . straightenState $ s & index -~ 1 + | otherwise = continue gs -updateState :: State -> State -updateState s = +straightenState :: CS -> CS +straightenState s = let card = (s ^. cards) !! (s ^. index) in s & currentCard .~ card & cardState .~ defaultCardState card @@ -485,75 +408,3 @@ let vali = kvs M.! i valj = kvs M.! j in M.insert j vali (M.insert i valj kvs) - ----------------------------------------------------- --------------------- Attributes -------------------- ----------------------------------------------------- - -titleAttr :: AttrName -titleAttr = attrName "title" - -textboxAttr :: AttrName -textboxAttr = attrName "textbox" - -highlightedChoiceAttr :: AttrName -highlightedChoiceAttr = attrName "highlighted choice" - -incorrectChoiceAttr :: AttrName -incorrectChoiceAttr = attrName "incorrect choice" - -correctChoiceAttr :: AttrName -correctChoiceAttr = attrName "correct choice" - -highlightedOptAttr :: AttrName -highlightedOptAttr = attrName "highlighted option" - -selectedOptAttr :: AttrName -selectedOptAttr = attrName "selected option" - -correctOptAttr :: AttrName -correctOptAttr = attrName "correct option" - -incorrectOptAttr :: AttrName -incorrectOptAttr = attrName "incorrect option" - -gapAttr :: AttrName -gapAttr = attrName "gap" - -incorrectGapAttr :: AttrName -incorrectGapAttr = attrName "incorrect gap" - -correctGapAttr :: AttrName -correctGapAttr = attrName "correct gap" - -highlightedElementAttr :: AttrName -highlightedElementAttr = attrName "highlighted element" - -grabbedElementAttr :: AttrName -grabbedElementAttr = attrName "grabbed element" - -correctElementAttr :: AttrName -correctElementAttr = attrName "correct element" - -incorrectElementAttr :: AttrName -incorrectElementAttr = attrName "incorrect element" - -theMap :: AttrMap -theMap = attrMap V.defAttr - [ (titleAttr, fg V.yellow) - , (textboxAttr, V.defAttr) - , (highlightedChoiceAttr, fg V.yellow) - , (incorrectChoiceAttr, fg V.red) - , (correctChoiceAttr, fg V.green) - , (incorrectGapAttr, fg V.red `V.withStyle` V.underline) - , (correctGapAttr, fg V.green `V.withStyle` V.underline) - , (highlightedOptAttr, fg V.yellow) - , (selectedOptAttr, fg V.blue) - , (incorrectOptAttr, fg V.red) - , (correctOptAttr, fg V.green) - , (highlightedElementAttr, fg V.yellow) - , (grabbedElementAttr, fg V.blue) - , (correctElementAttr, fg V.green) - , (incorrectElementAttr, fg V.red) - , (gapAttr, V.defAttr `V.withStyle` V.underline) - ] diff --git a/src/UI/FileBrowser.hs b/src/UI/FileBrowser.hs --- a/src/UI/FileBrowser.hs +++ b/src/UI/FileBrowser.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -Wall #-} -{-# LANGUAGE OverloadedStrings, TemplateHaskell, TupleSections #-} +{-# LANGUAGE OverloadedStrings, FlexibleInstances #-} -module UI.FileBrowser (runFileBrowserUI) where +module UI.FileBrowser (State, drawUI, handleEvent, theMap) where import Brick import Brick.Widgets.Border @@ -12,35 +12,16 @@ import Control.Monad.IO.Class import Lens.Micro.Platform import Parser -import Types +import States +import StateManagement +import Recents +import Runners +import UI.BrickHelpers +import qualified UI.Attributes as A import qualified Graphics.Vty as V -type Event = () -type Name = () -data State = State - { _fb :: FileBrowser Name - , _exception :: Maybe String - , _cards :: [Card] - , _filePath :: Maybe FilePath - , _showHidden :: Bool - } - -makeLenses ''State - -app :: App State Event Name -app = App - { appDraw = drawUI - , appChooseCursor = neverShowCursor - , appHandleEvent = handleEvent - , appStartEvent = return - , appAttrMap = const theMap - } - -errorAttr :: AttrName -errorAttr = "error" - theMap :: AttrMap -theMap = attrMap V.defAttr +theMap = applyAttrMappings [ (listSelectedFocusedAttr, V.black `on` V.yellow) , (fileBrowserCurrentDirectoryAttr, V.white `on` V.blue) , (fileBrowserSelectionInfoAttr, V.white `on` V.blue) @@ -51,11 +32,10 @@ , (fileBrowserSymbolicLinkAttr, fg V.cyan) , (fileBrowserUnixSocketAttr, fg V.red) , (fileBrowserSelectedAttr, V.white `on` V.magenta) - , (errorAttr, fg V.red) - ] + ] A.theMap -drawUI :: State -> [Widget Name] -drawUI State{_fb=b, _exception=exc} = [center $ ui <=> help] +drawUI :: FBS -> [Widget Name] +drawUI FBS{_fb=b, _exception'=exc} = [drawException exc, center $ ui <=> help] where ui = hCenter $ vLimit 15 $ @@ -67,54 +47,42 @@ , hCenter $ txt "/: search, Ctrl-C or Esc: cancel search" , hCenter $ txt "Enter: change directory or select file" , hCenter $ txt "Esc: quit" - , case exc of - Nothing -> emptyWidget - Just e -> hCenter $ withDefAttr errorAttr $ - str e ] -handleEvent :: State -> BrickEvent Name Event -> EventM Name (Next State) -handleEvent s@State{_fb=b} (VtyEvent ev) = - case ev of +handleEvent :: GlobalState -> FBS -> BrickEvent Name Event -> EventM Name (Next GlobalState) +handleEvent gs s@FBS{_fb=b, _exception'=excep} (VtyEvent ev) = + let update = updateFBS gs + continue' = continue . update + halt' = continue . popState in + case (excep, ev) of + (Just _, _) -> continue' $ s & exception' .~ Nothing + (_, e) -> case e of V.EvKey V.KEsc [] | not (fileBrowserIsSearching b) -> - halt s + halt' gs V.EvKey (V.KChar 'c') [V.MCtrl] | not (fileBrowserIsSearching b) -> - halt s + halt' gs V.EvKey (V.KChar 'h') [] | not (fileBrowserIsSearching b) -> let s' = s & showHidden %~ not in - continue $ s' & fb .~ setFileBrowserEntryFilter (Just (entryFilter (s' ^. showHidden))) b + continue' $ s' & fb .~ setFileBrowserEntryFilter (Just (entryFilter (s' ^. showHidden))) b _ -> do b' <- handleFileBrowserEvent ev b let s' = s & fb .~ b' - -- If the browser has a selected file after handling the - -- event (because the user pressed Enter), shut down. case ev of V.EvKey V.KEnter [] -> case fileBrowserSelection b' of - [] -> continue s' + [] -> continue' s' [fileInfo] -> do let fp = fileInfoFilePath fileInfo fileOrExc <- liftIO (try (readFile fp) :: IO (Either IOError String)) case fileOrExc of - Left exc -> continue (s' & exception ?~ displayException exc) + Left exc -> continue' (s' & exception' ?~ displayException exc) Right file -> case parseCards file of - Left parseError -> continue (s & exception ?~ show parseError) - Right result -> halt (s' & cards .~ result & filePath ?~ fp) - _ -> halt s' - - _ -> continue s' -handleEvent s _ = continue s - -runFileBrowserUI :: IO (Maybe ([Card], FilePath)) -runFileBrowserUI = do - browser <- newFileBrowser selectNonDirectories () Nothing - let filteredBrowser = setFileBrowserEntryFilter (Just (entryFilter False)) browser - s <- defaultMain app (State filteredBrowser Nothing [] Nothing False) - let mfp = s ^. filePath - return $ fmap (s ^. cards,) mfp + Left parseError -> continue' (s & exception' ?~ errorBundlePretty parseError) + -- Right result -> halt' (s' & parsedCards .~ result & filePath ?~ fp) + Right result -> continue =<< liftIO (do + addRecent fp + let gs' = update s' + (gs' `moveToState`) <$> cardsWithOptionsState (update s') result) + _ -> halt' gs -entryFilter :: Bool -> FileInfo -> Bool -entryFilter acceptHidden info = fileExtensionMatch "txt" info && (acceptHidden || - case fileInfoFilename info of - ".." -> True - '.' : _ -> False - _ -> True) + _ -> continue' s' +handleEvent gs _ _ = continue gs diff --git a/src/UI/Info.hs b/src/UI/Info.hs --- a/src/UI/Info.hs +++ b/src/UI/Info.hs @@ -1,24 +1,15 @@ -module UI.Info (runInfoUI) where +module UI.Info (State, drawUI, handleEvent, theMap) where import Brick import Brick.Widgets.Border import Brick.Widgets.Border.Style import Brick.Widgets.Center -import Control.Monad (void) +import States +import StateManagement import qualified Graphics.Vty as V -type Event = () -type Name = () -type State = () - -app :: App State Event Name -app = App - { appDraw = (:[]) . const ui - , appChooseCursor = neverShowCursor - , appHandleEvent = handleEvent - , appStartEvent = return - , appAttrMap = const theMap - } +drawUI :: IS -> [Widget Name] +drawUI = (:[]) . const ui ui :: Widget Name ui = @@ -31,18 +22,21 @@ hBorder <=> drawInfo -handleEvent :: State -> BrickEvent Name Event -> EventM Name (Next State) -handleEvent s (VtyEvent e) = +handleEvent :: GlobalState -> IS -> BrickEvent Name Event -> EventM Name (Next GlobalState) +handleEvent gs s (VtyEvent e) = + let update = updateIS gs + continue' = continue . update + halt' = continue . popState in case e of - V.EvKey (V.KChar 'c') [V.MCtrl] -> halt s - V.EvKey V.KEsc [] -> halt s - V.EvKey V.KEnter [] -> halt s - V.EvKey V.KDown [] -> vScrollBy (viewportScroll ()) 1 >> continue s - V.EvKey (V.KChar 'j') [] -> vScrollBy (viewportScroll ()) 1 >> continue s - V.EvKey V.KUp [] -> vScrollBy (viewportScroll ()) (-1) >> continue s - V.EvKey (V.KChar 'k') [] -> vScrollBy (viewportScroll ()) (-1) >> continue s - _ -> continue s -handleEvent s _ = continue s + V.EvKey (V.KChar 'c') [V.MCtrl] -> halt' gs + V.EvKey V.KEsc [] -> halt' gs + V.EvKey V.KEnter [] -> halt' gs + V.EvKey V.KDown [] -> vScrollBy (viewportScroll Ordinary) 1 >> continue' s + V.EvKey (V.KChar 'j') [] -> vScrollBy (viewportScroll Ordinary) 1 >> continue' s + V.EvKey V.KUp [] -> vScrollBy (viewportScroll Ordinary) (-1) >> continue' s + V.EvKey (V.KChar 'k') [] -> vScrollBy (viewportScroll Ordinary) (-1) >> continue' s + _ -> continue' s +handleEvent gs _ _ = continue gs titleAttr :: AttrName titleAttr = attrName "title" @@ -55,11 +49,23 @@ drawInfo = padLeftRight 1 $ vLimitPercent 60 $ - viewport () Vertical (strWrap info) - -runInfoUI :: IO () -runInfoUI = void $ defaultMain app () + viewport Ordinary Vertical (strWrap info) info :: String -info = - "Hascard is a text-based user interface for reviewing notes using 'flashcards'. Cards are written in markdown-like syntax; for more info see the README file. Use the --help flag for information on the command line options.\n\nControls:\n * Use arrows or the j and k keys for menu navigation\n * Enter confirms a selection, flips a card or continues to the next card\n * Use TAB or the arrow keys for navigating gaps in open questions\n * Use the c key for confirming reorder questions or multiple choice questions with more than 1 possible answer\n * Use F1 to show the answers of a open question.\n * Use CTRL+Left and CTRL+Right to move to previous and next cards without having to answer them" +info = unlines + [ "Hascard is a text-based user interface for reviewing notes using 'flashcards'. Cards are written in markdown-like syntax; for more info see the README file. Use the --help flag for information on the command line options." + , "" + , "Controls:" + , " * Use arrows or the j and k keys for menu navigation" + , "" + , " * Press the s key to toggle shuffling inside the deck selector menu" + , "" + , " * Enter confirms a selection, flips a card or continues to the next card" + , "" + , " * Use TAB or the arrow keys for navigating gaps in open questions" + , "" + , " * Use the c key for confirming reorder questions or multiple choice questions with more than 1 possible answer" + , "" + , " * Use F1 to show the answers of a open question" + , "" + , " * Use CTRL+Left and CTRL+Right to move to previous and next cards without having to answer them"] diff --git a/src/UI/MainMenu.hs b/src/UI/MainMenu.hs --- a/src/UI/MainMenu.hs +++ b/src/UI/MainMenu.hs @@ -1,49 +1,31 @@ -{-# LANGUAGE TemplateHaskell #-} -module UI.MainMenu (runMainMenuUI) where +module UI.MainMenu (State (..), drawUI, handleEvent, theMap) where import Brick import Brick.Widgets.Border import Brick.Widgets.Border.Style import Brick.Widgets.Center -import Data.Functor (($>)) +import Control.Monad.IO.Class import Lens.Micro.Platform -import Types (GlobalState) +import Runners +import Settings +import States +import StateManagement +import UI.Attributes import UI.BrickHelpers -import UI.CardSelector -import UI.Info -import UI.Settings -import qualified Data.Vector as Vec import qualified Graphics.Vty as V import qualified Brick.Widgets.List as L -type Event = () -type Name = () -data State = State - { _l :: L.List Name String - , _gs :: GlobalState } - -makeLenses ''State - -app :: App State Event Name -app = App - { appDraw = drawUI - , appChooseCursor = neverShowCursor - , appHandleEvent = handleEvent - , appStartEvent = return - , appAttrMap = const theMap - } - title :: Widget Name title = withAttr titleAttr $ str "┬ ┬┌─┐┌─┐┌─┐┌─┐┬─┐┌┬┐" <=> str "├─┤├─┤└─┐│ ├─┤├┬┘ ││" <=> str "┴ ┴┴ ┴└─┘└─┘┴ ┴┴└──┴┘" -drawUI :: State -> [Widget Name] +drawUI :: MMS -> [Widget Name] drawUI s = [ drawMenu s ] -drawMenu :: State -> Widget Name +drawMenu :: MMS -> Widget Name drawMenu s = joinBorders $ center $ @@ -54,7 +36,7 @@ hBorder <=> drawList s -drawList :: State -> Widget Name +drawList :: MMS -> Widget Name drawList s = vLimit 4 $ L.renderList drawListElement True (s^.l) @@ -62,59 +44,19 @@ drawListElement selected = hCenteredStrWrapWithAttr attr where attr = if selected then withAttr selectedAttr else id -titleAttr :: AttrName -titleAttr = attrName "title" - -selectedAttr :: AttrName -selectedAttr = attrName "selected" - -theMap :: AttrMap -theMap = attrMap V.defAttr - [ (L.listAttr, V.defAttr) - , (selectedAttr, fg V.white `V.withStyle` V.underline) - , (titleAttr, fg V.yellow) ] - -handleEvent :: State -> BrickEvent Name Event -> EventM Name (Next State) -handleEvent s (VtyEvent e) = +handleEvent :: GlobalState -> MMS -> BrickEvent Name Event -> EventM Name (Next GlobalState) +handleEvent gs s (VtyEvent e) = + let update = updateMMS gs in case e of - V.EvKey (V.KChar 'c') [V.MCtrl] -> halt s - V.EvKey V.KEsc [] -> halt s + V.EvKey (V.KChar 'c') [V.MCtrl] -> halt gs + V.EvKey V.KEsc [] -> halt gs V.EvKey V.KEnter [] -> case L.listSelected (s^.l) of - Just 0 -> suspendAndResume $ runCardSelectorUI (s^.gs)$> s - Just 1 -> suspendAndResume $ runInfoUI $> s - Just 2 -> suspendAndResume $ runSettingsUI $> s - Just 3 -> halt s + Just 0 -> continue =<< (gs `goToState`) <$> liftIO cardSelectorState + Just 1 -> continue $ gs `goToState` infoState + Just 2 -> continue =<< (gs `goToState`) <$> liftIO settingsState + Just 3 -> halt gs _ -> undefined - ev -> continue . flip (l .~) s =<< L.handleListEventVi L.handleListEvent ev (s^.l) -handleEvent l _ = continue l - -runMainMenuUI :: GlobalState -> IO () -runMainMenuUI gs = do - let options = Vec.fromList [ "Select" - , "Info" - , "Settings" - , "Quit" ] - - let initialState = State (L.list () options 1) gs - _ <- defaultMain app initialState - return () - --- _ _ _ --- | | | | | | --- | |__| | __ _ ___ ___ __ _ _ __ __| | --- | __ |/ _` / __|/ __/ _` | '__/ _` | --- | | | | (_| \__ \ (_| (_| | | | (_| | --- |_| |_|\__,_|___/\___\__,_|_| \__,_| - --- _ _ --- | | | | --- | |__ __ _ ___ ___ __ _ _ __ __| | --- | '_ \ / _` / __|/ __/ _` | '__/ _` | --- | | | | (_| \__ \ (_| (_| | | | (_| | --- |_| |_|\__,_|___/\___\__,_|_| \__,_| - --- ┬ ┬┌─┐┌─┐┌─┐┌─┐┬─┐┌┬┐ --- ├─┤├─┤└─┐│ ├─┤├┬┘ ││ --- ┴ ┴┴ ┴└─┘└─┘┴ ┴┴└──┴┘ + ev -> continue . update . flip (l .~) s =<< L.handleListEventVi L.handleListEvent ev (s^.l) +handleEvent gs _ _ = continue gs diff --git a/src/UI/Settings.hs b/src/UI/Settings.hs --- a/src/UI/Settings.hs +++ b/src/UI/Settings.hs @@ -1,36 +1,23 @@ -module UI.Settings (runSettingsUI, getShowHints, getShowControls, getUseEscapeCode) where +module UI.Settings (State, drawUI, handleEvent, theMap) where +import UI.Attributes import Brick hiding (mergeWithDefault) +import Brick.Focus +import Brick.Forms import Brick.Widgets.Border import Brick.Widgets.Border.Style import Brick.Widgets.Center -import Control.Monad (void) -import Data.Functor (($>)) -import Data.Map.Strict (Map, (!)) -import System.FilePath (()) -import System.Environment (lookupEnv) -import Text.Read (readMaybe) -import UI.BrickHelpers -import qualified Data.Map.Strict as M +import Control.Monad.IO.Class +import States +import StateManagement +import Settings import qualified Graphics.Vty as V -import qualified System.Directory as D -type Event = () -type Name = () -type Settings = Map Int Bool -type State = (Int, Settings) - -app :: App State Event Name -app = App - { appDraw = (:[]) . ui - , appChooseCursor = neverShowCursor - , appHandleEvent = handleEvent - , appStartEvent = return - , appAttrMap = const theMap - } +drawUI :: SS -> [Widget Name] +drawUI = (:[]) . ui -ui :: State -> Widget Name -ui s = +ui :: SS -> Widget Name +ui f = joinBorders $ center $ withBorderStyle unicodeRounded $ @@ -40,104 +27,20 @@ hCenter (withAttr titleAttr (str "Settings")) <=> hBorder <=> padLeftRight 1 - (drawSettings s) + (renderForm f) -handleEvent :: State -> BrickEvent Name Event -> EventM Name (Next State) -handleEvent s@(i, settings) (VtyEvent e) = +handleEvent :: GlobalState -> SS -> BrickEvent Name Event -> EventM Name (Next GlobalState) +handleEvent gs form ev@(VtyEvent e) = + let update = updateSS gs + continue' = continue . update + halt' global = continue (popState global) <* liftIO (setSettings (formState form)) in case e of - V.EvKey (V.KChar 'c') [V.MCtrl] -> halt s - V.EvKey V.KEsc [] -> halt s - V.EvKey V.KEnter [] -> continue (i, settings') - where settings' = M.adjust not i settings - V.EvKey V.KUp [] -> continue (max 0 (i-1), settings) - V.EvKey (V.KChar 'k') [] -> continue (max 0 (i-1), settings) - V.EvKey V.KDown [] -> continue (min (M.size settings-1) (i+1), settings) - V.EvKey (V.KChar 'j') [] -> continue (min (M.size settings-1) (i+1), settings) - _ -> continue s -handleEvent s _ = continue s - -titleAttr :: AttrName -titleAttr = attrName "title" - -selectedAttr :: AttrName -selectedAttr = attrName "selected" - -theMap :: AttrMap -theMap = attrMap V.defAttr - [ (titleAttr, fg V.yellow), - (selectedAttr, V.defAttr `V.withStyle` V.underline) ] - -drawSettings :: State -> Widget Name -drawSettings s = vBox $ map (drawSetting s) (zip [0..] descriptions) - where descriptions = map (++": ") - [ "Draw hints using underscores for definition cards" - , "Show controls at the bottom of screen" - , "Use the '-n \\e[5 q' escape code to change the cursor to a blinking line on start" ] - -drawSetting :: State -> (Int, String) -> Widget Name -drawSetting (selected, settings) (i, text) = - strWrap text <+> str " " <+> word - where word = if settings ! i then underline (str "Yes") else underline (str "No") <+> str " " - underline = if i == selected then withAttr selectedAttr else id - -runSettingsUI :: IO () -runSettingsUI = do - currentSettings <- getSettings - (_, newSettings) <- defaultMain app (0, currentSettings) - setSettings newSettings - -getSettings :: IO Settings -getSettings = do - sf <- getSettingsFile - exists <- D.doesFileExist sf - if exists - then do - maybeSettings <- parseSettings <$> readFile sf - flip (maybe (return defaultSettings)) maybeSettings $ \settings -> - if M.size settings == M.size defaultSettings - then return settings - else let settings' = settings `mergeWithDefault` defaultSettings in - setSettings settings' $> settings' - - else return defaultSettings - -mergeWithDefault :: Settings -> Settings -> Settings -mergeWithDefault = flip M.union - -getShowHints :: IO Bool -getShowHints = do - settings <- getSettings - return $ settings ! 0 - -getShowControls :: IO Bool -getShowControls = do - settings <- getSettings - return $ settings ! 1 - -getUseEscapeCode :: IO Bool -getUseEscapeCode = do - settings <- getSettings - return $ settings ! 2 - -parseSettings :: String -> Maybe Settings -parseSettings = readMaybe - -getSettingsFile :: IO FilePath -getSettingsFile = do - maybeSnap <- lookupEnv "SNAP_USER_DATA" - xdg <- D.getXdgDirectory D.XdgConfig "hascard" - - let dir = case maybeSnap of - Just path | not (null path) -> path - | otherwise -> xdg - Nothing -> xdg - D.createDirectoryIfMissing True dir - return (dir "settings") - -defaultSettings :: Settings -defaultSettings = M.fromList [(0, False), (1, True), (2, False)] + V.EvKey (V.KChar 'c') [V.MCtrl] -> halt' gs + V.EvKey V.KEsc [] -> halt' gs + V.EvKey V.KDown [] -> continue' $ form { formFocus = focusNext (formFocus form) } + V.EvKey (V.KChar 'j') [] -> continue' $ form { formFocus = focusNext (formFocus form) } + V.EvKey V.KUp [] -> continue' $ form { formFocus = focusPrev (formFocus form) } + V.EvKey (V.KChar 'k') [] -> continue' $ form { formFocus = focusPrev (formFocus form) } + _ -> continue' =<< handleFormEvent ev form -setSettings :: Settings -> IO () -setSettings settings = do - sf <- getSettingsFile - writeFile sf (show settings) +handleEvent gs _ _ = continue gs