diff --git a/Cards.hs b/Cards.hs index fe76e27..e63ee30 100644 --- a/Cards.hs +++ b/Cards.hs @@ -2,16 +2,23 @@ module Cards ( Element , Card , Comment - , isCard + , fromElement + , toElement + , isDue , sides - , resetLevel - , nextLevel + , reset + , update , showElement , showElements , parseElement , parseElements ) where +import Data.List +import Data.Time + +wee = EComment $ Comment "wee" + data Element = ECard Card | EComment Comment deriving (Show) @@ -34,16 +41,24 @@ isCard :: Element -> Bool isCard (ECard _) = True isCard _ = False +fromElement :: Element -> Maybe Card +fromElement (ECard c) = Just c +fromElement _ = Nothing + +toElement :: Card -> Element +toElement = ECard + +isDue :: UTCTime -> Card -> Bool +isDue = undefined + sides :: Card -> [String] sides (Card _ _ _ s) = s -resetTier :: Card -> Card -resetTier (Card t l d s) = Card minBound l d s +reset :: Card -> Card +reset (Card t l d s) = Card minBound l d s -nextTier :: Card -> Card -nextTier c@(Card t l d s) - | t == maxBound = c - | otherwise = Card (succ t) l d s +update :: UTCTime -> Card -> Card +update = undefined showElements :: [Element] -> String showElements = intercalate "\n\n" . map showElement diff --git a/Main.hs b/Main.hs new file mode 100644 index 0000000..a35a3ef --- /dev/null +++ b/Main.hs @@ -0,0 +1,128 @@ +module Main + ( main + ) where + +import Cards +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Trans.Maybe +import Data.Char +import Data.Time +import System.Console.Haskeline + +inputSettings = Settings + { complete = noCompletion + , historyFile = Nothing + , autoAddHistory = True + } + +promptYesNo :: String -> MaybeT (InputT IO) Bool +promptYesNo question = do + i <- MaybeT $ getInputLine $ question ++ " [Y/n] " + case map toLower i of + "" -> return True + "y" -> return True + "n" -> return False + _ -> do + lift $ outputStrLn $ "Incorrect input: " ++ show i + promptYesNo question + +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 ([], []) +spanM f l@(x:xs) = do + result <- f x + if result + then do + (with, without) <- spanM f xs + return (x:with, without) + else do + return ([], l) + +-- A combination of span and map, but with monads. +-- Note the line-by-line similarity to spanM. +-- Basically like spanM, but instead of splitting the list by a Bool, splits it +-- by a Maybe. +spanJustM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m ([b], [a]) +spanJustM _ [] = return ([], []) +spanJustM f l@(x:xs) = do + result <- f x + case result of + Just r -> do + (just, nothing) <- spanJustM f xs + return (r:just, nothing) + Nothing -> do + return ([], l) + +-- Basically spanJustM, but more similar to map. +mapWhileJustM :: (Monad m) => (a -> m (Maybe a)) -> [a] -> m [a] +mapWhileJustM f l = uncurry (++) <$> spanJustM f l + +{- + - Dealing with Elements/Cards. + -} + +learn :: UTCTime -> [Element] -> InputT IO [Element] +learn time = mapWhileJustM (runMaybeT . askElement time) + +askElement :: UTCTime -> Element -> MaybeT (InputT IO) Element +askElement time elem = + case fromElement elem of + Just card -> toElement <$> askCard time card + Nothing -> return elem + +askCard :: UTCTime -> Card -> MaybeT (InputT IO) Card +askCard time card = do + if isDue time card + then do + (asked, unasked) <- spanM askSide $ sides card + mapM_ showSide $ tail unasked + return $ if null unasked then update time card else reset card + else do + return card + +askSide :: String -> MaybeT (InputT IO) Bool +askSide side = do + lift $ displaySide side + promptYesNo "Did you know that side?" + +showSide :: String -> MaybeT (InputT IO) () +showSide side = do + lift $ displaySide side + promptContinue "Continue" + +displaySide :: String -> InputT IO () +displaySide side = lift (putStrLn side) + +displayStats :: [Element] -> InputT IO () +displayStats = undefined + +run :: UTCTime -> [Element] -> InputT IO [Element] +run time elem = do + cmd <- getInputLine "%> " + case (map toLower) <$> cmd of + Nothing -> return elem + Just "quit" -> return elem + Just "q" -> return elem + Just "learn" -> learn time elem >>= run time + Just "l" -> learn time elem >>= run time + Just "show" -> displayStats elem >> run time elem + Just "s" -> displayStats elem >> run time elem + Just x -> do + outputStrLn $ "Unknown command " ++ show x ++ "." + run time elem + -- Maybe save cards? + +main :: IO () +main = runInputT inputSettings loop + where loop :: InputT IO () + loop = do + f <- runMaybeT $ promptYesNo "Hey, do you want apples?" + outputStrLn $ show f