Yvee1/hascard
1
1
Fork 0
mirror of https://github.com/Yvee1/hascard.git synced 2024-11-22 04:33:06 +03:00
Code Issues Projects Releases Wiki Activity

Attempt at adding basic image support

Browse Source 
Parsing does not work completely yet
This commit is contained in:
Steven van den Broek 2020-11-13 12:33:17 +01:00
parent 0d11aad35f
commit e6c54b656e
10 changed files with 158 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
cards/images.txt Normal file
View File

@ -0,0 +1,15 @@
# What type of fruit is this?
![](pear.jpeg)
- Apple
- Pear
- Orange
- Banana
---
# More tests
![](pear.jpeg)
This is a pear
---
# Again
![](pear.jpeg)
This is a pear again
---

BIN
cards/pear.jpeg Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 25 KiB

4
src/DeckHandling.hs
View File

@ -4,13 +4,13 @@ import Lens.Micro.Platform
import States
import Types
doRandomization :: GlobalState -> [Card] -> IO [Card]
doRandomization :: GlobalState -> [a] -> IO [a]
doRandomization gs cards =
let n = length cards in do
cards' <- if gs^.parameters.pShuffle then sampleFrom (gs^.mwc) (shuffleN n cards) else return cards
return $ maybe cards' (`take` cards') (gs^.parameters.pSubset)
doChunking :: Chunk -> [Card] -> [Card]
doChunking :: Chunk -> [a] -> [a]
doChunking (Chunk i n) cards =
splitIntoNChunks n cards !! (i-1)

4
src/Import.hs
View File

@ -20,9 +20,9 @@ parseImportInput iType reverse input =
let listToTuple [q, a] = Just $ if not reverse then (q, a) else (a, q)
listToTuple _ = Nothing
xs = mapM (listToTuple . splitOn "\t") (lines input)
makeOpen (header, body) = OpenQuestion header
makeOpen (header, body) = OpenQuestion header Nothing
(P "" (NE.fromList (map (dropWhile isSpace) (splitOneOf ",/;" body))) (Normal ""))
in case iType of
Def -> map (uncurry Definition) <$> xs
Def -> map (\(s1, s2) -> Definition s1 Nothing s2) <$> xs
Open -> map makeOpen <$> xs

54
src/Parser.hs
View File

@ -12,7 +12,9 @@ import Data.Text (pack, unpack)
import Types
import qualified Data.List.NonEmpty as NE
-- Type synonyms for convenience
type Parser = Parsec Void String
type CardParser = Parser (Either String Card)
uncurry3 f (a, b, c) = f a b c
@ -27,42 +29,64 @@ pCards = (pCard `sepEndBy1` seperator) <* eof
pCard :: Parser (Either String Card)
pCard = try pMultChoice
<|> Right . uncurry MultipleAnswer <$> try pMultAnswer
<|> try pMultAnswer
<|> try pReorder
<|> Right . uncurry OpenQuestion <$> try pOpen
<|> Right . uncurry Definition <$> pDef
<|> try pOpen
<|> pDef
pHeader :: Parser String
pHeader = do
many eol
char '#'
spaceChar
many (noneOf ['\n', '\r'])
pImage :: Parser Image
pImage = do
many eol
char '!'
char '['
alt <- manyTill anySingle (char ']')
char '('
img <- manyTill anySingle (char ')')
return $ Image alt img
pMaybeImage :: Parser (Maybe Image)
pMaybeImage = Just <$> try pImage
<|> pure Nothing
pMultChoice :: CardParser
pMultChoice = do
header <- pHeader
img <- pMaybeImage
many eol
choices <- pChoice `sepBy1` lookAhead (try choicePrefix)
msgOrResult <- makeMultipleChoice choices
case msgOrResult of
Left errMsg -> do pos <- getSourcePos
return . Left $ sourcePosPretty pos <> "\n" <> errMsg
Right (correct, incorrects) -> return . Right $ MultipleChoice header correct incorrects
Right (correct, incorrects) -> return . Right $ MultipleChoice header img correct incorrects
pChoice :: Parser (Char, String)
pChoice = do
kind <- oneOf ['*','-']
spaceChar
text <- manyTill anySingle $ lookAhead (try (try choicePrefix <|> seperator <|> eof'))
return (kind, text)
choicePrefix :: Parser String
choicePrefix = string "- "
<|> string "* "
pMultAnswer :: CardParser
pMultAnswer = do
header <- pHeader
img <- pMaybeImage
many eol
options <- pOption `sepBy1` lookAhead (try (char '['))
return (header, NE.fromList options)
return . Right $ MultipleAnswer header img (NE.fromList options)
pOption :: Parser Option
pOption = do
char '['
kind <- oneOf ['*','x',' ']
@ -70,38 +94,46 @@ pOption = do
text <- manyTill anySingle $ lookAhead (try (seperator <|> string "[" <|> eof'))
return $ makeOption kind (dropWhileEnd isSpace' text)
pReorder :: CardParser
pReorder = do
header <- pHeader
img <- pMaybeImage
many eol
elements <- pReorderElement `sepBy1` lookAhead (try pReorderPrefix)
let numbers = map fst elements
if all (`elem` numbers) [1..length numbers]
then return . Right $ Reorder header (NE.fromList elements)
then return . Right $ Reorder header img (NE.fromList elements)
else do pos <- getSourcePos
return . Left $ sourcePosPretty pos <> "\n" <> "A reordering question should have numbers starting from 1 and increase from there without skipping any numbers, but this is not the case:\n"
<> unlines (map show numbers)
pReorderElement :: Parser (Int, String)
pReorderElement = do
int <- pReorderPrefix
text <- manyTill anySingle $ lookAhead (try (try seperator <|> try pReorderPrefix <|> eof'))
return (read int, dropWhileEnd isSpace' text)
pReorderPrefix :: Parser String
pReorderPrefix = do
int <- some digitChar
string ". "
return int
pOpen :: CardParser
pOpen = do
header <- pHeader
img <- pMaybeImage
many eol
(pre, gap) <- pGap
sentence <- pSentence
return (header, P pre gap sentence)
return $ Right (OpenQuestion header img (P pre gap sentence))
pSentence :: Parser Sentence
pSentence = try pPerforated
<|> pNormal
pPerforated :: Parser Sentence
pPerforated = do
(pre, gap) <- pGap
Perforated pre gap <$> pSentence
@ -109,6 +141,7 @@ pPerforated = do
chars = try escaped <|> anySingle
escaped = char '\\' >> char '_'
pGap :: Parser (String, NE.NonEmpty String)
pGap = do
pre <- manyTill chars $ lookAhead (try (string "_" <|> seperator))
char '_'
@ -120,15 +153,18 @@ gappedSpecialChars = seperator
<|> string "|"
<|> string "_"
pNormal :: Parser Sentence
pNormal = do
text <- manyTill (noneOf ['_']) $ lookAhead $ try $ seperator <|> eof'
return (Normal (dropWhileEnd isSpace' text))
pDef :: CardParser
pDef = do
header <- pHeader
img <- pMaybeImage
many eol
descr <- manyTill chars $ lookAhead $ try $ seperator <|> eof'
return (header, dropWhileEnd isSpace' descr)
return $ Right (Definition header img (dropWhileEnd isSpace' descr))
eof' = eof >> return [] <?> "end of file"

2
src/Runners.hs
View File

@ -47,7 +47,7 @@ cardsState doReview fp deck = do
controls <- getShowControls
let mFirstCard = safeHead deck
firstCard = fromMaybe (Definition "Empty deck" "Click enter to go back.") mFirstCard
firstCard = fromMaybe (Definition "Empty deck" Nothing "Click enter to go back.") mFirstCard
deck' = maybe [firstCard] (const deck) mFirstCard
initialState =

49
src/States.hs
View File

@ -103,43 +103,50 @@ data CardState =
defaultCardState :: Card -> CardState
defaultCardState Definition{} = DefinitionState { _flipped = False }
defaultCardState (MultipleChoice _ _ ics) = MultipleChoiceState
defaultCardState MultipleChoice{incorrects = ics} = MultipleChoiceState
{ _highlighted = 0
, _number = length ics + 1
, _tried = M.fromList [(i, False) | i <- [0..length ics]] }
defaultCardState (OpenQuestion _ perforated) = OpenQuestionState
defaultCardState OpenQuestion{perforated=perf} = OpenQuestionState
{ _gapInput = M.empty
, _highlighted = 0
, _number = nGapsInPerforated perforated
, _number = nGapsInPerforated perf
, _entered = False
, _correctGaps = M.fromList [(i, False) | i <- [0..nGapsInPerforated perforated - 1]]
, _correctGaps = M.fromList [(i, False) | i <- [0..nGapsInPerforated perf - 1]]
, _failed = False }
defaultCardState (MultipleAnswer _ answers) = MultipleAnswerState
defaultCardState MultipleAnswer{options=opts} = MultipleAnswerState
{ _highlighted = 0
, _selected = M.fromList [(i, False) | i <- [0..NE.length answers-1]]
, _selected = M.fromList [(i, False) | i <- [0..NE.length opts-1]]
, _entered = False
, _number = NE.length answers }
defaultCardState (Reorder _ elements) = ReorderState
, _number = NE.length opts }
defaultCardState Reorder{elements=elts} = ReorderState
{ _highlighted = 0
, _grabbed = False
, _order = M.fromList (zip [0..] (NE.toList elements))
, _order = M.fromList (zip [0..] (NE.toList elts))
, _entered = False
, _number = NE.length elements }
, _number = NE.length elts }
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
, _reviewMode :: Bool
, _correctCards :: [Int] -- list of indices of correct cards
, _popup :: Maybe (Popup CS)
, _pathToFile :: FilePath
{ _cards :: [Card] -- list of flashcards
, _index :: Int -- current card index
, _nCards :: Int -- number of cards
, _currentCard :: Card
, _cardState :: CardState
, _showHints :: Bool
, _showControls :: Bool
, _reviewMode :: Bool
, _correctCards :: [Int] -- list of indices of correct cards
, _popup :: Maybe (Popup CS)
, _pathToFile :: FilePath
}
-- -- Lens for just accessing the cards
-- cards :: Lens' CS [Card]
-- cards = lens (map snd . _cardsAndImages) (\cs cards -> cs {_cardsAndImages = zip (map fst (_cardsAndImages cs)) cards})
-- currentCard :: Lens' CS Card
-- currentCard = lens (snd . _currentCardAndImage) (\cs card -> cs {_currentCardAndImage = (fst (_currentCardAndImage cs), card)})
data Popup s = Popup
{ drawPopup :: s -> Widget Name
, handlePopupEvent :: GlobalState -> s -> V.Event -> EventM Name (Next GlobalState)

61
src/Types.hs
View File

@ -2,34 +2,75 @@ module Types where
import Data.Functor
import Data.List
import Data.List.NonEmpty (NonEmpty)
import System.FilePath
import System.Process (runCommand)
import System.Info
import qualified Data.List.NonEmpty as NE
import qualified System.Directory as D
-- Word Description
data Card = Definition String String
| OpenQuestion String Perforated
data Card = Definition {
question :: String,
image :: Maybe Image,
definition :: String }
| OpenQuestion {
question :: String,
image :: Maybe Image,
perforated :: Perforated }
| MultipleChoice {
question :: String,
image :: Maybe Image,
correct :: CorrectOption,
incorrects :: [IncorrectOption]}
| MultipleAnswer {
question :: String,
image :: Maybe Image,
options :: NonEmpty Option }
| Reorder {
question :: String,
image :: Maybe Image,
elements :: NonEmpty (Int, String)
}
instance Show Card where
show card = let showHeader h = "# " <> h <> "\n"
in case card of
Definition h descr -> showHeader h <> descr
OpenQuestion h p -> showHeader h <> show p
MultipleChoice h c inc ->
showHeader h <> showMultipleChoice c inc
MultipleAnswer h opts ->
showHeader h <> unlines' (NE.toList (NE.map show opts))
Reorder h elts ->
showHeader h <> unlines' (NE.toList (NE.map showReorder elts))
Definition h img descr -> showHeader h <> show img <> "\n" <> descr
OpenQuestion h img p -> showHeader h <> show img <> "\n" <> show p
MultipleChoice h img c inc ->
showHeader h <> show img <> "\n" <> showMultipleChoice c inc
MultipleAnswer h img opts ->
showHeader h <> show img <> "\n" <> unlines' (NE.toList (NE.map show opts))
Reorder h img elts ->
showHeader h <> show img<> "\n" <> unlines' (NE.toList (NE.map showReorder elts))
-- alt file
data Image = Image String String
instance Show Image where
show (Image alt file) = "![" <> alt <> "]" <> "(" <> file <> ")"
openCommand :: String
openCommand = case os of
"darwin" -> "open"
"linux" -> "xdg-open"
_ -> error "Unkown OS for opening images"
openImage :: FilePath -> Image -> IO ()
openImage origin (Image _ relative) = openImage' (origin </> relative)
openImage' :: FilePath -> IO ()
openImage' fp = do
exists <- D.doesFileExist fp
if exists
then void $ runCommand (openCommand <> " \"" <> fp <> "\"")
else error $ "The image you were trying to open does not exist: " <> fp
openCardImage :: FilePath -> Card -> IO ()
openCardImage fp = flip whenJust (openImage fp) . image
whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
whenJust mg f = maybe (pure ()) f mg
data Type = Incorrect | Correct
deriving (Show, Eq)

3
src/UI.hs
View File

@ -6,6 +6,7 @@ module UI
, GenIO
, Chunk(..)
, Card
, Image
, ImportType(..)
, Parameters(..)
@ -26,7 +27,7 @@ import Glue
import Import
import States
import StateManagement
import Types (Card, cardsToString)
import Types (Card, Image, cardsToString)
runBrickFlashcards :: GlobalState -> IO ()
runBrickFlashcards gs = do

24
src/UI/Cards.hs
View File

@ -63,23 +63,23 @@ drawCardUI :: CS -> Widget Name
drawCardUI s = let p = 1 in
joinBorders $ drawCardBox $ (<=> drawFooter s) $
case (s ^. cards) !! (s ^. index) of
Definition title descr -> drawHeader title
Definition title _ descr -> drawHeader title
<=> B.hBorder
<=> padLeftRight p (drawDef s descr <=> str " ")
MultipleChoice question correct others -> drawHeader question
MultipleChoice question _ correct others -> drawHeader question
<=> B.hBorder
<=> padLeftRight p (drawChoices s (listMultipleChoice correct others) <=> str " ")
OpenQuestion title perforated -> drawHeader title
OpenQuestion title _ perforated -> drawHeader title
<=> B.hBorder
<=> padLeftRight p (atLeastV 1 (drawPerforated s perforated) <=> str " ")
MultipleAnswer question options -> drawHeader question
MultipleAnswer question _ options -> drawHeader question
<=> B.hBorder
<=> padRight (Pad p) (drawOptions s options <=> str " ")
Reorder question _ -> drawHeader question
Reorder question _ _ -> drawHeader question
<=> B.hBorder
<=> padLeftRight p (drawReorder s <=> str " ")
@ -118,7 +118,7 @@ drawNormalDef s def = case s ^. cardState of
drawChoices :: CS -> [String] -> Widget Name
drawChoices s options = case (s ^. cardState, s ^. currentCard) of
(MultipleChoiceState {_highlighted=i, _tried=kvs}, MultipleChoice _ (CorrectOption k _) _) -> vBox formattedOptions
(MultipleChoiceState {_highlighted=i, _tried=kvs}, MultipleChoice _ _ (CorrectOption k _) _) -> vBox formattedOptions
where formattedOptions :: [Widget Name]
formattedOptions = [ prefix <+> coloring (drawDescr opt) |
@ -214,7 +214,7 @@ wrapStringWithPadding padding w s
drawReorder :: CS -> Widget Name
drawReorder s = case (s ^. cardState, s ^. currentCard) of
(ReorderState {_highlighted=j, _grabbed=g, _order=kvs, _number=n, _entered=submitted}, Reorder _ _) ->
(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)) ->
let color = case (i == j, g) of
@ -259,7 +259,7 @@ handleEvent gs s (VtyEvent e) =
else continue' $ s & cardState.flipped %~ not
_ -> continue' s
(MultipleChoiceState {_highlighted = i, _number = n, _tried = kvs}, MultipleChoice _ (CorrectOption j _) _) ->
(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
@ -286,7 +286,7 @@ handleEvent gs s (VtyEvent e) =
correctlyAnswered = i == j && M.size (M.filter (==True) kvs) == 1
(MultipleAnswerState {_highlighted = i, _number = n, _entered = submitted, _selected = kvs}, MultipleAnswer _ opts) ->
(MultipleAnswerState {_highlighted = i, _number = n, _entered = submitted, _selected = kvs}, MultipleAnswer _ _ opts) ->
case ev of
V.EvKey V.KUp [] -> continue' up
V.EvKey (V.KChar 'k') [] -> continue' up
@ -315,7 +315,7 @@ handleEvent gs s (VtyEvent e) =
correctlyAnswered = NE.toList (NE.map isOptionCorrect opts) == map snd (M.toAscList kvs)
(OpenQuestionState {_highlighted = i, _number = n, _gapInput = kvs, _correctGaps = cGaps, _failed=fail}, OpenQuestion _ perforated) ->
(OpenQuestionState {_highlighted = i, _number = n, _gapInput = kvs, _correctGaps = cGaps, _failed=fail}, OpenQuestion _ _ perforated) ->
let frozen = M.foldr (&&) True cGaps in
case ev of
V.EvKey (V.KFun 1) [] -> continue' $
@ -364,7 +364,7 @@ handleEvent gs s (VtyEvent e) =
backspace xs = init xs
_ -> continue' s
(ReorderState {_highlighted = i, _entered = submitted, _grabbed=dragging, _number = n, _order = kvs }, Reorder _ elts) ->
(ReorderState {_highlighted = i, _entered = submitted, _grabbed=dragging, _number = n, _order = kvs }, Reorder _ _ elts) ->
case ev of
V.EvKey V.KUp [] -> continue' up
V.EvKey (V.KChar 'k') [] -> continue' up
@ -406,7 +406,7 @@ handleEvent gs _ _ = continue gs
next :: GlobalState -> CS -> EventM Name (Next GlobalState)
next gs s
| s ^. index + 1 < length (s ^. cards) = continue . updateCS gs . straightenState $ s & index +~ 1
| s ^. index + 1 < length (s ^. cards) = liftIO (openCardImage (takeDirectory (s^.pathToFile)) ((s^.cards) !! (s^.index + 1))) *> (continue . updateCS gs . straightenState $ s & index +~ 1)
| s ^. reviewMode =
let thePopup =
if null (s^.correctCards) || length (s^. correctCards) == length (s^.cards)