{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE TypeOperators #-}

-- | Functions for retrieving context information from within tests.

module Test.Sandwich.Contexts where

import Control.Monad.Reader
import Data.Typeable
import GHC.TypeLits (KnownSymbol)
import Test.Sandwich.Types.ArgParsing
import Test.Sandwich.Types.RunTree
import Test.Sandwich.Types.Spec


-- | Get a context by its label.
getContext :: (HasLabel context l a, MonadReader context m) => Label l a -> m a
getContext :: forall context (l :: Symbol) a (m :: * -> *).
(HasLabel context l a, MonadReader context m) =>
Label l a -> m a
getContext = (context -> a) -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((context -> a) -> m a)
-> (Label l a -> context -> a) -> Label l a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label l a -> context -> a
forall context (l :: Symbol) a.
HasLabel context l a =>
Label l a -> context -> a
getLabelValue

-- | Try to get a context by its label. If not is in scope, returns 'Nothing'.
getContextMaybe :: (MonadReader context m, KnownSymbol l, Typeable context, Typeable a) => Label l a -> m (Maybe a)
getContextMaybe :: forall context (m :: * -> *) (l :: Symbol) a.
(MonadReader context m, KnownSymbol l, Typeable context,
 Typeable a) =>
Label l a -> m (Maybe a)
getContextMaybe = (context -> Maybe a) -> m (Maybe a)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((context -> Maybe a) -> m (Maybe a))
-> (Label l a -> context -> Maybe a) -> Label l a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label l a -> context -> Maybe a
forall context (l :: Symbol) a.
(KnownSymbol l, Typeable a, Typeable context) =>
Label l a -> context -> Maybe a
getLabelValueMaybe

-- | Get the root folder of the on-disk test tree for the current run.
-- Will be 'Nothing' if the run isn't configured to use the disk.
getRunRoot :: (HasBaseContextMonad context m) => m (Maybe FilePath)
getRunRoot :: forall context (m :: * -> *).
HasBaseContextMonad context m =>
m (Maybe FilePath)
getRunRoot = (context -> Maybe FilePath) -> m (Maybe FilePath)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BaseContext -> Maybe FilePath
baseContextRunRoot (BaseContext -> Maybe FilePath)
-> (context -> BaseContext) -> context -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. context -> BaseContext
forall a. HasBaseContext a => a -> BaseContext
getBaseContext)

-- | Get the on-disk folder corresponding to the current node.
-- Will be 'Nothing' if the run isn't configured to use the disk, or if the current node is configured
-- not to create a folder.
getCurrentFolder :: (HasBaseContextMonad context m) => m (Maybe FilePath)
getCurrentFolder :: forall context (m :: * -> *).
HasBaseContextMonad context m =>
m (Maybe FilePath)
getCurrentFolder = (context -> Maybe FilePath) -> m (Maybe FilePath)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (BaseContext -> Maybe FilePath
baseContextPath (BaseContext -> Maybe FilePath)
-> (context -> BaseContext) -> context -> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. context -> BaseContext
forall a. HasBaseContext a => a -> BaseContext
getBaseContext)

-- | Get the command line options, if configured.
-- Using the 'runSandwichWithCommandLineArgs' family of main functions will introduce these, or you can
-- introduce them manually.
getCommandLineOptions :: forall a context m. (HasCommandLineOptions context a, MonadReader context m) => m (CommandLineOptions a)
getCommandLineOptions :: forall a context (m :: * -> *).
(HasCommandLineOptions context a, MonadReader context m) =>
m (CommandLineOptions a)
getCommandLineOptions = Label "commandLineOptions" (CommandLineOptions a)
-> m (CommandLineOptions a)
forall context (l :: Symbol) a (m :: * -> *).
(HasLabel context l a, MonadReader context m) =>
Label l a -> m a
getContext Label "commandLineOptions" (CommandLineOptions a)
forall a. Label "commandLineOptions" (CommandLineOptions a)
commandLineOptions

-- | Get existentially wrapped command line options, if configured.
-- Using the 'runSandwichWithCommandLineArgs' family of main functions will introduce these, or you can
-- introduce them manually.
getSomeCommandLineOptions :: forall context m. (HasSomeCommandLineOptions context, MonadReader context m) => m SomeCommandLineOptions
getSomeCommandLineOptions :: forall context (m :: * -> *).
(HasSomeCommandLineOptions context, MonadReader context m) =>
m SomeCommandLineOptions
getSomeCommandLineOptions = Label "someCommandLineOptions" SomeCommandLineOptions
-> m SomeCommandLineOptions
forall context (l :: Symbol) a (m :: * -> *).
(HasLabel context l a, MonadReader context m) =>
Label l a -> m a
getContext Label "someCommandLineOptions" SomeCommandLineOptions
someCommandLineOptions

-- | Get the user command line options, if configured.
-- This just calls 'getCommandLineOptions' and pulls out the user options.
getUserCommandLineOptions :: (HasCommandLineOptions context a, MonadReader context m) => m a
getUserCommandLineOptions :: forall context a (m :: * -> *).
(HasCommandLineOptions context a, MonadReader context m) =>
m a
getUserCommandLineOptions = CommandLineOptions a -> a
forall a. CommandLineOptions a -> a
optUserOptions (CommandLineOptions a -> a) -> m (CommandLineOptions a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Label "commandLineOptions" (CommandLineOptions a)
-> m (CommandLineOptions a)
forall context (l :: Symbol) a (m :: * -> *).
(HasLabel context l a, MonadReader context m) =>
Label l a -> m a
getContext Label "commandLineOptions" (CommandLineOptions a)
forall a. Label "commandLineOptions" (CommandLineOptions a)
commandLineOptions

-- * Low-level context management helpers

-- | Push a label to the context.
pushContext :: forall m l a intro context. Label l intro -> intro -> ExampleT (LabelValue l intro :> context) m a -> ExampleT context m a
pushContext :: forall (m :: * -> *) (l :: Symbol) a intro context.
Label l intro
-> intro
-> ExampleT (LabelValue l intro :> context) m a
-> ExampleT context m a
pushContext Label l intro
_label intro
value (ExampleT ReaderT (LabelValue l intro :> context) (LoggingT m) a
action) = do
  ReaderT context (LoggingT m) a -> ExampleT context m a
forall context (m :: * -> *) a.
ReaderT context (LoggingT m) a -> ExampleT context m a
ExampleT (ReaderT context (LoggingT m) a -> ExampleT context m a)
-> ReaderT context (LoggingT m) a -> ExampleT context m a
forall a b. (a -> b) -> a -> b
$ (context -> LabelValue l intro :> context)
-> ReaderT (LabelValue l intro :> context) (LoggingT m) a
-> ReaderT context (LoggingT m) a
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT (\context
context -> intro -> LabelValue l intro
forall (l :: Symbol) a. a -> LabelValue l a
LabelValue intro
value LabelValue l intro -> context -> LabelValue l intro :> context
forall a b. a -> b -> a :> b
:> context
context) (ReaderT (LabelValue l intro :> context) (LoggingT m) a
 -> ReaderT context (LoggingT m) a)
-> ReaderT (LabelValue l intro :> context) (LoggingT m) a
-> ReaderT context (LoggingT m) a
forall a b. (a -> b) -> a -> b
$ ReaderT (LabelValue l intro :> context) (LoggingT m) a
action

-- | Remove a label from the context.
popContext :: forall m l a intro context. Label l intro -> ExampleT context m a -> ExampleT (LabelValue l intro :> context) m a
popContext :: forall (m :: * -> *) (l :: Symbol) a intro context.
Label l intro
-> ExampleT context m a
-> ExampleT (LabelValue l intro :> context) m a
popContext Label l intro
_label (ExampleT ReaderT context (LoggingT m) a
action) = do
  ReaderT (LabelValue l intro :> context) (LoggingT m) a
-> ExampleT (LabelValue l intro :> context) m a
forall context (m :: * -> *) a.
ReaderT context (LoggingT m) a -> ExampleT context m a
ExampleT (ReaderT (LabelValue l intro :> context) (LoggingT m) a
 -> ExampleT (LabelValue l intro :> context) m a)
-> ReaderT (LabelValue l intro :> context) (LoggingT m) a
-> ExampleT (LabelValue l intro :> context) m a
forall a b. (a -> b) -> a -> b
$ ((LabelValue l intro :> context) -> context)
-> ReaderT context (LoggingT m) a
-> ReaderT (LabelValue l intro :> context) (LoggingT m) a
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT (\(LabelValue l intro
_ :> context
context) -> context
context) (ReaderT context (LoggingT m) a
 -> ReaderT (LabelValue l intro :> context) (LoggingT m) a)
-> ReaderT context (LoggingT m) a
-> ReaderT (LabelValue l intro :> context) (LoggingT m) a
forall a b. (a -> b) -> a -> b
$ ReaderT context (LoggingT m) a
action