Getting Haskeline to quit early

Question

I am trying to use Haskeline to write a program which asks the user a sequence of questions, each one optionally with a default value in [brackets], and reads in their responses. I want the user to be able to

1. Press Enter to submit the [default] value;
2. Type in a string, edit it if needed, and then press Enter to submit this value;
3. Press Ctrl-C to reset all values to the defaults and start over; and,
4. Press Ctrl-D or enter "quit" to quit, in which case all the values which they submitted are lost.

I have been able to get points 1-3 working, but I cannot get point 4 to work: pressing Ctrl-D (or entering "quit") just brings up the next prompt instead of making the program quit the questioning. Looking at my program (please see below) I understand why this happens, but I am not able to figure out how to fix this so that Ctrl-D (or "quit") actually makes the questioning stop. How do I fix the program to make this happen?

I did see this question which seems to ask something similar, but I could not get much from there; I am not even sure that they are asking the same question as I am.

As a secondary question: my current program has quite a few case statements which switch on Maybe values. In particular, I currently check for Nothing two or three levels deep so that I can correctly return a Nothing when the user presses Ctrl-D. I have a feeling that this could be simplified using (something like) the monadic >>= operator, but I am unable to figure out how to do this in this case. Is my hunch right? Is there a way to do away with all this pattern matching which looks for Nothing?

Also: please tell me anything else which could improve my code below. I am quite new to this, so it is very likely that I am missing many obvious things here.

My program asks the user about the composition of a fruit basket. The information associated with a fruit basket consists of the name of the owner of the fruit basket and the names of the different kinds of fruit in the basket. To be able to ask for the latter, I first ask for the number of different kind of fruit in the basket, and then ask for the name of each kind. We start with a default fruit basket whose information is then modified as per what the user tells us.

module Main where 
import System.Console.Haskeline

type PersonName = String
type FruitName = String
data FruitBasket = FruitBasket { ownerName :: PersonName,
                                 fruitCount :: Int,
                                 fruitNames :: [FruitName]
                               } deriving Show

defaultBasket = FruitBasket "Mary" 2 ["Apple", "Peach"]

main :: IO ()
main = do
  basket <- getBasketData defaultBasket
  putStrLn $ "Got: " ++ show(basket)

-- Prompt the user for information about a fruit basket, and
-- return a FruitBasket instance containing this information.  The
-- first argument is an instance of FruitBasket from which we get
-- the default values for the various prompts. The return value
-- has a Maybe type because the user may abort the questioning, in
-- which case we get nothing from them.
getBasketData :: FruitBasket -> IO (Maybe FruitBasket)
getBasketData basket = runInputT defaultSettings $ withInterrupt $ getData basket
    where 
      getData :: FruitBasket -> InputT IO (Maybe FruitBasket)   
      getData initialBasket = handleInterrupt f  $ do 
        outputStrLn banner
        input <- getInputLine $ "Who owns this basket? [" ++ defaultOwner ++ "] : "
        basket <- case input of
                   Nothing -> return Nothing -- User pressed Ctrl-D with the input being empty
                   Just "" -> return (Just initialBasket) -- User pressed Enter with the input being empty
                   Just "quit" -> return Nothing -- User typed in "quit" and pressed Enter
                   Just newOwner -> return (Just initialBasket{ownerName = newOwner})
        input <- getInputLine $ "Number of kinds of fruit in the basket? [" ++ show defaultCount ++ "] : "
        basket' <- case input of
                    Nothing -> return Nothing
                    Just "" -> return basket 
                    Just "quit" -> return Nothing
                    Just count -> return $ updateFruitCount basket (read count)
                           where updateFruitCount Nothing _ = Nothing
                                 updateFruitCount (Just realBasket) newCount = Just $ realBasket{fruitCount = newCount}
        let defaultFruitNames = pruneOrPadNames basket' 
        newNames <- getFruitNames defaultFruitNames 1
        case newNames of 
          Nothing -> return (Just defaultBasket)
          Just newSetOfNames -> return $ updateFruitNames basket' newSetOfNames
              where updateFruitNames Nothing _ = Nothing
                    updateFruitNames (Just realBasket) realNewNames = Just $ realBasket{fruitNames = realNewNames} 
          where f = (outputStrLn "Press Ctrl-D or enter \"quit\" to quit." >> getData initialBasket)
                defaultOwner = ownerName initialBasket
                defaultCount = fruitCount initialBasket


banner :: String
banner = "Please enter details of the fruit basket below. At each prompt you can do one of the following:\n\
         \\t (a) Press Enter to submit the [default] value;\n\
         \\t (b) Type in a string, edit it if needed, and then press Enter to submit this value;\n\
         \\t (c) Press Ctrl-C to reset all values to the defaults and start over;\n\
         \\t (d) Press Ctrl-D or enter \"quit\" to quit; all the values you submitted will be lost." 

pruneOrPadNames :: Maybe FruitBasket -> Maybe [String]
pruneOrPadNames Nothing = Nothing
pruneOrPadNames (Just basket) = Just $ pruneOrPad (fruitNames basket) (fruitCount basket)

-- When requiredLength is not larger than (length inputList),
-- (pruneOrPad inputList requiredLength) is the prefix of
-- inputList of length requiredLength. Otherwise, it is inputList
-- padded with as many empty strings as required to make the total
-- length equal to requiredLength.

pruneOrPad :: [String] -> Int -> [String]
pruneOrPad inputList requiredLength
               | requiredLength <= inputLength  = take requiredLength inputList
               | otherwise = inputList ++ (replicate difference "")
    where inputLength = length inputList
          difference = requiredLength - inputLength



getFruitNames Nothing _ = return Nothing
getFruitNames (Just []) _  = return $ Just [""]
getFruitNames (Just (name:names)) count = do
  input <- getInputLine $ "Name of fruit " ++ (show count) ++ " [" ++ name ++ "] : "
  newNames <- case input of
               Nothing -> return Nothing 
               Just "" -> do -- Keep the default name for this fruit ...
                          newNames' <- getFruitNames (Just names) (count + 1) 
                          case newNames' of
                            Nothing -> return Nothing
                            -- ... unless the user chose to quit
                            -- while entering a name

                            Just [""] -> return $ Just [name] 
                            -- At this point names = [] so it is
                            -- already time to stop asking for
                            -- more names.

                            Just furtherNames ->   return $ Just (name : furtherNames)

               Just "quit" -> return Nothing
               Just name' -> do
                          newNames' <- getFruitNames (Just names) (count + 1) 
                          case newNames' of
                            Nothing -> return Nothing
                            Just [""] -> return $ Just [name'] 
                            Just furtherNames ->  return $ Just (name' : furtherNames)
  return newNames

Answer 1

With help from some of the advice here on the haskell-beginners mailing list I have managed to solve my problems, the Ctrl-D question entirely and the factoring question to my own satisfaction (as of now!). I am posting the answer here in the hope it helps others in my predicament.

First, the trouble with the Ctrl-D: The problem was that I was throwing away the control logic offered by the Maybe monad and just using the values from the monad, by referring to various variable names which contained these values. The first place where I do this is here, in the getBasketData function:

basket <- case input of ...               
input <- getInputLine ...
basket' <- case input of
                Nothing -> return Nothing
                Just "" -> return basket 

Notice how, in computing basket', I

1. Ignore the case where basket could have been Nothing, and
2. Use the value encapsulated by basket by referring to (and pattern matching on, when needed) the variable basket which is still in scope inside the expression for basket'.

This is the where the Ctrl-D was lost. Here, for contrast, is code for getBasketData which does not let the Nothings slip through the gaps (I renamed the basket variables to maybeBasket, because they are really instances of Maybe FruitBasket):

getBasketData basket = runInputT defaultSettings $ withInterrupt $ getData basket
    where 
      getData :: FruitBasket -> InputT IO (Maybe FruitBasket)
      getData initialBasket = handleInterrupt f  $ do
             outputStrLn banner
             input <- getInputLine $ "Who owns this basket? [" ++ defaultOwner ++ "] : "
             maybeBasket <- case input of
                       Nothing -> return $ Nothing -- User pressed Ctrl-D with the input being empty
                       Just "" -> return $ Just initialBasket -- User pressed Enter with the input being empty
                       Just "quit" -> return $ Nothing -- User typed in "quit" and pressed Enter
                       Just newOwner -> return $ Just initialBasket{ownerName = newOwner}
             maybeBasket' <- case maybeBasket of
                         Nothing -> return $ Nothing
                         Just realBasket -> do input <- getInputLine $ "Number of kinds of fruit in the basket? [" ++ show defaultCount ++ "] : "
                                               case input of
                                                Nothing -> return $ Nothing
                                                Just "" -> return $ maybeBasket 
                                                Just "quit" -> return $ Nothing
                                                Just count ->  return $ Just $ realBasket{fruitCount = (read count)}
             maybeBasket'' <- case maybeBasket' of
                               Nothing -> return $ Nothing
                               Just realBasket -> do let defaultFruitNames = pruneOrPad (fruitNames realBasket) (fruitCount realBasket)
                                                     newNames <- getFruitNames defaultFruitNames 1
                                                     case newNames of 
                                                       Nothing -> return $ Nothing
                                                       Just newSetOfNames -> return $ Just $ realBasket{fruitNames = newSetOfNames} 
             return maybeBasket''
               where f = (outputStrLn interruptMessage  >> getData initialBasket)
                     defaultOwner = ownerName initialBasket
                     defaultCount = fruitCount initialBasket

Thus, for instance, we try to do any real computation to get maybeBasket' --- including presenting the prompt for the number of different kinds of fruit --- only if maybeBasket is not Nothing.

This solves the Ctrl-D problem: the program now stops questioning and returns Nothing if the user presses Ctrl-D in response to any question.

---

Now onto the factoring. This is where advice from the mailing list answer helped: I started out by splitting up the big getData function into three pieces, one for each "big" use of the <- operator, and put these pieces into separate functions. This cleared up the logic a lot for me (indeed, this is how I found the fix to the Ctrl-D problem as well). Starting with this, I kept rephrasing the various parts till I got the following version which looks good enough to me. Notice how small and clean the getBasketData function has become!

module Main where 
import System.Console.Haskeline

type PersonName = String
type FruitName = String
data FruitBasket = FruitBasket { ownerName :: PersonName,
                                 fruitCount :: Int,
                                 fruitNames :: [FruitName]
                               } deriving Show

defaultBasket :: FruitBasket
defaultBasket = FruitBasket "Mary" 2 ["Apple", "Peach"]

main :: IO ()
main = do
  basket <- getBasketData defaultBasket
  putStrLn $ "Got: " ++ show(basket)

-- Prompt the user for information about a fruit basket, and
-- return a FruitBasket instance containing this information.  The
-- first argument is an instance of FruitBasket from which we get
-- the default values for the various prompts. The return value
-- has a Maybe type because the user may abort the questioning, in
-- which case we get nothing from them.
getBasketData :: FruitBasket -> IO (Maybe FruitBasket)
getBasketData basket = runInputT defaultSettings $ withInterrupt $ getData basket
    where 
      getData :: FruitBasket -> InputT IO (Maybe FruitBasket)
      getData initialBasket = handleInterrupt f  $ do
             outputStrLn banner
             (ownerQ initialBasket) >>=  (processOwner initialBasket) >>= processCount >>= processNames
               where f = (outputStrLn interruptMessage  >> getData initialBasket)


ownerQ :: FruitBasket -> InputT IO (Maybe PersonName)
ownerQ basket = getInputLine $ "Who owns this basket? [" ++ (ownerName basket) ++ "] : "


processOwner :: FruitBasket -> Maybe PersonName -> InputT IO (Maybe FruitBasket)
processOwner _ Nothing = return Nothing
processOwner _ (Just "quit") = return Nothing
processOwner basket (Just "") = return $ Just basket 
processOwner basket (Just newOwner) = return $ Just basket{ownerName = newOwner}


processCount ::  Maybe FruitBasket -> InputT IO (Maybe FruitBasket)
processCount Nothing = return Nothing
processCount (Just basket) = (fruitTypesQ basket) >>= processCount'
  where processCount' :: Maybe String -> InputT IO (Maybe FruitBasket)
        processCount' Nothing = return Nothing
        processCount' (Just "quit") = return Nothing
        processCount' (Just "") = return $ Just basket 
        processCount' (Just count) = return $ Just basket{fruitCount = (read count)}


fruitTypesQ :: FruitBasket -> InputT IO (Maybe String)        
fruitTypesQ basket = getInputLine $ "Number of kinds of fruit in the basket? [" ++ show (fruitCount basket) ++ "] : "


processNames :: Maybe FruitBasket -> InputT IO (Maybe FruitBasket)
processNames Nothing = return Nothing
processNames (Just basket) = input >>= processNames'
  where input = getFruitNames defaultFruitNames 1
        defaultFruitNames = pruneOrPad (fruitNames basket) (fruitCount basket)
        processNames' :: Maybe [FruitName] -> InputT IO (Maybe FruitBasket)
        processNames' Nothing = return Nothing
        processNames' (Just newSetOfNames) = return $ Just basket{fruitNames = newSetOfNames}



banner :: String
banner = "Please enter details of the fruit basket below. At each prompt you can do one of the following:\n\
         \\t (a) Press Enter to submit the [default] value;\n\
         \\t (b) Type in a string, edit it if needed, and then press Enter to submit this value;\n\
         \\t (c) Press Ctrl-C to reset all values to the defaults and start over;\n\
         \\t (d) Press Ctrl-D or enter \"quit\" to quit; all the values you submitted will be lost." 

interruptMessage :: String
interruptMessage = "#################################################\n\
                   \You pressed Ctrl-C.\n\
                   \We will now reset all values and start over.\n\
                   \To quit, press Ctrl-D or enter \"quit\".\n\
                   \#################################################\n"




pruneOrPadNames :: Maybe FruitBasket -> Maybe [String]
pruneOrPadNames Nothing = Nothing
pruneOrPadNames (Just basket) = Just $ pruneOrPad (fruitNames basket) (fruitCount basket)

-- When requiredLength is not larger than (length inputList),
-- (pruneOrPad inputList requiredLength) is the prefix of
-- inputList of length requiredLength. Otherwise, it is inputList
-- padded with as many empty strings as required to make the total
-- length equal to requiredLength.

pruneOrPad :: [String] -> Int -> [String]
pruneOrPad inputList requiredLength
               | requiredLength <= inputLength  = take requiredLength inputList
               | otherwise = inputList ++ (replicate difference "")
    where inputLength = length inputList
          difference = requiredLength - inputLength


getFruitNames :: [FruitName] -> Int -> InputT IO (Maybe [FruitName])
getFruitNames  [] _  = return $ Just [""]
getFruitNames (name:names) count = do
  input <- getInputLine $ "Name of fruit " ++ (show count) ++ " [" ++ name ++ "] : "
  newNames <- case input of
               Nothing -> return Nothing 
               Just "" -> do -- Keep the default name for this fruit ...
                          newNames' <- getFruitNames names (count + 1) 
                          case newNames' of
                            Nothing -> return Nothing
                            -- ... unless the user chose to quit
                            -- while entering a name

                            Just [""] -> return $ Just [name] 
                            -- At this point names = [] so it is
                            -- already time to stop asking for
                            -- more names.

                            Just furtherNames ->   return $ Just (name : furtherNames)

               Just "quit" -> return Nothing
               Just name' -> do
                          newNames' <- getFruitNames names (count + 1) 
                          case newNames' of
                            Nothing -> return Nothing
                            Just [""] -> return $ Just [name'] 
                            Just furtherNames ->  return $ Just (name' : furtherNames)
  return newNames

---

The moral of this story seems to be: "When confused, break things down."

Answer 2

I think your hunch is right here. Much of the pattern matching done via case can be replaced with using the Maybe Monad a bit more. Instead of

basket <- case input of
  Nothing -> return Nothing -- User pressed Ctrl-D with the input being empty
  Just "" -> return (Just initialBasket) -- User pressed Enter with the input being empty
  Just "quit" -> return Nothing -- User typed in "quit" and pressed Enter
  Just newOwner -> return (Just initialBasket{ownerName = newOwner})

you could write something like

let basket' = do
  i <- input
  guard $ i /= "quit"
  b <- basket
  return $ if (null i) then b else b{fruitCount = read i}

you could even introduce some helpers like

guardInput :: Maybe String -> (String -> Maybe a) -> Maybe a
guardInput input λ = input >>= \i -> ((guard $ i /= "quit") >> λ i)
-- | Custom ternary operator .)
True  ? (a, _) = a
False ? (_, b) = b

to write

let basket = guardInput input $
        \i -> return $ (null i) ? (initialBasket, initialBasket{ownerName = i})

Sorry - I know this doesn't answer your problem with Ctrl+D, but I haven't figured that one out myself (yet).