Writing an infinitely running( while(true) { } ) user input function in haskell

Question

I'm trying to implement a lexer in Haskell. For easy console input and output, I've used an intermediate data type Transition Table.

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

I want to take input from the user for all the states and transitions. I do not want to take the total number of states before hand. I want it to keep taking input for the transitions of each state until the user types "--" . If the user types "---", the current state is discarded and the input terminates.

After a lot of attempts I came up with this, which I think is horrible code.

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

Basically this is how it runs:

*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

Is there a better way to do this?

Answer 1

There sure is a cleaner way to write it!

import Control.Monad
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Writer
import System.IO

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

inputTransitionTable :: IO TransitionTable
inputTransitionTable = execWriterT $ runMaybeT $ forM_ [0..] $ \i -> do
    -- Monad transformer stack at this point is:
    -- MaybeT                      <= Outer loop
    --    (WriterT TransitionTable <= Outer writer
    --        IO ) r
    let liftIO    = lift . lift
        tellOuter = lift . tell
    liftIO $ putStrLn $ "Adding transitions to state " ++ show i ++ ": "
    t <- execWriterT $ runMaybeT $ forever $ do
        -- Monad transformer stack at this point is:
        -- MaybeT                                <= Inner loop
        --    (WriterT (Transitions String Int)  <= Inner writer
        --        (MaybeT                        <= Outer loop
        --            (WriterT TransitionTable   <= Outer writer
        --                 IO ) ) ) r
        let liftIO     = lift . lift . lift . lift
            breakOuter = lift . lift $ mzero
            tellInner  = lift . tell
            breakInner = mzero
        liftIO $ putStr "\tEnter transitions symbol: "
        symbol <- liftIO getLine
        case symbol of
            "--"  -> breakInner
            "---" -> breakOuter
            _     -> return ()
        liftIO $ putStr "\t\tEnter the transition state number: "
        state' <- liftIO getLine
        tellInner [(symbol, read state')]
    tellOuter [(i, t)]

prettyPrintTransitionTable table
  = forM_ table $ \(n, transitions) -> do
        putStr $ show n ++ " "
        forM_ transitions $ \(symbol, state) -> do
            putStr $ "{" ++ symbol ++ "→" ++ show state ++ "} "
        putStrLn ""

main = do
    hSetBuffering stdout NoBuffering -- <= Auto-flushes all "putStr"s
    t <- inputTransitionTable
    prettyPrintTransitionTable t

The following is how I would actually write it in my own code, so you can compare the size of the code a fluent Haskell programmer writes and compare to your favorite language:

inputTransitionTable = execWriterT $ runMaybeT $ forM_ [0..] $ \i -> do
    let liftIO = lift . lift
    liftIO $ putStrLn $ "Adding transitions to state " ++ show i ++ ": "
    t <- execWriterT $ runMaybeT $ forever $ do
        let liftIO     = lift . lift . lift . lift
        liftIO $ putStr "\tEnter transitions symbol: "
        symbol <- liftIO getLine
        case symbol of
            "--"  -> mzero
            "---" -> lift . lift $ mzero
            _     -> return ()
        liftIO $ putStr "\t\tEnter the transition state number: "
        state' <- liftIO getLine
        lift $ tell [(symbol, read state')]
    lift $ tell [(i, t)]

Test output from the program:

./transitions
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 {a→1} {b→2} 
1 {a→2} {b→3} 
2 {a→3} 
3

If you don't know very much about monad transformers, the best starting point is this paper. Don't be put off by the fact that it's a paper. It's written towards beginners and it's very readable and understandable.

To understand the trick I use for breaking out of loops, I recommend you read this post explaining how you can use MaybeT and EitherT to easily break from loops on the fly the same way you would in an imperative language.

Also, note that I use the WriterT monad transformer to collect results. WriterT commonly arises any time you need to fold or collect data interactively.

I use hSetBuffering to set the output buffering to auto-flush everything. This is an alternative to writing your own putStr function.

I want to also point out the nice forM_ combinator which you can use to mimic foreach in other languages. I show it off in the pretty printer function to write code that is almost indistinguishable from the equivalent imperative code.

Also, if you are new to monad transformers, I recommend you stick to the transformers library whenever possible and try to use the mtl only sparingly. This means using Control.Monad.Trans.Class instead of Control.Monad.Trans and Control.Monad.Trans.XXX for the monad transformers. The need to manually lift things might seem off-putting at first, but you gain the ability to equationally reason about your code. That might not seem like much to you now, but as you become a better Haskell programmer you will value that a lot more, so it's a good habit to build early on.

Answer 2

In order to repeat an action ad nauseum, you can use forever. But you don't really need to use that here, you can just do it the way you've done it so far. Though I'd think that your while function could be written with guards instead.

while :: (Monad m) => (a -> Bool) -> (a -> m a) -> a -> m a
while comparator func start | comparator start = func start >>= while comparator func
                            | otherwise        = return start

You could also look into using Control.Monad.LoopWhile, though I've never used it before.

Note that you don't need >> return (), since hFlush :: Handle -> IO () already returns () in the IO Monad. Actually, you never really need return (). I find it preferable to use void action or _ <- action in order to throw away the result of action.

Your inputTransitionTable function is… not very idiomatic. Threading state yourself is unnecessary, you can use the State monad.

Instead of this interactive process, it might actually be easier for a user to just specify the transition table as a list of ordered pairs, pretty much the way you're printing it after the thing is done. This would probably also require you to parse the user input properly, which is good opportunity to learn the ropes with parsec. If you want to keep the interactive model, then I'd recommend stacking the IO and State Monads together into an action of type State IO TransitionTable.

You can read up on all this stuff in the corresponding chapters of RealWorldHaskell. Chapter 16 on Parsec, and Chapter 18 on Monad Transformers.