Yvee1/hascard
1
1
Fork 0
mirror of https://github.com/Yvee1/hascard.git synced 2024-10-05 19:49:16 +03:00
Code Issues Projects Releases Wiki Activity

Update resolver and brick, which required refactor to MonadState

Browse Source
This commit is contained in:
Yvee1 2023-05-17 21:07:30 +02:00
parent 4b0981240d
commit f07ce0f769
19 changed files with 594 additions and 526 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@ -2,4 +2,5 @@
hascard.cabal
*~
*.snap
images/
images/
dist-newstyle

4
app/Main.hs
View File

@ -138,8 +138,8 @@ run opts = run' (opts ^. optFile)
start (Just (fp, result)) (mkGlobalState opts gen)
start :: Maybe (FilePath, [Card]) -> GlobalState -> IO ()
start Nothing gs = runBrickFlashcards (gs `goToState` mainMenuState)
start (Just (fp, cards)) gs = runBrickFlashcards =<< (gs `goToState`) <$> cardsWithOptionsState gs fp cards
start Nothing gs = runBrickFlashcards (gs `goToState_` mainMenuState)
start (Just (fp, cards)) gs = runBrickFlashcards =<< (gs `goToState_`) <$> cardsWithOptionsState gs fp cards
doImport :: ImportOpts -> IO ()
doImport opts' = do

6
package.yaml
View File

@ -21,7 +21,7 @@ description: Hascard is a text-based user interface for reviewing notes
dependencies:
- base >= 4.7 && < 5
- brick >= 0.52.1 && < 0.70.0
- brick >= 1.4 && < 2.0
- containers > 0.6.0 && < 0.7
- directory >= 1.3.3 && < 1.4
- filepath >= 1.4.2 && < 1.5
@ -36,12 +36,14 @@ dependencies:
- strict >= 0.3.2 && < 0.5
- text >= 1.2.3 && < 1.3
- vector >= 0.12.0 && < 0.13
- vty >= 5.28.2 && < 5.36
- vty >= 5.28.2 && < 5.38
- word-wrap >= 0.4.1 && < 0.6
- tasty >= 1.2.1 && < 1.5
- tasty-hunit >= 0.10.0 && < 0.11
- tasty-quickcheck >= 0.10.1 && < 0.11
- split >= 0.2.3 && < 0.3
- mtl >= 2.2 && < 2.4
- extra >= 1.7 && < 1.8
library:
source-dirs: src

30
src/Glue.hs
View File

@ -1,5 +1,6 @@
module Glue where
import Brick
import Control.Monad.State.Lazy
import States
import StateManagement
import qualified Graphics.Vty as V
@ -16,12 +17,12 @@ globalApp = App
{ appDraw = drawUI
, appChooseCursor = showFirstCursor
, appHandleEvent = handleEvent
, appStartEvent = return
, appStartEvent = return ()
, appAttrMap = handleAttrMap
}
drawUI :: GlobalState -> [Widget Name]
drawUI gs = case getState gs of
drawUI gs = case evalState getState gs of
MainMenuState s -> MM.drawUI s
SettingsState s -> S.drawUI s
InfoState s -> I.drawUI s
@ -30,20 +31,21 @@ drawUI gs = case getState gs of
CardsState s -> C.drawUI s
ParameterState s -> P.drawUI s
handleEvent :: GlobalState -> BrickEvent Name Event -> EventM Name (Next GlobalState)
handleEvent gs ev =
if ev == VtyEvent (V.EvKey (V.KChar 'c') [V.MCtrl]) then halt gs else
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
ParameterState s -> P.handleEvent gs s ev
handleEvent :: BrickEvent Name Event -> EventM Name GlobalState ()
handleEvent ev = do
if ev == VtyEvent (V.EvKey (V.KChar 'c') [V.MCtrl]) then halt else do
s <- getState
case s of
MainMenuState s -> MM.handleEvent ev
SettingsState s -> S.handleEvent ev
InfoState s -> I.handleEvent ev
CardSelectorState s -> CS.handleEvent ev
FileBrowserState s -> FB.handleEvent ev
CardsState s -> C.handleEvent ev
ParameterState s -> P.handleEvent ev
handleAttrMap :: GlobalState -> AttrMap
handleAttrMap gs = case getState gs of
handleAttrMap gs = case evalState getState gs of
MainMenuState _ -> MM.theMap
SettingsState _ -> S.theMap
InfoState _ -> I.theMap

78
src/Parameters.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RankNTypes, FlexibleContexts #-}
module Parameters where
import UI.Attributes
import Brick
@ -35,47 +35,51 @@ chunkSubsetField :: Int -> Lens' s (Chunk, Int) -> s -> FormFieldState s e Name
chunkSubsetField capacity stLens initialState =
let (initChunk, initInt) = initialState ^. stLens
handleChunkEvent1 :: BrickEvent n e -> (Chunk, Int) -> EventM n (Chunk, Int)
handleChunkEvent1 (VtyEvent ev) s@(c@(Chunk i n), int) = case ev of
V.EvKey (V.KChar c) [] | isDigit c ->
let i' = read (show i ++ [c])
in return $ if i' <= n || n == 0 then (Chunk i' n, getSizeOfChunk (Chunk i' n)) else (Chunk n n, getSizeOfChunk (Chunk n n))
V.EvKey V.KBS [] ->
let calcNew x = if null (show x) then 0 else fromMaybe 0 (readMaybe (init (show x)))
in return (Chunk (calcNew i) n, int)
_ -> return s
handleChunkEvent1 _ s = return s
handleChunkEvent1 :: BrickEvent n e -> EventM n (Chunk, Int) ()
handleChunkEvent1 (VtyEvent ev) = do
s@(c@(Chunk i n), int) <- get
case ev of
V.EvKey (V.KChar c) [] | isDigit c -> do
let i' = read (show i ++ [c])
put $ if i' <= n || n == 0 then (Chunk i' n, getSizeOfChunk (Chunk i' n)) else (Chunk n n, getSizeOfChunk (Chunk n n))
V.EvKey V.KBS [] -> do
let calcNew x = if null (show x) then 0 else fromMaybe 0 (readMaybe (init (show x)))
put (Chunk (calcNew i) n, int)
_ -> return ()
handleChunkEvent1 _ = return ()
handleChunkEvent2 :: BrickEvent n e -> (Chunk, Int) -> EventM n (Chunk, Int)
handleChunkEvent2 (VtyEvent ev) s@(c@(Chunk i n), int) = case ev of
V.EvKey (V.KChar c) [] | isDigit c ->
let n' = read (show n ++ [c])
i' = if i <= n' || n' == 0 then i else n'
in return $ if n' <= capacity then (Chunk i' n', getSizeOfChunk (Chunk i' n')) else (Chunk i capacity, getSizeOfChunk (Chunk i capacity))
V.EvKey V.KBS [] ->
let calcNew x = if null (show x) then 0 else fromMaybe 0 (readMaybe (init (show x)))
in return $
let newN = calcNew n
newI = if i <= newN || newN == 0 then i else newN
in (Chunk newI newN, int)
_ -> return s
handleChunkEvent2 _ s = return s
handleChunkEvent2 :: BrickEvent n e -> EventM n (Chunk, Int) ()
handleChunkEvent2 (VtyEvent ev) = do
s@(c@(Chunk i n), int) <- get
case ev of
V.EvKey (V.KChar c) [] | isDigit c -> do
let n' = read (show n ++ [c])
i' = if i <= n' || n' == 0 then i else n'
put $ if n' <= capacity then (Chunk i' n', getSizeOfChunk (Chunk i' n')) else (Chunk i capacity, getSizeOfChunk (Chunk i capacity))
V.EvKey V.KBS [] -> do
let calcNew x = if null (show x) then 0 else fromMaybe 0 (readMaybe (init (show x)))
newN = calcNew n
newI = if i <= newN || newN == 0 then i else newN
put (Chunk newI newN, int)
_ -> return ()
handleChunkEvent2 _ = return ()
handleSubsetEvent :: BrickEvent n e -> (Chunk, Int) -> EventM n (Chunk, Int)
handleSubsetEvent (VtyEvent ev) s@(ch@(Chunk i n), int) =
handleSubsetEvent :: BrickEvent n e -> EventM n (Chunk, Int) ()
handleSubsetEvent (VtyEvent ev) = do
s@(ch@(Chunk i n), int) <- get
let bound = getSizeOfChunk ch in
case ev of
V.EvKey (V.KChar c) [] | isDigit c ->
V.EvKey (V.KChar c) [] | isDigit c -> do
let newValue = read (show int ++ [c])
int' = if newValue <= bound then newValue else bound
in return (ch, int')
V.EvKey V.KBS [] ->
int' = min newValue bound
put (ch, int')
V.EvKey V.KBS [] -> do
let int' = case show int of
"" -> 0
xs -> fromMaybe 0 (readMaybe (init xs))
in return (ch, int')
_ -> return s
handleSubsetEvent _ s = return s
put (ch, int')
_ -> return ()
handleSubsetEvent _ = return ()
renderChunk1 :: Bool -> (Chunk, Int) -> Widget Name
renderChunk1 foc (Chunk i n, _) =
@ -131,6 +135,7 @@ chunkSubsetField capacity stLens initialState =
handleSubsetEvent
]
, formFieldLens = stLens
, formFieldUpdate = const
, formFieldRenderHelper = id
, formFieldConcat = customConcat }
@ -138,14 +143,15 @@ okField :: (Ord n, Show n) => Lens' s Bool -> n -> String -> s -> FormFieldState
okField stLens name label initialState =
let initVal = initialState ^. stLens
handleEvent (VtyEvent (V.EvKey V.KEnter [])) _ = return True
handleEvent _ s = return s
handleEvent (VtyEvent (V.EvKey V.KEnter [])) = put True
handleEvent _ = return ()
in FormFieldState { formFieldState = initVal
, formFields = [ FormField name Just True
(renderOk label name)
handleEvent ]
, formFieldLens = stLens
, formFieldUpdate = const
, formFieldRenderHelper = id
, formFieldConcat = vBox }

8
src/Runners.hs
View File

@ -1,6 +1,9 @@
{-# LANGUAGE FlexibleContexts #-}
module Runners where
import Brick.Widgets.FileBrowser
import Brick.Forms
import Control.Monad.IO.Class
import Control.Monad.State.Class
import DeckHandling
import Data.Maybe (fromMaybe)
import Recents
@ -71,6 +74,11 @@ cardsState doReview fp originalDeck shuffledDeck ixs = do
openCardExternal (takeDirectory fp) firstCard
return $ CardsState initialState
cardsWithOptionsStateM :: (MonadState GlobalState m, MonadIO m) => FilePath -> [Card] -> m State
cardsWithOptionsStateM fp cards = do
gs <- get
liftIO $ cardsWithOptionsState gs fp cards
cardsWithOptionsState :: GlobalState -> FilePath -> [Card] -> IO State
cardsWithOptionsState gs fp cards =
let chunked = doChunking (gs^.parameters.pChunk) cards

165
src/StateManagement.hs
View File

@ -1,6 +1,10 @@
{-# LANGUAGE FlexibleContexts #-}
module StateManagement where
import Brick
import Control.Monad.IO.Class
import Control.Monad.State.Class
import Control.Monad.State.Lazy (execState)
import Control.Monad (when, (<=<))
import Data.Maybe (fromJust)
import Lens.Micro.Platform
import Recents
@ -20,95 +24,116 @@ getMode (FileBrowserState _) = FileBrowser
getMode (CardsState _) = Cards
getMode (ParameterState _) = Parameter
getState :: GlobalState -> State
getState = fromJust . safeGetState
getState :: MonadState GlobalState m => m State
getState = fromJust <$> safeGetState
updateState :: GlobalState -> State -> GlobalState
updateState gs s = gs & states %~ M.insert (getMode s) s
mms :: Lens' GlobalState MMS
mms = lens (\gs -> mmsCast . fromJust $ M.lookup MainMenu (gs ^. states)) (\gs s -> gs & states %~ M.insert MainMenu (MainMenuState s))
where mmsCast s@(MainMenuState mms) = mms
mmsCast _ = error "impossible"
updateMMS :: GlobalState -> MMS -> GlobalState
updateMMS gs s = updateState gs (MainMenuState s)
ss :: Lens' GlobalState SS
ss = lens (\gs -> ssCast . fromJust $ M.lookup Settings (gs ^. states)) (\gs s -> gs & states %~ M.insert Settings (SettingsState s))
where ssCast s@(SettingsState ss) = ss
ssCast _ = error "impossible"
updateSS :: GlobalState -> SS -> GlobalState
updateSS gs s = updateState gs (SettingsState s)
is :: Lens' GlobalState IS
is = lens (\gs -> isCast . fromJust $ M.lookup Info (gs ^. states)) (\gs s -> gs & states %~ M.insert Info (InfoState s))
where isCast s@(InfoState ss) = ss
isCast _ = error "impossible"
updateIS :: GlobalState -> IS -> GlobalState
updateIS gs s = updateState gs (InfoState s)
cs :: Lens' GlobalState CS
cs = lens (\gs -> csCast . fromJust $ M.lookup Cards (gs ^. states)) (\gs s -> gs & states %~ M.insert Cards (CardsState s))
where csCast s@(CardsState cs) = cs
csCast _ = error "impossible"
updateCS :: GlobalState -> CS -> GlobalState
updateCS gs s = updateState gs (CardsState s)
css :: Lens' GlobalState CSS
css = lens (\gs -> cssCast . fromJust $ M.lookup CardSelector (gs ^. states)) (\gs s -> gs & states %~ M.insert CardSelector (CardSelectorState s))
where cssCast s@(CardSelectorState css) = css
cssCast _ = error "impossible"
updateCSS :: GlobalState -> CSS -> GlobalState
updateCSS gs s = updateState gs (CardSelectorState s)
fbs :: Lens' GlobalState FBS
fbs = lens (\gs -> fbsCast . fromJust $ M.lookup FileBrowser (gs ^. states)) (\gs s -> gs & states %~ M.insert FileBrowser (FileBrowserState s))
where fbsCast s@(FileBrowserState fbs) = fbs
fbsCast _ = error "impossible"
updateInfo :: GlobalState -> IS -> GlobalState
updateInfo gs s = updateState gs (InfoState s)
ps :: Lens' GlobalState PS
ps = lens (\gs -> psCast . fromJust $ M.lookup Parameter (gs ^. states)) (\gs s -> gs & states %~ M.insert Parameter (ParameterState s))
where psCast s@(ParameterState ps) = ps
psCast _ = error "impossible"
updateFBS :: GlobalState -> FBS -> GlobalState
updateFBS gs s = updateState gs (FileBrowserState s)
goToState_ :: GlobalState -> State -> GlobalState
goToState_ gs s = execState (goToState s) gs
updatePS :: GlobalState -> PS -> GlobalState
updatePS gs s = updateState gs (ParameterState s)
goToState :: MonadState GlobalState m => State -> m ()
goToState s = do states %= M.insert (getMode s) s
stack %= insert (getMode 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)
moveToState :: MonadState GlobalState m => State -> m ()
moveToState s = do
popState
goToState s
-- popState until at mode of state s.
removeToState :: GlobalState -> State -> GlobalState
removeToState gs s = go (popState gs)
where go global =
let current = Stack.head (global ^. stack)
in if current == getMode s then moveToState global s
else go (popState global)
removeToState :: MonadState GlobalState m => State -> m ()
removeToState s = do
popState
current <- Stack.head <$> use stack
if current == getMode s
then moveToState s
else removeToState s
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'
popState :: MonadState GlobalState m => m ()
popState = do
s <- use stack
let top = Stack.head s
s' = Stack.pop s
states %= M.delete top
stack .= s'
popStateOrQuit :: GlobalState -> EventM n (Next GlobalState)
popStateOrQuit gs = let gs' = popState gs in
if Stack.size (gs' ^. stack) == 0
then halt gs'
else continue gs'
popStateOrQuit :: EventM n GlobalState ()
popStateOrQuit =
do popState
s <- use stack
when (Stack.size s == 0) halt
safeGetState :: GlobalState -> Maybe State
safeGetState gs = do
key <- safeHead (gs ^. stack)
M.lookup key (gs ^. states)
safeGetState :: MonadState GlobalState m => m (Maybe State)
safeGetState = do
gs <- get
return $ 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)
goToModeOrQuit :: Mode -> EventM n GlobalState ()
goToModeOrQuit mode = do
mMode <- M.lookup mode <$> use states
maybe halt goToState mMode
moveToModeOrQuit :: GlobalState -> Mode -> EventM n (Next GlobalState)
moveToModeOrQuit = moveToModeOrQuit' return
removeToMode :: MonadState GlobalState m => Mode -> m ()
removeToMode m = do
popState
current <- Stack.head <$> use stack
if current == m
then return ()
else removeToMode m
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)
removeToModeOrQuit :: Mode -> EventM n GlobalState ()
removeToModeOrQuit = removeToModeOrQuit' $ return ()
removeToModeOrQuit :: GlobalState -> Mode -> EventM n (Next GlobalState)
removeToModeOrQuit = removeToModeOrQuit' return
removeToModeOrQuit' :: EventM n GlobalState () -> Mode -> EventM n GlobalState ()
removeToModeOrQuit' beforeMoving mode = do
mState <- M.lookup mode <$> use states
case mState of
Nothing -> halt
Just m -> do
gs <- get
beforeMoving
removeToMode mode
removeToModeOrQuit' :: (State -> IO State) -> GlobalState -> Mode -> EventM n (Next GlobalState)
removeToModeOrQuit' f gs mode =
maybe (halt gs) (\s -> continue . removeToState gs =<< liftIO (f s)) $ M.lookup mode (gs ^. states)
refreshRecents :: CSS -> IO CSS
refreshRecents s = do
rs <- getRecents
refreshRecents :: (MonadState CSS m, MonadIO m) => m ()
refreshRecents = do
rs <- liftIO getRecents
let prettyRecents = shortenFilepaths (toList rs)
options = Vec.fromList (prettyRecents ++ ["Select file from system"])
return $ s & recents .~ rs
& list .~ L.list Ordinary options 1
refreshRecents' :: GlobalState -> IO GlobalState
refreshRecents' gs = maybe (return gs) ((updateCSS gs <$>) . refreshRecents) ((\(CardSelectorState s) -> s) <$> M.lookup CardSelector (gs^.states))
recents .= rs
list .= L.list Ordinary options 1

10
src/States.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE TemplateHaskell #-}
module States (module States, GenIO) where
import Brick (Widget, EventM, Next)
import Brick (Widget, EventM)
import Brick.Forms (Form)
import Brick.Widgets.FileBrowser
import Brick.Widgets.List (List)
@ -142,7 +142,7 @@ data CS = CS
, _isCaseSensitive :: Bool
, _reviewMode :: Bool
, _correctCards :: [Int] -- list of indices of correct cards
, _popup :: Maybe (Popup CS)
, _popup :: Maybe (Popup GlobalState CS)
, _pathToFile :: FilePath
}
@ -153,9 +153,9 @@ data CS = CS
-- 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)
data Popup s d = Popup
{ drawPopup :: d -> Widget Name
, handlePopupEvent :: V.Event -> EventM Name s ()
, _popupState :: PopupState
}

2
src/UI.hs
View File

@ -11,7 +11,7 @@ module UI
, ImportOpts(..)
, Parameters(..)
, goToState
, goToState_
, cardsToString

29
src/UI/BrickHelpers.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RankNTypes, FlexibleContexts #-}
module UI.BrickHelpers where
import Text.Wrap
import Brick
@ -66,16 +66,17 @@ yesnoField :: (Ord n, Show n) => Bool -> Lens' s Bool -> n -> String -> s -> For
yesnoField rightAlign 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
handleEvent (MouseDown n _ _ _) | n == name = modify not
handleEvent (VtyEvent (V.EvKey (V.KChar ' ') [])) = modify not
handleEvent (VtyEvent (V.EvKey V.KEnter [])) = modify not
handleEvent _ = return ()
in FormFieldState { formFieldState = initVal
, formFields = [ FormField name Just True
(renderYesno rightAlign label name)
handleEvent ]
, formFieldLens = stLens
, formFieldUpdate = const
, formFieldRenderHelper = id
, formFieldConcat = vBox }
@ -93,19 +94,23 @@ naturalNumberField :: (Ord n, Show n) => Int -> Lens' s Int -> n -> String -> s
naturalNumberField bound stLens name postfix initialState =
let initVal = initialState ^. stLens
handleEvent (VtyEvent (V.EvKey (V.KChar c) [])) s | isDigit c =
let newValue = read (show s ++ [c])
in return $ if newValue <= bound then newValue else bound
handleEvent (VtyEvent (V.EvKey V.KBS [])) s = return $ case show s of
"" -> 0
xs -> fromMaybe 0 (readMaybe (init xs))
handleEvent _ s = return s
handleEvent (VtyEvent (V.EvKey (V.KChar c) [])) | isDigit c =
do s <- get
let newValue = read (show s ++ [c])
put $ min newValue bound
handleEvent (VtyEvent (V.EvKey V.KBS [])) =
do s <- get
put $ case show s of
"" -> 0
xs -> fromMaybe 0 (readMaybe (init xs))
handleEvent _ = return ()
in FormFieldState { formFieldState = initVal
, formFields = [ FormField name Just True
(renderNaturalNumber bound postfix name)
handleEvent ]
, formFieldLens = stLens
, formFieldUpdate = const
, formFieldRenderHelper = id
, formFieldConcat = vBox }

72
src/UI/CardSelector.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
module UI.CardSelector
( State
, drawUI
@ -13,6 +15,7 @@ import Brick.Widgets.Border.Style
import Brick.Widgets.Center
import Control.Exception (displayException, try)
import Control.Monad.IO.Class
import Control.Monad.State.Class
import Lens.Micro.Platform
import Parser
import Recents
@ -64,41 +67,40 @@ theMap = applyAttrMappings
, (titleAttr, fg V.yellow)
, (lastElementAttr, fg V.blue) ] A.theMap
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.KEsc [] -> halt' gs
V.EvKey (V.KChar 'q') [] -> halt' gs
handleEvent :: BrickEvent Name Event -> EventM Name GlobalState ()
handleEvent (VtyEvent ev) = do
l <- use $ css.list
exc <- use $ css.exception
case (exc, ev) of
(Just _, _) -> css.exception .= Nothing
(_, e) -> case e of
V.EvKey V.KEsc [] -> popState
V.EvKey (V.KChar 'q') [] -> popState
_ -> 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 ?~ parseError)
Right result -> continue =<< liftIO (do
s'' <- addRecentInternal s' fp
let gs' = update s''
return (gs' `goToState` parameterState (gs'^.parameters) fp result))
_ -> continue' s'
_ -> do zoom (css.list) $ L.handleListEventVi L.handleListEvent e
case e of
V.EvKey V.KEnter [] -> do
selected <- L.listSelectedElement <$> use (css.list)
case selected of
Just (_, "Select file from system") -> do
fbs <- liftIO fileBrowserState
goToState fbs
Just (i, _) -> do
fp <- (`S.unsafeElemAt` i) <$> use (css.recents)
fileOrExc <- liftIO (try (readFile fp) :: IO (Either IOError String))
case fileOrExc of
Left exc -> css.exception ?= displayException exc
Right file -> case parseCards file of
Left parseError -> css.exception ?= parseError
Right result -> do
zoom css $ addRecentInternal fp
params <- use parameters
goToState (parameterState params fp result)
_ -> return ()
handleEvent gs _ _ = continue gs
handleEvent _ = return ()
addRecentInternal :: CSS -> FilePath -> IO CSS
addRecentInternal s fp = do
addRecent fp
refreshRecents s
addRecentInternal ::(MonadState CSS m, MonadIO m) => FilePath -> m ()
addRecentInternal fp = do
liftIO $ addRecent fp
refreshRecents

476
src/UI/Cards.hs
View File

@ -1,8 +1,11 @@
{-# LANGUAGE FlexibleContexts #-}
module UI.Cards (Card, State(..), drawUI, handleEvent, theMap) where
import Brick
import Control.Monad
import Control.Monad.Extra (whenM, notM, unlessM)
import Control.Monad.IO.Class
import Control.Monad.State.Class
import Lens.Micro.Platform
import Types
import States
@ -240,210 +243,227 @@ drawReorder s = case (s ^. cardState, s ^. currentCard) of
----------------------------------------------------
---------------------- Events ----------------------
----------------------------------------------------
halt' :: GlobalState -> EventM n (Next GlobalState)
halt' = flip (removeToModeOrQuit' (\(CardSelectorState s) -> CardSelectorState <$> refreshRecents s)) CardSelector
halt' :: EventM n GlobalState ()
halt' = removeToModeOrQuit' beforeMoving CardSelector
where beforeMoving = zoom css refreshRecents
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 [] -> popStateOrQuit gs
V.EvKey V.KRight [V.MCtrl] -> if not (s^.reviewMode) then next gs s else continue gs
V.EvKey V.KLeft [V.MCtrl] -> if not (s^.reviewMode) then previous gs s else continue gs
handleEvent :: BrickEvent Name Event -> EventM Name GlobalState ()
handleEvent (VtyEvent e) =
-- let update = updateCS gs
-- continue' = continue . update in
case e of
V.EvKey V.KEsc [] -> popStateOrQuit
V.EvKey V.KRight [V.MCtrl] -> (whenM.notM.use $ cs.reviewMode) next
V.EvKey V.KLeft [V.MCtrl] -> (whenM.notM.use $ cs.reviewMode) previous
ev ->
flip (`maybe` (\p -> handlePopupEvent p gs s ev)) (s ^. popup) $
case (s ^. cardState, s ^. currentCard) of
(DefinitionState{_flipped = f}, _) ->
ev -> do
pUp <- use $ cs.popup
s <- use cs
flip (`maybe` (`handlePopupEvent` ev)) pUp $
case (s ^. cardState, s ^. currentCard) of
(DefinitionState{_flipped = f}, _) ->
case ev of
V.EvKey V.KEnter [] ->
if f
then if not (s^.reviewMode) then next
else cs.popup ?= correctPopup
else cs.cardState.flipped %= not
_ -> return ()
(MultipleChoiceState {_highlighted = i, _number = n, _tried = kvs}, MultipleChoice _ _ (CorrectOption j _) _) ->
case ev of
V.EvKey V.KUp [] -> up
V.EvKey (V.KChar 'k') [] -> up
V.EvKey V.KDown [] -> down
V.EvKey (V.KChar 'j') [] -> down
V.EvKey V.KEnter [] ->
if frozen
then do when correctlyAnswered $ cs.correctCards %= (s^.index:)
next
else cs.cardState.tried %= M.insert i True
_ -> return ()
where frozen = M.findWithDefault False j kvs
down = when (i < n-1 && not frozen) $
cs.cardState.highlighted += 1
up = when (i > 0 && not frozen) $
cs.cardState.highlighted -= 1
correctlyAnswered = i == j && M.size (M.filter id kvs) == 1
(MultipleAnswerState {_highlighted = i, _number = n, _entered = submitted, _selected = kvs}, MultipleAnswer _ _ opts) ->
case ev of
V.EvKey V.KUp [] -> up
V.EvKey (V.KChar 'k') [] -> up
V.EvKey V.KDown [] -> down
V.EvKey (V.KChar 'j') [] -> down
V.EvKey (V.KChar 'c') [] -> cs.cardState.entered .= True
V.EvKey V.KEnter [] ->
if frozen
then do when correctlyAnswered $ cs.correctCards %= (s^.index:)
next
else cs.cardState.selected %= M.adjust not i
V.EvKey (V.KChar '\t') [] ->
if frozen
then do when correctlyAnswered $ cs.correctCards %= (s^.index:)
next
else cs.cardState.selected %= M.adjust not i
_ -> return ()
where frozen = submitted
down = when (i < n-1 && not frozen) $
cs.cardState.highlighted += 1
up = when (i > 0 && not frozen) $
cs.cardState.highlighted -= 1
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) ->
let frozen = M.foldr (&&) True cGaps in
case ev of
V.EvKey V.KEnter [] ->
if f
then if not (s^.reviewMode) then next gs s
else continue' (s & popup ?~ correctPopup)
else continue' $ s & cardState.flipped %~ not
_ -> continue' s
V.EvKey (V.KFun 1) [] -> zoom (cs.cardState) $ do
gapInput .= correctAnswers
entered .= True
failed .= True
correctGaps .= M.fromAscList [(i, True) | i <- [0..n-1]]
where correctAnswers = M.fromAscList $ zip [0..] $ map NE.head (sentenceToGaps (perforatedToSentence perforated))
(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.KChar '\t') [] -> zoom (cs.cardState) $ do
if i < n - 1 && not frozen
then highlighted += 1
else highlighted .= 0
V.EvKey V.KEnter [] ->
if frozen
then next gs $ s & if correctlyAnswered then correctCards %~ (s^.index:) else id
else continue' $ s & cardState.tried %~ M.insert i True
_ -> continue' s
V.EvKey V.KRight [] ->
when (i < n - 1 && not frozen) $
cs.cardState.highlighted += 1
where frozen = M.findWithDefault False j kvs
V.EvKey V.KLeft [] ->
when (i > 0 && not frozen) $
cs.cardState.highlighted -= 1
down = if i < n-1 && not frozen
then s & (cardState.highlighted) +~ 1
else s
-- C-w deletes a word back (eg. "test test" -> "test")
V.EvKey (V.KChar 'w') [V.MCtrl] -> zoom (cs.cardState) $ do
unless frozen $ gapInput.ix i %= backword
where backword "" = ""
backword xs = unwords . init . words $ xs
up = if i > 0 && not frozen
then s & (cardState.highlighted) -~ 1
else s
V.EvKey (V.KChar c) [] -> zoom (cs.cardState) $ do
unless frozen $ gapInput.at i.non "" %= (++[c])
correctlyAnswered = i == j && M.size (M.filter (==True) kvs) == 1
V.EvKey V.KEnter [] -> case (frozen, fail) of
(False, _) -> zoom cs $ do
let sentence = perforatedToSentence perforated
gaps = sentenceToGaps sentence
(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
V.EvKey V.KDown [] -> continue' down
V.EvKey (V.KChar 'j') [] -> continue' down
wordIsCorrect :: String -> NonEmpty String -> Bool
wordIsCorrect = if s^.isCaseSensitive
then elem
else (\word possibilites -> map toLower word `elem` NE.map (map toLower) possibilites)
V.EvKey (V.KChar 'c') [] -> continue' $ s & (cardState.entered) .~ True
cardState.correctGaps %= M.mapWithKey (\j _ -> M.findWithDefault "" j kvs `wordIsCorrect` (gaps !! j))
cardState.entered .= True
V.EvKey V.KEnter [] ->
if frozen
then next gs $ s & if correctlyAnswered then correctCards %~ (s^.index:) else id
else continue' $ s & cardState.selected %~ M.adjust not i
V.EvKey (V.KChar '\t') [] ->
if frozen
then next gs $ s & if correctlyAnswered then correctCards %~ (s^.index:) else id
else continue' $ s & cardState.selected %~ M.adjust not i
unlessM (M.foldr (&&) True <$> use (cardState.correctGaps)) $
cardState.failed .= True
(_, True) -> next
(_, False) -> do
cs.correctCards %= (s^.index:)
next
V.EvKey V.KBS [] -> unless frozen $
cs.cardState.gapInput.ix i %= backspace
where backspace "" = ""
backspace xs = init xs
_ -> return ()
(ReorderState {_highlighted = i, _entered = submitted, _grabbed=dragging, _number = n, _order = kvs }, Reorder _ _ elts) ->
case ev of
V.EvKey V.KUp [] -> up
V.EvKey (V.KChar 'k') [] -> up
V.EvKey V.KDown [] -> down
V.EvKey (V.KChar 'j') [] -> down
V.EvKey (V.KChar 'c') [] -> cs.cardState.entered .= True
V.EvKey V.KEnter [] ->
if frozen
then do when correct $ cs.correctCards %= (s^.index:)
next
else cs.cardState.grabbed %= not
_ -> return ()
_ -> continue' s
where frozen = submitted
down = zoom (cs.cardState) $
case (frozen, i < n - 1, dragging) of
(True, _, _) -> return ()
(_, False, _) -> return ()
(_, _, False) -> highlighted += 1
(_, _, True) -> do highlighted += 1
order %= interchange i (i+1)
where frozen = submitted
up = zoom (cs.cardState) $
case (frozen, i > 0, dragging) of
(True, _, _) -> return ()
(_, False, _) -> return ()
(_, _, False) -> highlighted -= 1
(_, _, True) -> do highlighted -= 1
order %= interchange i (i-1)
down = if i < n-1 && not frozen
then s & (cardState.highlighted) +~ 1
else s
correct = all (uncurry (==) . (\i -> (i+1, fst (kvs M.! i)))) [0..n-1]
up = if i > 0 && not frozen
then s & (cardState.highlighted) -~ 1
else s
_ -> error "impossible"
handleEvent _ = return ()
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) ->
let frozen = M.foldr (&&) True cGaps in
case ev of
V.EvKey (V.KFun 1) [] -> continue' $
s & cardState.gapInput .~ correctAnswers
& cardState.entered .~ True
& cardState.failed .~ 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 frozen
then s & (cardState.highlighted) +~ 1
else s & (cardState.highlighted) .~ 0
V.EvKey V.KRight [] -> continue' $
if i < n - 1 && not frozen
then s & (cardState.highlighted) +~ 1
else s
V.EvKey V.KLeft [] -> continue' $
if i > 0 && not frozen
then s & (cardState.highlighted) -~ 1
else s
-- C-w deletes a word back (eg. "test test" -> "test")
V.EvKey (V.KChar 'w') [V.MCtrl] -> continue' $
if frozen then s else s & cardState.gapInput.ix i %~ backword
where backword "" = ""
backword xs = intercalate " " $ init $ words xs
V.EvKey (V.KChar c) [] -> continue' $
if frozen then s else s & cardState.gapInput.at i.non "" %~ (++[c])
V.EvKey V.KEnter [] -> if frozen
then if fail
then next gs s
else next gs (s & correctCards %~ (s^.index:))
else continue' s''
where sentence = perforatedToSentence perforated
gaps = sentenceToGaps sentence
wordIsCorrect :: String -> NonEmpty String -> Bool
wordIsCorrect = if s^.isCaseSensitive
then elem
else (\word possibilites -> map toLower word `elem` NE.map (map toLower) possibilites)
s' = s & (cardState.correctGaps) %~ M.mapWithKey (\j _ -> M.findWithDefault "" j kvs `wordIsCorrect` (gaps !! j))
& (cardState.entered) .~ True
s'' = if M.foldr (&&) True (s' ^. cardState.correctGaps)
then s'
else s' & cardState.failed .~ True
V.EvKey V.KBS [] -> continue' $
if frozen 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, _order = kvs }, Reorder _ _ elts) ->
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 gs $ s & if correct then correctCards %~ (s^.index:) else id
else continue' $ s & cardState.grabbed %~ not
_ -> 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)
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)
correct = all (uncurry (==) . (\i -> (i+1, fst (kvs M.! i)))) [0..n-1]
_ -> error "impossible"
handleEvent gs _ _ = continue gs
next :: GlobalState -> CS -> EventM Name (Next GlobalState)
next gs s
| s ^. index + 1 < length (s ^. shownCards) = liftIO (openCardExternal (takeDirectory (s^.pathToFile)) ((s^.shownCards) !! (s^.index + 1))) *> (continue . updateCS gs . straightenState $ s & index +~ 1)
| s ^. reviewMode =
let thePopup =
if null (s^.correctCards) || length (s^. correctCards) == length (s^.shownCards)
next :: EventM Name GlobalState ()
next = do
i <- use $ cs.index
sc <- use $ cs.shownCards
rm <- use $ cs.reviewMode
case (i + 1 < length sc, rm) of
(True, _) -> zoom cs $ do
fp <- use pathToFile
sc <- use shownCards
liftIO (openCardExternal (takeDirectory fp) (sc !! (i + 1)))
index += 1
straightenState
(_, True) -> zoom cs $ do
cc <- use correctCards
let thePopup =
if null cc || length cc == length sc
then finalPopup
else deckMakerPopup
in continue . updateCS gs $ s & popup ?~ thePopup
| otherwise = halt' gs
popup ?= thePopup
_ -> halt'
previous :: GlobalState -> CS -> EventM Name (Next GlobalState)
previous gs s | s ^. index > 0 = liftIO (openCardExternal (takeDirectory (s^.pathToFile)) ((s^.shownCards) !! (s^.index - 1))) *> (continue . updateCS gs . straightenState $ s & index -~ 1)
| otherwise = continue gs
previous :: EventM Name GlobalState ()
previous = zoom cs $ do
i <- use index
when (i > 0) $ do
fp <- use pathToFile
sc <- use shownCards
liftIO (openCardExternal (takeDirectory fp) (sc !! (i - 1)))
index -= 1
straightenState
straightenState :: CS -> CS
straightenState s =
let card = (s ^. shownCards) !! (s ^. index) in s
& currentCard .~ card
& cardState .~ defaultCardState card
straightenState :: MonadState CS m => m ()
straightenState = do
sc <- use shownCards
i <- use index
let card = sc !! i
currentCard .= card
cardState .= defaultCardState card
interchange :: (Ord a) => a -> a -> Map a b -> Map a b
interchange i j kvs =
@ -460,7 +480,7 @@ isFinalPopup FinalPopup = True
isFinalPopup DeckMakerPopup{} = True
isFinalPopup _ = False
correctPopup :: Popup CS
correctPopup :: Popup GlobalState CS
correctPopup = Popup drawer eventHandler initialState
where drawer s =
let selected = maybe 0 (^?! popupState.popupSelected) (s^.popup)
@ -477,22 +497,25 @@ correctPopup = Popup drawer eventHandler initialState
initialState = CorrectPopup 0
eventHandler gs s ev =
let update = updateCS gs
continue' = continue . update
p = fromJust (s ^. popup)
in case ev of
V.EvKey V.KLeft [] -> continue' $ s & popup ?~ (p & popupState.popupSelected .~ 0)
V.EvKey V.KRight [] -> continue' $ s & popup ?~ (p & popupState.popupSelected .~ 1)
-- Adding vim shortcuts here
V.EvKey (V.KChar 'h') []-> continue' $ s & popup ?~ (p & popupState.popupSelected .~ 0)
V.EvKey (V.KChar 'l') []-> continue' $ s & popup ?~ (p & popupState.popupSelected .~ 1)
-- V.EvKey V.KRight [] -> s & popup .~ popupState.popupSelected .~ Just 1
V.EvKey V.KEnter [] -> next gs $ s & popup .~ Nothing
& if p ^?! popupState.popupSelected == 1 then correctCards %~ (s^.index:) else id
_ -> continue' s
eventHandler ev = do
p <- fromJust <$> use (cs.popup)
let ps = cs.popup._Just.popupState
case ev of
V.EvKey V.KLeft [] -> ps.popupSelected .= 0
V.EvKey V.KRight [] -> ps.popupSelected .= 1
-- Adding vim shortcuts here
V.EvKey (V.KChar 'h') [] -> ps.popupSelected .= 0
V.EvKey (V.KChar 'l') [] -> ps.popupSelected .= 1
finalPopup :: Popup CS
V.EvKey V.KEnter [] -> do
cs.popup .= Nothing
when (p ^?! popupState.popupSelected == 1) $
do i <- use $ cs.index
cs.correctCards %= (i:)
next
_ -> return ()
finalPopup :: Popup GlobalState CS
finalPopup = Popup drawer eventHandler initialState
where drawer s =
let wrong = withAttr wrongAttr (str (" Incorrect: " <> show nWrong) <+> hFill ' ')
@ -508,13 +531,13 @@ finalPopup = Popup drawer eventHandler initialState
initialState = FinalPopup
eventHandler gs s (V.EvKey V.KEnter []) = halt' gs
eventHandler gs _ _ = continue gs
eventHandler (V.EvKey V.KEnter []) = halt'
eventHandler _ = return ()
deckMakerPopup :: Popup CS
deckMakerPopup :: Popup GlobalState CS
deckMakerPopup = Popup drawer eventHandler initialState
where drawer s =
let state = fromMaybe initialState $ view popupState <$> s^.popup
let state = maybe initialState (view popupState) (s^.popup)
j = state ^?! popupSelected
makeSym lens i = case (state ^?! lens, i == j) of
@ -544,32 +567,37 @@ deckMakerPopup = Popup drawer eventHandler initialState
initialState = DeckMakerPopup 0 False False
eventHandler gs s ev =
let update = updateCS gs
continue' = continue . update
p = fromJust (s ^. popup)
state = p ^. popupState
originalCorrects = sortOn negate (map ((s ^. indexMapping) !!) (s ^. correctCards))
in case state ^?! popupSelected of
eventHandler ev = do
im <- use $ cs.indexMapping
ccs <- use $ cs.correctCards
let originalCorrects =
sortOn negate (map (im !!) ccs)
p <- fromJust <$> use (cs.popup)
let ps = cs.popup._Just.popupState
let state = p ^. popupState
case state ^?! popupSelected of
0 -> case ev of
V.EvKey V.KEnter [] -> continue' $ s & popup ?~ (p & popupState.makeDeckIncorrect %~ not)
V.EvKey V.KDown [] -> continue' $ s & popup ?~ (p & popupState.popupSelected +~ 1)
V.EvKey (V.KChar 'j') [] -> continue' $ s & popup ?~ (p & popupState.popupSelected +~ 1)
_ -> continue' s
V.EvKey V.KEnter [] -> ps.makeDeckIncorrect %= not
V.EvKey V.KDown [] -> ps.popupSelected += 1
V.EvKey (V.KChar 'j') [] -> ps.popupSelected += 1
_ -> return ()
1 -> case ev of
V.EvKey V.KEnter [] -> continue' $ s & popup ?~ (p & popupState.makeDeckCorrect %~ not)
V.EvKey V.KDown [] -> continue' $ s & popup ?~ (p & popupState.popupSelected +~ 1)
V.EvKey (V.KChar 'j') [] -> continue' $ s & popup ?~ (p & popupState.popupSelected +~ 1)
V.EvKey V.KUp [] -> continue' $ s & popup ?~ (p & popupState.popupSelected -~ 1)
V.EvKey (V.KChar 'k') [] -> continue' $ s & popup ?~ (p & popupState.popupSelected -~ 1)
_ -> continue' s
V.EvKey V.KEnter [] -> ps.makeDeckCorrect %= not
V.EvKey V.KDown [] -> ps.popupSelected += 1
V.EvKey (V.KChar 'j') [] -> ps.popupSelected += 1
V.EvKey V.KUp [] -> ps.popupSelected -= 1
V.EvKey (V.KChar 'k') [] -> ps.popupSelected -= 1
_ -> return ()
2 -> case ev of
V.EvKey V.KEnter [] -> liftIO (generateDecks (s ^. pathToFile)
(s ^. originalCards) originalCorrects (state ^?! makeDeckCorrect) (state ^?! makeDeckIncorrect))
*> halt' gs
V.EvKey V.KUp [] -> continue' $ s & popup ?~ (p & popupState.popupSelected -~ 1)
V.EvKey (V.KChar 'k') [] -> continue' $ s & popup ?~ (p & popupState.popupSelected -~ 1)
_ -> continue' s
V.EvKey V.KEnter [] -> do
fp <- use $ cs.pathToFile
ocs <- use $ cs.originalCards
liftIO $ generateDecks fp ocs originalCorrects (state ^?! makeDeckCorrect) (state ^?! makeDeckIncorrect)
halt'
V.EvKey V.KUp [] -> ps.popupSelected -= 1
V.EvKey (V.KChar 'k') [] -> ps.popupSelected -= 1
_ -> return ()
generateDecks :: FilePath -> [Card] -> [Int] -> Bool -> Bool -> IO ()
generateDecks fp cards corrects makeCorrect makeIncorrect =

63
src/UI/FileBrowser.hs
View File

@ -49,39 +49,36 @@ drawUI FBS{_fb=b, _exception'=exc} = [drawException exc, center $ ui <=> help]
, hCenter $ txt "Esc or q: quit"
]
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
handleEvent :: BrickEvent Name Event -> EventM Name GlobalState ()
handleEvent (VtyEvent ev) = do
excep <- use $ fbs.exception'
b <- use $ fbs.fb
case (excep, ev) of
(Just _, _) -> continue' $ s & exception' .~ Nothing
(Just _, _) -> fbs.exception' .= Nothing
(_, e) -> case e of
V.EvKey V.KEsc [] | not (fileBrowserIsSearching b) ->
halt' gs
V.EvKey (V.KChar 'q') [] | not (fileBrowserIsSearching b) ->
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
V.EvKey V.KEsc [] | not (fileBrowserIsSearching b) -> popState
V.EvKey (V.KChar 'q') [] | not (fileBrowserIsSearching b) -> popState
V.EvKey (V.KChar 'h') [] | not (fileBrowserIsSearching b) -> do
fbs.showHidden %= not
eFilter <- Just . entryFilter <$> use (fbs.showHidden)
fbs.fb .= setFileBrowserEntryFilter eFilter b
_ -> do
b' <- handleFileBrowserEvent ev b
let s' = s & fb .~ b'
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' ?~ parseError)
Right result -> continue =<< liftIO (do
addRecent fp
gs' <- refreshRecents' gs
return (gs' `goToState` parameterState (gs'^.parameters) fp result))
_ -> halt' gs
_ -> continue' s'
handleEvent gs _ _ = continue gs
zoom (fbs.fb) $ handleFileBrowserEvent ev
b' <- use $ fbs.fb
case (ev, fileBrowserSelection b') of
(V.EvKey V.KEnter [], []) -> return ()
(V.EvKey V.KEnter [], [fileInfo]) -> do
let fp = fileInfoFilePath fileInfo
fileOrExc <- liftIO (try (readFile fp) :: IO (Either IOError String))
case fileOrExc of
Left exc -> fbs.exception' ?= displayException exc
Right file -> case parseCards file of
Left parseError -> fbs.exception' ?= parseError
Right result -> do
liftIO $ addRecent fp
zoom css refreshRecents
params <- use parameters
goToState $ parameterState params fp result
(V.EvKey V.KEnter [], _) -> popState
_ -> return ()
handleEvent _ = return ()

27
src/UI/Info.hs
View File

@ -22,21 +22,18 @@ ui =
hBorder <=>
drawInfo
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.KEsc [] -> halt' gs
V.EvKey (V.KChar 'q') [] -> 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
handleEvent :: BrickEvent Name Event -> EventM Name GlobalState ()
handleEvent (VtyEvent e) =
case e of
V.EvKey V.KEsc [] -> popState
V.EvKey (V.KChar 'q') [] -> popState
V.EvKey V.KEnter [] -> popState
V.EvKey V.KDown [] -> vScrollBy (viewportScroll Ordinary) 1
V.EvKey (V.KChar 'j') [] -> vScrollBy (viewportScroll Ordinary) 1
V.EvKey V.KUp [] -> vScrollBy (viewportScroll Ordinary) (-1)
V.EvKey (V.KChar 'k') [] -> vScrollBy (viewportScroll Ordinary) (-1)
_ -> return ()
handleEvent _ = return ()
titleAttr :: AttrName
titleAttr = attrName "title"

29
src/UI/MainMenu.hs
View File

@ -44,19 +44,18 @@ drawListElement :: Bool -> String -> Widget Name
drawListElement selected = hCenteredStrWrapWithAttr attr
where attr = if selected then withAttr selectedAttr else id
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.KEsc [] -> halt gs
V.EvKey (V.KChar 'q') [] -> halt gs
V.EvKey V.KEnter [] ->
case L.listSelected (s^.l) of
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
handleEvent :: BrickEvent Name Event -> EventM Name GlobalState ()
handleEvent (VtyEvent e) = case e of
V.EvKey V.KEsc [] -> halt
V.EvKey (V.KChar 'q') [] -> halt
V.EvKey V.KEnter [] -> do
list <- use (mms.l)
case L.listSelected list of
Just 0 -> goToState =<< liftIO cardSelectorState
Just 1 -> goToState infoState
Just 2 -> goToState =<< liftIO settingsState
Just 3 -> halt
_ -> undefined
ev -> continue . update . flip (l .~) s =<< L.handleListEventVi L.handleListEvent ev (s^.l)
handleEvent gs _ _ = continue gs
ev -> zoom (mms.l) $ L.handleListEventVi L.handleListEvent ev
handleEvent _ = return ()

64
src/UI/Parameter.hs
View File

@ -7,6 +7,7 @@ import Brick.Forms
import Brick.Widgets.Border
import Brick.Widgets.Border.Style
import Brick.Widgets.Center
import Control.Monad (when)
import Control.Monad.IO.Class
import Lens.Micro.Platform
import States
@ -30,48 +31,43 @@ ui s =
padLeftRight 1
(renderForm (s ^. psForm))
handleEvent :: GlobalState -> PS -> BrickEvent Name Event -> EventM Name (Next GlobalState)
handleEvent gs s ev@(VtyEvent e) =
handleEvent :: BrickEvent Name Event -> EventM Name GlobalState ()
handleEvent ev@(VtyEvent e) = do
s <- use ps
let form = s ^. psForm
update = updatePS gs
continue' = continue . update
continue'' f = continue . update $ s & psForm .~ f
halt' = continue . popState
focus = formFocus form
(Just n) = focusGetCurrent focus
down = case n of
ParametersOkField -> continue gs
ChunkField1 -> continue'' $ form { formFocus = focusNext (focusNext focus) }
_ -> continue'' $ form { formFocus = focusNext focus }
up = case n of
ChunkField1 -> continue gs
ChunkField2 -> continue gs
SubsetField -> continue'' $ form { formFocus = focusPrev (focusPrev focus) }
_ -> continue'' $ form { formFocus = focusPrev focus }
down = zoom ps $ case n of
ParametersOkField -> return ()
ChunkField1 -> psForm .= form { formFocus = focusNext (focusNext focus) }
_ -> psForm .= form { formFocus = focusNext focus }
up = zoom ps $ case n of
ChunkField1 -> return ()
ChunkField2 -> return ()
SubsetField -> psForm .= form { formFocus = focusPrev (focusPrev focus) }
_ -> psForm .= form { formFocus = focusPrev focus }
in case e of
V.EvKey V.KEsc [] -> halt' gs
V.EvKey (V.KChar 'q') [] -> halt' gs
case e of
V.EvKey V.KEsc [] -> popState
V.EvKey (V.KChar 'q') [] -> popState
V.EvKey V.KDown [] -> down
V.EvKey (V.KChar 'j') [] -> down
V.EvKey V.KUp [] -> up
V.EvKey (V.KChar 'k') [] -> up
V.EvKey (V.KChar '\t') [] -> continue gs
V.EvKey V.KBackTab [] -> continue gs
V.EvKey (V.KChar '\t') [] -> return ()
V.EvKey V.KBackTab [] -> return ()
_ -> case (e, n) of
(V.EvKey V.KRight [], ChunkField2) -> continue gs
(V.EvKey V.KLeft [], ChunkField1) -> continue gs
_ -> do f <- handleFormEvent ev form
if formState f ^. pOk
then continue =<< (gs `goToState`)
<$> liftIO (cardsWithOptionsState
(gs & parameters .~ formState f)
(s ^. psFp)
(s ^. psCards))
else continue' (s & psForm .~ f)
(V.EvKey V.KRight [], ChunkField2) -> return ()
(V.EvKey V.KLeft [], ChunkField1) -> return ()
_ -> do zoom (ps.psForm) $ handleFormEvent ev
f <- use $ ps.psForm
when (formState f ^. pOk) $ do
parameters .= formState f
parameters.pOk .= False
paramsWithoutOk <- use parameters
ps.psForm .= updateFormState paramsWithoutOk f
state <- cardsWithOptionsStateM (s ^. psFp) (s ^. psCards)
goToState state
handleEvent gs _ _ = continue gs
handleEvent _ = return ()

44
src/UI/Settings.hs
View File

@ -7,7 +7,9 @@ import Brick.Forms
import Brick.Widgets.Border
import Brick.Widgets.Border.Style
import Brick.Widgets.Center
import Control.Monad (unless)
import Control.Monad.IO.Class
import Lens.Micro.Platform
import States
import StateManagement
import Settings
@ -29,29 +31,27 @@ ui f =
padLeftRight 1
(renderForm f)
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))
handleEvent :: BrickEvent Name Event -> EventM Name GlobalState ()
handleEvent ev@(VtyEvent e) = do
form <- use ss
let halt' = popState <* liftIO (setSettings (formState form))
focus = formFocus form
(Just n) = focusGetCurrent focus
down = if n == MaxRecentsField then continue gs
else continue' $ form { formFocus = focusNext focus }
up = if n == HintsField then continue gs
else continue' $ form { formFocus = focusPrev focus }
down = unless (n == MaxRecentsField) $
ss .= form { formFocus = focusNext focus }
up = unless (n == HintsField) $
ss .= form { formFocus = focusPrev focus }
in
case e of
V.EvKey V.KEsc [] -> halt' gs
V.EvKey (V.KChar 'q') [] -> halt' gs
V.EvKey V.KDown [] -> down
V.EvKey (V.KChar 'j') [] -> down
V.EvKey V.KUp [] -> up
V.EvKey (V.KChar 'k') [] -> up
V.EvKey (V.KChar '\t') [] -> continue gs
V.EvKey V.KBackTab [] -> continue gs
_ -> continue' =<< handleFormEvent ev form
case e of
V.EvKey V.KEsc [] -> halt'
V.EvKey (V.KChar 'q') [] -> halt'
V.EvKey V.KDown [] -> down
V.EvKey (V.KChar 'j') [] -> down
V.EvKey V.KUp [] -> up
V.EvKey (V.KChar 'k') [] -> up
V.EvKey (V.KChar '\t') [] -> return ()
V.EvKey V.KBackTab [] -> return ()
_ -> zoom ss $ handleFormEvent ev
handleEvent gs _ _ = continue gs
handleEvent _ = return ()

2
stack.yaml
View File

@ -17,7 +17,7 @@
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-19.13
resolver: lts-20.21
# User packages to be built.
# Various formats can be used as shown in the example below.

8
stack.yaml.lock
View File

@ -6,7 +6,7 @@
packages: []
snapshots:
- completed:
size: 618740
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/13.yaml
sha256: ef98d70e4018bf01feb00ccdcd33ab26d056dbb71b38057c78fdd0d1ec671c85
original: lts-19.13
size: 650044
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/20/21.yaml
sha256: 401a0e813162ba62f04517f60c7d25e93a0f867f94a902421ebf07d1fb5a8c46
original: lts-20.21