haskell - 让 Haskeline 提前退出

Question

我正在尝试使用Haskeline编写一个程序，询问用户一系列问题，每个问题都可以选择在[括号]中包含一个默认值，并读取他们的回答。我希望用户能够

1. 按 Enter 键提交[默认]值；
2. 输入一个字符串，根据需要进行编辑，然后按 Enter 键提交该值；
3. 按 Ctrl-C 将所有值重置为默认值并重新开始；并且，
4. 按 Ctrl-D 或输入“quit”退出，在这种情况下，他们提交的所有值都会丢失。

我已经能够使第 1-3 点工作，但无法使第 4 点工作:按 Ctrl-D(或输入“退出”)只会弹出下一个提示，而不是使程序退出提问。看看我的程序(请参见下文)，我明白为什么会发生这种情况，但我无法弄清楚如何解决这个问题，以便 Ctrl-D (或“退出”)实际上使提问停止。我该如何修复程序才能实现这一点？

我确实看到了this question这似乎问了类似的问题，但我无法从那里得到太多；我什至不确定他们是否在问与我相同的问题。

作为第二个问题:我当前的程序有很多 case 语句，它们会打开 Maybe 值。特别是，我目前检查两到三层深度的 Nothing ，以便当用户按 Ctrl-D 时我可以正确返回 Nothing 。我有一种感觉，这可以使用(类似的)单子(monad) >>= 运算符来简化，但我无法弄清楚在这种情况下如何做到这一点。我的预感对吗？有没有办法消除所有这些寻找 Nothing 的模式匹配？

另外:请告诉我任何其他可以改进我的代码的事情。我对此很陌生，所以很可能我在这里遗漏了许多明显的东西。

我的程序询问用户水果篮的组成。与水果篮相关联的信息包括水果篮所有者的姓名以及篮子中不同种类水果的名称。为了能够询问后者，我首先询问篮子中不同种类水果的数量，然后询问每种水果的名称。我们从默认的水果篮开始，然后根据用户告诉我们的内容修改其信息。

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

在一些建议的帮助下here on the haskell-beginners mailing list我已经成功地解决了我的问题，完全解决了 Ctrl-D 问题和因式分解问题，令我满意(到目前为止!)。我将答案发布在这里，希望它能帮助其他人解决我的困境。

首先，Ctrl-D 的问题:问题是我抛弃了 Maybe monad 提供的控制逻辑，只使用了值 monad，通过引用包含这些值的各种变量名称。我执行此操作的第一个地方是这里，在 getBasketData 中。功能:

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

注意计算中的情况 basket' ，我

1. 忽略 basket 的情况可能是Nothing ，并且
2. 使用 basket 封装的值通过引用(并在需要时进行模式匹配)变量 basket它仍然在 basket' 表达式的范围内.

这就是 Ctrl-D 丢失的地方。作为对比，这里的代码是 getBasketData这不让Nothing s 穿过间隙(我将 basket 变量重命名为 maybeBasket ，因为它们实际上是 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

因此，例如，我们尝试进行任何实际计算以获得 maybeBasket' --- 包括提示不同种类水果的数量 --- 仅当maybeBasket时不是Nothing 。

这解决了 Ctrl-D 问题:程序现在停止询问并返回 Nothing如果用户按 Ctrl-D 来回答任何问题。

<小时/>

现在进行保理。这就是邮件列表答案中的建议有所帮助的地方:我首先将大的 getData 分开。函数分为三部分，每个“大”使用 <-运算符，并将这些部分放入单独的函数中。这对我来说逻辑清晰了很多(事实上，这也是我找到解决 Ctrl-D 问题的方法)。从这里开始，我不断地重新表述各个部分，直到得到对我来说看起来足够好的以下版本。请注意getBasketData是多么小和干净。功能变成了!

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

<小时/>

这个故事的寓意似乎是:“当困惑时，把事情分解。”