{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs, ScopedTypeVariables #-}

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

import Control.Exception.Extra
import Control.Monad.IO.Class
import Data.IORef.Extra
import Control.Applicative
import Control.Monad
import Prelude

#if __GLASGOW_HASKELL__ >= 800
import Control.Monad.Fail
#endif


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

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

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

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

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

#if __GLASGOW_HASKELL__ >= 800
instance MonadFail (RAW ro rw) where
    fail :: String -> RAW ro rw a
fail = IO a -> RAW ro rw a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> RAW ro rw a) -> (String -> IO a) -> String -> RAW 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
#endif

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


-- | Run and then call a continuation.
runRAW :: ro -> rw -> RAW ro rw a -> Capture (Either SomeException a)
runRAW :: ro -> rw -> RAW ro rw a -> Capture (Either SomeException a)
runRAW ro :: ro
ro rw :: rw
rw m :: RAW ro rw a
m k :: Either SomeException a -> IO ()
k = do
    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 ()) -> IO (IORef (SomeException -> IO ())))
-> (SomeException -> IO ()) -> IO (IORef (SomeException -> IO ()))
forall a b. (a -> b) -> a -> b
$ Either SomeException a -> IO ()
k (Either SomeException a -> IO ())
-> (SomeException -> Either SomeException a)
-> SomeException
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException a
forall a b. a -> Either a b
Left
    IORef (SomeException -> IO ())
-> ro -> IORef rw -> RAW ro rw a -> Capture a
forall ro rw a.
IORef (SomeException -> IO ())
-> ro -> IORef rw -> RAW ro rw a -> Capture a
goRAW IORef (SomeException -> IO ())
handler ro
ro IORef rw
rw RAW ro rw a
m (Either SomeException a -> IO ()
k (Either SomeException a -> IO ())
-> (a -> Either SomeException a) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either SomeException a
forall a b. b -> Either a b
Right)
        IO () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
`catch_` \e :: 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 ro rw a . IORef (SomeException -> IO ()) -> ro -> IORef rw -> RAW ro rw a -> Capture a
goRAW :: IORef (SomeException -> IO ())
-> ro -> IORef rw -> RAW ro rw a -> Capture a
goRAW handler :: IORef (SomeException -> IO ())
handler ro :: ro
ro rw :: IORef rw
rw = RAW ro rw a -> Capture a
forall b. RAW ro rw b -> Capture b
go
    where
        go :: RAW ro rw b -> Capture b
        go :: RAW ro rw b -> Capture b
go x :: RAW ro rw b
x k :: b -> IO ()
k = case RAW ro rw b
x of
            Fmap f :: a -> b
f a :: RAW ro rw a
a -> RAW ro rw a -> Capture a
forall b. RAW ro rw b -> Capture b
go RAW ro rw a
a Capture a -> Capture a
forall a b. (a -> b) -> a -> b
$ \v :: a
v -> b -> IO ()
k (b -> IO ()) -> b -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> b
f a
v
            Pure a :: b
a -> b -> IO ()
k b
a
            Ap f :: RAW ro rw (a -> b)
f x :: RAW ro rw a
x -> RAW ro rw (a -> b) -> Capture (a -> b)
forall b. RAW ro rw b -> Capture b
go RAW ro rw (a -> b)
f Capture (a -> b) -> Capture (a -> b)
forall a b. (a -> b) -> a -> b
$ \f :: a -> b
f -> RAW ro rw a -> Capture a
forall b. RAW ro rw b -> Capture b
go RAW ro rw a
x Capture a -> Capture a
forall a b. (a -> b) -> a -> b
$ \v :: a
v -> b -> IO ()
k (b -> IO ()) -> b -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> b
f a
v
            Bind a :: RAW ro rw a
a b :: a -> RAW ro rw b
b -> RAW ro rw a -> Capture a
forall b. RAW ro rw b -> Capture b
go RAW ro rw a
a Capture a -> Capture a
forall a b. (a -> b) -> a -> b
$ \a :: a
a -> RAW ro rw b -> Capture b
forall b. RAW ro rw b -> Capture b
go (a -> RAW ro rw b
b a
a) b -> IO ()
k
            Next a :: RAW ro rw a
a b :: RAW ro rw b
b -> RAW ro rw a -> Capture a
forall b. RAW ro rw b -> Capture b
go RAW ro rw a
a Capture a -> Capture a
forall a b. (a -> b) -> a -> b
$ \_ -> RAW ro rw b -> Capture b
forall b. RAW ro rw b -> Capture b
go RAW ro rw b
b b -> IO ()
k
            LiftIO x :: IO b
x -> b -> IO ()
k (b -> IO ()) -> IO b -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO b
x

            GetRO -> b -> IO ()
k ro
b
ro
            GetRW -> b -> IO ()
k (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 x :: rw
x -> 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
>> b -> IO ()
k ()
            ModifyRW f :: rw -> rw
f -> 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
>> b -> IO ()
k ()

            CatchRAW m :: RAW ro rw b
m hdl :: SomeException -> RAW ro rw b
hdl -> do
                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
$ \e :: SomeException
e -> do
                    IORef (SomeException -> IO ()) -> (SomeException -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (SomeException -> IO ())
handler SomeException -> IO ()
old
                    RAW ro rw b -> Capture b
forall b. RAW ro rw b -> Capture b
go (SomeException -> RAW ro rw b
hdl SomeException
e) b -> IO ()
k IO () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
`catch_`
                        \e :: 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
                RAW ro rw b -> Capture b
forall b. RAW ro rw b -> Capture b
go RAW ro rw b
m Capture b -> Capture b
forall a b. (a -> b) -> a -> b
$ \x :: 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
>> b -> IO ()
k b
x

            CaptureRAW f :: Capture (Either SomeException b)
f -> do
                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
$ \x :: Either SomeException b
x -> case Either SomeException b
x of
                    Left e :: SomeException
e -> SomeException -> IO ()
old SomeException
e
                    Right v :: b
v -> do
                        IORef (SomeException -> IO ()) -> (SomeException -> IO ()) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (SomeException -> IO ())
handler SomeException -> IO ()
old
                        b -> IO ()
k b
v IO () -> (SomeException -> IO ()) -> IO ()
forall a. IO a -> (SomeException -> IO a) -> IO a
`catch_` \e :: 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
                        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


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

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

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

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

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


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

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

tryRAW :: RAW ro rw a -> RAW ro rw (Either SomeException a)
tryRAW :: RAW ro rw a -> RAW ro rw (Either SomeException a)
tryRAW m :: RAW ro rw a
m = RAW ro rw (Either SomeException a)
-> (SomeException -> RAW ro rw (Either SomeException a))
-> RAW ro rw (Either SomeException a)
forall ro rw a.
RAW ro rw a -> (SomeException -> RAW ro rw a) -> RAW ro rw a
catchRAW ((a -> Either SomeException a)
-> RAW ro rw a -> RAW 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 ro rw a
m) (Either SomeException a -> RAW ro rw (Either SomeException a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SomeException a -> RAW ro rw (Either SomeException a))
-> (SomeException -> Either SomeException a)
-> SomeException
-> RAW 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 ro rw a
throwRAW :: e -> RAW ro rw a
throwRAW = IO a -> RAW ro rw a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> RAW ro rw a) -> (e -> IO a) -> e -> RAW 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


---------------------------------------------------------------------
-- 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 ro rw a
captureRAW :: Capture (Either SomeException a) -> RAW ro rw a
captureRAW = Capture (Either SomeException a) -> RAW ro rw a
forall a ro rw. Capture (Either SomeException a) -> RAW ro rw a
CaptureRAW