module StateTrans (
STB, fixSTB,
readBase, writeBase, transBase, readGeneric, writeGeneric,
transGeneric, liftIO, runSTB, interleave,
throwExc, fatal, catchExc, fatalsHandledBy,
MVar, newMV, readMV, assignMV)
where
import Prelude hiding (catch)
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
import Control.Exception (catch)
import System.IO (fixIO)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Errors (interr)
infixr 1 +>=, +>
newtype STB bs gs a = STB (bs -> gs -> IO (bs, gs, Either (String, String) a))
instance Functor (STB bs gs) where
fmap :: forall a b. (a -> b) -> STB bs gs a -> STB bs gs b
fmap = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative (STB bs gs) where
pure :: forall a. a -> STB bs gs a
pure = forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: forall a b. STB bs gs (a -> b) -> STB bs gs a -> STB bs gs b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap
instance Monad (STB bs gs) where
return :: forall a. a -> STB bs gs a
return = forall a bs gs. a -> STB bs gs a
yield
>>= :: forall a b. STB bs gs a -> (a -> STB bs gs b) -> STB bs gs b
(>>=) = forall bs gs a b. STB bs gs a -> (a -> STB bs gs b) -> STB bs gs b
(+>=)
>> :: forall a b. STB bs gs a -> STB bs gs b -> STB bs gs b
(>>) = forall bs gs a b. STB bs gs a -> STB bs gs b -> STB bs gs b
(+>)
yield :: a -> STB bs gs a
yield :: forall a bs gs. a -> STB bs gs a
yield a
a = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs, forall a b. b -> Either a b
Right a
a)
(+>=) :: STB bs gs a -> (a -> STB bs gs b) -> STB bs gs b
STB bs gs a
m +>= :: forall bs gs a b. STB bs gs a -> (a -> STB bs gs b) -> STB bs gs b
+>= a -> STB bs gs b
k = let
STB bs -> gs -> IO (bs, gs, Either (String, String) a)
m' = STB bs gs a
m
in
forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> bs -> gs -> IO (bs, gs, Either (String, String) a)
m' bs
bs gs
gs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(bs
bs', gs
gs', Either (String, String) a
res) ->
case Either (String, String) a
res of
Left (String, String)
exc -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs', gs
gs', forall a b. a -> Either a b
Left (String, String)
exc)
Right a
a -> let
STB bs -> gs -> IO (bs, gs, Either (String, String) b)
k' = a -> STB bs gs b
k a
a
in
bs -> gs -> IO (bs, gs, Either (String, String) b)
k' bs
bs' gs
gs'
(+>) :: STB bs gs a -> STB bs gs b -> STB bs gs b
STB bs gs a
k +> :: forall bs gs a b. STB bs gs a -> STB bs gs b -> STB bs gs b
+> STB bs gs b
m = STB bs gs a
k forall bs gs a b. STB bs gs a -> (a -> STB bs gs b) -> STB bs gs b
+>= forall a b. a -> b -> a
const STB bs gs b
m
fixSTB :: (a -> STB bs gs a) -> STB bs gs a
fixSTB :: forall a bs gs. (a -> STB bs gs a) -> STB bs gs a
fixSTB a -> STB bs gs a
m = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs
-> forall a. (a -> IO a) -> IO a
fixIO (\(bs, gs, Either (String, String) a)
future -> let
STB bs -> gs -> IO (bs, gs, Either (String, String) a)
m' = a -> STB bs gs a
m (forall {a} {b} {a} {b}. (a, b, Either a b) -> b
extractResult (bs, gs, Either (String, String) a)
future)
in
bs -> gs -> IO (bs, gs, Either (String, String) a)
m' bs
bs gs
gs)
where
extractResult :: (a, b, Either a b) -> b
extractResult (a
_, b
_, Right b
r) = b
r
extractResult (a
_, b
_, Left a
_ ) = forall a. String -> a
interr String
"StateTrans: fixSTB: \
\Tried to access result \
\of unsuccessful \
\recursive computation!"
readBase :: (bs -> a) -> STB bs gs a
readBase :: forall bs a gs. (bs -> a) -> STB bs gs a
readBase bs -> a
f = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs, forall a b. b -> Either a b
Right (bs -> a
f bs
bs))
writeBase :: bs -> STB bs gs ()
writeBase :: forall bs gs. bs -> STB bs gs ()
writeBase bs
bs' = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
_ gs
gs -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs', gs
gs, forall a b. b -> Either a b
Right ())
transBase :: (bs -> (bs, a)) -> STB bs gs a
transBase :: forall bs a gs. (bs -> (bs, a)) -> STB bs gs a
transBase bs -> (bs, a)
f = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> let
(bs
bs', a
a) = bs -> (bs, a)
f bs
bs
in
forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs', gs
gs, forall a b. b -> Either a b
Right a
a)
readGeneric :: (gs -> a) -> STB bs gs a
readGeneric :: forall gs a bs. (gs -> a) -> STB bs gs a
readGeneric gs -> a
f = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs, forall a b. b -> Either a b
Right (gs -> a
f gs
gs))
writeGeneric :: gs -> STB bs gs ()
writeGeneric :: forall gs bs. gs -> STB bs gs ()
writeGeneric gs
gs' = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs', forall a b. b -> Either a b
Right ())
transGeneric :: (gs -> (gs, a)) -> STB bs gs a
transGeneric :: forall gs a bs. (gs -> (gs, a)) -> STB bs gs a
transGeneric gs -> (gs, a)
f = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> let
(gs
gs', a
a) = gs -> (gs, a)
f gs
gs
in
forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs', forall a b. b -> Either a b
Right a
a)
liftIO :: IO a -> STB bs gs a
liftIO :: forall a bs gs. IO a -> STB bs gs a
liftIO IO a
m = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> IO a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
r -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs, forall a b. b -> Either a b
Right a
r)
runSTB :: STB bs gs a -> bs -> gs -> IO a
runSTB :: forall bs gs a. STB bs gs a -> bs -> gs -> IO a
runSTB STB bs gs a
m bs
bs gs
gs = let
STB bs -> gs -> IO (bs, gs, Either (String, String) a)
m' = STB bs gs a
m
in
bs -> gs -> IO (bs, gs, Either (String, String) a)
m' bs
bs gs
gs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(bs
_, gs
_, Either (String, String) a
res) ->
case Either (String, String) a
res of
Left (String
tag, String
msg) -> let
err :: IOError
err = String -> IOError
userError (String
"Exception `"
forall a. [a] -> [a] -> [a]
++ String
tag forall a. [a] -> [a] -> [a]
++ String
"': "
forall a. [a] -> [a] -> [a]
++ String
msg)
in
forall a. IOError -> IO a
ioError IOError
err
Right a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
interleave :: STB bs gs' a -> gs' -> STB bs gs a
interleave :: forall bs gs' a gs. STB bs gs' a -> gs' -> STB bs gs a
interleave STB bs gs' a
m gs'
gs' = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ let
STB bs -> gs' -> IO (bs, gs', Either (String, String) a)
m' = STB bs gs' a
m
in
\bs
bs gs
gs
-> (bs -> gs' -> IO (bs, gs', Either (String, String) a)
m' bs
bs gs'
gs' forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(bs
bs', gs'
_, Either (String, String) a
a) -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs', gs
gs, Either (String, String) a
a))
throwExc :: String -> String -> STB bs gs a
throwExc :: forall bs gs a. String -> String -> STB bs gs a
throwExc String
tag String
msg = forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs, forall a b. a -> Either a b
Left (String
tag, String
msg))
fatal :: String -> STB bs gs a
fatal :: forall bs gs a. String -> STB bs gs a
fatal String
s = forall a bs gs. IO a -> STB bs gs a
liftIO (forall a. IOError -> IO a
ioError (String -> IOError
userError String
s))
catchExc :: STB bs gs a
-> (String, String -> STB bs gs a)
-> STB bs gs a
catchExc :: forall bs gs a.
STB bs gs a -> (String, String -> STB bs gs a) -> STB bs gs a
catchExc STB bs gs a
m (String
tag, String -> STB bs gs a
handler) =
forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs
-> let
STB bs -> gs -> IO (bs, gs, Either (String, String) a)
m' = STB bs gs a
m
in
bs -> gs -> IO (bs, gs, Either (String, String) a)
m' bs
bs gs
gs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \state :: (bs, gs, Either (String, String) a)
state@(bs
bs', gs
gs', Either (String, String) a
res) ->
case Either (String, String) a
res of
Left (String
tag', String
msg) -> if (String
tag forall a. Eq a => a -> a -> Bool
== String
tag')
then
let
STB bs -> gs -> IO (bs, gs, Either (String, String) a)
handler' = String -> STB bs gs a
handler String
msg
in
bs -> gs -> IO (bs, gs, Either (String, String) a)
handler' bs
bs' gs
gs'
else
forall (m :: * -> *) a. Monad m => a -> m a
return (bs, gs, Either (String, String) a)
state
Right a
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs, gs, Either (String, String) a)
state
fatalsHandledBy :: STB bs gs a -> (IOError -> STB bs gs a) -> STB bs gs a
fatalsHandledBy :: forall bs gs a.
STB bs gs a -> (IOError -> STB bs gs a) -> STB bs gs a
fatalsHandledBy STB bs gs a
m IOError -> STB bs gs a
handler =
forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs
-> (let
STB bs -> gs -> IO (bs, gs, Either (String, String) a)
m' = STB bs gs a
m
in
bs -> gs -> IO (bs, gs, Either (String, String) a)
m' bs
bs gs
gs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \state :: (bs, gs, Either (String, String) a)
state@(bs
gs', gs
bs', Either (String, String) a
res) ->
case Either (String, String) a
res of
Left (String
tag, String
msg) -> let
err :: IOError
err = String -> IOError
userError (String
"Exception `" forall a. [a] -> [a] -> [a]
++ String
tag
forall a. [a] -> [a] -> [a]
++ String
"': " forall a. [a] -> [a] -> [a]
++ String
msg)
in
forall a. IOError -> IO a
ioError IOError
err
Right a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return (bs, gs, Either (String, String) a)
state
)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\IOError
err -> let
STB bs -> gs -> IO (bs, gs, Either (String, String) a)
handler' = IOError -> STB bs gs a
handler IOError
err
in
bs -> gs -> IO (bs, gs, Either (String, String) a)
handler' bs
bs gs
gs)
type MVar a = IORef a
newMV :: a -> STB bs gs (MVar a)
newMV :: forall a bs gs. a -> STB bs gs (MVar a)
newMV a
x = forall a bs gs. IO a -> STB bs gs a
liftIO (forall a. a -> IO (IORef a)
newIORef a
x)
readMV :: MVar a -> STB bs gs a
readMV :: forall a bs gs. MVar a -> STB bs gs a
readMV MVar a
mv = forall a bs gs. IO a -> STB bs gs a
liftIO (forall a. IORef a -> IO a
readIORef MVar a
mv)
assignMV :: MVar a -> a -> STB bs gs ()
assignMV :: forall a bs gs. MVar a -> a -> STB bs gs ()
assignMV MVar a
mv a
x = forall a bs gs. IO a -> STB bs gs a
liftIO (forall a. IORef a -> a -> IO ()
writeIORef MVar a
mv a
x)