在haskell中编写一个无限运行的（while（true）{}）用户输入函数

Question

我正在尝试在 Haskell 中实现词法分析器。为了方便控制​​台输入和输出，我使用了中间数据类型 Transition Table。

type TransitionTable = [(Int, Transitions String Int)]
type Transitions a b = [(a, b)]

我想从用户那里获取所有状态和转换的输入。我不想事先了解州的总数。我希望它继续输入每个状态的转换，直到用户输入 "--" 。如果用户键入 "---"，则丢弃当前状态并终止输入。

经过多次尝试，我想出了这个，我认为这是可怕的代码。

-- |A function to emulate the while loop for easy IO functionality.
--  Defination:- while @comparator @func @start:
--      *comparator @arg: A function which returns True or False on the basis of @arg.
--          The loop stops when False is returned.
--      *func: The function which is executed repeadly.
--          It is responsible for returning the next @arg for the comparator on the basis of the current @arg.
--      *start: The starting value of @arg to pass to the comparator.
while :: (Monad m) => (a -> Bool) -> (a -> m a) -> a -> m a
while comparator func start =
    if comparator start then do
        nxt <- func start
        while comparator func nxt
    else
        return start

-- |A modification of putStr which flushes out stdout. Corrents buffer problems.
myPutStr :: String -> IO ()
myPutStr str = putStr str >> hFlush stdout >> return ()

---

-- Takes input from the console to generate a TransitionTable.
inputTransitionTable :: IO TransitionTable
inputTransitionTable = do
    putStrLn "Type -- for next state and --- for completing input entering."
    retVal <- while notFinished takeInfo (0, [])
    return (snd retVal)
        where
            -- Returns True when input entry is over.
            notFinished (i, _) = i > -1

            -- Takes the current state number and the incomplete corrosponding transition table which is populated 
            -- with user input. Input ends when user enters "---". State number is set to -1 when input is over.
            takeInfo (i, states) = do
                putStrLn ("Adding transitions to state " ++ show i ++ ": ")
                retVal <- while entryNotFinished takeStateInfo ("", [])
                let (inpStr, stateInfo) = retVal
                case inpStr == "---" of
                    True -> return (-1, states)
                    False -> return (i+1, states ++ [(i, stateInfo)])

            -- Checks if input entry is over. Returns False if finished.
            entryNotFinished (s, _)
                | s == "--" || s == "---"  =  False
                | otherwise  =  True

            -- Takes the input state number along with the corresponding transitions.
            -- Input ends when the user enters "--".
            takeStateInfo (str, state_info) = do
                myPutStr "\tEnter transitions symbol: "
                symbol <- getLine
                if symbol == "--" || symbol == "---" then
                    return (symbol, state_info)
                else do
                    myPutStr "\t\tEnter the transition state number: "
                    state' <- getLine
                    let state = read state' :: Int
                    return (str, (symbol, state):state_info)

基本上是这样运行的：

*Main> x <- inputTransitionTable
Type -- for next state and --- for completing input entering.
Adding transitions to state 0: 
    Enter transitions symbol: a
        Enter the transition state number: 1
    Enter transitions symbol: b
        Enter the transition state number: 2
    Enter transitions symbol: --
Adding transitions to state 1: 
    Enter transitions symbol: a
        Enter the transition state number: 2
    Enter transitions symbol: b
        Enter the transition state number: 3
    Enter transitions symbol: --
Adding transitions to state 2: 
    Enter transitions symbol: a
        Enter the transition state number: 3
    Enter transitions symbol: --
Adding transitions to state 3: 
    Enter transitions symbol: --
Adding transitions to state 4:
    Enter transitions symbol: ---
(0.03 secs, 344420 bytes)

-- Output
*Main> prettyPrintTransitionTable x
State   Transitions
0  ("b",2)  ("a",1)
1  ("b",3)  ("a",2)
2  ("a",3)
3

有没有更好的方法来做到这一点？

Answer 1

如果您添加“派生读取”声明并且不关心交互，它可能就这么简单。

main = do
    allInput <- getContents -- scarfs all stdin up to eof
    let inLines = lines allInput
    let (tableLines, _:otherlines) = break (== "endtable") inLines
    let table = ((read $ unlines tableLines) :: TransitionTable)
    -- process otherlines here

Answer 2

正如其他人所建议的，对于与解析相关的任务，您应该查看Parsec。虽然我没有这方面的经验，但我仍然可以建议另一种编写解析应用程序的方法。

module Main where

  import Control.Monad (liftM)

  computeTransitions :: [String] -> [(Int, [(String, Int)])]
  computeTransitions is = foldl folder [] is
    where
      getState states            = if null states then (0, []) else last states
      getTransition transitions  = if null transitions  then 0 else (snd $ head transitions)
      prepend state transition   = let (c, ts) = state in (c, transition:ts)
      swapLastState states state = if null states then [state] else init states ++ [state]
      folder states i =
        let currentState = getState states
            currentTransition = getTransition (snd currentState)
        in case i == "--" of False -> swapLastState states (prepend currentState (i, currentTransition + 1))
                             True  -> states ++ [((fst currentState) + 1, [])]

  main = do
    inputLines <- liftM (takeWhile (/="---")) (liftM lines getContents)
    let result = computeTransitions inputLines
    mapM_ (\(s, t) -> putStrLn $ show s ++ "\t" ++ show t) result

我不知道您的要求是否打印出中间消息，但转换的计算可以转换为折叠操作（如果您想打印中间消息，则可以转换为 foldM）；而不是“while”循环，我使用了提升到 Monadic 空间的 takeWhile 函数（所以我可以将它应用于类型 IO [String]）。

另请注意，getContents 在评估中是惰性的，并且与lines 结合将作为“读取时行”。

编辑：

根据@pat 的建议（以及hlint 的想法），这是重构后的版本：

module Main where

  import Control.Monad (liftM)

  computeTransitions :: [String] -> [(Int, [(String, Int)])]
  computeTransitions = foldl folder []
    where
      getState []                = (0, [])
      getState states            = last states

      getTransition []           = 0
      getTransition ((_, t):_)  = t

      prepend (c,ts) transition  = (c, transition:ts)

      swapLastState [] state     = [state]
      swapLastState states state = init states ++ [state]

      folder states i =
        let currentState = getState states
            currentTransition = getTransition (snd currentState)
        in if i == "--"
          then states ++ [(fst currentState + 1, [])]
          else swapLastState states (prepend currentState (i, currentTransition + 1))

  main = do
    inputLines <- liftM (takeWhile (/="---") . lines) getContents
    mapM_ (\(s, t) -> putStrLn $ show s ++ "\t" ++ show t) (computeTransitions inputLines)