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

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

  , hoistExample

  , webdriver

  , wdDownloadDir

  -- * 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) <- 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
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef WDSession
sessVar
  putSession :: WDSession -> ExampleT context m ()
putSession WDSession
sess = do
    (Session
_, IORef WDSession
sessVar) <- 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
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 :: forall a b.
(HasCallStack, ToJSON a, FromJSON b) =>
Method -> Text -> a -> ExampleT context m b
doCommand Method
method Text
path a
args = forall (s :: * -> *) a.
(WDSessionState s, ToJSON a) =>
Method -> Text -> a -> s Request
WI.mkRequest Method
method Text
path a
args
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (s :: * -> *).
WDSessionStateIO s =>
Request -> s (Either SomeException (Response ByteString))
WI.sendHTTPRequest
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO forall (m :: * -> *) a. Monad m => a -> m a
return
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (s :: * -> *) a.
(HasCallStack, WDSessionStateControl s, FromJSON a) =>
Response ByteString -> s (Either SomeException a)
WI.getJSONResult
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO 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 :: forall context a.
ExampleT context IO a -> ExampleT (ContextWithSession context) IO a
hoistExample (ExampleT ReaderT context (LoggingT IO) a
r) = forall context (m :: * -> *) a.
ReaderT context (LoggingT m) a -> ExampleT context m a
ExampleT forall a b. (a -> b) -> a -> b
$ 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 = 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)