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
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
bs gs :: 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
m :: STB bs gs a
m +>= :: STB bs gs a -> (a -> STB bs gs b) -> STB bs gs b
+>= k :: a -> STB bs gs b
k = let
STB m' :: 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
bs gs :: 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
bs', gs' :: gs
gs', res :: Either (String, String) a
res) ->
case Either (String, String) a
res of
Left exc :: (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
a -> let
STB k' :: 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
k :: STB bs gs a
k +> :: STB bs gs a -> STB bs gs b -> STB bs gs b
+> m :: 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 m :: 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
bs gs :: 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 (\future :: (bs, gs, Either (String, String) a)
future -> let
STB m' :: 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 (_, _, Right r :: p
r) = p
r
extractResult (_, _, Left _ ) = String -> p
forall a. String -> a
interr "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 f :: 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
bs gs :: 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' = (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
$ \_ gs :: 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 f :: 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
bs gs :: gs
gs -> let
(bs' :: bs
bs', a :: 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 f :: 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
bs gs :: 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
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
bs _ -> (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 f :: 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
bs gs :: gs
gs -> let
(gs' :: gs
gs', a :: 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 m :: 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
bs gs :: 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
>>= \r :: 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 m :: STB bs gs a
m bs :: bs
bs gs :: gs
gs = let
STB m' :: 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
>>= \(_, _, res :: Either (String, String) a
res) ->
case Either (String, String) a
res of
Left (tag :: String
tag, msg :: String
msg) -> let
err :: IOError
err = String -> IOError
userError ("Exception `"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tag String -> String -> String
forall a. [a] -> [a] -> [a]
++ "': "
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 -> 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 m :: STB bs gs' a
m gs' :: 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 m' :: bs -> gs' -> IO (bs, gs', Either (String, String) a)
m' = STB bs gs' a
m
in
\bs :: bs
bs gs :: 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
bs', _, a :: 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 tag :: String
tag msg :: 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
bs gs :: 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 s :: 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 m :: STB bs gs a
m (tag :: String
tag, handler :: 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
bs gs :: gs
gs
-> let
STB m' :: 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
bs', gs' :: gs
gs', res :: Either (String, String) a
res) ->
case Either (String, String) a
res of
Left (tag' :: String
tag', msg :: String
msg) -> if (String
tag String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
tag')
then
let
STB handler' :: 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 _ -> (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 m :: STB bs gs a
m handler :: 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
bs gs :: gs
gs
-> (let
STB m' :: 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@(gs' :: bs
gs', bs' :: gs
bs', res :: Either (String, String) a
res) ->
case Either (String, String) a
res of
Left (tag :: String
tag, msg :: String
msg) -> let
err :: IOError
err = String -> IOError
userError ("Exception `" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tag
String -> String -> String
forall a. [a] -> [a] -> [a]
++ "': " 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
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` (\err :: IOError
err -> let
STB handler' :: 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 x :: 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 mv :: 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 mv :: MVar a
mv x :: 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)