1
1
mirror of https://github.com/Yvee1/hascard.git synced 2024-11-22 22:12:06 +03:00

Make it compile and basic functionality

This commit is contained in:
Steven van den Broek 2020-08-02 12:15:55 +02:00
parent d45921e57f
commit 33fb7881b3
13 changed files with 307 additions and 213 deletions

View File

@ -14,6 +14,8 @@ import System.Directory (makeAbsolute)
import System.FilePath (takeExtension) import System.FilePath (takeExtension)
import System.Process (runCommand) import System.Process (runCommand)
import System.Random.MWC (createSystemRandom, GenIO) import System.Random.MWC (createSystemRandom, GenIO)
import qualified Data.Map.Strict as Map (empty)
import qualified Stack
data Opts = Opts data Opts = Opts
{ _optFile :: Maybe String { _optFile :: Maybe String
@ -54,7 +56,7 @@ nothingIf p a
run :: Opts -> IO () run :: Opts -> IO ()
run opts = run' (opts ^. optFile) run opts = run' (opts ^. optFile)
where where
mkGlobalState gen = GlobalState {_mwc=gen, _doShuffle=opts^.optShuffle, _subset=nothingIf (<0) (opts^.optSubset) } mkGlobalState gen = GlobalState {_mwc=gen, _doShuffle=opts^.optShuffle, _subset=nothingIf (<0) (opts^.optSubset), _states=Map.empty, _stack=Stack.empty }
run' Nothing = createSystemRandom >>= start Nothing . mkGlobalState run' Nothing = createSystemRandom >>= start Nothing . mkGlobalState
run' (Just file) = do run' (Just file) = do
let filepath = let filepath =
@ -76,5 +78,5 @@ run opts = run' (opts ^. optFile)
start (Just result) (mkGlobalState gen) start (Just result) (mkGlobalState gen)
start :: Maybe [Card] -> GlobalState -> IO () start :: Maybe [Card] -> GlobalState -> IO ()
start Nothing gs = runBrickFlashcards gs start Nothing gs = runBrickFlashcards (runMainMenuUI gs)
start (Just cards) gs = runCardsWithOptions gs cards start (Just cards) gs = runBrickFlashcards =<< runCardsWithOptions gs cards

11
src/DeckHandling.hs Normal file
View File

@ -0,0 +1,11 @@
module DeckHandling where
import Data.Random
import Lens.Micro.Platform
import States
import Types
doRandomization :: GlobalState -> [Card] -> IO [Card]
doRandomization state cards =
let n = length cards in do
cards' <- if state^.doShuffle then sampleFrom (state^.mwc) (shuffleN n cards) else return cards
return $ maybe cards' (`take` cards') (state^.subset)

View File

@ -48,29 +48,13 @@ handleAttrMap gs = case getState gs of
FileBrowserState _ -> FB.theMap FileBrowserState _ -> FB.theMap
CardsState _ -> C.theMap CardsState _ -> C.theMap
runCardsUI :: GlobalState -> [Card] -> IO GlobalState -- runMainMenuUI :: GlobalState -> GlobalState
runCardsUI gs deck = do -- runMainMenuUI gs =
hints <- S.getShowHints -- let options = Vec.fromList
controls <- S.getShowControls -- [ "Select"
-- , "Info"
-- , "Settings"
-- , "Quit" ]
let initialState = -- initialState = MMS (L.list () options 1) in
C.State { C._cards = deck -- gs `goToState` MainMenuState initialState
, C._index = 0
, C._currentCard = head deck
, C._cardState = C.defaultCardState (head deck)
, C._nCards = length deck
, C._showHints = hints
, C._showControls = controls }
return $ goToState initialState
runMainMenuUI :: GlobalState -> GlobalState
runMainMenuUI gs =
let options = Vec.fromList
[ "Select"
, "Info"
, "Settings"
, "Quit" ]
initialState = MM.State (L.list () options 1) gs in
goToState initialState

93
src/Recents.hs Normal file
View File

@ -0,0 +1,93 @@
module Recents where
import Control.Monad (filterM)
import Data.List (sort)
import Stack (Stack)
import System.Environment (lookupEnv)
import System.FilePath ((</>), splitFileName, dropExtension, splitPath, joinPath)
import qualified Data.Vector as Vec
import qualified Stack as S
import qualified System.Directory as D
import qualified System.IO.Strict as IOS (readFile)
getRecents :: IO (Stack FilePath)
getRecents = do
rf <- getRecentsFile
exists <- D.doesFileExist rf
if exists
then removeDeletedFiles rf
else return S.empty
removeDeletedFiles :: FilePath -> IO (Stack FilePath)
removeDeletedFiles fp = do
file <- IOS.readFile fp
existing <- S.fromList <$> filterM D.doesFileExist (lines file)
writeRecents existing
return existing
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''
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

View File

@ -27,8 +27,18 @@ safeHead = (`elemAt` 0)
last :: Stack a -> a last :: Stack a -> a
last s = s `unsafeElemAt` (Stack.size s - 1) last s = s `unsafeElemAt` (Stack.size s - 1)
pop :: Ord a => Stack a -> Stack a
pop s = OS.delete (Stack.head s) s
popWithInfo :: Ord a => Stack a -> (Stack a, a, a)
popWithInfo s = let
top = Stack.head s
s' = OS.delete top s
top' = Stack.head s' in
(s', top, top')
tail :: Ord a => Stack a -> [a] tail :: Ord a => Stack a -> [a]
tail s = toList $ OS.delete (Stack.head s) s tail = toList . pop
elemAt :: Stack a -> Int -> Maybe a elemAt :: Stack a -> Int -> Maybe a
elemAt = OS.elemAt elemAt = OS.elemAt

View File

@ -1,4 +1,4 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell, TypeSynonymInstances, FlexibleInstances #-}
module States where module States where
import Brick.Widgets.FileBrowser import Brick.Widgets.FileBrowser
@ -23,6 +23,9 @@ data Mode = MainMenu
| Cards | Cards
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
-- class HasMode t where
-- getMode :: t -> Mode
data State = MainMenuState MMS data State = MainMenuState MMS
| SettingsState SS | SettingsState SS
| InfoState IS | InfoState IS
@ -77,20 +80,31 @@ data CS = CS
, _showControls :: Bool , _showControls :: Bool
-- , _incorrectCards :: [Int] -- list of indices of incorrect answers -- , _incorrectCards :: [Int] -- list of indices of incorrect answers
} }
-- instance HasMode CS where
-- getMode = const Cards
newtype MMS = MMS newtype MMS = MMS
{ _l :: List Name String } { _l :: List Name String }
-- instance HasMode MMS where
-- getMode = const MainMenu
type IS = () type IS = ()
-- instance HasMode IS where
-- getMode = const Info
type Settings = Map Int Bool type Settings = Map Int Bool
type SS = (Int, Settings) type SS = (Int, Settings)
-- instance HasMode SS where
-- getMode = const Settings
data CSS = CSS data CSS = CSS
{ _list :: List Name String { _list :: List Name String
, _exception :: Maybe String , _exception :: Maybe String
, _recents :: Stack FilePath , _recents :: Stack FilePath
} }
-- instance HasMode CSS where
-- getMode = const CardSelector
data FBS = FBS data FBS = FBS
{ _fb :: FileBrowser Name { _fb :: FileBrowser Name
@ -99,6 +113,16 @@ data FBS = FBS
, _filePath :: Maybe FilePath , _filePath :: Maybe FilePath
, _showHidden :: Bool , _showHidden :: Bool
} }
-- instance HasMode FBS where
-- getMode = const FileBrowser
getMode :: State -> Mode
getMode (MainMenuState _) = MainMenu
getMode (SettingsState _) = Settings
getMode (InfoState _) = Info
getMode (CardSelectorState _) = CardSelector
getMode (FileBrowserState _) = FileBrowser
getMode (CardsState _) = Cards
makeLenses ''State makeLenses ''State
makeLenses ''MMS makeLenses ''MMS
@ -112,12 +136,13 @@ getState :: GlobalState -> State
getState = fromJust . safeGetState getState = fromJust . safeGetState
updateState :: GlobalState -> State -> GlobalState updateState :: GlobalState -> State -> GlobalState
updateState gs s@(MainMenuState _) = gs & states %~ Map.insert MainMenu s -- updateState gs s@(MainMenuState _) = gs & states %~ Map.insert MainMenu s
updateState gs s@(SettingsState _) = gs & states %~ Map.insert Settings s -- updateState gs s@(SettingsState _) = gs & states %~ Map.insert Settings s
updateState gs s@(InfoState _) = gs & states %~ Map.insert Info s -- updateState gs s@(InfoState _) = gs & states %~ Map.insert Info s
updateState gs s@(CardSelectorState _) = gs & states %~ Map.insert CardSelector s -- updateState gs s@(CardSelectorState _) = gs & states %~ Map.insert CardSelector s
updateState gs s@(FileBrowserState _) = gs & states %~ Map.insert FileBrowser s -- updateState gs s@(FileBrowserState _) = gs & states %~ Map.insert FileBrowser s
-- updateState gs s@(MainMenuState _) = gs & states %~ Map.insert MainMenu s -- updateState gs s@(CardsState _) = gs & states %~ Map.insert Cards s
updateState gs s = gs & states %~ Map.insert (getMode s) s
updateMMS :: GlobalState -> MMS -> GlobalState updateMMS :: GlobalState -> MMS -> GlobalState
updateMMS gs s = updateState gs (MainMenuState s) updateMMS gs s = updateState gs (MainMenuState s)
@ -125,6 +150,9 @@ updateMMS gs s = updateState gs (MainMenuState s)
updateSS :: GlobalState -> SS -> GlobalState updateSS :: GlobalState -> SS -> GlobalState
updateSS gs s = updateState gs (SettingsState s) updateSS gs s = updateState gs (SettingsState s)
updateIS :: GlobalState -> IS -> GlobalState
updateIS gs s = updateState gs (InfoState s)
updateCS :: GlobalState -> CS -> GlobalState updateCS :: GlobalState -> CS -> GlobalState
updateCS gs s = updateState gs (CardsState s) updateCS gs s = updateState gs (CardsState s)
@ -137,17 +165,29 @@ updateInfo gs s = updateState gs (InfoState s)
updateFBS :: GlobalState -> FBS -> GlobalState updateFBS :: GlobalState -> FBS -> GlobalState
updateFBS gs s = updateState gs (FileBrowserState s) updateFBS gs s = updateState gs (FileBrowserState s)
goToState :: State -> GlobalState -> GlobalState goToState :: GlobalState -> State -> GlobalState
goToState s@(MainMenuState _) gs = gs & states %~ Map.insert MainMenu s -- goToState gs s@(MainMenuState _) = gs & states %~ Map.insert MainMenu s
& stack %~ insert MainMenu -- & stack %~ insert MainMenu
goToState s@(SettingsState _) gs = gs & states %~ Map.insert Settings s -- goToState gs s@(SettingsState _) = gs & states %~ Map.insert Settings s
& stack %~ insert Settings -- & stack %~ insert Settings
goToState s@(InfoState _) gs = gs & states %~ Map.insert Info s -- goToState gs s@(InfoState _) = gs & states %~ Map.insert Info s
& stack %~ insert Info -- & stack %~ insert Info
goToState s@(CardSelectorState _) gs = gs & states %~ Map.insert CardSelector s -- goToState gs s@(CardSelectorState _) = gs & states %~ Map.insert CardSelector s
& stack %~ insert CardSelector -- & stack %~ insert CardSelector
goToState s@(FileBrowserState _) gs = gs & states %~ Map.insert FileBrowser s -- goToState gs s@(FileBrowserState _) = gs & states %~ Map.insert FileBrowser s
& stack %~ insert FileBrowser -- & stack %~ insert FileBrowser
-- goToState gs s@(CardsState _) = gs & states %~ Map.insert Cards s
-- & stack %~ insert Cards
goToState gs s = gs & states %~ Map.insert (getMode s) s
& stack %~ insert (getMode s)
popState :: GlobalState -> GlobalState
popState gs = let
s = gs ^. stack
top = Stack.head s
s' = Stack.pop s in
gs & states %~ Map.delete top
& stack .~ s'
safeGetState :: GlobalState -> Maybe State safeGetState :: GlobalState -> Maybe State
safeGetState gs = do safeGetState gs = do

View File

@ -1,13 +1,18 @@
module UI (module X, runBrickFlashcards) where module UI (module X, runBrickFlashcards, GlobalState(..), Card) where
import UI.Cards as X (runCardsUI) import UI.Cards as X (runCardsUI, runCardsWithOptions)
import UI.CardSelector as X import UI.CardSelector as X (addRecent)
import UI.MainMenu as X (runMainMenuUI) import UI.MainMenu as X (runMainMenuUI)
import UI.Settings as X import UI.Settings as X (getUseEscapeCode)
import Types as X (mwc, doShuffle, subset, Card) -- import Types as X (mwc, doShuffle, subset, Card)
import GlobalState as X (GlobalState (..)) -- import GlobalState as X (GlobalState (..))
import GlobalState (globalApp) -- import GlobalState (globalApp)
import Brick
import Glue
import States
import Types (Card)
runBrickFlashcards :: GlobalState -> IO () runBrickFlashcards :: GlobalState -> IO ()
runBrickFlashcards gs = do runBrickFlashcards gs = do
defaultMain globalApp gs _ <- defaultMain globalApp gs
return ()

View File

@ -6,7 +6,8 @@ module UI.CardSelector
, theMap , theMap
, getRecents , getRecents
, getRecentsFile , getRecentsFile
, addRecent) where , addRecent
, runCardSelectorUI ) where
import Brick import Brick
import Brick.Widgets.Border import Brick.Widgets.Border
@ -17,10 +18,9 @@ import Control.Monad (filterM)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Data.Functor (void) import Data.Functor (void)
import Data.List (sort) import Data.List (sort)
import Data.Random
import Lens.Micro.Platform import Lens.Micro.Platform
import Parser import Parser
import Stack (Stack) import Recents
import System.Environment (lookupEnv) import System.Environment (lookupEnv)
import System.FilePath ((</>), splitFileName, dropExtension, splitPath, joinPath) import System.FilePath ((</>), splitFileName, dropExtension, splitPath, joinPath)
import States import States
@ -28,15 +28,21 @@ import Types
import UI.Attributes hiding (theMap) import UI.Attributes hiding (theMap)
import UI.BrickHelpers import UI.BrickHelpers
import UI.FileBrowser (runFileBrowserUI) import UI.FileBrowser (runFileBrowserUI)
import UI.Cards (Card) import UI.Cards (Card, runCardsUI, runCardsWithOptions)
import qualified Brick.Widgets.List as L import qualified Brick.Widgets.List as L
import qualified Data.Vector as Vec import qualified Data.Vector as Vec
import qualified Graphics.Vty as V import qualified Graphics.Vty as V
import qualified Stack as S import qualified Stack as S
import qualified System.Directory as D
import qualified System.IO.Strict as IOS (readFile)
import qualified UI.Attributes as A import qualified UI.Attributes as A
runCardSelectorUI :: GlobalState -> IO GlobalState
runCardSelectorUI gs = do
rs <- getRecents
let prettyRecents = shortenFilepaths (S.toList rs)
let options = Vec.fromList (prettyRecents ++ ["Select file from system"])
let initialState = CSS (L.list () options 1) Nothing rs
return $ gs `goToState` CardSelectorState initialState
drawUI :: CSS -> [Widget Name] drawUI :: CSS -> [Widget Name]
drawUI s = drawUI s =
[ drawException (s ^. exception), drawMenu s ] [ drawException (s ^. exception), drawMenu s ]
@ -79,12 +85,12 @@ handleEvent :: GlobalState -> CSS -> BrickEvent Name Event -> EventM Name (Next
handleEvent gs s@CSS{_list=l, _exception=exc} (VtyEvent ev) = handleEvent gs s@CSS{_list=l, _exception=exc} (VtyEvent ev) =
let update = updateCSS gs let update = updateCSS gs
continue' = continue . update continue' = continue . update
halt' = halt . update in halt' = continue . popState in
case (exc, ev) of case (exc, ev) of
(Just _, _) -> continue' $ s & exception .~ Nothing (Just _, _) -> continue' $ s & exception .~ Nothing
(_, e) -> case e of (_, e) -> case e of
V.EvKey (V.KChar 'c') [V.MCtrl] -> halt gs V.EvKey (V.KChar 'c') [V.MCtrl] -> halt' gs
V.EvKey V.KEsc [] -> halt gs V.EvKey V.KEsc [] -> halt' gs
_ -> do l' <- L.handleListEventVi L.handleListEvent e l _ -> do l' <- L.handleListEventVi L.handleListEvent e l
let s' = (s & list .~ l') in let s' = (s & list .~ l') in
@ -92,7 +98,7 @@ handleEvent gs s@CSS{_list=l, _exception=exc} (VtyEvent ev) =
V.EvKey V.KEnter [] -> V.EvKey V.KEnter [] ->
case L.listSelectedElement l' of case L.listSelectedElement l' of
Nothing -> continue' s' Nothing -> continue' s'
Just (_, "Select file from system") -> liftIO (runFileBrowser (update s')) >>= continue Just (_, "Select file from system") -> continue =<< liftIO (runFileBrowser (update s'))
Just (i, _) -> do Just (i, _) -> do
let fp = (s' ^. recents) `S.unsafeElemAt` i let fp = (s' ^. recents) `S.unsafeElemAt` i
fileOrExc <- liftIO (try (readFile fp) :: IO (Either IOError String)) fileOrExc <- liftIO (try (readFile fp) :: IO (Either IOError String))
@ -100,110 +106,20 @@ handleEvent gs s@CSS{_list=l, _exception=exc} (VtyEvent ev) =
Left exc -> continue' (s' & exception ?~ displayException exc) Left exc -> continue' (s' & exception ?~ displayException exc)
Right file -> case parseCards file of Right file -> case parseCards file of
Left parseError -> continue' (s' & exception ?~ errorBundlePretty parseError) Left parseError -> continue' (s' & exception ?~ errorBundlePretty parseError)
Right result -> suspendAndResume $ do Right result -> continue =<< liftIO (do
s'' <- addRecentInternal s' fp s'' <- addRecentInternal s' fp
-- _ <- runCardsWithOptions (s^.gs) result let s''' = s'' & exception .~ Nothing
return $ update (s'' & exception .~ Nothing) runCardsWithOptions (update s''') result)
-- return $ update ()
_ -> continue' s' _ -> continue' s'
handleEvent gs _ _ = continue gs handleEvent gs _ _ = continue gs
-- runCardSelectorUI :: GlobalState -> IO () runFileBrowser :: GlobalState -> IO GlobalState
-- runCardSelectorUI gs = do runFileBrowser gs = do
-- rs <- getRecents result <- runFileBrowserUI gs
-- let prettyRecents = shortenFilepaths (S.toList rs) -- maybe (return s) (\(cards, fp) -> addRecentInternal s fp <* runCardsWithOptions (s^.gs) cards) result
-- let options = Vec.fromList (prettyRecents ++ ["Select file from system"]) return result
-- let initialState = State (L.list () options 1) Nothing rs gs
-- _ <- defaultMain app initialState
-- return ()
getRecents :: IO (Stack FilePath)
getRecents = do
rf <- getRecentsFile
exists <- D.doesFileExist rf
if exists
then removeDeletedFiles rf
else return S.empty
removeDeletedFiles :: FilePath -> IO (Stack FilePath)
removeDeletedFiles fp = do
file <- IOS.readFile fp
existing <- S.fromList <$> filterM D.doesFileExist (lines file)
writeRecents existing
return existing
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 :: CSS -> FilePath -> IO CSS
addRecentInternal s fp = do
addRecent fp
refreshRecents s
writeRecents :: Stack FilePath -> IO ()
writeRecents stack = do
file <- getRecentsFile
writeFile file $ unlines (S.toList stack)
getRecentsFile :: IO FilePath
getRecentsFile = do
maybeSnap <- lookupEnv "SNAP_USER_DATA"
xdg <- D.getXdgDirectory D.XdgData "hascard"
let dir = case maybeSnap of
Just path | not (null path) -> path
| otherwise -> xdg
Nothing -> xdg
D.createDirectoryIfMissing True dir
return (dir </> "recents")
initLast :: [a] -> ([a], a)
initLast [x] = ([], x)
initLast (x:xs) = let (xs', y) = initLast xs
in (x:xs', y)
shortenFilepaths :: [FilePath] -> [FilePath]
shortenFilepaths fps = uncurry shortenFilepaths' (unzip (map ((\(pre, fn) -> (pre, dropExtension fn)) . splitFileName) fps))
where
shortenFilepaths' prefixes abbreviations =
let ds = duplicates abbreviations in
if null ds then abbreviations else
shortenFilepaths'
(flip map (zip [0..] prefixes) (
\(i, pre) -> if i `elem` ds then
joinPath (init (splitPath pre)) else pre
))
(flip map (zip [0..] abbreviations) (
\(i, abbr) -> if i `elem` ds then
last (splitPath (prefixes !! i)) ++ abbr
else abbr) )
duplicates :: Eq a => [a] -> [Int]
duplicates = sort . map fst . duplicates' 0 [] []
where duplicates' _ _ acc [] = acc
duplicates' i seen acc (x:xs) = duplicates' (i+1) ((i, x) : seen) acc' xs
where acc' = case (getPairsWithValue x acc, getPairsWithValue x seen) of
([], []) -> acc
([], ys) -> (i, x) : ys ++ acc
(_, _) -> (i, x) : acc
-- acc' = if getPairsWithValue x seen then (i, x) : acc else acc
getPairsWithValue :: Eq a => a -> [(Int, a)] -> [(Int, a)]
getPairsWithValue y [] = []
getPairsWithValue y ((i, x):xs)
| x == y = (i, x) : getPairsWithValue y xs
| otherwise = getPairsWithValue y xs
refreshRecents :: CSS -> IO CSS refreshRecents :: CSS -> IO CSS
refreshRecents s = do refreshRecents s = do
@ -213,17 +129,7 @@ refreshRecents s = do
return $ s & recents .~ rs return $ s & recents .~ rs
& list .~ L.list () options 1 & list .~ L.list () options 1
runFileBrowser :: GlobalState -> IO GlobalState addRecentInternal :: CSS -> FilePath -> IO CSS
runFileBrowser gs = do addRecentInternal s fp = do
result <- runFileBrowserUI gs addRecent fp
-- maybe (return s) (\(cards, fp) -> addRecentInternal s fp <* runCardsWithOptions (s^.gs) cards) result refreshRecents s
return result
-- runCardsWithOptions :: GlobalState -> [Card] -> IO ()
-- runCardsWithOptions state cards = void $ doRandomization state cards >>= runCardsUI state
-- doRandomization :: GlobalState -> [Card] -> IO [Card]
-- doRandomization state cards =
-- let n = length cards in do
-- cards' <- if state^.doShuffle then sampleFrom (state^.mwc) (shuffleN n cards) else return cards
-- return $ maybe cards' (`take` cards') (state^.subset)

View File

@ -1,4 +1,4 @@
module UI.Cards (Card, State(..), drawUI, handleEvent, theMap, defaultCardState) where module UI.Cards (Card, State(..), drawUI, handleEvent, theMap, defaultCardState, runCardsUI, runCardsWithOptions) where
import Brick import Brick
import Lens.Micro.Platform import Lens.Micro.Platform
@ -10,6 +10,7 @@ import Data.List.NonEmpty (NonEmpty)
import Data.Map.Strict (Map) import Data.Map.Strict (Map)
import Text.Wrap import Text.Wrap
import Data.Text (pack) import Data.Text (pack)
import DeckHandling
import UI.Attributes import UI.Attributes
import UI.BrickHelpers import UI.BrickHelpers
import UI.Settings (getShowHints, getShowControls) import UI.Settings (getShowHints, getShowControls)
@ -45,6 +46,25 @@ defaultCardState (Reorder _ elements) = ReorderState
, _entered = False , _entered = False
, _number = NE.length elements } , _number = NE.length elements }
runCardsUI :: GlobalState -> [Card] -> IO GlobalState
runCardsUI gs deck = do
hints <- getShowHints
controls <- getShowControls
let initialState =
CS { _cards = deck
, _index = 0
, _currentCard = head deck
, _cardState = defaultCardState (head deck)
, _nCards = length deck
, _showHints = hints
, _showControls = controls }
return $ gs `goToState` CardsState initialState
runCardsWithOptions :: GlobalState -> [Card] -> IO GlobalState
runCardsWithOptions state cards = doRandomization state cards >>= runCardsUI state
--------------------------------------------------- ---------------------------------------------------
--------------------- DRAWING --------------------- --------------------- DRAWING ---------------------
--------------------------------------------------- ---------------------------------------------------
@ -266,10 +286,11 @@ drawReorder s elements = case (s ^. cardState, s ^. currentCard) of
handleEvent :: GlobalState -> CS -> BrickEvent Name Event -> EventM Name (Next GlobalState) handleEvent :: GlobalState -> CS -> BrickEvent Name Event -> EventM Name (Next GlobalState)
handleEvent gs s (VtyEvent e) = handleEvent gs s (VtyEvent e) =
let update = updateCS gs let update = updateCS gs
continue' = continue . update in continue' = continue . update
halt' = continue . popState in
case e of case e of
V.EvKey V.KEsc [] -> halt gs V.EvKey V.KEsc [] -> halt' gs
V.EvKey (V.KChar 'c') [V.MCtrl] -> halt gs V.EvKey (V.KChar 'c') [V.MCtrl] -> halt' gs
V.EvKey V.KRight [V.MCtrl] -> next gs s V.EvKey V.KRight [V.MCtrl] -> next gs s
V.EvKey V.KLeft [V.MCtrl] -> previous gs s V.EvKey V.KLeft [V.MCtrl] -> previous gs s
@ -413,7 +434,7 @@ handleEvent gs _ _ = continue gs
next :: GlobalState -> CS -> EventM Name (Next GlobalState) next :: GlobalState -> CS -> EventM Name (Next GlobalState)
next gs s next gs s
| s ^. index + 1 < length (s ^. cards) = continue . updateCS gs . straightenState $ s & index +~ 1 | s ^. index + 1 < length (s ^. cards) = continue . updateCS gs . straightenState $ s & index +~ 1
| otherwise = halt gs | otherwise = continue $ popState gs
previous :: GlobalState -> CS -> EventM Name (Next GlobalState) previous :: GlobalState -> CS -> EventM Name (Next GlobalState)
previous gs s | s ^. index > 0 = continue . updateCS gs . straightenState $ s & index -~ 1 previous gs s | s ^. index > 0 = continue . updateCS gs . straightenState $ s & index -~ 1

View File

@ -13,7 +13,9 @@ import Control.Monad.IO.Class
import Lens.Micro.Platform import Lens.Micro.Platform
import Parser import Parser
import States import States
import Recents
import UI.BrickHelpers import UI.BrickHelpers
import UI.Cards (runCardsWithOptions)
import qualified UI.Attributes as A import qualified UI.Attributes as A
import qualified Graphics.Vty as V import qualified Graphics.Vty as V
@ -50,14 +52,14 @@ handleEvent :: GlobalState -> FBS -> BrickEvent Name Event -> EventM Name (Next
handleEvent gs s@FBS{_fb=b, _exception'=excep} (VtyEvent ev) = handleEvent gs s@FBS{_fb=b, _exception'=excep} (VtyEvent ev) =
let update = updateFBS gs let update = updateFBS gs
continue' = continue . update continue' = continue . update
halt' = halt . update in halt' = continue . popState in
case (excep, ev) of case (excep, ev) of
(Just _, _) -> continue' $ s & exception' .~ Nothing (Just _, _) -> continue' $ s & exception' .~ Nothing
(_, e) -> case e of (_, e) -> case e of
V.EvKey V.KEsc [] | not (fileBrowserIsSearching b) -> V.EvKey V.KEsc [] | not (fileBrowserIsSearching b) ->
halt gs halt' gs
V.EvKey (V.KChar 'c') [V.MCtrl] | not (fileBrowserIsSearching b) -> V.EvKey (V.KChar 'c') [V.MCtrl] | not (fileBrowserIsSearching b) ->
halt gs halt' gs
V.EvKey (V.KChar 'h') [] | not (fileBrowserIsSearching b) -> let s' = s & showHidden %~ not in V.EvKey (V.KChar 'h') [] | not (fileBrowserIsSearching b) -> let s' = s & showHidden %~ not in
continue' $ s' & fb .~ setFileBrowserEntryFilter (Just (entryFilter (s' ^. showHidden))) b continue' $ s' & fb .~ setFileBrowserEntryFilter (Just (entryFilter (s' ^. showHidden))) b
_ -> do _ -> do
@ -76,8 +78,12 @@ handleEvent gs s@FBS{_fb=b, _exception'=excep} (VtyEvent ev) =
Left exc -> continue' (s' & exception' ?~ displayException exc) Left exc -> continue' (s' & exception' ?~ displayException exc)
Right file -> case parseCards file of Right file -> case parseCards file of
Left parseError -> continue' (s & exception' ?~ errorBundlePretty parseError) Left parseError -> continue' (s & exception' ?~ errorBundlePretty parseError)
Right result -> halt' (s' & parsedCards .~ result & filePath ?~ fp) -- Right result -> halt' (s' & parsedCards .~ result & filePath ?~ fp)
_ -> halt gs Right result -> continue =<< liftIO (do
addRecent fp
let s'' = s' & exception' .~ Nothing
runCardsWithOptions (update s'') result)
_ -> halt' gs
_ -> continue' s' _ -> continue' s'
handleEvent gs _ _ = continue gs handleEvent gs _ _ = continue gs
@ -86,7 +92,7 @@ runFileBrowserUI :: GlobalState -> IO GlobalState
runFileBrowserUI gs = do runFileBrowserUI gs = do
browser <- newFileBrowser selectNonDirectories () Nothing browser <- newFileBrowser selectNonDirectories () Nothing
let filteredBrowser = setFileBrowserEntryFilter (Just (entryFilter False)) browser let filteredBrowser = setFileBrowserEntryFilter (Just (entryFilter False)) browser
return $ goToState (FileBrowserState (FBS filteredBrowser Nothing [] Nothing False)) gs return $ gs `goToState` FileBrowserState (FBS filteredBrowser Nothing [] Nothing False)
-- browser <- newFileBrowser selectNonDirectories () Nothing -- browser <- newFileBrowser selectNonDirectories () Nothing
-- let filteredBrowser = setFileBrowserEntryFilter (Just (entryFilter False)) browser -- let filteredBrowser = setFileBrowserEntryFilter (Just (entryFilter False)) browser

View File

@ -8,7 +8,7 @@ import Control.Monad (void)
import States import States
import qualified Graphics.Vty as V import qualified Graphics.Vty as V
drawUI :: State -> [Widget Name] drawUI :: IS -> [Widget Name]
drawUI = (:[]) . const ui drawUI = (:[]) . const ui
ui :: Widget Name ui :: Widget Name
@ -22,18 +22,21 @@ ui =
hBorder <=> hBorder <=>
drawInfo drawInfo
handleEvent :: GlobalState -> BrickEvent Name Event -> EventM Name (Next GlobalState) handleEvent :: GlobalState -> IS -> BrickEvent Name Event -> EventM Name (Next GlobalState)
handleEvent s (VtyEvent e) = handleEvent gs s (VtyEvent e) =
let update = updateIS gs
continue' = continue . update
halt' = continue . popState in
case e of case e of
V.EvKey (V.KChar 'c') [V.MCtrl] -> halt s V.EvKey (V.KChar 'c') [V.MCtrl] -> halt' gs
V.EvKey V.KEsc [] -> halt s V.EvKey V.KEsc [] -> halt' gs
V.EvKey V.KEnter [] -> halt s V.EvKey V.KEnter [] -> halt' gs
V.EvKey V.KDown [] -> vScrollBy (viewportScroll ()) 1 >> continue s V.EvKey V.KDown [] -> vScrollBy (viewportScroll ()) 1 >> continue' s
V.EvKey (V.KChar 'j') [] -> 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.KUp [] -> vScrollBy (viewportScroll ()) (-1) >> continue' s
V.EvKey (V.KChar 'k') [] -> vScrollBy (viewportScroll ()) (-1) >> continue s V.EvKey (V.KChar 'k') [] -> vScrollBy (viewportScroll ()) (-1) >> continue' s
_ -> continue s _ -> continue' s
handleEvent s _ = continue s handleEvent gs _ _ = continue gs
titleAttr :: AttrName titleAttr :: AttrName
titleAttr = attrName "title" titleAttr = attrName "title"
@ -49,7 +52,7 @@ drawInfo =
viewport () Vertical (strWrap info) viewport () Vertical (strWrap info)
runInfoUI :: GlobalState -> GlobalState runInfoUI :: GlobalState -> GlobalState
runInfoUI = goToState (InfoState ()) runInfoUI = (`goToState` InfoState ())
info :: String info :: String
info = info =

View File

@ -1,22 +1,34 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module UI.MainMenu (State (..), drawUI, handleEvent, theMap) where module UI.MainMenu (State (..), drawUI, handleEvent, theMap, runMainMenuUI) where
import Brick import Brick
import Brick.Widgets.Border import Brick.Widgets.Border
import Brick.Widgets.Border.Style import Brick.Widgets.Border.Style
import Brick.Widgets.Center import Brick.Widgets.Center
import Control.Monad.IO.Class
import Data.Functor (($>)) import Data.Functor (($>))
import Lens.Micro.Platform import Lens.Micro.Platform
import States import States
import UI.Attributes import UI.Attributes
import UI.BrickHelpers import UI.BrickHelpers
-- import UI.CardSelector (runCardSelectorUI) import UI.CardSelector (runCardSelectorUI)
-- import UI.Info (runInfoUI) import UI.Info (runInfoUI)
-- import UI.Settings (runSettingsUI) import UI.Settings (runSettingsUI)
import qualified Data.Vector as Vec import qualified Data.Vector as Vec
import qualified Graphics.Vty as V import qualified Graphics.Vty as V
import qualified Brick.Widgets.List as L import qualified Brick.Widgets.List as L
runMainMenuUI :: GlobalState -> GlobalState
runMainMenuUI gs =
let options = Vec.fromList
[ "Select"
, "Info"
, "Settings"
, "Quit" ]
initialState = MMS (L.list () options 1) in
gs `goToState` MainMenuState initialState
title :: Widget Name title :: Widget Name
title = withAttr titleAttr $ title = withAttr titleAttr $
str "┬ ┬┌─┐┌─┐┌─┐┌─┐┬─┐┌┬┐" <=> str "┬ ┬┌─┐┌─┐┌─┐┌─┐┬─┐┌┬┐" <=>
@ -54,9 +66,9 @@ handleEvent gs s (VtyEvent e) =
V.EvKey V.KEsc [] -> halt gs V.EvKey V.KEsc [] -> halt gs
V.EvKey V.KEnter [] -> V.EvKey V.KEnter [] ->
case L.listSelected (s^.l) of case L.listSelected (s^.l) of
-- Just 0 -> suspendAndResume $ runCardSelectorUI (s^.gs)$> s Just 0 -> continue =<< liftIO (runCardSelectorUI gs)
-- Just 1 -> suspendAndResume $ runInfoUI $> s Just 1 -> continue $ runInfoUI gs
-- Just 2 -> suspendAndResume $ runSettingsUI $> s Just 2 -> continue =<< liftIO (runSettingsUI gs)
Just 3 -> halt gs Just 3 -> halt gs
_ -> undefined _ -> undefined

View File

@ -34,10 +34,11 @@ ui s =
handleEvent :: GlobalState -> SS -> BrickEvent Name Event -> EventM Name (Next GlobalState) handleEvent :: GlobalState -> SS -> BrickEvent Name Event -> EventM Name (Next GlobalState)
handleEvent gs s@(i, settings) (VtyEvent e) = handleEvent gs s@(i, settings) (VtyEvent e) =
let update = updateSS gs in let update = updateSS gs
halt' = continue . popState in
case e of case e of
V.EvKey (V.KChar 'c') [V.MCtrl] -> halt gs V.EvKey (V.KChar 'c') [V.MCtrl] -> halt' gs
V.EvKey V.KEsc [] -> halt gs V.EvKey V.KEsc [] -> halt' gs
V.EvKey V.KEnter [] -> continue $ update (i, settings') V.EvKey V.KEnter [] -> continue $ update (i, settings')
where settings' = M.adjust not i settings where settings' = M.adjust not i settings
V.EvKey V.KUp [] -> continue $ update (max 0 (i-1), settings) V.EvKey V.KUp [] -> continue $ update (max 0 (i-1), settings)
@ -75,7 +76,7 @@ runSettingsUI :: GlobalState -> IO GlobalState
runSettingsUI gs = do runSettingsUI gs = do
currentSettings <- getSettings currentSettings <- getSettings
-- (_, newSettings) <- defaultMain app (0, currentSettings) -- (_, newSettings) <- defaultMain app (0, currentSettings)
return $ goToState (SettingsState (0, currentSettings)) gs return $ gs `goToState` SettingsState (0, currentSettings)
-- setSettings newSettings -- setSettings newSettings