Writing an infinitely running( while(true) { } ) user input function in haskell - 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

It could be as simple as this, if you add the "deriving Read" declarations and don't care about interaction.
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

As others have suggested, for a tasks related to parsing you should look at Parsec. While I have no experience with it, I can still suggest an alternative way of writing your parsing application.
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
I don't know if in your requirements was to print out the intermediary messages, but the computation of the transitions can be transformed to a fold operation (or foldM if you want to print intermediary messages); and instead of the "while" loop I've used the takeWhile function lifted to the Monadic space (so I can apply it on the type IO [String]).
Also note that getContents is lazy in evaluation, and in combination with lines will perform as a "while read line".
Edit:
With #pat's suggestion (and what hlint came up with), here is the refactored version:
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)