Attempt to make a user interface

Cards.hs

@@ -2,16 +2,23 @@ module Cards
   ( Element
   , Card
   , Comment
-  , isCard
+  , fromElement
+  , toElement
+  , isDue
   , sides
-  , resetLevel
+  , reset
-  , nextLevel
+  , 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
+reset :: Card -> Card
-resetTier (Card t l d s) = Card minBound l d s
+reset (Card t l d s) = Card minBound l d s
 
-nextTier :: Card -> Card
+update :: UTCTime -> Card -> Card
-nextTier c@(Card t l d s)
+update = undefined
-  | t == maxBound = c
-  | otherwise     = Card (succ t) l d s
 
 showElements :: [Element] -> String
 showElements = intercalate "\n\n" . map showElement

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