{-# LANGUAGE GADTs, Rank2Types, LambdaCase #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Object.Instance
-- Copyright   :  (c) Fumiaki Kinoshita 2015
-- License     :  BSD3
--
-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
-- Stability   :  provisional
-- Portability :  GADTs, Rank2Types
--
-----------------------------------------------------------------------------
module Control.Object.Instance (
  -- * Instantiation
  Instance
  , new
  , newSettle
  -- * Invocation
  , invokeOnUsing
  , invokeOn
  , (.-)
  , (..-)
  , (?-)
  ) where
import Control.Concurrent
import Control.Exception (evaluate)
import Control.Object.Object
import Control.Monad.IO.Class
import Control.Monad.Catch
import Control.Monad.Skeleton

type Instance f g = MVar (Object f g)

invokeOnUsing :: (MonadIO m, MonadMask m)
  => (Object f g -> t a -> g (a, Object f g))
  -> (forall x. g x -> m x) -> Instance f g -> t a -> m a
invokeOnUsing :: (Object f g -> t a -> g (a, Object f g))
-> (forall x. g x -> m x) -> Instance f g -> t a -> m a
invokeOnUsing Object f g -> t a -> g (a, Object f g)
run forall x. g x -> m x
m Instance f g
v t a
f = ((forall a. m a -> m a) -> m a) -> m a
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m a) -> m a)
-> ((forall a. m a -> m a) -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
  Object f g
obj <- IO (Object f g) -> m (Object f g)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Object f g) -> m (Object f g))
-> IO (Object f g) -> m (Object f g)
forall a b. (a -> b) -> a -> b
$ Instance f g -> IO (Object f g)
forall a. MVar a -> IO a
takeMVar Instance f g
v
  (a
a, Object f g
obj') <- m (a, Object f g) -> m (a, Object f g)
forall a. m a -> m a
restore (g (a, Object f g) -> m (a, Object f g)
forall x. g x -> m x
m (Object f g -> t a -> g (a, Object f g)
run Object f g
obj t a
f) m (a, Object f g)
-> ((a, Object f g) -> m (a, Object f g)) -> m (a, Object f g)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (a, Object f g) -> m (a, Object f g)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (a, Object f g) -> m (a, Object f g))
-> ((a, Object f g) -> IO (a, Object f g))
-> (a, Object f g)
-> m (a, Object f g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Object f g) -> IO (a, Object f g)
forall a. a -> IO a
evaluate) m (a, Object f g) -> m () -> m (a, Object f g)
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Instance f g -> Object f g -> IO ()
forall a. MVar a -> a -> IO ()
putMVar Instance f g
v Object f g
obj)
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Instance f g -> Object f g -> IO ()
forall a. MVar a -> a -> IO ()
putMVar Instance f g
v Object f g
obj'
  a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Invoke a method with an explicit landing function.
-- In case of exception, the original object will be set.
invokeOn :: (MonadIO m, MonadMask m)
         => (forall x. g x -> m x) -> Instance f g -> f a -> m a
invokeOn :: (forall x. g x -> m x) -> Instance f g -> f a -> m a
invokeOn = (Object f g -> f a -> g (a, Object f g))
-> (forall x. g x -> m x) -> Instance f g -> f a -> m a
forall (m :: * -> *) (f :: * -> *) (g :: * -> *) (t :: * -> *) a.
(MonadIO m, MonadMask m) =>
(Object f g -> t a -> g (a, Object f g))
-> (forall x. g x -> m x) -> Instance f g -> t a -> m a
invokeOnUsing (\Object f g
o f a
f -> Object f g -> f a -> g (a, Object f g)
forall (f :: * -> *) (g :: * -> *).
Object f g -> forall x. f x -> g (x, Object f g)
runObject Object f g
o f a
f)
{-# INLINE invokeOn #-}

-- | Invoke a method.
(.-) :: (MonadIO m, MonadMask m) => Instance f m -> f a -> m a
.- :: Instance f m -> f a -> m a
(.-) = (forall x. m x -> m x) -> Instance f m -> f a -> m a
forall (m :: * -> *) (g :: * -> *) (f :: * -> *) a.
(MonadIO m, MonadMask m) =>
(forall x. g x -> m x) -> Instance f g -> f a -> m a
invokeOn forall a. a -> a
forall x. m x -> m x
id
{-# INLINE (.-) #-}
infixr 3 .-

(..-) :: (MonadIO m, MonadMask m)
    => Instance t m -> Skeleton t a -> m a
..- :: Instance t m -> Skeleton t a -> m a
(..-) = (Object t m -> Skeleton t a -> m (a, Object t m))
-> (forall x. m x -> m x) -> Instance t m -> Skeleton t a -> m a
forall (m :: * -> *) (f :: * -> *) (g :: * -> *) (t :: * -> *) a.
(MonadIO m, MonadMask m) =>
(Object f g -> t a -> g (a, Object f g))
-> (forall x. g x -> m x) -> Instance f g -> t a -> m a
invokeOnUsing Object t m -> Skeleton t a -> m (a, Object t m)
forall (m :: * -> *) (t :: * -> *) a.
Monad m =>
Object t m -> Skeleton t a -> m (a, Object t m)
cascadeObject forall a. a -> a
forall x. m x -> m x
id
{-# INLINE (..-) #-}
infixr 3 ..-

-- | Try to invoke a method. If the instance is unavailable, it returns Nothing.
(?-) :: (MonadIO m, MonadMask m) => Instance f m -> f a -> m (Maybe a)
Instance f m
v ?- :: Instance f m -> f a -> m (Maybe a)
?- f a
f = ((forall a. m a -> m a) -> m (Maybe a)) -> m (Maybe a)
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m (Maybe a)) -> m (Maybe a))
-> ((forall a. m a -> m a) -> m (Maybe a)) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> IO (Maybe (Object f m)) -> m (Maybe (Object f m))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Instance f m -> IO (Maybe (Object f m))
forall a. MVar a -> IO (Maybe a)
tryTakeMVar Instance f m
v) m (Maybe (Object f m))
-> (Maybe (Object f m) -> m (Maybe a)) -> m (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Just Object f m
obj -> do
    (a
a, Object f m
obj') <- m (a, Object f m) -> m (a, Object f m)
forall a. m a -> m a
restore (Object f m -> f a -> m (a, Object f m)
forall (f :: * -> *) (g :: * -> *).
Object f g -> forall x. f x -> g (x, Object f g)
runObject Object f m
obj f a
f m (a, Object f m)
-> ((a, Object f m) -> m (a, Object f m)) -> m (a, Object f m)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (a, Object f m) -> m (a, Object f m)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (a, Object f m) -> m (a, Object f m))
-> ((a, Object f m) -> IO (a, Object f m))
-> (a, Object f m)
-> m (a, Object f m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, Object f m) -> IO (a, Object f m)
forall a. a -> IO a
evaluate) m (a, Object f m) -> m () -> m (a, Object f m)
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Instance f m -> Object f m -> IO ()
forall a. MVar a -> a -> IO ()
putMVar Instance f m
v Object f m
obj)
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Instance f m -> Object f m -> IO ()
forall a. MVar a -> a -> IO ()
putMVar Instance f m
v Object f m
obj'
    Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
a)
  Maybe (Object f m)
Nothing -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

-- | Create a new instance. This can be used inside 'unsafePerformIO' to create top-level instances.
new :: MonadIO m => Object f g -> m (Instance f g)
new :: Object f g -> m (Instance f g)
new = IO (Instance f g) -> m (Instance f g)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Instance f g) -> m (Instance f g))
-> (Object f g -> IO (Instance f g))
-> Object f g
-> m (Instance f g)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object f g -> IO (Instance f g)
forall a. a -> IO (MVar a)
newMVar
{-# INLINE new #-}

-- | Create a new instance, having it sitting on the current environment.
newSettle :: MonadIO m => Object f m -> m (Instance f m)
newSettle :: Object f m -> m (Instance f m)
newSettle = Object f m -> m (Instance f m)
forall (m :: * -> *) (f :: * -> *) (g :: * -> *).
MonadIO m =>
Object f g -> m (Instance f g)
new
{-# INLINE newSettle #-}