module Language.Piet.PietMonad
(
PietMonad
, InterpreterStatus
, LogLevel(..)
, getDP, setDP
, getCC, setCC
, getPosition, setPosition
, stackPush, stackPop, stackRoll
, printNumber, printChar
, readNumber, readChar
, logMessage
, terminate
, runPietMonad
) where
import Control.Concurrent
import Control.Monad.Error ()
import Control.Monad.State
import Data.RollStack
import Language.Piet.Types
data InterpreterStatus = InterpreterStatus
{ dp :: DirectionPointer
, cc :: CodelChooser
, position :: (Int, Int)
, stack :: RollStack Int
}
data PietRequest
= Read PietType
| Print PietType Int
| Log LogLevel String
| Terminate
deriving (Show, Eq, Ord)
data LogLevel
= Verbosed
| Info
| Error
| Fatal
deriving (Eq, Ord)
instance Show LogLevel where
show Verbosed = "VERBOSED"
show Info = "INFO "
show Error = "ERROR "
show Fatal = "FATAL "
newtype PietMonad a = PietMonad (InterpreterStatus
-> Chan PietRequest
-> Chan Int
-> IO (Either String (a, InterpreterStatus)))
instance Monad PietMonad where
return x = PietMonad (\status _ _ -> return (return (x, status)))
(PietMonad m01) >>= f = PietMonad (\status0 requestChan inputChan -> do
either1 <- m01 status0 requestChan inputChan
case either1 of
Left msg -> return (fail msg)
Right (x1, status1) -> do
let (PietMonad m12) = f x1
m12 status1 requestChan inputChan
)
fail msg = do
logMessage Fatal msg
PietMonad (\_ _ _ -> return (fail msg))
instance MonadState InterpreterStatus PietMonad where
get = PietMonad $ \status _ _ -> return (return (status, status))
put status = PietMonad $ \_ _ _ -> return (return ((), status))
getDP :: PietMonad DirectionPointer
getDP = gets dp
setDP :: DirectionPointer -> PietMonad ()
setDP newDP = modify (\status -> status { dp = newDP })
getCC :: PietMonad CodelChooser
getCC = gets cc
setCC :: CodelChooser -> PietMonad ()
setCC newCC = modify (\status -> status { cc = newCC })
getPosition :: PietMonad (Int, Int)
getPosition = gets position
setPosition :: Int -> Int -> PietMonad ()
setPosition x y = modify (\status -> status { position = (x, y) })
stackPush :: Int -> PietMonad ()
stackPush n = modify (\status -> status { stack = push n (stack status) })
stackPop :: PietMonad (Maybe Int)
stackPop = do
response <- gets (pop . stack)
case response of
Nothing -> return Nothing
Just (x, xs) -> do
modify (\status -> status { stack = xs })
return (Just x)
stackRoll :: Int
-> Int
-> PietMonad ()
stackRoll rolls depth = modify (\status -> status { stack = roll rolls depth (stack status) })
readType :: PietType -> PietMonad Int
readType pType = PietMonad $ \status requestChan inputChan -> do
writeChan requestChan (Read pType)
response <- readChan inputChan
return $ return (response, status)
readNumber :: PietMonad Int
readNumber = readType PietNumber
readChar :: PietMonad Int
readChar = readType PietChar
logMessage :: LogLevel -> String -> PietMonad ()
logMessage level msg = PietMonad $ \status requestChan _ -> do
writeChan requestChan (Log level msg)
return $ return ((), status)
printType :: PietType -> Int -> PietMonad ()
printType pType n = PietMonad $ \status requestChan _ -> do
writeChan requestChan (Print pType n)
return $ return ((), status)
printNumber :: Int -> PietMonad ()
printNumber = printType PietNumber
printChar :: Int -> PietMonad ()
printChar = printType PietChar
terminate :: PietMonad ()
terminate = PietMonad $ \status requestChan _ -> do
writeChan requestChan Terminate
return $ return ((), status)
runPietMonad :: (PietType -> IO Int)
-> (PietType -> Int -> IO ())
-> (LogLevel -> String -> IO ())
-> PietMonad a
-> IO (Either String a)
runPietMonad readCallback printCallback logCallback program = do
requestChannel <- newChan
responseChannel <- newChan
lock <- newEmptyMVar
forkIO $ do
let PietMonad piet = do
x <- program
terminate
return x
x <- piet InterpreterStatus
{ dp = DPRight
, cc = CCLeft
, position = (0, 0)
, stack = empty
}
requestChannel
responseChannel
putMVar lock x
let serviceRoutine = do
request <- readChan requestChannel
case request of
Read pType -> do
n <- readCallback pType
writeChan responseChannel n
serviceRoutine
Print pType n -> do
printCallback pType n
serviceRoutine
Log level msg -> do
logCallback level msg
serviceRoutine
Terminate -> return ()
serviceRoutine
(liftM fst) `liftM` takeMVar lock