Clean up Main.hs a bit.
This commit is contained in:
parent
373a245591
commit
bf49310bdf
1 changed files with 40 additions and 24 deletions
64
Main.hs
64
Main.hs
|
|
@ -18,6 +18,10 @@ inputSettings = Settings
|
|||
, autoAddHistory = True
|
||||
}
|
||||
|
||||
-- The prompt functions use a MaybeT wrapper because they can fail at any time.
|
||||
-- This happens when the user presses ctrl+D (EOF).
|
||||
|
||||
-- Simple yes/no prompt (defaults to yes)
|
||||
promptYesNo :: String -> MaybeT (InputT IO) Bool
|
||||
promptYesNo question = do
|
||||
i <- MaybeT $ getInputLine $ question ++ " [Y/n] "
|
||||
|
|
@ -29,13 +33,10 @@ promptYesNo question = do
|
|||
lift $ outputStrLn $ "Incorrect input: " ++ show i
|
||||
promptYesNo question
|
||||
|
||||
-- Wait until user pressed Enter
|
||||
promptContinue :: String -> MaybeT (InputT IO) ()
|
||||
promptContinue question = void $ MaybeT $ getInputLine $ question ++ "[Enter] "
|
||||
|
||||
{-
|
||||
- General functions for functions operating on lists within monads.
|
||||
-}
|
||||
|
||||
-- Just span, but with monads.
|
||||
spanM :: (Monad m) => (a -> m Bool) -> [a] -> m ([a], [a])
|
||||
spanM _ [] = return ([], [])
|
||||
|
|
@ -52,36 +53,47 @@ spanM f l@(x:xs) = do
|
|||
- Dealing with Elements/Cards.
|
||||
-}
|
||||
|
||||
countDueCards :: UTCTime -> [Element] -> Int
|
||||
countDueCards time elms = length $ filter isDueCard elms
|
||||
where isDueCard e = fromMaybe False (isDue time <$> toCard e)
|
||||
-- Generic card counting function
|
||||
countCardsBy :: (Card -> Bool) -> [Element] -> Int
|
||||
countCardsBy f = length . filter elmF
|
||||
where elmF e = fromMaybe False (f <$> toCard e)
|
||||
|
||||
askCountdown :: UTCTime -> Int -> [Element] -> InputT IO [Element]
|
||||
askCountdown _ _ [] = return []
|
||||
askCountdown time left elms@(e:es) = do
|
||||
case toCard e of
|
||||
Nothing -> (e :) <$> askCountdown time left es
|
||||
Just card -> defaultTo elms $
|
||||
if isDue time card
|
||||
then do
|
||||
card' <- askNthCard time card (left - 1)
|
||||
(fromCard card' :) <$> liftedAsk time (left - 1) es
|
||||
else do
|
||||
(e :) <$> liftedAsk time left es
|
||||
-- Ask all cards in the list of elements which are due.
|
||||
-- When askNthCard fails, don't modify the rest of the list.
|
||||
-- This bit uses two MaybeTs inside each other, so beware :P
|
||||
askCountdown :: UTCTime -> [Element] -> InputT IO [Element]
|
||||
askCountdown _ [] = return []
|
||||
askCountdown time elms@(e:es) =
|
||||
defaultTo elms $ do
|
||||
result <- runMaybeT $ do
|
||||
card <- MaybeT $ return $ toCard e
|
||||
guard $ isDue time card
|
||||
card' <- lift $ askCardWithInfo time card (countCardsBy (isDue time) es)
|
||||
lift $ lift $ (fromCard card' :) <$> askCountdown time es
|
||||
case result of
|
||||
Nothing -> lift $ continue
|
||||
Just r -> return r
|
||||
where defaultTo what monad = fromMaybe what <$> runMaybeT monad
|
||||
liftedAsk t l e' = lift $ askCountdown t l e'
|
||||
continue = (e :) <$> askCountdown time es
|
||||
|
||||
-- A simple right justify
|
||||
rjust :: Char -> Int -> String -> String
|
||||
rjust c l s = replicate (max 0 $ l - length s) c ++ s
|
||||
|
||||
askNthCard :: UTCTime -> Card -> Int -> MaybeT (InputT IO) Card
|
||||
askNthCard time card left = do
|
||||
-- These functions use a MaybeT wrapper because they can fail at any time,
|
||||
-- because they use the prompt functions.
|
||||
|
||||
-- Print out info about a card when asking it
|
||||
askCardWithInfo :: UTCTime -> Card -> Int -> MaybeT (InputT IO) Card
|
||||
askCardWithInfo time card left = do
|
||||
let t = rjust ' ' 9 $ tierName $ tier card
|
||||
l = rjust ' ' 3 $ show left
|
||||
lift $ outputStrLn ""
|
||||
lift $ outputStrLn $ "-----< tier: " ++ t ++ ", left: " ++ l ++ " >-----"
|
||||
askCard time card
|
||||
|
||||
-- Ask the sides on a card and reset or update the card accordingly
|
||||
-- Doesn't check whether the card is due or not.
|
||||
askCard :: UTCTime -> Card -> MaybeT (InputT IO) Card
|
||||
askCard time card = do
|
||||
(_, unasked) <- spanM askSide $ sides card
|
||||
|
|
@ -110,16 +122,20 @@ displaySide side = lift (putStrLn side)
|
|||
learn :: [Element] -> InputT IO [Element]
|
||||
learn elms = do
|
||||
time <- lift $ getCurrentTime
|
||||
askCountdown time (countDueCards time elms) elms
|
||||
askCountdown time elms
|
||||
|
||||
stats :: [Element] -> InputT IO ()
|
||||
stats = undefined -- TODO: Use tierName
|
||||
|
||||
trim :: Char -> String -> String
|
||||
trim c = dropWhile (== c) . reverse . dropWhile (== c) . reverse
|
||||
|
||||
run :: [Element] -> InputT IO [Element]
|
||||
run elms = do
|
||||
cmd <- getInputLine "%> "
|
||||
case (map toLower) <$> cmd of
|
||||
case trim ' ' . map toLower <$> cmd of
|
||||
Nothing -> return elms
|
||||
Just "" -> run elms
|
||||
Just "quit" -> return elms
|
||||
Just "q" -> return elms
|
||||
Just "learn" -> learn elms >>= run
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue