I'm having trouble figuring how to wrap a StateT with an ExceptT (I'm pretty new to Haskell). I have this (incomplete, working) code:
-- Initialise the computer and run the program
runProgram pr dv = do
let comp = Computer { program = pr
, dataVals = dv
, acc = 0
, pc = 0
, halted = False
}
evalStateT execute comp
-- Main execution "loop"
execute :: StateT Computer IO ()
execute = do
output <- step
liftIO $ putStr output
comp <- get
if halted comp
then return ()
else execute
-- Execute a single step/cycle
step :: Monad m => StateT Computer m String
step = do
comp <- get
-- TODO handle out of range PC and other errors here?
let Instruction lineNo opCode operand = program comp !! pc comp
-- TODO add rest of instructions
case opCode of
HALT -> do
put $ comp{ halted = True }
return "HALT\n"
LINE -> do
let comp' = comp{ pc = pc comp + 1 }
put comp'
return "\n"
PRINT -> do
let comp' = comp{ pc = pc comp + 1 }
put comp'
let TextOperand s = operand
return s
_ -> do
let comp' = comp{ pc = pc comp + 1 }
put comp'
return $ "step: PC = " ++ (show $ pc comp') ++ "\n"
I'd like to add some error handling to step (see "TODO" comment) so I figured that wrapping the StateT in an ExceptT would allow me to do some checks which return an error status instead of continuing if something's wrong (like PC being out of range). However, I can't figure out how - I've tried lots of combinations but none work.
Related
As an exercise in learning Haskell I've written an interpreter for the CESIL language (an old, very basic, educational low level language). It works, but compared to implementations I've written in other compiled languages it's very slow, even when compiled with -O2, and only a little faster than Python. Timing a large CESIL program with time gives:
Haskell:
real 0m0.346s
user 0m0.199s
sys 0m0.016s
Go:
real 0m0.243s
user 0m0.003s
sys 0m0.007s
Python:
real 0m0.414s
user 0m0.387s
sys 0m0.004s
Here's the main execution part of the code where most of the time is spent, and which I would like to speed up. I'm new to Haskell, and I'm sure there are better, cleaner ways of writing some of this, but my main concern at the moment is the speed. Hopefully I've included enough to make sense:
-- Define the computer state
data Computer =
Computer
{ program :: Array Integer Instruction
, dataVals :: [Integer]
, ram :: Map.Map String Integer
, acc :: Integer
, pc :: Integer
, steps :: Integer
, halted :: Bool
}
-- Initialise the computer and run the program
runProgram ::
Array Integer Instruction -> [Integer] -> Params -> ExceptT String IO ()
runProgram pr dv pars = do
let comp =
Computer
{ program = pr
, dataVals = dv
, ram = Map.empty
, acc = 0
, pc = 0
, steps = 0
, halted = False
}
comp' <- execute comp pars
if countSteps pars
then liftIO . putStrLn $ "Steps executed: " ++ (show $ steps comp')
else return ()
-- Main execution "loop"
execute :: Computer -> Params -> ExceptT String IO Computer
execute comp pars = do
liftEither $ checkPC comp
(comp', output) <- liftEither $ step comp
liftIO $ putStr output
case () of
_
| halted comp' -> return comp'
| Just (steps comp') == maxSteps pars -> do
liftIO $
putStrLn $
"Execution halted after " ++ (show $ steps comp') ++ " steps."
return comp'
| otherwise -> execute comp' pars
-- Check program counter is in range.
checkPC :: Computer -> Either String ()
checkPC comp =
if pc comp >= (toInteger . length . program $ comp) || pc comp < 0
then Left $ "PC OUT OF RANGE: " ++ (show $ pc comp) ++ "\n"
else Right ()
-- Execute a single step/cycle
step :: Computer -> Either String (Computer, String)
step comp = do
let Instruction lineNo label opCode operand =
program comp ! (fromIntegral . pc $ comp)
comp' = comp {pc = pc comp + 1, steps = steps comp + 1}
case opCode of
IN ->
if null $ dataVals comp
then Left $ "Data exhausted at line " ++ show lineNo ++ "\n"
else let a:dv = dataVals comp
in Right (comp {acc = a, dataVals = dv, pc = pc comp + 1}, "")
OUT -> Right (comp', printf "%8d" $ acc comp)
LINE -> Right (comp', "\n")
PRINT ->
let TextOperand s = operand
in Right (comp', s)
HALT -> Right (comp' {halted = True}, "")
LOAD -> do
n <- getVal operand comp' lineNo
Right (comp' {acc = n}, "")
STORE ->
let SymbolOperand s = operand
ram' = Map.insert s (acc comp') (ram comp')
in Right (comp' {ram = ram'}, "")
ADD -> do
n <- getVal operand comp' lineNo
let a = acc comp' + n
Right (comp' {acc = a}, "")
SUBTRACT -> do
n <- getVal operand comp' lineNo
let a = acc comp' - n
Right (comp' {acc = a}, "")
MULTIPLY -> do
n <- getVal operand comp' lineNo
let a = acc comp' * n
Right (comp' {acc = a}, "")
DIVIDE -> do
n <- getVal operand comp' lineNo
if n == 0
then Left $ "Divide by zero error at line " ++ show lineNo ++ "\n"
else let a = acc comp' `div` n
in Right (comp' {acc = a}, "")
JUMP -> do
let AddrOperand a = operand
Right (comp' {pc = a}, "")
JIZERO -> do
let AddrOperand a = operand
comp'' =
if acc comp' == 0
then comp' {pc = a}
else comp'
Right (comp'', "")
JINEG -> do
let AddrOperand a = operand
comp'' =
if acc comp' < 0
then comp' {pc = a}
else comp'
Right (comp'', "")
NoOp -> Right (comp' {steps = steps comp}, "")
-- Get the value of a numeric operand, which may be a literal constant
-- or a reference to a stored variable.
getVal :: Operand -> Computer -> LineNo -> Either String Integer
getVal (ValueOperand (Left n)) _ _ = Right n
getVal (ValueOperand (Right s)) comp lineNo =
case Map.lookup s $ ram comp of
Just n -> Right n
Nothing ->
Left $ "Unknown variable: '" ++ s ++ "' at line " ++ show lineNo ++ "\n"
As others have pointed out, you're not actually comparing apples to apples here - you've chosen types which are well known to be inefficient - String, Integer, []. So, in order of things to try:
Profile your code - we can make guesses about what might be slow but only the program can tell us if that's true. GHC 9.2 has made some nice improvements in profiling optimised code, see https://well-typed.com/blog/2022/05/hasura-supports-haskell-tooling/. Covering how to do profiling is a topic too large to go into here, but there is a lot of documentation available: https://downloads.haskell.org/ghc/latest/docs/html/users_guide/profiling.html
Try basic improvements to the types you use, stop using String and switch to ByteString, use Int instead of Integer (you'll lose the ability to do arbitrary precision calculations but I assume CESIL was never intended to do that). Using a HashMap instead of a Map might see some improvements, but you'll have to benchmark to know.
Be more explicit about strictness - most, if not all, of the fields in the Computer type could be made strict to tell the compiler "Always evaluate this, there's no need for it to be lazy":
data Computer =
Computer
{ program :: Array Int Instruction
, dataVals :: [Int]
, ram :: !HashMap ByteString Int
, acc :: !Int
, pc :: !Int
, steps :: !Int
, halted :: Bool
}
Doing this will also remove many of the conversions you had between Integer and Int which are unnecessary (unless you really want your program to work with programs with more than 9,223,372,036,854,775,807 instructions)
I can't understand this:
Assuming t is hidden inside a Reader Monad.
I can get to it using ask:
do
x <- ask
...
which unpacks the hidden value into x
Now I'm trying to understand what >>= will do but I struggle with it.
Can you explain that to me?
Here, is my attempt:
f = \x -> x
ask >>= (\x -> return x)
= Reader $ \r -> f (ask (r)) r
{ using the fact that ask is identity }
= Reader $ \r -> f(r) r
However, I don't see how this get's to the hidden value
I think the main point is, that there is really nothing hidden inside Reader - instead it's a function - and your hidden value enters the stage when you run the reader (this is when you show your hidden value to the reader and let it evaluate to some output).
revisiting the definition
Well let's simplify things a bit and assume that the structure for our Reader Monad is defined as this:
data Reader h a = Reader { run :: h -> a }
that means you hidden value will have some type h and the Reader is just a function that produces some other value (of type a) from when presented with such a value.
As you can see there is no value hidden at all - you have to provide it yourself when running the Reader with run
Here is an example:
showInt :: Reader Int String
showInt = Reader show
you'll use it like
λ> run showInt 5
"5" -- has type :: String
make it a Monad
the Monad instance is basically this (you'll have to provide instances for Applicative and Functor too, which I'll skip)
instance Monad (Reader h) where
return v =
Reader (const v)
r >>= f = Reader $ \ h ->
let v = run r h
r' = f v
in run r' h
notice how again you wait till someone provides you with a h (by calling run) and then:
first get the value v out of the reader using run r h
use this v to get another reader f'
finally get the value of this reader by running it with the same h: run r' h
what is ask
well as you said: it's just the reader using id - it will reproduce the given value when run:
ask :: Reader h h
ask = Reader id
your question
now we can finally deal with the question:
what happens if we run
let r = ask >>= (\x -> return x)
well let's stick a "Hello" in:
run r "Hello"
{ def r }
= run (ask >>= return) "Hello"
{ def >>= }
= run (\h ->
let v = run ask h
r' = return v
in run r' h) "Hello"
{ def run: plug "Hello" into h }
= let v = run ask "Hello"
r' = return v
in run r' "Hello"
{ ask = Reader id - so run ask "Hello" = "Hello" -> v = "Hello" }
= let r' = return "Hello"
in run r' "Hello"
{ simplify }
= run (return "Hello") "Hello"
{ r' = const "Hello" = \ _ -> "Hello" }
= (\ _ -> "Hello") "Hello"
{ apply }
= "Hello"
laws
By the way: it's a good thing that it worked out that way, because one of the monad-laws (which should hold but are not enforced by Haskell) states:
m >>= return == m
which means here, that your reader ask >>= return == ask
which would have made all this a bit easier ;)
I'm trying to use CPS to simplify control-flow implementation in my Python interpreter. Specifically, when implementing return/break/continue, I have to store state and unwind manually, which is tedious. I've read that it's extraordinarily tricky to implement exception handling in this way. What I want is for each eval function to be able to direct control flow to either the next instruction, or to a different instruction entirely.
Some people with more experience than me suggested looking into CPS as a way to deal with this properly. I really like how it simplifies control flow in the interpreter, but I'm not sure how much I need to actually do in order to accomplish this.
Do I need to run a CPS transform on the AST? Should I lower this AST into a lower-level IR that is smaller and then transform that?
Do I need to update the evaluator to accept the success continuation everywhere? (I'm assuming so).
I think I generally understand the CPS transform: the goal is to thread the continuation through the entire AST, including all expressions.
I'm also a bit confused where the Cont monad fits in here, as the host language is Haskell.
Edit: here's a condensed version of the AST in question. It is a 1-1 mapping of Python statements, expressions, and built-in values.
data Statement
= Assignment Expression Expression
| Expression Expression
| Break
| While Expression [Statement]
data Expression
| Attribute Expression String
| Constant Value
data Value
= String String
| Int Integer
| None
To evaluate statements, I use eval:
eval (Assignment (Variable var) expr) = do
value <- evalExpr expr
updateSymbol var value
eval (Expression e) = do
_ <- evalExpr e
return ()
To evaluate expressions, I use evalExpr:
evalExpr (Attribute target name) = do
receiver <- evalExpr target
attribute <- getAttr name receiver
case attribute of
Just v -> return v
Nothing -> fail $ "No attribute " ++ name
evalExpr (Constant c) = return c
What motivated the whole thing was the shenanigans required for implementing break. The break definition is reasonable, but what it does to the while definition is a bit much:
eval (Break) = do
env <- get
when (loopLevel env <= 0) (fail "Can only break in a loop!")
put env { flow = Breaking }
eval (While condition block) = do
setup
loop
cleanup
where
setup = do
env <- get
let level = loopLevel env
put env { loopLevel = level + 1 }
loop = do
env <- get
result <- evalExpr condition
when (isTruthy result && flow env == Next) $ do
evalBlock block
-- Pretty ugly! Eat continue.
updatedEnv <- get
when (flow updatedEnv == Continuing) $ put updatedEnv { flow = Next }
loop
cleanup = do
env <- get
let level = loopLevel env
put env { loopLevel = level - 1 }
case flow env of
Breaking -> put env { flow = Next }
Continuing -> put env { flow = Next }
_ -> return ()
I am sure there are more simplifications that can be done here, but the core problem is one of stuffing state somewhere and manually winding out. I'm hoping that CPS will let me stuff book-keeping (like loop exit points) into state and just use those when I need them.
I dislike the split between statements and expressions and worry it might make the CPS transform more work.
This finally gave me a good excuse to try using ContT!
Here's one possible way of doing this: store (in a Reader wrapped in ContT) the continuation of exiting the current (innermost) loop:
newtype M r a = M{ unM :: ContT r (ReaderT (M r ()) (StateT (Map Id Value) IO)) a }
deriving ( Functor, Applicative, Monad
, MonadReader (M r ()), MonadCont, MonadState (Map Id Value)
, MonadIO
)
runM :: M a a -> IO a
runM m = evalStateT (runReaderT (runContT (unM m) return) (error "not in a loop")) M.empty
withBreakHere :: M r () -> M r ()
withBreakHere act = callCC $ \break -> local (const $ break ()) act
break :: M r ()
break = join ask
(I've also added IO for easy printing in my toy interpreter, and State (Map Id Value) for variables).
Using this setup, you can write Break and While as:
eval Break = break
eval (While condition block) = withBreakHere $ fix $ \loop -> do
result <- evalExpr condition
unless (isTruthy result)
break
evalBlock block
loop
Here's the full code for reference:
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Interp where
import Prelude hiding (break)
import Control.Applicative
import Control.Monad.Cont
import Control.Monad.State
import Control.Monad.Reader
import Data.Function
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
type Id = String
data Statement
= Print Expression
| Assign Id Expression
| Break
| While Expression [Statement]
| If Expression [Statement]
deriving Show
data Expression
= Var Id
| Constant Value
| Add Expression Expression
| Not Expression
deriving Show
data Value
= String String
| Int Integer
| None
deriving Show
data Env = Env{ loopLevel :: Int
, flow :: Flow
}
data Flow
= Breaking
| Continuing
| Next
deriving Eq
newtype M r a = M{ unM :: ContT r (ReaderT (M r ()) (StateT (Map Id Value) IO)) a }
deriving ( Functor, Applicative, Monad
, MonadReader (M r ()), MonadCont, MonadState (Map Id Value)
, MonadIO
)
runM :: M a a -> IO a
runM m = evalStateT (runReaderT (runContT (unM m) return) (error "not in a loop")) M.empty
withBreakHere :: M r () -> M r ()
withBreakHere act = callCC $ \break -> local (const $ break ()) act
break :: M r ()
break = join ask
evalExpr :: Expression -> M r Value
evalExpr (Constant val) = return val
evalExpr (Var v) = gets $ fromMaybe err . M.lookup v
where
err = error $ unwords ["Variable not in scope:", show v]
evalExpr (Add e1 e2) = do
Int val1 <- evalExpr e1
Int val2 <- evalExpr e2
return $ Int $ val1 + val2
evalExpr (Not e) = do
val <- evalExpr e
return $ if isTruthy val then None else Int 1
isTruthy (String s) = not $ null s
isTruthy (Int n) = n /= 0
isTruthy None = False
evalBlock = mapM_ eval
eval :: Statement -> M r ()
eval (Assign v e) = do
val <- evalExpr e
modify $ M.insert v val
eval (Print e) = do
val <- evalExpr e
liftIO $ print val
eval (If cond block) = do
val <- evalExpr cond
when (isTruthy val) $
evalBlock block
eval Break = break
eval (While condition block) = withBreakHere $ fix $ \loop -> do
result <- evalExpr condition
unless (isTruthy result)
break
evalBlock block
loop
and here's a neat test example:
prog = [ Assign "i" $ Constant $ Int 10
, While (Var "i") [ Print (Var "i")
, Assign "i" (Add (Var "i") (Constant $ Int (-1)))
, Assign "j" $ Constant $ Int 10
, While (Var "j") [ Print (Var "j")
, Assign "j" (Add (Var "j") (Constant $ Int (-1)))
, If (Not (Add (Var "j") (Constant $ Int (-4)))) [ Break ]
]
]
, Print $ Constant $ String "Done"
]
which is
i = 10
while i:
print i
i = i - 1
j = 10
while j:
print j
j = j - 1
if j == 4:
break
so it will print
10 10 9 8 7 6 5
9 10 9 8 7 6 5
8 10 9 8 7 6 5
...
1 10 9 8 7 6 5
First, because this is about a specific case, I haven't reduced the code at all, so it will be quite long, and in 2 parts (Helper module, and the main).
SpawnThreads in ConcurHelper takes a list of actions, forks them, and gets an MVar containing the result of the action. It them combines the results, and returns the resulting list. It works fine in certain cases, but blocks indefinitely on others.
If I give it a list of putStrLn actions, it executes them fine, then returns the resulting ()s (yes, I know running print commands on different threads at the same time is bad in most cases).
If I try running multiTest in Scanner though (which takes either scanPorts or scanAddresses, the scan range, and the number of threads to use; then splits the scan range over the threads, and passes the list of actions to SpawnThreads), it will block indefinitely. The odd thing is, according to the debug prompts scattered around ConcurHelper, on each thread, ForkIO is returning before the MVar is filled. This would make sense if it wasn't in a do block, but shouldn't the actions be performed sequentially? (I don't know if this is related to the problem or not; it's just something I noticed while attempting to debug it).
I've thought it out step by step, and if it's executing in the order laid out in spawnThreads, the following should happen:
An empty MVar should be created inside forkIOReturnMVar, and passed to mVarWrapAct.
mVarWrapAct should execute the action, and put the result in the MVar (this is where the problem seems to lie. "MVar filled" is never shown, suggesting the MVar is never put into)
getResults should then take from the resulting list of MVars, and return the results
If point #2 isn't the issue, I can see where the problem would be (and if it is the issue, I can't see why putMVar never executes. Inside the scanner module, the only real function of interest for this question is multiTest. I only included the rest so it could be run).
To do a simple test, you can run the following:
spawnThreads [putStrLn "Hello", putStrLn "World"] (should return [(),()])
multiTest (scanPorts "127.0.0.1") 1 (0,5) (Creates the MVar, hangs for a sec, then crashes with the aforementioned error)
Any help in understanding whats going on here would be appreciated. I can't see what the difference between the 2 use cases are.
Thank you
(And I'm using this atrocious exception handling system because IO errors don't give codes for specific network exceptions, so I've been left with parsing messages to find out what happened)
Main:
module Scanner where
import Network
import Network.Socket
import System.IO
import Control.Exception
import Control.Concurrent
import ConcurHelper
import Data.Maybe
import Data.Char
import NetHelp
data NetException = NetNoException | NetTimeOut | NetRefused | NetHostUnreach
| NetANotAvail | NetAccessDenied | NetAddrInUse
deriving (Show, Eq)
diffExcept :: Either SomeException Handle -> Either NetException Handle
diffExcept (Right h) = Right h
diffExcept (Left (SomeException m))
| err == "WSAETIMEDOUT" = Left NetTimeOut
| err == "WSAECONNREFUSED" = Left NetRefused
| err == "WSAEHOSTUNREACH" = Left NetHostUnreach
| err == "WSAEADDRNOTAVAIL" = Left NetANotAvail
| err == "WSAEACCESS" = Left NetAccessDenied
| err == "WSAEADDRINUSE" = Left NetAddrInUse
| otherwise = error $ show m
where
err = reverse . dropWhile (== ')') . reverse . dropWhile (/='W') $ show m
extJust :: Maybe a -> a
extJust (Just a) = a
selectJusts :: IO [Maybe a] -> IO [a]
selectJusts mayActs = do
mays <- mayActs; return . map extJust $ filter isJust mays
scanAddresses :: Int -> Int -> Int -> IO [String]
scanAddresses port minAddr maxAddr =
selectJusts $ mapM (\addr -> do
let sAddr = "192.168.1." ++ show addr
print $ "Trying " ++ sAddr ++ " " ++ show port
connection <- testConn sAddr port
if isJust connection
then do hClose $ extJust connection; return $ Just sAddr
else return Nothing) [minAddr..maxAddr]
scanPorts :: String -> Int -> Int -> IO [Int]
scanPorts addr minPort maxPort =
selectJusts $ mapM (\port -> do
--print $ "Trying " ++ addr ++ " " ++ show port
connection <- testConn addr port
if isJust connection
then do hClose $ extJust connection; return $ Just port
else return Nothing) [minPort..maxPort]
main :: IO ()
main = do
withSocketsDo $ do
putStrLn "Scan Addresses or Ports? (a/p)"
choice <- getLine
if (toLower $ head choice) == 'a'
then do
putStrLn "On what port?"
sPort <- getLine
addrs <- scanAddresses (read sPort :: Int) 0 255
print addrs
else do
putStrLn "At what address?"
address <- getLine
ports <- scanPorts address 0 9999
print ports
main
testConn :: HostName -> Int -> IO (Maybe Handle)
testConn host port = do
result <- try $ timedConnect 1 host port
let result' = diffExcept result
case result' of
Left e -> do putStrLn $ "\t" ++ show e; return Nothing
Right h -> return $ Just h
setPort :: AddrInfo -> Int -> AddrInfo
setPort addInf nPort = case addrAddress addInf of
(SockAddrInet _ host) -> addInf { addrAddress = (SockAddrInet (fromIntegral nPort) host)}
getHostAddress :: HostName -> Int -> IO SockAddr
getHostAddress host port = do
addrs <- getAddrInfo Nothing (Just host) Nothing
let adInfo = head addrs
newAdInfo = setPort adInfo port
return $ addrAddress newAdInfo
timedConnect :: Int -> HostName -> Int -> IO Handle
timedConnect time host port = do
s <- socket AF_INET Stream defaultProtocol
setSocketOption s RecvTimeOut time; setSocketOption s SendTimeOut time
addr <- getHostAddress host port
connect s addr
socketToHandle s ReadWriteMode
multiTest :: (Int -> Int -> IO a) -> Int -> (Int, Int) -> IO [a]
multiTest partAction threads (mi,ma) =
spawnThreads $ recDiv [mi,perThread..ma]
where
perThread = ((ma - mi) `div` threads) + 1
recDiv [] = []
recDiv (curN:restN) =
partAction (curN + 1) (head restN) : recDiv restN
Helper:
module ConcurHelper where
import Control.Concurrent
import System.IO
spawnThreads :: [IO a] -> IO [a]
spawnThreads actions = do
ms <- mapM (\act -> do m <- forkIOReturnMVar act; return m) actions
results <- getResults ms
return results
forkIOReturnMVar :: IO a -> IO (MVar a)
forkIOReturnMVar act = do
m <- newEmptyMVar
putStrLn "Created MVar"
forkIO $ mVarWrapAct act m
putStrLn "Fork returned"
return m
mVarWrapAct :: IO a -> MVar a -> IO ()
mVarWrapAct act m = do a <- act; putMVar m a; putStrLn "MVar filled"
getResults :: [MVar a] -> IO [a]
getResults mvars = do
unpacked <- mapM (\m -> do r <- takeMVar m; return r) mvars
putStrLn "MVar taken from"
return unpacked
Your forkIOReturnMVar isn't exception safe: whenever act throws, the MVar isn't going to be filled.
Minimal example
import ConcurHelper
main = spawnThreads [badOperation]
where badOperation = do
error "You're never going to put something in the MVar"
return True
As you can see, badOperation throws, and therefore the MVar won't get filled in mVarWrapAct.
Fix
Fill the MVar with an appropriate value if you encounter an exception. Since you cannot provide a default value for all possible types a, it's better to use MVar (Maybe a) or MVar (Either b a) as you already do in your network code.
In order to catch the exceptions, use one of the operations provided in Control.Exception. For example, you could use onException:
mVarWrapAct :: IO a -> MVar (Maybe a) -> IO ()
mVarWrapAct act m = do
onException (act >>= putMVar m . Just) (putMVar m Nothing)
putStrLn "MVar filled"
However, you might want to preserve the actual exception for more information. In this case you could simply use catch together with Either SomeException a :
mVarWrapAct :: IO a -> MVar (Either SomeException a) -> IO ()
mVarWrapAct act m = do
catch (act >>= putMVar m . Right) (putMVar m . Left)
putStrLn "MVar filled"
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?
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
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)