{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Sandwich.WebDriver.Types (
  ExampleWithWebDriver
  , HasWebDriverContext
  , HasWebDriverSessionContext
  , ContextWithSession

  , hoistExample

  , webdriver

  -- * Constraint synonyms
  , BaseMonad
  , BaseMonadContext
  , WebDriverMonad
  , WebDriverSessionMonad
  ) where

import Control.Exception.Safe as ES
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.IORef
import GHC.Stack
import Test.Sandwich
import Test.Sandwich.Internal
import Test.Sandwich.WebDriver.Internal.Types
import qualified Test.WebDriver.Class as W
import qualified Test.WebDriver.Internal as WI
import qualified Test.WebDriver.Session as W


type ContextWithSession context = LabelValue "webdriverSession" WebDriverSession :> context

instance (MonadIO m, HasLabel context "webdriverSession" WebDriverSession) => W.WDSessionState (ExampleT context m) where
  getSession :: ExampleT context m WDSession
getSession = do
    (Session
_, IORef WDSession
sessVar) <- Label "webdriverSession" WebDriverSession
-> ExampleT context m WebDriverSession
forall (m :: * -> *) context (l :: Symbol) a.
(Monad m, HasLabel context l a, HasCallStack,
 MonadReader context m) =>
Label l a -> m a
getContext Label "webdriverSession" WebDriverSession
webdriverSession
    IO WDSession -> ExampleT context m WDSession
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO WDSession -> ExampleT context m WDSession)
-> IO WDSession -> ExampleT context m WDSession
forall a b. (a -> b) -> a -> b
$ IORef WDSession -> IO WDSession
forall a. IORef a -> IO a
readIORef IORef WDSession
sessVar
  putSession :: WDSession -> ExampleT context m ()
putSession WDSession
sess = do
    (Session
_, IORef WDSession
sessVar) <- Label "webdriverSession" WebDriverSession
-> ExampleT context m WebDriverSession
forall (m :: * -> *) context (l :: Symbol) a.
(Monad m, HasLabel context l a, HasCallStack,
 MonadReader context m) =>
Label l a -> m a
getContext Label "webdriverSession" WebDriverSession
webdriverSession
    IO () -> ExampleT context m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExampleT context m ()) -> IO () -> ExampleT context m ()
forall a b. (a -> b) -> a -> b
$ IORef WDSession -> WDSession -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef WDSession
sessVar WDSession
sess

-- Implementation copied from that of the WD monad implementation
instance (MonadIO m, MonadThrow m, HasLabel context "webdriverSession" WebDriverSession, MonadBaseControl IO m) => W.WebDriver (ExampleT context m) where
  doCommand :: Method -> Text -> a -> ExampleT context m b
doCommand Method
method Text
path a
args = Method -> Text -> a -> ExampleT context m Request
forall (s :: * -> *) a.
(WDSessionState s, ToJSON a) =>
Method -> Text -> a -> s Request
WI.mkRequest Method
method Text
path a
args
    ExampleT context m Request
-> (Request
    -> ExampleT context m (Either SomeException (Response ByteString)))
-> ExampleT context m (Either SomeException (Response ByteString))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Request
-> ExampleT context m (Either SomeException (Response ByteString))
forall (s :: * -> *).
WDSessionStateIO s =>
Request -> s (Either SomeException (Response ByteString))
WI.sendHTTPRequest
    ExampleT context m (Either SomeException (Response ByteString))
-> (Either SomeException (Response ByteString)
    -> ExampleT context m (Response ByteString))
-> ExampleT context m (Response ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> ExampleT context m (Response ByteString))
-> (Response ByteString
    -> ExampleT context m (Response ByteString))
-> Either SomeException (Response ByteString)
-> ExampleT context m (Response ByteString)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> ExampleT context m (Response ByteString)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO Response ByteString -> ExampleT context m (Response ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return
    ExampleT context m (Response ByteString)
-> (Response ByteString
    -> ExampleT context m (Either SomeException b))
-> ExampleT context m (Either SomeException b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response ByteString -> ExampleT context m (Either SomeException b)
forall (s :: * -> *) a.
(HasCallStack, WDSessionStateControl s, FromJSON a) =>
Response ByteString -> s (Either SomeException a)
WI.getJSONResult
    ExampleT context m (Either SomeException b)
-> (Either SomeException b -> ExampleT context m b)
-> ExampleT context m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (SomeException -> ExampleT context m b)
-> (b -> ExampleT context m b)
-> Either SomeException b
-> ExampleT context m b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> ExampleT context m b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO b -> ExampleT context m b
forall (m :: * -> *) a. Monad m => a -> m a
return

type HasWebDriverContext context = HasLabel context "webdriver" WebDriver
type HasWebDriverSessionContext context = HasLabel context "webdriverSession" WebDriverSession
type ExampleWithWebDriver context wd = (W.WDSessionState (ExampleT context wd), W.WebDriver wd)

hoistExample :: ExampleT context IO a -> ExampleT (ContextWithSession context) IO a
hoistExample :: ExampleT context IO a -> ExampleT (ContextWithSession context) IO a
hoistExample (ExampleT ReaderT context (LoggingT IO) a
r) = ReaderT (ContextWithSession context) (LoggingT IO) a
-> ExampleT (ContextWithSession context) IO a
forall context (m :: * -> *) a.
ReaderT context (LoggingT m) a -> ExampleT context m a
ExampleT (ReaderT (ContextWithSession context) (LoggingT IO) a
 -> ExampleT (ContextWithSession context) IO a)
-> ReaderT (ContextWithSession context) (LoggingT IO) a
-> ExampleT (ContextWithSession context) IO a
forall a b. (a -> b) -> a -> b
$ ReaderT context (LoggingT IO) a
-> ReaderT (ContextWithSession context) (LoggingT IO) a
forall r (m :: * -> *) a a. ReaderT r m a -> ReaderT (a :> r) m a
transformContext ReaderT context (LoggingT IO) a
r
  where transformContext :: ReaderT r m a -> ReaderT (a :> r) m a
transformContext = ((a :> r) -> r) -> ReaderT r m a -> ReaderT (a :> r) m a
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT (\(a
_ :> r
ctx) -> r
ctx)

type WebDriverMonad m context = (HasCallStack, HasLabel context "webdriver" WebDriver, MonadIO m, MonadBaseControl IO m)
type WebDriverSessionMonad m context = (WebDriverMonad m context, MonadReader context m, HasLabel context "webdriverSession" WebDriverSession)
type BaseMonad m = (HasCallStack, MonadIO m, MonadCatch m, MonadBaseControl IO m, MonadMask m)
type BaseMonadContext m context = (BaseMonad m, HasBaseContext context)