让Haskeline早点辞职

Question

我试图使用哈斯林编写一个程序，它向用户询问一系列问题，每个问题的括号中都有一个默认值，并读取他们的回答。我希望用户能够

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

我已经能够得到点1-3的工作，但我不能让第4点工作:按下Ctrl(或输入“退出”)只是打开下一个提示，而不是让程序退出提问。看看我的程序(请看下面)，我理解为什么会发生这种情况，但我无法弄清楚如何解决这个问题，所以Ctrl(或“退出”)实际上停止了询问。我如何修改程序以实现这一目标？

我确实看到了这个问题，它似乎问了一些类似的问题，但我从那里得到的东西不多，我甚至不确定他们是否问的问题和我一样。

第二个问题是:我当前的程序中有相当多的case语句可以打开Maybe值。特别是，我目前检查了Nothing的两到三个深度级别，以便在用户按下Ctrl键时能够正确地返回Nothing。我有一种感觉，这可以使用(类似于)一元>>=运算符来简化，但在这种情况下，我想不出如何做到这一点。我的预感对吗？有没有办法消除所有寻找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

在一些建议( 这里是haskell-初学者邮件列表 )的帮助下，我成功地解决了我的问题，完全解决了Ctrl问题，以及我自己满意的保理问题(到现在为止！)我在这里发布答案，希望它能帮助处于困境中的其他人。

首先，Ctrl的问题是，我抛弃了可能的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号丢失的地方。与此形成对比的是getBasketData的代码，它不让Nothing通过空白(我将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问题:如果用户在回答任何问题时按下Ctrl，则程序将停止提问并返回Nothing。

现在进入保理业务。这正是来自邮件列表答案的建议的帮助所在:我首先将大型getData函数分成三个部分，每个“大”使用<-操作符一个，然后将这些部分放入单独的函数中。这为我清理了很多逻辑(实际上，这也是我找到Ctrl问题的修复方法)。从这个开始，我不断地修改不同的部分，直到我得到下面的版本，它看起来对我来说足够好。注意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

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

Answer 2

我想你的预感就在这里。通过case完成的许多模式匹配可以更多地使用可能的Monad。而不是

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})

你可以写点什么

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

你甚至可以介绍一些帮手

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

去写

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

对不起-我知道这并不能解决你对Ctrl+D的问题，但我还没有想到(目前为止)这个问题。