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 :: (a -> b) -> STB bs gs a -> STB bs gs b
fmap = (a -> b) -> STB bs gs a -> STB bs gs b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM
instance Applicative (STB bs gs) where
pure :: a -> STB bs gs a
pure = a -> STB bs gs a
forall (m :: * -> *) a. Monad m => a -> m a
return
<*> :: STB bs gs (a -> b) -> STB bs gs a -> STB bs gs 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 :: a -> STB bs gs a
return = a -> STB bs gs a
forall a bs gs. a -> STB bs gs a
yield
>>= :: STB bs gs a -> (a -> STB bs gs b) -> STB bs gs 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
(+>=)
>> :: STB bs gs a -> STB bs gs b -> STB bs gs 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 :: a -> STB bs gs a
yield a
a = (bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB ((bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a)
-> (bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a
forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> (bs, gs, Either (String, String) a)
-> IO (bs, gs, Either (String, String) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs, a -> Either (String, String) a
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 +>= :: 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
(bs -> gs -> IO (bs, gs, Either (String, String) b)) -> STB bs gs b
forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB ((bs -> gs -> IO (bs, gs, Either (String, String) b))
-> STB bs gs b)
-> (bs -> gs -> IO (bs, gs, Either (String, String) b))
-> STB bs gs b
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 IO (bs, gs, Either (String, String) a)
-> ((bs, gs, Either (String, String) a)
-> IO (bs, gs, Either (String, String) b))
-> IO (bs, gs, Either (String, String) b)
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 -> (bs, gs, Either (String, String) b)
-> IO (bs, gs, Either (String, String) b)
forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs', gs
gs', (String, String) -> Either (String, String) b
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 +> :: STB bs gs a -> STB bs gs b -> STB bs gs b
+> STB bs gs b
m = STB bs gs a
k 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
+>= STB bs gs b -> a -> 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 :: (a -> STB bs gs a) -> STB bs gs a
fixSTB a -> STB bs gs a
m = (bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB ((bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a)
-> (bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a
forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs
-> ((bs, gs, Either (String, String) a)
-> IO (bs, gs, Either (String, String) a))
-> IO (bs, gs, Either (String, String) a)
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 ((bs, gs, Either (String, String) a) -> a
forall a b a p. (a, b, Either a p) -> p
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 p) -> p
extractResult (a
_, b
_, Right p
r) = p
r
extractResult (a
_, b
_, Left a
_ ) = String -> p
forall a. String -> a
interr String
"StateTrans: fixSTB: \
\Tried to access result \
\of unsuccessful \
\recursive computation!"
readBase :: (bs -> a) -> STB bs gs a
readBase :: (bs -> a) -> STB bs gs a
readBase bs -> a
f = (bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB ((bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a)
-> (bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a
forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> (bs, gs, Either (String, String) a)
-> IO (bs, gs, Either (String, String) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs, a -> Either (String, String) a
forall a b. b -> Either a b
Right (bs -> a
f bs
bs))
writeBase :: bs -> STB bs gs ()
writeBase :: bs -> STB bs gs ()
writeBase bs
bs' = (bs -> gs -> IO (bs, gs, Either (String, String) ()))
-> STB bs gs ()
forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB ((bs -> gs -> IO (bs, gs, Either (String, String) ()))
-> STB bs gs ())
-> (bs -> gs -> IO (bs, gs, Either (String, String) ()))
-> STB bs gs ()
forall a b. (a -> b) -> a -> b
$ \bs
_ gs
gs -> (bs, gs, Either (String, String) ())
-> IO (bs, gs, Either (String, String) ())
forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs', gs
gs, () -> Either (String, String) ()
forall a b. b -> Either a b
Right ())
transBase :: (bs -> (bs, a)) -> STB bs gs a
transBase :: (bs -> (bs, a)) -> STB bs gs a
transBase bs -> (bs, a)
f = (bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB ((bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a)
-> (bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a
forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> let
(bs
bs', a
a) = bs -> (bs, a)
f bs
bs
in
(bs, gs, Either (String, String) a)
-> IO (bs, gs, Either (String, String) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs', gs
gs, a -> Either (String, String) a
forall a b. b -> Either a b
Right a
a)
readGeneric :: (gs -> a) -> STB bs gs a
readGeneric :: (gs -> a) -> STB bs gs a
readGeneric gs -> a
f = (bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB ((bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a)
-> (bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a
forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> (bs, gs, Either (String, String) a)
-> IO (bs, gs, Either (String, String) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs, a -> Either (String, String) a
forall a b. b -> Either a b
Right (gs -> a
f gs
gs))
writeGeneric :: gs -> STB bs gs ()
writeGeneric :: gs -> STB bs gs ()
writeGeneric gs
gs' = (bs -> gs -> IO (bs, gs, Either (String, String) ()))
-> STB bs gs ()
forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB ((bs -> gs -> IO (bs, gs, Either (String, String) ()))
-> STB bs gs ())
-> (bs -> gs -> IO (bs, gs, Either (String, String) ()))
-> STB bs gs ()
forall a b. (a -> b) -> a -> b
$ \bs
bs gs
_ -> (bs, gs, Either (String, String) ())
-> IO (bs, gs, Either (String, String) ())
forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs', () -> Either (String, String) ()
forall a b. b -> Either a b
Right ())
transGeneric :: (gs -> (gs, a)) -> STB bs gs a
transGeneric :: (gs -> (gs, a)) -> STB bs gs a
transGeneric gs -> (gs, a)
f = (bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB ((bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a)
-> (bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a
forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> let
(gs
gs', a
a) = gs -> (gs, a)
f gs
gs
in
(bs, gs, Either (String, String) a)
-> IO (bs, gs, Either (String, String) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs', a -> Either (String, String) a
forall a b. b -> Either a b
Right a
a)
liftIO :: IO a -> STB bs gs a
liftIO :: IO a -> STB bs gs a
liftIO IO a
m = (bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB ((bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a)
-> (bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a
forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> IO a
m IO a
-> (a -> IO (bs, gs, Either (String, String) a))
-> IO (bs, gs, Either (String, String) a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
r -> (bs, gs, Either (String, String) a)
-> IO (bs, gs, Either (String, String) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs, a -> Either (String, String) a
forall a b. b -> Either a b
Right a
r)
runSTB :: STB bs gs a -> bs -> gs -> IO a
runSTB :: 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 IO (bs, gs, Either (String, String) a)
-> ((bs, gs, Either (String, String) a) -> IO a) -> IO a
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 `"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tag String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"': "
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg)
in
IOError -> IO a
forall a. IOError -> IO a
ioError IOError
err
Right a
a -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
interleave :: STB bs gs' a -> gs' -> STB bs gs a
interleave :: STB bs gs' a -> gs' -> STB bs gs a
interleave STB bs gs' a
m gs'
gs' = (bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB ((bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a)
-> (bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a
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' IO (bs, gs', Either (String, String) a)
-> ((bs, gs', Either (String, String) a)
-> IO (bs, gs, Either (String, String) a))
-> IO (bs, gs, Either (String, String) a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(bs
bs', gs'
_, Either (String, String) a
a) -> (bs, gs, Either (String, String) a)
-> IO (bs, gs, Either (String, String) 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 :: String -> String -> STB bs gs a
throwExc String
tag String
msg = (bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB ((bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a)
-> (bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a
forall a b. (a -> b) -> a -> b
$ \bs
bs gs
gs -> (bs, gs, Either (String, String) a)
-> IO (bs, gs, Either (String, String) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (bs
bs, gs
gs, (String, String) -> Either (String, String) a
forall a b. a -> Either a b
Left (String
tag, String
msg))
fatal :: String -> STB bs gs a
fatal :: String -> STB bs gs a
fatal String
s = IO a -> STB bs gs a
forall a bs gs. IO a -> STB bs gs a
liftIO (IOError -> IO a
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 :: 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) =
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB ((bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a)
-> (bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a
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 IO (bs, gs, Either (String, String) a)
-> ((bs, gs, Either (String, String) a)
-> IO (bs, gs, Either (String, String) a))
-> IO (bs, gs, Either (String, String) a)
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 String -> String -> Bool
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
(bs, gs, Either (String, String) a)
-> IO (bs, gs, Either (String, String) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (bs, gs, Either (String, String) a)
state
Right a
_ -> (bs, gs, Either (String, String) a)
-> IO (bs, gs, Either (String, String) 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 :: 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 =
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
forall bs gs a.
(bs -> gs -> IO (bs, gs, Either (String, String) a)) -> STB bs gs a
STB ((bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a)
-> (bs -> gs -> IO (bs, gs, Either (String, String) a))
-> STB bs gs a
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 IO (bs, gs, Either (String, String) a)
-> ((bs, gs, Either (String, String) a)
-> IO (bs, gs, Either (String, String) a))
-> IO (bs, gs, Either (String, String) a)
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 `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tag
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"': " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg)
in
IOError -> IO (bs, gs, Either (String, String) a)
forall a. IOError -> IO a
ioError IOError
err
Right a
a -> (bs, gs, Either (String, String) a)
-> IO (bs, gs, Either (String, String) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (bs, gs, Either (String, String) a)
state
)
IO (bs, gs, Either (String, String) a)
-> (IOError -> IO (bs, gs, Either (String, String) a))
-> IO (bs, gs, Either (String, String) a)
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 :: a -> STB bs gs (MVar a)
newMV a
x = IO (MVar a) -> STB bs gs (MVar a)
forall a bs gs. IO a -> STB bs gs a
liftIO (a -> IO (MVar a)
forall a. a -> IO (IORef a)
newIORef a
x)
readMV :: MVar a -> STB bs gs a
readMV :: MVar a -> STB bs gs a
readMV MVar a
mv = IO a -> STB bs gs a
forall a bs gs. IO a -> STB bs gs a
liftIO (MVar a -> IO a
forall a. IORef a -> IO a
readIORef MVar a
mv)
assignMV :: MVar a -> a -> STB bs gs ()
assignMV :: MVar a -> a -> STB bs gs ()
assignMV MVar a
mv a
x = IO () -> STB bs gs ()
forall a bs gs. IO a -> STB bs gs a
liftIO (MVar a -> a -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef MVar a
mv a
x)