{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs, ScopedTypeVariables, TupleSections, GeneralizedNewtypeDeriving #-}

module Development.Shake.Internal.Core.Monad(
    RAW, Capture, runRAW,
    getRO, getRW, putRW, modifyRW,
    stepRAW,
    catchRAW, tryRAW, throwRAW, finallyRAW,
    captureRAW,
    ) where

import Control.Exception.Extra
import Development.Shake.Internal.Errors
import Control.Monad.IO.Class
import Data.IORef
import Control.Monad
import System.IO
import Data.Semigroup
import Control.Monad.Fail
import Prelude


data RAW k v ro rw a where
    Fmap :: (a -> b) -> RAW k v ro rw a -> RAW k v ro rw b
    Pure :: a -> RAW k v ro rw a
    Ap :: RAW k v ro rw (a -> b) -> RAW k v ro rw a -> RAW k v ro rw b
    Next :: RAW k v ro rw a -> RAW k v ro rw b -> RAW k v ro rw b
    Bind :: RAW k v ro rw a -> (a -> RAW k v ro rw b) -> RAW k v ro rw b
    LiftIO :: IO a -> RAW k v ro rw a
    GetRO :: RAW k v ro rw ro
    GetRW :: RAW k v ro rw rw
    PutRW :: !rw -> RAW k v ro rw ()
    ModifyRW :: (rw -> rw) -> RAW k v ro rw ()
    StepRAW :: k -> RAW k v ro rw v
    CaptureRAW :: Capture (Either SomeException a) -> RAW k v ro rw a
    CatchRAW :: RAW k v ro rw a -> (SomeException -> RAW k v ro rw a) -> RAW k v ro rw a

instance Functor (RAW k v ro rw) where
    fmap :: (a -> b) -> RAW k v ro rw a -> RAW k v ro rw b
fmap = (a -> b) -> RAW k v ro rw a -> RAW k v ro rw b
forall a b k v ro rw.
(a -> b) -> RAW k v ro rw a -> RAW k v ro rw b
Fmap

instance Applicative (RAW k v ro rw) where
    pure :: a -> RAW k v ro rw a
pure = a -> RAW k v ro rw a
forall a k v ro rw. a -> RAW k v ro rw a
Pure
    *> :: RAW k v ro rw a -> RAW k v ro rw b -> RAW k v ro rw b
(*>) = RAW k v ro rw a -> RAW k v ro rw b -> RAW k v ro rw b
forall k v ro rw a b.
RAW k v ro rw a -> RAW k v ro rw b -> RAW k v ro rw b
Next
    <*> :: RAW k v ro rw (a -> b) -> RAW k v ro rw a -> RAW k v ro rw b
(<*>) = RAW k v ro rw (a -> b) -> RAW k v ro rw a -> RAW k v ro rw b
forall k v ro rw a b.
RAW k v ro rw (a -> b) -> RAW k v ro rw a -> RAW k v ro rw b
Ap

instance Monad (RAW k v ro rw) where
    return :: a -> RAW k v ro rw a
return = a -> RAW k v ro rw a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    >> :: RAW k v ro rw a -> RAW k v ro rw b -> RAW k v ro rw b
(>>) = RAW k v ro rw a -> RAW k v ro rw b -> RAW k v ro rw b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
    >>= :: RAW k v ro rw a -> (a -> RAW k v ro rw b) -> RAW k v ro rw b
(>>=) = RAW k v ro rw a -> (a -> RAW k v ro rw b) -> RAW k v ro rw b
forall k v ro rw a b.
RAW k v ro rw a -> (a -> RAW k v ro rw b) -> RAW k v ro rw b
Bind

instance MonadIO (RAW k v ro rw) where
    liftIO :: IO a -> RAW k v ro rw a
liftIO = IO a -> RAW k v ro rw a
forall a k v ro rw. IO a -> RAW k v ro rw a
LiftIO

instance MonadFail (RAW k v ro rw) where
    fail :: String -> RAW k v ro rw a
fail = IO a -> RAW k v ro rw a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> RAW k v ro rw a)
-> (String -> IO a) -> String -> RAW k v ro rw a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
Control.Monad.Fail.fail

instance Semigroup a => Semigroup (RAW k v ro rw a) where
    <> :: RAW k v ro rw a -> RAW k v ro rw a -> RAW k v ro rw a
(<>) RAW k v ro rw a
a RAW k v ro rw a
b = a -> a -> a
forall a. Semigroup a => a -> a -> a
(<>) (a -> a -> a) -> RAW k v ro rw a -> RAW k v ro rw (a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RAW k v ro rw a
a RAW k v ro rw (a -> a) -> RAW k v ro rw a -> RAW k v ro rw a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RAW k v ro rw a
b

instance (Semigroup a, Monoid a) => Monoid (RAW k v ro rw a) where
    mempty :: RAW k v ro rw a
mempty = a -> RAW k v ro rw a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty
    mappend :: RAW k v ro rw a -> RAW k v ro rw a -> RAW k v ro rw a
mappend = RAW k v ro rw a -> RAW k v ro rw a -> RAW k v ro rw a
forall a. Semigroup a => a -> a -> a
(<>)


type Capture a = (a -> IO ()) -> IO ()


-- Useful for checking that all continuations are run only once
-- Cannot be enabled for performance reasons and because some of
-- "monad test" deliberately breaks the invariant to check it doesn't go wrong
assertOnceCheck :: Bool
assertOnceCheck = Bool
False

assertOnce :: MonadIO m => String -> (a -> m b) -> IO (a -> m b)
assertOnce :: String -> (a -> m b) -> IO (a -> m b)
assertOnce String
msg a -> m b
k
    | Bool -> Bool
not Bool
assertOnceCheck = (a -> m b) -> IO (a -> m b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> m b
k
    | Bool
otherwise = do
        IORef Bool
ref <- IO (IORef Bool) -> IO (IORef Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Bool) -> IO (IORef Bool))
-> IO (IORef Bool) -> IO (IORef Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
        (a -> m b) -> IO (a -> m b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> m b) -> IO (a -> m b)) -> (a -> m b) -> IO (a -> m b)
forall a b. (a -> b) -> a -> b
$ \a
v -> do
            IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IO (IO ()) -> IO ()
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> (Bool -> (Bool, IO ())) -> IO (IO ())
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef Bool
ref ((Bool -> (Bool, IO ())) -> IO (IO ()))
-> (Bool -> (Bool, IO ())) -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \Bool
old -> (Bool
True,) (IO () -> (Bool, IO ())) -> IO () -> (Bool, IO ())
forall a b. (a -> b) -> a -> b
$ Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
old (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"FATAL ERROR: assertOnce failed"
                String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
Prelude.fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"assertOnce failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
            a -> m b
k a
v

-- | Run and then call a continuation.
runRAW :: ([k] -> RAW k v ro rw [v]) -> ro -> rw -> RAW k v ro rw a -> Capture (Either SomeException a)
runRAW :: ([k] -> RAW k v ro rw [v])
-> ro -> rw -> RAW k v ro rw a -> Capture (Either SomeException a)
runRAW [k] -> RAW k v ro rw [v]
step ro
ro rw
rw RAW k v ro rw a
m Either SomeException a -> IO ()
k = do
    Either SomeException a -> IO ()
k <- String
-> (Either SomeException a -> IO ())
-> IO (Either SomeException a -> IO ())
forall (m :: * -> *) a b.
MonadIO m =>
String -> (a -> m b) -> IO (a -> m b)
assertOnce String
"runRAW" Either SomeException a -> IO ()
k
    IORef rw
rw <- rw -> IO (IORef rw)
forall a. a -> IO (IORef a)
newIORef rw
rw
    IORef (SomeException -> IO ())
handler <- (SomeException -> IO ()) -> IO (IORef (SomeException -> IO ()))
forall a. a -> IO (IORef a)
newIORef SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO
    Steps k v
steps <- IO (Steps k v)
forall k v. IO (Steps k v)
newSteps
    IORef (SomeException -> IO ()) -> (SomeException -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (SomeException -> IO ())
handler ((SomeException -> IO ()) -> IO ())
-> (SomeException -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SomeException
e -> do
        -- make sure we never call the error continuation twice
        IORef (SomeException -> IO ()) -> (SomeException -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (SomeException -> IO ())
handler SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO
        Either SomeException a -> IO ()
k (Either SomeException a -> IO ())
-> Either SomeException a -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> Either SomeException a
forall a b. a -> Either a b
Left SomeException
e
    -- If the continuation itself throws an error we need to make sure we
    -- don't end up running it twice (once with its result, once with its own exception)
    ([k] -> RAW k v ro rw [v])
-> Steps k v
-> IORef (SomeException -> IO ())
-> ro
-> IORef rw
-> RAW k v ro rw a
-> Capture a
forall k v ro rw a.
([k] -> RAW k v ro rw [v])
-> Steps k v
-> IORef (SomeException -> IO ())
-> ro
-> IORef rw
-> RAW k v ro rw a
-> Capture a
goRAW [k] -> RAW k v ro rw [v]
step Steps k v
steps IORef (SomeException -> IO ())
handler ro
ro IORef rw
rw RAW k v ro rw a
m (\a
v -> do IORef (SomeException -> IO ()) -> (SomeException -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (SomeException -> IO ())
handler SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO; Either SomeException a -> IO ()
k (Either SomeException a -> IO ())
-> Either SomeException a -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> Either SomeException a
forall a b. b -> Either a b
Right a
v)
        IO () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
`catch_` \SomeException
e -> ((SomeException -> IO ()) -> SomeException -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException
e) ((SomeException -> IO ()) -> IO ())
-> IO (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (SomeException -> IO ()) -> IO (SomeException -> IO ())
forall a. IORef a -> IO a
readIORef IORef (SomeException -> IO ())
handler


goRAW :: forall k v ro rw a . ([k] -> RAW k v ro rw [v]) -> Steps k v -> IORef (SomeException -> IO ()) -> ro -> IORef rw -> RAW k v ro rw a -> Capture a
goRAW :: ([k] -> RAW k v ro rw [v])
-> Steps k v
-> IORef (SomeException -> IO ())
-> ro
-> IORef rw
-> RAW k v ro rw a
-> Capture a
goRAW [k] -> RAW k v ro rw [v]
step Steps k v
steps IORef (SomeException -> IO ())
handler ro
ro IORef rw
rw = \RAW k v ro rw a
x a -> IO ()
k -> RAW k v ro rw a -> Capture (SIO a)
forall b. RAW k v ro rw b -> Capture (SIO b)
go RAW k v ro rw a
x Capture (SIO a) -> Capture (SIO a)
forall a b. (a -> b) -> a -> b
$ \SIO a
v -> SIO a -> Capture a
forall b. SIO b -> Capture b
sio SIO a
v a -> IO ()
k
    where
        sio :: SIO b -> Capture b
        sio :: SIO b -> Capture b
sio (SIO IO b
v) b -> IO ()
k = IO () -> IO ()
flush (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do b
v <- IO b
v; b -> IO ()
k b
v

        flush :: IO () -> IO ()
        flush :: IO () -> IO ()
flush IO ()
k = do
            Maybe (([k] -> RAW k v ro rw [v]) -> RAW k v ro rw ())
v <- Steps k v
-> IO (Maybe (([k] -> RAW k v ro rw [v]) -> RAW k v ro rw ()))
forall (m :: * -> *) k v.
MonadIO m =>
Steps k v -> IO (Maybe (([k] -> m [v]) -> m ()))
flushSteps Steps k v
steps
            case Maybe (([k] -> RAW k v ro rw [v]) -> RAW k v ro rw ())
v of
                Maybe (([k] -> RAW k v ro rw [v]) -> RAW k v ro rw ())
Nothing -> IO ()
k
                Just ([k] -> RAW k v ro rw [v]) -> RAW k v ro rw ()
f -> RAW k v ro rw () -> Capture (SIO ())
forall b. RAW k v ro rw b -> Capture (SIO b)
go (([k] -> RAW k v ro rw [v]) -> RAW k v ro rw ()
f [k] -> RAW k v ro rw [v]
step) Capture (SIO ()) -> Capture (SIO ())
forall a b. (a -> b) -> a -> b
$ IO () -> SIO () -> IO ()
forall a b. a -> b -> a
const IO ()
k

        unflush :: IO ()
        unflush :: IO ()
unflush = Steps k v -> IO ()
forall k v. Steps k v -> IO ()
unflushSteps Steps k v
steps

        go :: RAW k v ro rw b -> Capture (SIO b)
        go :: RAW k v ro rw b -> Capture (SIO b)
go RAW k v ro rw b
x SIO b -> IO ()
k = case RAW k v ro rw b
x of
            Fmap a -> b
f RAW k v ro rw a
a -> RAW k v ro rw a -> Capture (SIO a)
forall b. RAW k v ro rw b -> Capture (SIO b)
go RAW k v ro rw a
a Capture (SIO a) -> Capture (SIO a)
forall a b. (a -> b) -> a -> b
$ \SIO a
v -> SIO b -> IO ()
k (SIO b -> IO ()) -> SIO b -> IO ()
forall a b. (a -> b) -> a -> b
$ (a -> b) -> SIO a -> SIO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f SIO a
v
            Pure b
a -> SIO b -> IO ()
k (SIO b -> IO ()) -> SIO b -> IO ()
forall a b. (a -> b) -> a -> b
$ b -> SIO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
a
            Ap RAW k v ro rw (a -> b)
f RAW k v ro rw a
x -> RAW k v ro rw (a -> b) -> Capture (SIO (a -> b))
forall b. RAW k v ro rw b -> Capture (SIO b)
go RAW k v ro rw (a -> b)
f Capture (SIO (a -> b)) -> Capture (SIO (a -> b))
forall a b. (a -> b) -> a -> b
$ \SIO (a -> b)
f -> RAW k v ro rw a -> Capture (SIO a)
forall b. RAW k v ro rw b -> Capture (SIO b)
go RAW k v ro rw a
x Capture (SIO a) -> Capture (SIO a)
forall a b. (a -> b) -> a -> b
$ \SIO a
v -> SIO b -> IO ()
k (SIO b -> IO ()) -> SIO b -> IO ()
forall a b. (a -> b) -> a -> b
$ SIO (a -> b)
f SIO (a -> b) -> SIO a -> SIO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SIO a
v
            Next RAW k v ro rw a
a RAW k v ro rw b
b -> RAW k v ro rw a -> Capture (SIO a)
forall b. RAW k v ro rw b -> Capture (SIO b)
go RAW k v ro rw a
a Capture (SIO a) -> Capture (SIO a)
forall a b. (a -> b) -> a -> b
$ \SIO a
a -> RAW k v ro rw b -> Capture (SIO b)
forall b. RAW k v ro rw b -> Capture (SIO b)
go RAW k v ro rw b
b Capture (SIO b) -> Capture (SIO b)
forall a b. (a -> b) -> a -> b
$ \SIO b
b -> SIO b -> IO ()
k (SIO b -> IO ()) -> SIO b -> IO ()
forall a b. (a -> b) -> a -> b
$ SIO a
a SIO a -> SIO b -> SIO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> SIO b
b
            StepRAW k
q -> do
                SIO v
v <- Steps k v -> k -> IO (SIO v)
forall k v. Steps k v -> k -> IO (SIO v)
addStep Steps k v
steps k
q
                SIO b -> IO ()
k SIO v
SIO b
v

            Bind RAW k v ro rw a
a a -> RAW k v ro rw b
b -> RAW k v ro rw a -> Capture (SIO a)
forall b. RAW k v ro rw b -> Capture (SIO b)
go RAW k v ro rw a
a Capture (SIO a) -> Capture (SIO a)
forall a b. (a -> b) -> a -> b
$ \SIO a
a -> SIO a -> Capture a
forall b. SIO b -> Capture b
sio SIO a
a Capture a -> Capture a
forall a b. (a -> b) -> a -> b
$ \a
a -> RAW k v ro rw b -> Capture (SIO b)
forall b. RAW k v ro rw b -> Capture (SIO b)
go (a -> RAW k v ro rw b
b a
a) SIO b -> IO ()
k
            LiftIO IO b
act -> IO () -> IO ()
flush (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do b
v <- IO b
act; SIO b -> IO ()
k (SIO b -> IO ()) -> SIO b -> IO ()
forall a b. (a -> b) -> a -> b
$ b -> SIO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
v

            RAW k v ro rw b
GetRO -> SIO b -> IO ()
k (SIO b -> IO ()) -> SIO b -> IO ()
forall a b. (a -> b) -> a -> b
$ ro -> SIO ro
forall (f :: * -> *) a. Applicative f => a -> f a
pure ro
ro
            RAW k v ro rw b
GetRW -> IO () -> IO ()
flush (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SIO b -> IO ()
k (SIO b -> IO ()) -> (b -> SIO b) -> b -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> SIO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> IO ()) -> IO b -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef rw -> IO rw
forall a. IORef a -> IO a
readIORef IORef rw
rw
            PutRW rw
x -> IO () -> IO ()
flush (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef rw -> rw -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef rw
rw rw
x IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SIO b -> IO ()
k (() -> SIO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
            ModifyRW rw -> rw
f -> IO () -> IO ()
flush (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef rw -> (rw -> rw) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef rw
rw rw -> rw
f IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SIO b -> IO ()
k (() -> SIO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

            CatchRAW RAW k v ro rw b
m SomeException -> RAW k v ro rw b
hdl -> IO () -> IO ()
flush (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                SomeException -> RAW k v ro rw b
hdl <- String
-> (SomeException -> RAW k v ro rw b)
-> IO (SomeException -> RAW k v ro rw b)
forall (m :: * -> *) a b.
MonadIO m =>
String -> (a -> m b) -> IO (a -> m b)
assertOnce String
"CatchRAW" SomeException -> RAW k v ro rw b
hdl
                SomeException -> IO ()
old <- IORef (SomeException -> IO ()) -> IO (SomeException -> IO ())
forall a. IORef a -> IO a
readIORef IORef (SomeException -> IO ())
handler
                IORef (SomeException -> IO ()) -> (SomeException -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (SomeException -> IO ())
handler ((SomeException -> IO ()) -> IO ())
-> (SomeException -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SomeException
e -> do
                    IORef (SomeException -> IO ()) -> (SomeException -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (SomeException -> IO ())
handler SomeException -> IO ()
old
                    RAW k v ro rw b -> Capture (SIO b)
forall b. RAW k v ro rw b -> Capture (SIO b)
go (SomeException -> RAW k v ro rw b
hdl SomeException
e) SIO b -> IO ()
k IO () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
`catch_`
                        \SomeException
e -> do IO ()
unflush; ((SomeException -> IO ()) -> SomeException -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException
e) ((SomeException -> IO ()) -> IO ())
-> IO (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (SomeException -> IO ()) -> IO (SomeException -> IO ())
forall a. IORef a -> IO a
readIORef IORef (SomeException -> IO ())
handler
                RAW k v ro rw b -> Capture (SIO b)
forall b. RAW k v ro rw b -> Capture (SIO b)
go RAW k v ro rw b
m Capture (SIO b) -> Capture (SIO b)
forall a b. (a -> b) -> a -> b
$ \SIO b
x -> IORef (SomeException -> IO ()) -> (SomeException -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (SomeException -> IO ())
handler SomeException -> IO ()
old IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SIO b -> IO ()
k SIO b
x

            CaptureRAW Capture (Either SomeException b)
f -> IO () -> IO ()
flush (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Capture (Either SomeException b)
f <- String
-> Capture (Either SomeException b)
-> IO (Capture (Either SomeException b))
forall (m :: * -> *) a b.
MonadIO m =>
String -> (a -> m b) -> IO (a -> m b)
assertOnce String
"CaptureRAW" Capture (Either SomeException b)
f
                SomeException -> IO ()
old <- IORef (SomeException -> IO ()) -> IO (SomeException -> IO ())
forall a. IORef a -> IO a
readIORef IORef (SomeException -> IO ())
handler
                IORef (SomeException -> IO ()) -> (SomeException -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (SomeException -> IO ())
handler SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO
                Capture (Either SomeException b)
f Capture (Either SomeException b)
-> Capture (Either SomeException b)
forall a b. (a -> b) -> a -> b
$ \case
                    Left SomeException
e -> SomeException -> IO ()
old SomeException
e
                    Right b
v -> do
                        IORef (SomeException -> IO ()) -> (SomeException -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (SomeException -> IO ())
handler SomeException -> IO ()
old
                        SIO b -> IO ()
k (b -> SIO b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
v) IO () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
`catch_` \SomeException
e -> do IO ()
unflush; ((SomeException -> IO ()) -> SomeException -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException
e) ((SomeException -> IO ()) -> IO ())
-> IO (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef (SomeException -> IO ()) -> IO (SomeException -> IO ())
forall a. IORef a -> IO a
readIORef IORef (SomeException -> IO ())
handler


newtype SIO a = SIO (IO a)
    deriving (a -> SIO b -> SIO a
(a -> b) -> SIO a -> SIO b
(forall a b. (a -> b) -> SIO a -> SIO b)
-> (forall a b. a -> SIO b -> SIO a) -> Functor SIO
forall a b. a -> SIO b -> SIO a
forall a b. (a -> b) -> SIO a -> SIO b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SIO b -> SIO a
$c<$ :: forall a b. a -> SIO b -> SIO a
fmap :: (a -> b) -> SIO a -> SIO b
$cfmap :: forall a b. (a -> b) -> SIO a -> SIO b
Functor, Applicative SIO
a -> SIO a
Applicative SIO
-> (forall a b. SIO a -> (a -> SIO b) -> SIO b)
-> (forall a b. SIO a -> SIO b -> SIO b)
-> (forall a. a -> SIO a)
-> Monad SIO
SIO a -> (a -> SIO b) -> SIO b
SIO a -> SIO b -> SIO b
forall a. a -> SIO a
forall a b. SIO a -> SIO b -> SIO b
forall a b. SIO a -> (a -> SIO b) -> SIO b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> SIO a
$creturn :: forall a. a -> SIO a
>> :: SIO a -> SIO b -> SIO b
$c>> :: forall a b. SIO a -> SIO b -> SIO b
>>= :: SIO a -> (a -> SIO b) -> SIO b
$c>>= :: forall a b. SIO a -> (a -> SIO b) -> SIO b
$cp1Monad :: Applicative SIO
Monad, Functor SIO
a -> SIO a
Functor SIO
-> (forall a. a -> SIO a)
-> (forall a b. SIO (a -> b) -> SIO a -> SIO b)
-> (forall a b c. (a -> b -> c) -> SIO a -> SIO b -> SIO c)
-> (forall a b. SIO a -> SIO b -> SIO b)
-> (forall a b. SIO a -> SIO b -> SIO a)
-> Applicative SIO
SIO a -> SIO b -> SIO b
SIO a -> SIO b -> SIO a
SIO (a -> b) -> SIO a -> SIO b
(a -> b -> c) -> SIO a -> SIO b -> SIO c
forall a. a -> SIO a
forall a b. SIO a -> SIO b -> SIO a
forall a b. SIO a -> SIO b -> SIO b
forall a b. SIO (a -> b) -> SIO a -> SIO b
forall a b c. (a -> b -> c) -> SIO a -> SIO b -> SIO c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: SIO a -> SIO b -> SIO a
$c<* :: forall a b. SIO a -> SIO b -> SIO a
*> :: SIO a -> SIO b -> SIO b
$c*> :: forall a b. SIO a -> SIO b -> SIO b
liftA2 :: (a -> b -> c) -> SIO a -> SIO b -> SIO c
$cliftA2 :: forall a b c. (a -> b -> c) -> SIO a -> SIO b -> SIO c
<*> :: SIO (a -> b) -> SIO a -> SIO b
$c<*> :: forall a b. SIO (a -> b) -> SIO a -> SIO b
pure :: a -> SIO a
$cpure :: forall a. a -> SIO a
$cp1Applicative :: Functor SIO
Applicative)


newtype Steps k v = Steps (IORef [(k, IORef v)])

newSteps :: IO (Steps k v)
newSteps :: IO (Steps k v)
newSteps = IORef [(k, IORef v)] -> Steps k v
forall k v. IORef [(k, IORef v)] -> Steps k v
Steps (IORef [(k, IORef v)] -> Steps k v)
-> IO (IORef [(k, IORef v)]) -> IO (Steps k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(k, IORef v)] -> IO (IORef [(k, IORef v)])
forall a. a -> IO (IORef a)
newIORef []

addStep :: Steps k v -> k -> IO (SIO v)
addStep :: Steps k v -> k -> IO (SIO v)
addStep (Steps IORef [(k, IORef v)]
ref) k
k = do
    IORef v
out <- v -> IO (IORef v)
forall a. a -> IO (IORef a)
newIORef (v -> IO (IORef v)) -> v -> IO (IORef v)
forall a b. (a -> b) -> a -> b
$ SomeException -> v
forall a. SomeException -> a
throwImpure (SomeException -> v) -> SomeException -> v
forall a b. (a -> b) -> a -> b
$ Partial => String -> SomeException
String -> SomeException
errorInternal String
"Monad, addStep not flushed"
    IORef [(k, IORef v)] -> ([(k, IORef v)] -> [(k, IORef v)]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [(k, IORef v)]
ref ((k
k,IORef v
out)(k, IORef v) -> [(k, IORef v)] -> [(k, IORef v)]
forall a. a -> [a] -> [a]
:)
    SIO v -> IO (SIO v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SIO v -> IO (SIO v)) -> SIO v -> IO (SIO v)
forall a b. (a -> b) -> a -> b
$ IO v -> SIO v
forall a. IO a -> SIO a
SIO (IO v -> SIO v) -> IO v -> SIO v
forall a b. (a -> b) -> a -> b
$ IORef v -> IO v
forall a. IORef a -> IO a
readIORef IORef v
out

unflushSteps :: Steps k v -> IO ()
unflushSteps :: Steps k v -> IO ()
unflushSteps (Steps IORef [(k, IORef v)]
ref) = IORef [(k, IORef v)] -> [(k, IORef v)] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [(k, IORef v)]
ref []

flushSteps :: MonadIO m => Steps k v -> IO (Maybe (([k] -> m [v]) -> m ()))
flushSteps :: Steps k v -> IO (Maybe (([k] -> m [v]) -> m ()))
flushSteps (Steps IORef [(k, IORef v)]
ref) = do
    [(k, IORef v)]
v <- [(k, IORef v)] -> [(k, IORef v)]
forall a. [a] -> [a]
reverse ([(k, IORef v)] -> [(k, IORef v)])
-> IO [(k, IORef v)] -> IO [(k, IORef v)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef [(k, IORef v)] -> IO [(k, IORef v)]
forall a. IORef a -> IO a
readIORef IORef [(k, IORef v)]
ref
    case [(k, IORef v)]
v of
        [] -> Maybe (([k] -> m [v]) -> m ())
-> IO (Maybe (([k] -> m [v]) -> m ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (([k] -> m [v]) -> m ())
forall a. Maybe a
Nothing
        [(k, IORef v)]
xs -> do
            IORef [(k, IORef v)] -> [(k, IORef v)] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef [(k, IORef v)]
ref []
            Maybe (([k] -> m [v]) -> m ())
-> IO (Maybe (([k] -> m [v]) -> m ()))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (([k] -> m [v]) -> m ())
 -> IO (Maybe (([k] -> m [v]) -> m ())))
-> Maybe (([k] -> m [v]) -> m ())
-> IO (Maybe (([k] -> m [v]) -> m ()))
forall a b. (a -> b) -> a -> b
$ (([k] -> m [v]) -> m ()) -> Maybe (([k] -> m [v]) -> m ())
forall a. a -> Maybe a
Just ((([k] -> m [v]) -> m ()) -> Maybe (([k] -> m [v]) -> m ()))
-> (([k] -> m [v]) -> m ()) -> Maybe (([k] -> m [v]) -> m ())
forall a b. (a -> b) -> a -> b
$ \[k] -> m [v]
step -> do
                [v]
vs <- [k] -> m [v]
step ([k] -> m [v]) -> [k] -> m [v]
forall a b. (a -> b) -> a -> b
$ ((k, IORef v) -> k) -> [(k, IORef v)] -> [k]
forall a b. (a -> b) -> [a] -> [b]
map (k, IORef v) -> k
forall a b. (a, b) -> a
fst [(k, IORef v)]
xs
                IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (IORef v -> v -> IO ()) -> [IORef v] -> [v] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ IORef v -> v -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (((k, IORef v) -> IORef v) -> [(k, IORef v)] -> [IORef v]
forall a b. (a -> b) -> [a] -> [b]
map (k, IORef v) -> IORef v
forall a b. (a, b) -> b
snd [(k, IORef v)]
xs) [v]
vs


---------------------------------------------------------------------
-- STANDARD

getRO :: RAW k v ro rw ro
getRO :: RAW k v ro rw ro
getRO = RAW k v ro rw ro
forall k v ro rw. RAW k v ro rw ro
GetRO

getRW :: RAW k v ro rw rw
getRW :: RAW k v ro rw rw
getRW = RAW k v ro rw rw
forall k v ro rw. RAW k v ro rw rw
GetRW

-- | Strict version
putRW :: rw -> RAW k v ro rw ()
putRW :: rw -> RAW k v ro rw ()
putRW = rw -> RAW k v ro rw ()
forall rw k v ro. rw -> RAW k v ro rw ()
PutRW

modifyRW :: (rw -> rw) -> RAW k v ro rw ()
modifyRW :: (rw -> rw) -> RAW k v ro rw ()
modifyRW = (rw -> rw) -> RAW k v ro rw ()
forall rw k v ro. (rw -> rw) -> RAW k v ro rw ()
ModifyRW


---------------------------------------------------------------------
-- EXCEPTIONS

catchRAW :: RAW k v ro rw a -> (SomeException -> RAW k v ro rw a) -> RAW k v ro rw a
catchRAW :: RAW k v ro rw a
-> (SomeException -> RAW k v ro rw a) -> RAW k v ro rw a
catchRAW = RAW k v ro rw a
-> (SomeException -> RAW k v ro rw a) -> RAW k v ro rw a
forall k v ro rw a.
RAW k v ro rw a
-> (SomeException -> RAW k v ro rw a) -> RAW k v ro rw a
CatchRAW

tryRAW :: RAW k v ro rw a -> RAW k v ro rw (Either SomeException a)
tryRAW :: RAW k v ro rw a -> RAW k v ro rw (Either SomeException a)
tryRAW RAW k v ro rw a
m = RAW k v ro rw (Either SomeException a)
-> (SomeException -> RAW k v ro rw (Either SomeException a))
-> RAW k v ro rw (Either SomeException a)
forall k v ro rw a.
RAW k v ro rw a
-> (SomeException -> RAW k v ro rw a) -> RAW k v ro rw a
catchRAW ((a -> Either SomeException a)
-> RAW k v ro rw a -> RAW k v ro rw (Either SomeException a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either SomeException a
forall a b. b -> Either a b
Right RAW k v ro rw a
m) (Either SomeException a -> RAW k v ro rw (Either SomeException a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException a -> RAW k v ro rw (Either SomeException a))
-> (SomeException -> Either SomeException a)
-> SomeException
-> RAW k v ro rw (Either SomeException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException a
forall a b. a -> Either a b
Left)

throwRAW :: Exception e => e -> RAW k v ro rw a
-- Note that while we could directly pass this to the handler
-- that would avoid triggering the catch, which would mean they built up on the stack
throwRAW :: e -> RAW k v ro rw a
throwRAW = IO a -> RAW k v ro rw a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> RAW k v ro rw a) -> (e -> IO a) -> e -> RAW k v ro rw a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> IO a
forall e a. Exception e => e -> IO a
throwIO

finallyRAW :: RAW k v ro rw a -> RAW k v ro rw b -> RAW k v ro rw a
finallyRAW :: RAW k v ro rw a -> RAW k v ro rw b -> RAW k v ro rw a
finallyRAW RAW k v ro rw a
a RAW k v ro rw b
undo = do
    a
r <- RAW k v ro rw a
-> (SomeException -> RAW k v ro rw a) -> RAW k v ro rw a
forall k v ro rw a.
RAW k v ro rw a
-> (SomeException -> RAW k v ro rw a) -> RAW k v ro rw a
catchRAW RAW k v ro rw a
a (\SomeException
e -> RAW k v ro rw b
undo RAW k v ro rw b -> RAW k v ro rw a -> RAW k v ro rw a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> RAW k v ro rw a
forall e k v ro rw a. Exception e => e -> RAW k v ro rw a
throwRAW SomeException
e)
    RAW k v ro rw b
undo
    a -> RAW k v ro rw a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r


---------------------------------------------------------------------
-- CONTINUATIONS

-- | Capture a continuation. The continuation should be called at most once.
--   Calling the same continuation, multiple times, in parallel, results in incorrect behaviour.
captureRAW :: Capture (Either SomeException a) -> RAW k v ro rw a
captureRAW :: Capture (Either SomeException a) -> RAW k v ro rw a
captureRAW = Capture (Either SomeException a) -> RAW k v ro rw a
forall a k v ro rw.
Capture (Either SomeException a) -> RAW k v ro rw a
CaptureRAW


---------------------------------------------------------------------
-- STEPS

stepRAW :: k -> RAW k v ro rw v
stepRAW :: k -> RAW k v ro rw v
stepRAW = k -> RAW k v ro rw v
forall k v ro rw. k -> RAW k v ro rw v
StepRAW