{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GADTs #-}
module Test.MockCat.MockT (
MockT(..), Definition(..), Verification(..),
runMockT,
MonadMockDefs(..)
) where
import Control.Concurrent.STM
( TVar
, atomically
, modifyTVar'
, newTVarIO
, readTVarIO
)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Reader (ReaderT(..), runReaderT, asks)
import GHC.TypeLits (KnownSymbol, symbolVal)
import Data.Data (Proxy, Typeable)
import Data.IORef (newIORef, IORef)
import Data.Dynamic (Dynamic)
import UnliftIO (MonadUnliftIO(..))
import Test.MockCat.Internal.Types (InvocationRecorder)
import Test.MockCat.Verify (ResolvableParamsOf)
import Test.MockCat.WithMock (WithMockContext(..), MonadWithMockContext(..))
import Control.Concurrent.MVar (MVar)
import qualified Data.Map.Strict as Map
import qualified Test.MockCat.Internal.Registry.Core as Registry
data MockTEnv = MockTEnv
{ MockTEnv -> TVar [Definition]
envDefinitions :: TVar [Definition]
, MockTEnv -> WithMockContext
envWithMockContext :: WithMockContext
, MockTEnv -> IORef (Map String (Either Dynamic (MVar Dynamic)))
envNameForwarders :: IORef (Map.Map String (Either Dynamic (MVar Dynamic)))
}
newtype MockT m a = MockT { forall (m :: * -> *) a. MockT m a -> ReaderT MockTEnv m a
unMockT :: ReaderT MockTEnv m a }
deriving ((forall a b. (a -> b) -> MockT m a -> MockT m b)
-> (forall a b. a -> MockT m b -> MockT m a) -> Functor (MockT m)
forall a b. a -> MockT m b -> MockT m a
forall a b. (a -> b) -> MockT m a -> MockT m b
forall (m :: * -> *) a b. Functor m => a -> MockT m b -> MockT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> MockT m a -> MockT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> MockT m a -> MockT m b
fmap :: forall a b. (a -> b) -> MockT m a -> MockT m b
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> MockT m b -> MockT m a
<$ :: forall a b. a -> MockT m b -> MockT m a
Functor, Functor (MockT m)
Functor (MockT m) =>
(forall a. a -> MockT m a)
-> (forall a b. MockT m (a -> b) -> MockT m a -> MockT m b)
-> (forall a b c.
(a -> b -> c) -> MockT m a -> MockT m b -> MockT m c)
-> (forall a b. MockT m a -> MockT m b -> MockT m b)
-> (forall a b. MockT m a -> MockT m b -> MockT m a)
-> Applicative (MockT m)
forall a. a -> MockT m a
forall a b. MockT m a -> MockT m b -> MockT m a
forall a b. MockT m a -> MockT m b -> MockT m b
forall a b. MockT m (a -> b) -> MockT m a -> MockT m b
forall a b c. (a -> b -> c) -> MockT m a -> MockT m b -> MockT m 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
forall (m :: * -> *). Applicative m => Functor (MockT m)
forall (m :: * -> *) a. Applicative m => a -> MockT m a
forall (m :: * -> *) a b.
Applicative m =>
MockT m a -> MockT m b -> MockT m a
forall (m :: * -> *) a b.
Applicative m =>
MockT m a -> MockT m b -> MockT m b
forall (m :: * -> *) a b.
Applicative m =>
MockT m (a -> b) -> MockT m a -> MockT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> MockT m a -> MockT m b -> MockT m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> MockT m a
pure :: forall a. a -> MockT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
MockT m (a -> b) -> MockT m a -> MockT m b
<*> :: forall a b. MockT m (a -> b) -> MockT m a -> MockT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> MockT m a -> MockT m b -> MockT m c
liftA2 :: forall a b c. (a -> b -> c) -> MockT m a -> MockT m b -> MockT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
MockT m a -> MockT m b -> MockT m b
*> :: forall a b. MockT m a -> MockT m b -> MockT m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
MockT m a -> MockT m b -> MockT m a
<* :: forall a b. MockT m a -> MockT m b -> MockT m a
Applicative, Applicative (MockT m)
Applicative (MockT m) =>
(forall a b. MockT m a -> (a -> MockT m b) -> MockT m b)
-> (forall a b. MockT m a -> MockT m b -> MockT m b)
-> (forall a. a -> MockT m a)
-> Monad (MockT m)
forall a. a -> MockT m a
forall a b. MockT m a -> MockT m b -> MockT m b
forall a b. MockT m a -> (a -> MockT m b) -> MockT m b
forall (m :: * -> *). Monad m => Applicative (MockT m)
forall (m :: * -> *) a. Monad m => a -> MockT m a
forall (m :: * -> *) a b.
Monad m =>
MockT m a -> MockT m b -> MockT m b
forall (m :: * -> *) a b.
Monad m =>
MockT m a -> (a -> MockT m b) -> MockT m 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
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
MockT m a -> (a -> MockT m b) -> MockT m b
>>= :: forall a b. MockT m a -> (a -> MockT m b) -> MockT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
MockT m a -> MockT m b -> MockT m b
>> :: forall a b. MockT m a -> MockT m b -> MockT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> MockT m a
return :: forall a. a -> MockT m a
Monad, (forall (m :: * -> *). Monad m => Monad (MockT m)) =>
(forall (m :: * -> *) a. Monad m => m a -> MockT m a)
-> MonadTrans MockT
forall (m :: * -> *). Monad m => Monad (MockT m)
forall (m :: * -> *) a. Monad m => m a -> MockT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall (m :: * -> *) a. Monad m => m a -> MockT m a
lift :: forall (m :: * -> *) a. Monad m => m a -> MockT m a
MonadTrans, Monad (MockT m)
Monad (MockT m) =>
(forall a. IO a -> MockT m a) -> MonadIO (MockT m)
forall a. IO a -> MockT m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (MockT m)
forall (m :: * -> *) a. MonadIO m => IO a -> MockT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> MockT m a
liftIO :: forall a. IO a -> MockT m a
MonadIO)
class Monad m => MonadMockDefs m where
addDefinition :: Definition -> m ()
getDefinitions :: m [Definition]
instance MonadUnliftIO m => MonadUnliftIO (MockT m) where
withRunInIO :: forall b. ((forall a. MockT m a -> IO a) -> IO b) -> MockT m b
withRunInIO (forall a. MockT m a -> IO a) -> IO b
inner = ReaderT MockTEnv m b -> MockT m b
forall (m :: * -> *) a. ReaderT MockTEnv m a -> MockT m a
MockT (ReaderT MockTEnv m b -> MockT m b)
-> ReaderT MockTEnv m b -> MockT m b
forall a b. (a -> b) -> a -> b
$ (MockTEnv -> m b) -> ReaderT MockTEnv m b
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((MockTEnv -> m b) -> ReaderT MockTEnv m b)
-> (MockTEnv -> m b) -> ReaderT MockTEnv m b
forall a b. (a -> b) -> a -> b
$ \MockTEnv
env ->
((forall a. m a -> IO a) -> IO b) -> m b
forall b. ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO b) -> m b)
-> ((forall a. m a -> IO a) -> IO b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run -> (forall a. MockT m a -> IO a) -> IO b
inner (\(MockT ReaderT MockTEnv m a
r) -> m a -> IO a
forall a. m a -> IO a
run (ReaderT MockTEnv m a -> MockTEnv -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT MockTEnv m a
r MockTEnv
env))
instance {-# OVERLAPPING #-} Monad m => MonadWithMockContext (MockT m) where
askWithMockContext :: MockT m WithMockContext
askWithMockContext = ReaderT MockTEnv m WithMockContext -> MockT m WithMockContext
forall (m :: * -> *) a. ReaderT MockTEnv m a -> MockT m a
MockT (ReaderT MockTEnv m WithMockContext -> MockT m WithMockContext)
-> ReaderT MockTEnv m WithMockContext -> MockT m WithMockContext
forall a b. (a -> b) -> a -> b
$ (MockTEnv -> WithMockContext) -> ReaderT MockTEnv m WithMockContext
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MockTEnv -> WithMockContext
envWithMockContext
data Definition =
forall f params sym.
( KnownSymbol sym
, Typeable f
, Typeable params
, params ~ ResolvableParamsOf f
, Typeable (InvocationRecorder params)
) =>
Definition {
()
symbol :: Proxy sym,
()
mockFunction :: f,
()
verification :: Verification f
}
data Verification f
= NoVerification
| Verification (f -> IO ())
runMockT :: MonadIO m => MockT m a -> m a
runMockT :: forall (m :: * -> *) a. MonadIO m => MockT m a -> m a
runMockT (MockT ReaderT MockTEnv m a
r) = do
TVar [Definition]
defsVar <- IO (TVar [Definition]) -> m (TVar [Definition])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar [Definition]) -> m (TVar [Definition]))
-> IO (TVar [Definition]) -> m (TVar [Definition])
forall a b. (a -> b) -> a -> b
$ [Definition] -> IO (TVar [Definition])
forall a. a -> IO (TVar a)
newTVarIO []
TVar [IO ()]
expectsVar <- IO (TVar [IO ()]) -> m (TVar [IO ()])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar [IO ()]) -> m (TVar [IO ()]))
-> IO (TVar [IO ()]) -> m (TVar [IO ()])
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO (TVar [IO ()])
forall a. a -> IO (TVar a)
newTVarIO []
IORef (Map String (Either Dynamic (MVar Dynamic)))
fwdRef <- IO (IORef (Map String (Either Dynamic (MVar Dynamic))))
-> m (IORef (Map String (Either Dynamic (MVar Dynamic))))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (Map String (Either Dynamic (MVar Dynamic))))
-> m (IORef (Map String (Either Dynamic (MVar Dynamic)))))
-> IO (IORef (Map String (Either Dynamic (MVar Dynamic))))
-> m (IORef (Map String (Either Dynamic (MVar Dynamic))))
forall a b. (a -> b) -> a -> b
$ Map String (Either Dynamic (MVar Dynamic))
-> IO (IORef (Map String (Either Dynamic (MVar Dynamic))))
forall a. a -> IO (IORef a)
newIORef Map String (Either Dynamic (MVar Dynamic))
forall k a. Map k a
Map.empty
let env :: MockTEnv
env =
MockTEnv
{ envDefinitions :: TVar [Definition]
envDefinitions = TVar [Definition]
defsVar
, envWithMockContext :: WithMockContext
envWithMockContext = TVar [IO ()] -> WithMockContext
WithMockContext TVar [IO ()]
expectsVar
, envNameForwarders :: IORef (Map String (Either Dynamic (MVar Dynamic)))
envNameForwarders = IORef (Map String (Either Dynamic (MVar Dynamic)))
fwdRef
}
Overlay
overlay <- IO Overlay -> m Overlay
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Overlay
Registry.createOverlay
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Overlay -> IO ()
Registry.installOverlay Overlay
overlay
a
a <- ReaderT MockTEnv m a -> MockTEnv -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT MockTEnv m a
r MockTEnv
env
[IO ()]
actions <- IO [IO ()] -> m [IO ()]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [IO ()] -> m [IO ()]) -> IO [IO ()] -> m [IO ()]
forall a b. (a -> b) -> a -> b
$ TVar [IO ()] -> IO [IO ()]
forall a. TVar a -> IO a
readTVarIO TVar [IO ()]
expectsVar
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
actions
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
Registry.clearOverlay
a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
instance MonadIO m => MonadMockDefs (MockT m) where
addDefinition :: Definition -> MockT m ()
addDefinition Definition
d = ReaderT MockTEnv m () -> MockT m ()
forall (m :: * -> *) a. ReaderT MockTEnv m a -> MockT m a
MockT (ReaderT MockTEnv m () -> MockT m ())
-> ReaderT MockTEnv m () -> MockT m ()
forall a b. (a -> b) -> a -> b
$ (MockTEnv -> m ()) -> ReaderT MockTEnv m ()
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((MockTEnv -> m ()) -> ReaderT MockTEnv m ())
-> (MockTEnv -> m ()) -> ReaderT MockTEnv m ()
forall a b. (a -> b) -> a -> b
$ \MockTEnv
env -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar [Definition] -> ([Definition] -> [Definition]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (MockTEnv -> TVar [Definition]
envDefinitions MockTEnv
env) (([Definition] -> [Definition]) -> STM ())
-> ([Definition] -> [Definition]) -> STM ()
forall a b. (a -> b) -> a -> b
$ \[Definition]
xs ->
case Definition
d of
Definition Proxy sym
sym f
_ Verification f
_ ->
let name :: String
name = Proxy sym -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy sym
sym
exists :: Bool
exists = (Definition -> Bool) -> [Definition] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Definition Proxy sym
sym' f
_ Verification f
_) -> Proxy sym -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy sym
sym' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name) [Definition]
xs
in if Bool
exists then [Definition]
xs else [Definition]
xs [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ [Definition
d]
() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
getDefinitions :: MockT m [Definition]
getDefinitions = ReaderT MockTEnv m [Definition] -> MockT m [Definition]
forall (m :: * -> *) a. ReaderT MockTEnv m a -> MockT m a
MockT (ReaderT MockTEnv m [Definition] -> MockT m [Definition])
-> ReaderT MockTEnv m [Definition] -> MockT m [Definition]
forall a b. (a -> b) -> a -> b
$ (MockTEnv -> m [Definition]) -> ReaderT MockTEnv m [Definition]
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((MockTEnv -> m [Definition]) -> ReaderT MockTEnv m [Definition])
-> (MockTEnv -> m [Definition]) -> ReaderT MockTEnv m [Definition]
forall a b. (a -> b) -> a -> b
$ \MockTEnv
env -> IO [Definition] -> m [Definition]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Definition] -> m [Definition])
-> IO [Definition] -> m [Definition]
forall a b. (a -> b) -> a -> b
$ TVar [Definition] -> IO [Definition]
forall a. TVar a -> IO a
readTVarIO (MockTEnv -> TVar [Definition]
envDefinitions MockTEnv
env)
instance MonadIO m => MonadMockDefs (ReaderT MockTEnv m) where
addDefinition :: Definition -> ReaderT MockTEnv m ()
addDefinition Definition
d = (MockTEnv -> m ()) -> ReaderT MockTEnv m ()
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((MockTEnv -> m ()) -> ReaderT MockTEnv m ())
-> (MockTEnv -> m ()) -> ReaderT MockTEnv m ()
forall a b. (a -> b) -> a -> b
$ \MockTEnv
env -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar [Definition] -> ([Definition] -> [Definition]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (MockTEnv -> TVar [Definition]
envDefinitions MockTEnv
env) (([Definition] -> [Definition]) -> STM ())
-> ([Definition] -> [Definition]) -> STM ()
forall a b. (a -> b) -> a -> b
$ \[Definition]
xs ->
case Definition
d of
Definition Proxy sym
sym f
_ Verification f
_ ->
let name :: String
name = Proxy sym -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy sym
sym
exists :: Bool
exists = (Definition -> Bool) -> [Definition] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Definition Proxy sym
sym' f
_ Verification f
_) -> Proxy sym -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal Proxy sym
sym' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
name) [Definition]
xs
in if Bool
exists then [Definition]
xs else [Definition]
xs [Definition] -> [Definition] -> [Definition]
forall a. [a] -> [a] -> [a]
++ [Definition
d]
getDefinitions :: ReaderT MockTEnv m [Definition]
getDefinitions = (MockTEnv -> m [Definition]) -> ReaderT MockTEnv m [Definition]
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((MockTEnv -> m [Definition]) -> ReaderT MockTEnv m [Definition])
-> (MockTEnv -> m [Definition]) -> ReaderT MockTEnv m [Definition]
forall a b. (a -> b) -> a -> b
$ \MockTEnv
env -> IO [Definition] -> m [Definition]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Definition] -> m [Definition])
-> IO [Definition] -> m [Definition]
forall a b. (a -> b) -> a -> b
$ TVar [Definition] -> IO [Definition]
forall a. TVar a -> IO a
readTVarIO (MockTEnv -> TVar [Definition]
envDefinitions MockTEnv
env)