hascard (empty) → 0.1.1.0
raw patch · 19 files changed
+1663/−0 lines, 19 filesdep +basedep +brickdep +containerssetup-changed
Dependencies added: base, brick, containers, directory, filepath, hascard, microlens, microlens-platform, optparse-applicative, ordered-containers, parsec, process, strict, text, vector, vty, word-wrap
Files
- ChangeLog.md +17/−0
- LICENSE +30/−0
- README.md +76/−0
- Setup.hs +2/−0
- app/Main.hs +55/−0
- hascard.cabal +120/−0
- src/Debug.hs +7/−0
- src/Parser.hs +117/−0
- src/Stack.hs +40/−0
- src/Types.hs +58/−0
- src/UI.hs +10/−0
- src/UI/BrickHelpers.hs +16/−0
- src/UI/CardSelector.hs +227/−0
- src/UI/Cards.hs +448/−0
- src/UI/FileBrowser.hs +117/−0
- src/UI/Info.hs +65/−0
- src/UI/MainMenu.hs +113/−0
- src/UI/Settings.hs +143/−0
- test/Spec.hs +2/−0
+ ChangeLog.md view
@@ -0,0 +1,17 @@+# Changelog for hascard++## 0.1.1.0+New:+- Add nix build support (by @srid)+- Recently used decks are now ordered by most recent first+- Recently used decks now have unique names. Previously only the filename was shown, but now path is shown up to unique name++Fixed bugs:+- Failed parsing of settings file now results in default settings instead of error+- After selecting a file from system, the card selector had to be refreshed before the file appeared in the recently selected decks list. The file is now present immediately+- Directly selecting a card via the CLI now also adds it to the recents list+- Selecting a card via the CLI now returns an error if it has a different filetype than '.txt'. If no filetype is given, '.txt' is assumed.+++## 0.1.0.0+Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Steven van den Broek (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Steven van den Broek nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,76 @@+# hascard+A minimal commandline utility for reviewing notes. 'Flashcards' can be written in markdown-like syntax.++++## Contents+- [Installation](#installation)+- [Cards](#cards)+- [Miscellaneous info](#miscellaneous-info)++## Installation+### Binary+The binary used on my system is available under [releases](https://github.com/Yvee1/hascard/releases/). If you run debian with the x86-64 architecture that binary should work for you too. To be able to run it from any directory, it has to be added to the PATH. This can be done by copying it to e.g. the `/usr/local/bin` directory.++### Snapcraft+Hascard is also on [snapcraft](https://snapcraft.io/hascard). Installation instructions are on that site. If you already have snap installed you can just install hascard via `sudo snap install hascard`. By default snap applications are isolated from the system and run in a sandbox. This means that hascard does not have permission to read or write any files on the system aside from those under `%HOME/snap/hascard`. To be able to read cards also in other directories under the home directory, hascard makes use of the `home` interface which might need to be enabled manually using `sudo snap connect hascard:home :home`.++### Install from source+Another option is to build hascard and install it from source. For this you can use the Haskell build tool called [stack](https://docs.haskellstack.org/en/stable/README/#how-to-install), or [nix](https://nixos.org/). Then for example clone this repository somewhere:+```+git clone https://github.com/Yvee1/hascard.git+cd hascard+```+and do `stack install hascard` or `nix-build` respectively.++## Cards+Decks of cards are written in `.txt` files. Cards are seperated with a line containing three dashes `---`. For examples, see the [`/cards`](https://github.com/Yvee1/hascard/tree/master/cards) directory. In this section the 4 different cards are listed, with the syntax and how it is represented in the application.++### Definition+This is the simplest card, it simply has a title and can be flipped to show the contents. For example the following card+```+# Word or question+Explanation or definition of this word, or the answer to the question.+```+will result in+++### Multiple choice+This is a typical multiple choice question. The question starts with a `#` and the choices follow. Only one answer is correct, and is indicated by a `*`, the other questions are preceded by a `-`. As an example, the following text++```+# Multiple choice question, (only one answer is right)+- Choice 1+* Choice 2 (this is the correct answer)+- Choice 3+- Choice 4+```++gets rendered as+++### Multiple answer+Multiple choice questions with multiple possible answers is also possible. Here again the question starts with `#` and the options follow. Preceding each option is a box `[ ]` that is filled with a `*` or a `x` if it is correct. For example++```+# Multiple answer question+[*] Option 1 (this is a correct answer)+[ ] Option 2+[*] Option 3 (this is a correct answer)+[ ] Option 4+```+results in+++### Open question+Open questions are also supported. The words that have to be filled in should be surrounded by underscores `_`. Multiple answer possibilities can also be given by seperating them with vertical bars `|`. As an example, the card++```+# Fill in the gaps+The symbol € is for the currency named _Euro_, and is used in the _EU|European Union_.+```+behaves like this+++## Miscellaneous info+Written in Haskell, UI built with [brick](https://github.com/jtdaugherty/brick) and parsing of cards done with [parsec](https://github.com/haskell/parsec). Recordings of the terminal were made using [terminalizer](https://github.com/faressoft/terminalizer).
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,55 @@+module Main where++import UI+import Control.Exception (displayException, try)+import Control.Monad (void, when)+import Data.Functor (($>))+import Data.Version (showVersion)+import Paths_hascard (version)+import Parser+import Options.Applicative+import System.Process (runCommand)+import System.FilePath (takeExtension)++data Opts = Opts+ { optFile :: Maybe String+ , optVersion :: Bool+ }++main :: IO ()+main = do+ useEscapeCode <- getUseEscapeCode+ when useEscapeCode $ void (runCommand "echo -n \\\\e[5 q")+ + options <- execParser optsWithHelp+ if optVersion options+ then putStrLn (showVersion version)+ else run $ optFile options++opts :: Parser Opts+opts = Opts+ <$> optional (argument str (metavar "FILE.txt" <> help "A .txt file containing flashcards"))+ <*> 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."+ <> header "Hascard - a TUI for reviewing notes"++run :: Maybe String -> IO ()+run Nothing = runBrickFlashcards+run (Just file) = do+ 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" + 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 -> addRecent textfile *> runCardsUI result $> ()
+ hascard.cabal view
@@ -0,0 +1,120 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 6a57f1e9b67613bc9c711646e3e9db7e237814e8d4b3baf027cb4827af79f38c++name: hascard+version: 0.1.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 <https://github.com/Yvee1/hascard#readme> for more information.+category: Application+homepage: https://github.com/Yvee1/hascard#readme+bug-reports: https://github.com/Yvee1/hascard/issues+author: Steven van den Broek+maintainer: stevenvdb@live.nl+copyright: 2020 Steven van den Broek+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/Yvee1/hascard++library+ exposed-modules:+ Debug+ Parser+ Stack+ Types+ UI+ UI.BrickHelpers+ UI.Cards+ UI.CardSelector+ UI.FileBrowser+ UI.Info+ UI.MainMenu+ UI.Settings+ other-modules:+ Paths_hascard+ hs-source-dirs:+ src+ build-depends:+ base >=4.7 && <5+ , brick >=0.52.1 && <0.56+ , containers >0.6.0 && <0.7+ , directory >=1.3.3 && <1.4+ , filepath >=1.4.2 && <1.5+ , microlens >=0.4.11 && <0.5+ , microlens-platform >=0.4.1 && <0.5+ , 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+ , strict >=0.3.2 && <0.4+ , text >=1.2.3 && <1.3+ , vector >=0.12.0 && <0.13+ , vty >=5.28.2 && <5.31+ , word-wrap >=0.4.1 && <0.5+ default-language: Haskell2010++executable hascard+ main-is: Main.hs+ other-modules:+ Paths_hascard+ hs-source-dirs:+ app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , brick >=0.52.1 && <0.56+ , containers >0.6.0 && <0.7+ , directory >=1.3.3 && <1.4+ , filepath >=1.4.2 && <1.5+ , hascard+ , microlens >=0.4.11 && <0.5+ , microlens-platform >=0.4.1 && <0.5+ , 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+ , strict >=0.3.2 && <0.4+ , text >=1.2.3 && <1.3+ , vector >=0.12.0 && <0.13+ , vty >=5.28.2 && <5.31+ , word-wrap >=0.4.1 && <0.5+ default-language: Haskell2010++test-suite hascard-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_hascard+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , brick >=0.52.1 && <0.56+ , containers >0.6.0 && <0.7+ , directory >=1.3.3 && <1.4+ , filepath >=1.4.2 && <1.5+ , hascard+ , microlens >=0.4.11 && <0.5+ , microlens-platform >=0.4.1 && <0.5+ , 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+ , strict >=0.3.2 && <0.4+ , text >=1.2.3 && <1.3+ , vector >=0.12.0 && <0.13+ , vty >=5.28.2 && <5.31+ , word-wrap >=0.4.1 && <0.5+ default-language: Haskell2010
+ src/Debug.hs view
@@ -0,0 +1,7 @@+module Debug where+import System.IO.Unsafe (unsafePerformIO)++debugToFile :: String -> a -> a+debugToFile s expr = unsafePerformIO $ do+ appendFile "log.txt" s+ return expr
+ src/Parser.hs view
@@ -0,0 +1,117 @@+-- {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DataKinds, ExistentialQuantification, GADTs, KindSignatures #-}+module Parser (parseCards) where+ +import qualified Data.List.NonEmpty as NE+import Text.Parsec+import Types++uncurry3 f (a, b, c) = f a b c++parseCards :: String -> Either ParseError [Card]+parseCards = parse pCards "failed when parsing cards"++pCards = pCard `sepEndBy1` seperator+pCard = uncurry3 MultipleChoice<$> try pMultChoice+ <|> uncurry MultipleAnswer <$> try pMultAnswer+ <|> uncurry OpenQuestion <$> try pOpen+ <|> uncurry Definition <$> pDef++pHeader = do+ many eol+ char '#'+ spaces+ many notEOL++pMultChoice = do+ header <- pHeader+ many eol+ choices <- pChoice `sepBy1` lookAhead (try choicePrefix)+ let (correct, incorrects) = makeMultipleChoice choices+ return (header, correct, incorrects)++pChoice = do+ kind <- oneOf "*-"+ space+ text <- manyTill anyChar $ lookAhead (try (try choicePrefix <|> seperator))+ return (kind, text)++choicePrefix = string "- "+ <|> string "* "++pMultAnswer = do+ header <- pHeader+ many eol+ options <- pOption `sepBy1` lookAhead (try (char '['))+ return (header, NE.fromList options)++pOption = do+ char '['+ kind <- oneOf "*x "+ string "] "+ text <- manyTill anyChar $ lookAhead (try (seperator <|> string "["))+ return $ makeOption kind text++pOpen = do+ header <- pHeader+ many eol+ (pre, gap) <- pGap+ sentence <- pSentence++ return (header, P pre gap sentence)++pSentence = try pPerforated+ <|> pNormal+ +pPerforated = do+ (pre, gap) <- pGap+ Perforated pre gap <$> pSentence ++chars = escaped <|> anyChar+escaped = char '\\' >> char '_'++pGap = do+ pre <- manyTill chars $ lookAhead (try gappedSpecialChars)+ char '_'+ gaps <- manyTill (noneOf "_|") (lookAhead (try gappedSpecialChars)) `sepBy1` string "|"+ char '_'+ return (pre, NE.fromList gaps)++gappedSpecialChars = seperator+ <|> string "|"+ <|> string "_"++pNormal = do+ text <- manyTill (noneOf "_") $ lookAhead (try gappedSpecialChars)+ return (Normal text)++pDef = do+ header <- pHeader+ many eol+ descr <- manyTill chars $ lookAhead (try seperator)+ return (header, descr)++eol = try (string "\n\r")+ <|> try (string "\r\n")+ <|> string "\n"+ <|> string "\r"+ <?> "end of line"++seperator = string "---"++notEOL = noneOf "\n\r"++makeMultipleChoice :: [(Char, String)] -> (CorrectOption, [IncorrectOption])+makeMultipleChoice options = makeMultipleChoice' [] [] 0 options+ where+ makeMultipleChoice' [] _ _ [] = error ("multiple choice had no correct answer: \n" ++ show options)+ makeMultipleChoice' [c] ics _ [] = (c, reverse ics)+ makeMultipleChoice' _ _ _ [] = error ("multiple choice had multiple correct answers: \n" ++ show options)+ makeMultipleChoice' cs ics i (('-', text) : opts) = makeMultipleChoice' cs (IncorrectOption text : ics) (i+1) opts+ makeMultipleChoice' cs ics i (('*', text) : opts) = makeMultipleChoice' (CorrectOption i text : cs) ics (i+1) opts+ makeMultipleChoice' _ _ _ _ = error "impossible"++makeOption :: Char -> String -> Option+makeOption kind text+ | kind `elem` "*x" = Option Correct text+ | otherwise = Option Incorrect text
+ src/Stack.hs view
@@ -0,0 +1,40 @@+module Stack (module Stack, module X) where+import Data.Maybe (fromJust)+import Data.Foldable as X (toList)+import Data.Set.Ordered (OSet, (|<))+import qualified Data.Set.Ordered as OS++type Stack a = OSet a++empty :: Stack a+empty = OS.empty++insert :: Ord a => a -> Stack a -> Stack a+insert = (|<)++removeLast :: Ord a => Stack a -> Stack a+removeLast s = OS.delete (Stack.last s) s++head :: Stack a -> a+head = (`unsafeElemAt` 0)++last :: Stack a -> a+last s = s `unsafeElemAt` (Stack.size s - 1)++tail :: Ord a => Stack a -> [a]+tail s = toList $ OS.delete (Stack.head s) s++elemAt :: Stack a -> Int -> Maybe a+elemAt = OS.elemAt++unsafeElemAt :: Stack a -> Int -> a+unsafeElemAt s = fromJust . OS.elemAt s++fromList :: Ord a => [a] -> Stack a+fromList = OS.fromList++-- toList :: Ord a => Stack a -> [a]+-- toList = toList++size :: Stack a -> Int+size = OS.size
+ src/Types.hs view
@@ -0,0 +1,58 @@+module Types where+import Data.List.NonEmpty (NonEmpty)++-- Word Description+data Card = Definition String String+ | OpenQuestion String Perforated+ | MultipleChoice {+ mcQuestion :: String,+ mcCorrect :: CorrectOption,+ mcIncorrects :: [IncorrectOption]}+ -- | MultipleAnswer String (NE.NonEmpty Answer) + | MultipleAnswer {+ maQuestion :: String,+ maOptions :: NonEmpty Option }+ + deriving Show++data Type = Incorrect | Correct+ deriving (Show, Eq)+data CorrectOption = CorrectOption Int String+ deriving Show+newtype IncorrectOption = IncorrectOption String+ deriving Show+data Option = Option Type String+ deriving Show++-- Pre Gap Post+data Sentence = Perforated String (NonEmpty String) Sentence+ | Normal String+ deriving Show++data Perforated = P String (NonEmpty String) Sentence+ deriving Show++nGapsInSentence :: Sentence -> Int+nGapsInSentence = nGapsInSentence' 0+ where+ nGapsInSentence' acc (Normal _) = acc+ nGapsInSentence' acc (Perforated _ _ post) = nGapsInSentence' (1+acc) post++foldSentence :: (String -> a) -> (String -> NonEmpty String -> a -> a) -> Sentence -> a+foldSentence norm perf = f where+ f (Normal text) = norm text+ f (Perforated pre gap sent) = perf pre gap (f sent)++foldSentenceIndex :: (String -> Int -> a) -> (String -> NonEmpty String -> a -> Int -> a) -> Sentence -> a+foldSentenceIndex norm perf = f 0 where+ f i (Normal text) = norm text i+ f i (Perforated pre gap sent) = perf pre gap (f (i+1) sent) i++perforatedToSentence :: Perforated -> Sentence+perforatedToSentence (P pre gap sentence) = Perforated pre gap sentence++nGapsInPerforated :: Perforated -> Int+nGapsInPerforated = nGapsInSentence . perforatedToSentence++sentenceToGaps :: Sentence -> [NonEmpty String]+sentenceToGaps = foldSentence (const []) (\_ gap acc -> gap : acc)
+ src/UI.hs view
@@ -0,0 +1,10 @@+module UI (module X, runBrickFlashcards) where++import UI.Cards as X (runCardsUI)+import UI.CardSelector as X+import UI.MainMenu as X (runMainMenuUI)+import UI.Settings as X++runBrickFlashcards :: IO ()+runBrickFlashcards = runMainMenuUI+
+ src/UI/BrickHelpers.hs view
@@ -0,0 +1,16 @@+module UI.BrickHelpers where+import Text.Wrap+import Brick+import Brick.Widgets.Center+import Data.Text (pack)+import Lens.Micro++hCenteredStrWrap :: String -> Widget n+hCenteredStrWrap = hCenteredStrWrapWithAttr id++hCenteredStrWrapWithAttr :: (Widget n -> Widget n) -> String -> Widget n+hCenteredStrWrapWithAttr attr p = Widget Greedy Fixed $ do+ c <- getContext+ let w = c^.availWidthL+ let result = vBox $ map (hCenter . attr . txt) $ wrapTextToLines (WrapSettings {preserveIndentation=False, breakLongWords=True}) w (pack p)+ render result
+ src/UI/CardSelector.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE TemplateHaskell #-}+module UI.CardSelector (runCardSelectorUI, getRecents, getRecentsFile, 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.IO.Class+import Data.List (sort)+import Lens.Micro.Platform+import Parser+import Stack (Stack)+import System.Environment (lookupEnv)+import System.FilePath ((</>), splitFileName, dropExtension, splitPath, joinPath)+import UI.BrickHelpers+import UI.FileBrowser (runFileBrowserUI)+import UI.Cards (runCardsUI)+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+ }++makeLenses ''State++app :: App State Event Name+app = App + { appDraw = drawUI+ , appChooseCursor = neverShowCursor+ , appHandleEvent = handleEvent+ , appStartEvent = return+ , appAttrMap = const theMap+ }++drawUI :: State -> [Widget Name]+drawUI s = + [ drawMenu s <=> drawException s ]++title :: Widget Name+title = withAttr titleAttr $ hCenteredStrWrap "Select a deck of flashcards"++drawMenu :: State -> Widget Name+drawMenu s = + joinBorders $+ center $ + withBorderStyle unicodeRounded $+ border $+ hLimitPercent 60 $+ title <=>+ hBorder <=>+ hCenter (drawList s)++drawList :: State -> Widget Name+drawList s = vLimit 6 $+ L.renderListWithIndex (drawListElement l) True l+ where l = s ^. list++drawListElement :: L.List Name String -> Int -> Bool -> String -> Widget Name+drawListElement l i selected = hCenteredStrWrapWithAttr (wAttr1 . wAttr2)+ 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+ [ (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+ _ <- runCardsUI result+ return (s'' & exception .~ Nothing)+ _ -> continue s'++handleEvent l _ = continue l++runCardSelectorUI :: IO ()+runCardSelectorUI = 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+ _ <- defaultMain app initialState+ return () ++getRecents :: IO (Stack FilePath)+getRecents = do+ rf <- getRecentsFile+ exists <- D.doesFileExist rf+ if exists+ then S.fromList . lines <$> IOS.readFile rf+ else return S.empty++maxRecents :: Int+maxRecents = 5++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''++addRecentInternal :: State -> FilePath -> IO State+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 <* runCardsUI cards) result
+ src/UI/Cards.hs view
@@ -0,0 +1,448 @@+{-# LANGUAGE TemplateHaskell #-}+module UI.Cards (runCardsUI) where++import Brick+import Lens.Micro.Platform+import Types+import Data.Char (isSeparator, isSpace)+import Data.List (dropWhileEnd)+import Data.List.NonEmpty (NonEmpty)+import Data.Map.Strict (Map)+import Text.Wrap+import Data.Text (pack)+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+import qualified Brick.Widgets.Border as B+import qualified Brick.Widgets.Border.Style as BS+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+ , _nChoices :: Int+ , _tried :: Map Int Bool -- indices of tried choices+ }+ | MultipleAnswerState+ { _highlighted :: Int+ , _selected :: Map Int Bool+ , _nChoices :: Int+ , _entered :: Bool+ }+ | OpenQuestionState+ { _gapInput :: Map Int String+ , _highlighted :: Int+ , _nGaps :: Int+ , _entered :: Bool+ , _correctGaps :: Map Int Bool+ }++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+ , _nChoices = length ics + 1+ , _tried = M.fromList [(i, False) | i <- [0..length ics]] }+defaultCardState (OpenQuestion _ perforated) = OpenQuestionState + { _gapInput = M.empty+ , _highlighted = 0+ , _nGaps = 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+ , _nChoices = NE.length answers }++app :: App State Event Name+app = App + { appDraw = drawUI+ , appChooseCursor = showFirstCursor+ , appHandleEvent = handleEvent+ , appStartEvent = return+ , appAttrMap = const theMap+ }++drawUI :: State -> [Widget Name]+drawUI s = [drawCardUI s <=> drawInfo s]++drawInfo :: State -> Widget Name+drawInfo s = if not (s ^. showControls) then emptyWidget else+ strWrap . ("ESC: quit" <>) $ case s ^. cardState of+ DefinitionState {} -> ", ENTER: flip card / continue"+ MultipleChoiceState {} -> ", ENTER: confirm answer / continue"+ MultipleAnswerState {} -> ", ENTER: select / continue, c: confirm selection"+ OpenQuestionState {} -> ", LEFT/RIGHT/TAB: navigate gaps, ENTER: confirm answer / continue"++drawProgress :: State -> Widget Name+drawProgress s = C.hCenter $ str (show (s^.index + 1) ++ "/" ++ show (s^.nCards))++drawHeader :: String -> Widget Name+drawHeader title = withAttr titleAttr $+ padLeftRight 1 $+ hCenteredStrWrap title++wrapSettings :: WrapSettings+wrapSettings = WrapSettings {preserveIndentation=False, breakLongWords=True}++drawDescr :: String -> Widget Name+drawDescr descr =+ strWrapWith wrapSettings descr'+ where+ descr' = dropWhileEnd isSpace descr++listMultipleChoice :: CorrectOption -> [IncorrectOption] -> [String]+listMultipleChoice c = reverse . listMultipleChoice' [] 0 c+ where listMultipleChoice' opts i (CorrectOption j cStr) [] = + if i == j+ then cStr : opts+ else opts+ listMultipleChoice' opts i c'@(CorrectOption j cStr) ics@(IncorrectOption icStr : ics') = + if i == j+ then listMultipleChoice' (cStr : opts) (i+1) c' ics+ else listMultipleChoice' (icStr : opts) (i+1) c' ics'++drawCardUI :: State -> 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 " ")+ + 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 " ")++ MultipleAnswer question options -> drawHeader question <=> B.hBorder <=> padRight (Pad p) (drawOptions s options <=> str " ")++drawDef :: State -> String -> Widget Name+drawDef s def = if s ^. showHints then drawHintedDef s def else drawNormalDef s def++drawHintedDef :: State -> String -> Widget Name+drawHintedDef s def = case s ^. cardState of+ DefinitionState {_flipped=f} -> if f then drawDescr def else drawDescr [if isSeparator char || char == '\n' then char else '_' | char <- def]+ _ -> error "impossible: " ++drawNormalDef:: State -> String -> Widget Name+drawNormalDef s def = case s ^. cardState of+ DefinitionState {_flipped=f} -> if f+ then drawDescr def+ else Widget Greedy Fixed $ do+ c <- getContext+ let w = c^.availWidthL+ let def' = dropWhileEnd isSpace def+ render . vBox $ [str " " | _ <- wrapTextToLines wrapSettings w (pack def')]+ _ -> error "impossible: " ++drawChoices :: State -> [String] -> Widget Name+drawChoices s options = case (s ^. cardState, s ^. currentCard) of+ (MultipleChoiceState {_highlighted=i, _tried=kvs}, MultipleChoice _ (CorrectOption k _) _) -> vBox formattedOptions+ + where formattedOptions :: [Widget Name]+ formattedOptions = [ prefix <+> coloring (drawDescr opt) |+ (j, opt) <- zip [0..] options,+ let prefix = if i == j then withAttr highlightedChoiceAttr (str "* ") else str " "+ chosen = M.findWithDefault False j kvs + coloring = case (chosen, j==k) of+ (False, _) -> id+ (True, False) -> withAttr incorrectChoiceAttr+ (True, True) -> withAttr correctChoiceAttr+ ]+ _ -> error "impossible"++drawOptions :: State -> 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..])+ where drawOption (Option kind text, i) = coloring (str "[") <+> coloring (highlighting (str symbol)) <+> coloring (str "] ") <+> drawDescr text+ where symbol = if (i == j && not submitted) || enabled then "*" else " "+ enabled = M.findWithDefault False i kvs+ highlighting = if i == j && not submitted then withAttr highlightedOptAttr else id+ coloring = case (submitted, enabled, kind) of+ (True, True, Correct) -> withAttr correctOptAttr+ (True, False, Incorrect) -> withAttr correctOptAttr+ (True, _, _) -> withAttr incorrectOptAttr+ (False, True, _) -> withAttr selectedOptAttr+ _ -> id++ _ -> error "hopefully this is never shown"+++drawPerforated :: State -> Perforated -> Widget Name+drawPerforated s p = drawSentence s $ perforatedToSentence p++drawSentence :: State -> 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 w state = vBox . fst . makeSentenceWidget' 0 0+ where+ makeSentenceWidget' :: Int -> Int -> Sentence -> ([Widget Name], Bool)+ makeSentenceWidget' padding _ (Normal s) = let (ws, _, fit) = wrapStringWithPadding padding w s in (ws, fit) + makeSentenceWidget' padding i (Perforated pre _ post) = case state ^. cardState of+ OpenQuestionState {_gapInput = kvs, _highlighted=j, _entered=submitted, _correctGaps=cgs} ->+ let (ws, n, fit') = wrapStringWithPadding padding w pre+ gap = M.findWithDefault "" i kvs+ n' = w - n - length gap ++ 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 (length gap, 0)) else id++ correct = M.findWithDefault False i cgs+ coloring = case (submitted, correct) of+ (False, _) -> withAttr gapAttr+ (True, False) -> withAttr incorrectGapAttr+ (True, True) -> withAttr correctGapAttr+ + gapWidget = cursor $ coloring (str gap) in++ if n' >= 0 + then let (ws1@(w':ws'), fit) = makeSentenceWidget' (w-n') (i+1) post in+ if fit then ((ws & _last %~ (<+> (gapWidget <+> w'))) ++ ws', fit')+ else ((ws & _last %~ (<+> gapWidget)) ++ ws1, fit')+ else let (ws1@(w':ws'), fit) = makeSentenceWidget' (length gap) (i+1) post in+ if fit then (ws ++ [gapWidget <+> w'] ++ ws', fit')+ else (ws ++ [gapWidget] ++ ws1, fit')+ _ -> error "PANIC!"++wrapStringWithPadding :: Int -> Int -> String -> ([Widget Name], Int, Bool)+wrapStringWithPadding padding w s+ | null (words s) = ([str ""], padding, True)+ | otherwise = if length (head (words s)) < w - padding then+ let startsWithSpace = head s == ' ' + s' = if startsWithSpace then " " <> replicate padding 'X' <> tail s else replicate padding 'X' ++ s+ lastLetter = last s+ postfix = if lastLetter == ' ' then T.pack [lastLetter] else T.empty+ ts = wrapTextToLines wrapSettings w (pack s') & ix 0 %~ (if startsWithSpace then (T.pack " " `T.append`) . T.drop (padding + 1) else T.drop padding)+ ts' = ts & _last %~ (`T.append` postfix)+ padding' = T.length (last ts') + (if length ts' == 1 then 1 else 0) * padding in+ (map txt (filter (/=T.empty) ts'), padding', True)+ else+ let lastLetter = last s+ (x: xs) = s+ s' = if x == ' ' then xs else s+ postfix = if lastLetter == ' ' then T.pack [lastLetter] else T.empty+ ts = wrapTextToLines wrapSettings w (pack s')+ ts' = ts & _last %~ (`T.append` postfix) in+ (map txt (filter (/=T.empty) ts'), T.length (last ts'), False)++drawCardBox :: Widget Name -> Widget Name+drawCardBox w = C.center $+ withBorderStyle BS.unicodeRounded $+ B.border $+ withAttr textboxAttr $+ hLimitPercent 60 w++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++ 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++ (MultipleChoiceState {_highlighted = i, _nChoices = 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++ _ -> continue 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, _nChoices = 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.KEnter [] ->+ if frozen+ then next s+ else continue $ s & cardState.selected %~ M.adjust not i++ _ -> continue 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++ (OpenQuestionState {_highlighted = i, _nGaps = n, _gapInput = kvs, _correctGaps = cGaps}, OpenQuestion _ perforated) ->+ let correct = M.foldr (&&) True cGaps in+ case ev of+ 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.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++ 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+ + _ -> error "impossible"+handleEvent s _ = continue s+ +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"++hiddenAttr :: AttrName+hiddenAttr = attrName "hidden"++gapAttr :: AttrName+gapAttr = attrName "gap"++incorrectGapAttr :: AttrName+incorrectGapAttr = attrName "incorrect gap"++correctGapAttr :: AttrName+correctGapAttr = attrName "correct gap"++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)+ , (hiddenAttr, fg V.black)+ , (gapAttr, V.defAttr `V.withStyle` V.underline)+ ]++runCardsUI :: [Card] -> IO State+runCardsUI 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++next :: State -> EventM Name (Next State)+next s+ | s ^. index + 1 < length (s ^. cards) = continue . updateState $ s & index +~ 1+ | otherwise = halt s++previous :: State -> EventM Name (Next State)+previous s | s ^. index > 0 = continue . updateState $ s & index -~ 1+ | otherwise = continue s++updateState :: State -> State+updateState s =+ let card = (s ^. cards) !! (s ^. index) in s+ & currentCard .~ card+ & cardState .~ defaultCardState card
+ src/UI/FileBrowser.hs view
@@ -0,0 +1,117 @@+{-# OPTIONS_GHC -Wall #-}+{-# LANGUAGE OverloadedStrings, TemplateHaskell, TupleSections #-}++module UI.FileBrowser (runFileBrowserUI) where++import Brick+import Data.List+import Data.Char+import Types+import Parser+import Control.Exception (displayException, try)+import Control.Monad.IO.Class+import Brick.Widgets.Border+import Brick.Widgets.Center+import Brick.Widgets.List+import Brick.Widgets.FileBrowser+import Lens.Micro.Platform+import qualified Graphics.Vty as V++type Event = ()+type Name = ()+data State = State+ { _fb :: FileBrowser Name+ , _exception :: Maybe String+ , _cards :: [Card]+ , _filePath :: Maybe FilePath+ }++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+ [ (listSelectedFocusedAttr, V.black `on` V.yellow)+ , (fileBrowserCurrentDirectoryAttr, V.white `on` V.blue)+ , (fileBrowserSelectionInfoAttr, V.white `on` V.blue)+ , (fileBrowserDirectoryAttr, fg V.blue)+ , (fileBrowserBlockDeviceAttr, fg V.magenta)+ , (fileBrowserCharacterDeviceAttr, fg V.green)+ , (fileBrowserNamedPipeAttr, fg V.yellow)+ , (fileBrowserSymbolicLinkAttr, fg V.cyan)+ , (fileBrowserUnixSocketAttr, fg V.red)+ , (fileBrowserSelectedAttr, V.white `on` V.magenta)+ , (errorAttr, fg V.red)+ ]++drawUI :: State -> [Widget Name]+drawUI State{_fb=b, _exception=exc} = [center $ ui <=> help]+ where+ ui = hCenter $+ vLimit 15 $+ hLimit 50 $+ borderWithLabel (txt "Choose a file") $+ renderFileBrowser True b+ help = padTop (Pad 1) $+ vBox [ hCenter $ txt "Up/Down: select"+ , 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+ V.EvKey V.KEsc [] | not (fileBrowserIsSearching b) ->+ halt s+ V.EvKey (V.KChar 'c') [V.MCtrl] | not (fileBrowserIsSearching b) ->+ halt s+ _ -> 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'+ [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)+ 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 (fileExtensionMatch' "txt")) browser+ s <- defaultMain app (State filteredBrowser Nothing [] Nothing)+ let mfp = s ^. filePath+ return $ fmap (s ^. cards,) mfp++fileExtensionMatch' :: String -> FileInfo -> Bool+fileExtensionMatch' ext i = case fileInfoFileType i of+ Just RegularFile -> ('.' : (toLower <$> ext)) `isSuffixOf` (toLower <$> fileInfoFilename i)+ _ -> True
+ src/UI/Info.hs view
@@ -0,0 +1,65 @@+module UI.Info (runInfoUI) where++import Brick+import Brick.Widgets.Border+import Brick.Widgets.Border.Style+import Brick.Widgets.Center+import Control.Monad (void)+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+ }++ui :: Widget Name+ui =+ joinBorders $+ center $ + withBorderStyle unicodeRounded $+ border $+ hLimit 40 $+ hCenter (withAttr titleAttr (str "Info")) <=>+ hBorder <=>+ drawInfo++handleEvent :: State -> BrickEvent Name Event -> EventM Name (Next State)+handleEvent s (VtyEvent e) =+ 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++titleAttr :: AttrName+titleAttr = attrName "title"++theMap :: AttrMap+theMap = attrMap V.defAttr+ [ (titleAttr, fg V.yellow) ]++drawInfo :: Widget Name+drawInfo = + padLeftRight 1 $+ vLimitPercent 60 $+ viewport () Vertical (strWrap info)++runInfoUI :: IO ()+runInfoUI = void $ defaultMain app ()++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 multiple choice questions with more than 1 possible answer\n * Use CTRL+Left and CTRL+Right to move to previous and next cards without having to answer them"
+ src/UI/MainMenu.hs view
@@ -0,0 +1,113 @@+module UI.MainMenu (runMainMenuUI) where++import Brick+import Brick.Widgets.Border+import Brick.Widgets.Border.Style+import Brick.Widgets.Center+import Data.Functor (($>))+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 = ()+type State = L.List Name String++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 s = + [ drawMenu s ]++drawMenu :: State -> Widget Name+drawMenu s = + joinBorders $+ center $ + withBorderStyle unicodeRounded $+ border $+ hLimit 40 $+ hCenter title <=>+ hBorder <=>+ drawList s++drawList :: State -> Widget Name+drawList s = vLimit 4 $+ L.renderList drawListElement True s++drawListElement :: Bool -> String -> Widget Name+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 l (VtyEvent e) =+ case e of+ V.EvKey (V.KChar 'c') [V.MCtrl] -> halt l+ V.EvKey V.KEsc [] -> halt l+ V.EvKey V.KEnter [] ->+ case L.listSelected l of+ Just 0 -> suspendAndResume $ runCardSelectorUI $> l+ Just 1 -> suspendAndResume $ runInfoUI $> l+ Just 2 -> suspendAndResume $ runSettingsUI $> l+ Just 3 -> halt l+ _ -> undefined++ ev -> continue =<< L.handleListEventVi L.handleListEvent ev l+handleEvent l _ = continue l++runMainMenuUI :: IO ()+runMainMenuUI = do+ let options = Vec.fromList [ "Select"+ , "Info"+ , "Settings"+ , "Quit" ]++ let initialState = L.list () options 1+ _ <- defaultMain app initialState+ return ()++-- _ _ _ +-- | | | | | |+-- | |__| | __ _ ___ ___ __ _ _ __ __| |+-- | __ |/ _` / __|/ __/ _` | '__/ _` |+-- | | | | (_| \__ \ (_| (_| | | | (_| |+-- |_| |_|\__,_|___/\___\__,_|_| \__,_|+ +-- _ _ +-- | | | |+-- | |__ __ _ ___ ___ __ _ _ __ __| |+-- | '_ \ / _` / __|/ __/ _` | '__/ _` |+-- | | | | (_| \__ \ (_| (_| | | | (_| |+-- |_| |_|\__,_|___/\___\__,_|_| \__,_|+ +-- ┬ ┬┌─┐┌─┐┌─┐┌─┐┬─┐┌┬┐+-- ├─┤├─┤└─┐│ ├─┤├┬┘ ││+-- ┴ ┴┴ ┴└─┘└─┘┴ ┴┴└──┴┘
+ src/UI/Settings.hs view
@@ -0,0 +1,143 @@+module UI.Settings (runSettingsUI, getShowHints, getShowControls, getUseEscapeCode) where++import Brick hiding (mergeWithDefault)+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 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+ }++ui :: State -> Widget Name+ui s =+ joinBorders $+ center $ + withBorderStyle unicodeRounded $+ border $+ hLimitPercent 60 $+ hLimit 40 $+ hCenter (withAttr titleAttr (str "Settings")) <=>+ hBorder <=>+ padLeftRight 1+ (drawSettings s)++handleEvent :: State -> BrickEvent Name Event -> EventM Name (Next State)+handleEvent s@(i, settings) (VtyEvent e) =+ 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)]++setSettings :: Settings -> IO ()+setSettings settings = do+ sf <- getSettingsFile+ writeFile sf (show settings)
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"