{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}

-- | The 'SetupFunc' abstraction makes resource provider functions (of type @(a -> IO r) -> IO r@) composable.
module Test.Syd.Def.SetupFunc where

import Control.Exception
import Control.Monad.IO.Class
import Test.Syd.Def.Around
import Test.Syd.Def.AroundAll
import Test.Syd.Def.TestDefM
import Test.Syd.HList

-- * Creating 'SetupFunc's

-- | A function that can provide a 'resource'.
--
-- You can think of this as a potentially-resource-aware version of 'IO resource'.
-- In other words, it's like an 'IO resource' that can clean up after itself.
--
-- This type has a monad instance, which means you can now compose setup functions using regular do-notation.
-- This works together nicely with most supplier functions.
-- Some examples:
--
-- * [Network.Wai.Handler.Warp.testWithApplication](https://hackage.haskell.org/package/warp-3.3.13/docs/Network-Wai-Handler-Warp.html#v:testWithApplication)
-- * [Path.IO.withSystemTempDir](https://hackage.haskell.org/package/path-io-1.6.2/docs/Path-IO.html#v:withSystemTempDir)
--
-- Note that these examples already have functions defined for them in sydtest companion libraries.
newtype SetupFunc resource = SetupFunc
  { forall resource.
SetupFunc resource -> forall r. (resource -> IO r) -> IO r
unSetupFunc :: forall r. (resource -> IO r) -> IO r
  }

instance Functor SetupFunc where
  fmap :: forall a b. (a -> b) -> SetupFunc a -> SetupFunc b
fmap a -> b
f (SetupFunc forall r. (a -> IO r) -> IO r
provideA) = (forall r. (b -> IO r) -> IO r) -> SetupFunc b
forall resource.
(forall r. (resource -> IO r) -> IO r) -> SetupFunc resource
SetupFunc ((forall r. (b -> IO r) -> IO r) -> SetupFunc b)
-> (forall r. (b -> IO r) -> IO r) -> SetupFunc b
forall a b. (a -> b) -> a -> b
$ \b -> IO r
takeB ->
    let takeA :: a -> IO r
takeA = \a
a -> b -> IO r
takeB (b -> IO r) -> b -> IO r
forall a b. (a -> b) -> a -> b
$ a -> b
f a
a
     in (a -> IO r) -> IO r
forall r. (a -> IO r) -> IO r
provideA a -> IO r
takeA

instance Applicative SetupFunc where
  pure :: forall a. a -> SetupFunc a
pure a
a = (forall r. (a -> IO r) -> IO r) -> SetupFunc a
forall resource.
(forall r. (resource -> IO r) -> IO r) -> SetupFunc resource
SetupFunc ((forall r. (a -> IO r) -> IO r) -> SetupFunc a)
-> (forall r. (a -> IO r) -> IO r) -> SetupFunc a
forall a b. (a -> b) -> a -> b
$ \a -> IO r
aFunc -> a -> IO r
aFunc a
a
  (SetupFunc forall r. ((a -> b) -> IO r) -> IO r
provideF) <*> :: forall a b. SetupFunc (a -> b) -> SetupFunc a -> SetupFunc b
<*> (SetupFunc forall r. (a -> IO r) -> IO r
provideA) = (forall r. (b -> IO r) -> IO r) -> SetupFunc b
forall resource.
(forall r. (resource -> IO r) -> IO r) -> SetupFunc resource
SetupFunc ((forall r. (b -> IO r) -> IO r) -> SetupFunc b)
-> (forall r. (b -> IO r) -> IO r) -> SetupFunc b
forall a b. (a -> b) -> a -> b
$ \b -> IO r
takeB ->
    ((a -> b) -> IO r) -> IO r
forall r. ((a -> b) -> IO r) -> IO r
provideF
      ( \a -> b
f ->
          (a -> IO r) -> IO r
forall r. (a -> IO r) -> IO r
provideA
            ( \a
a ->
                b -> IO r
takeB (a -> b
f a
a)
            )
      )

instance Monad SetupFunc where
  (SetupFunc forall r. (a -> IO r) -> IO r
provideA) >>= :: forall a b. SetupFunc a -> (a -> SetupFunc b) -> SetupFunc b
>>= a -> SetupFunc b
m = (forall r. (b -> IO r) -> IO r) -> SetupFunc b
forall resource.
(forall r. (resource -> IO r) -> IO r) -> SetupFunc resource
SetupFunc ((forall r. (b -> IO r) -> IO r) -> SetupFunc b)
-> (forall r. (b -> IO r) -> IO r) -> SetupFunc b
forall a b. (a -> b) -> a -> b
$ \b -> IO r
takeB ->
    (a -> IO r) -> IO r
forall r. (a -> IO r) -> IO r
provideA
      ( \a
a ->
          let (SetupFunc forall r. (b -> IO r) -> IO r
provideB) = a -> SetupFunc b
m a
a
           in (b -> IO r) -> IO r
forall r. (b -> IO r) -> IO r
provideB (\b
b -> b -> IO r
takeB b
b)
      )

instance MonadIO SetupFunc where
  liftIO :: forall a. IO a -> SetupFunc a
liftIO IO a
ioFunc = (forall r. (a -> IO r) -> IO r) -> SetupFunc a
forall resource.
(forall r. (resource -> IO r) -> IO r) -> SetupFunc resource
SetupFunc ((forall r. (a -> IO r) -> IO r) -> SetupFunc a)
-> (forall r. (a -> IO r) -> IO r) -> SetupFunc a
forall a b. (a -> b) -> a -> b
$ \a -> IO r
takeA -> do
    IO a
ioFunc IO a -> (a -> IO r) -> IO r
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> IO r
takeA

-- | Turn the arguments that you would normally give to 'bracket' into a 'SetupFunc'.
bracketSetupFunc :: IO resource -> (resource -> IO r) -> SetupFunc resource
bracketSetupFunc :: forall resource r.
IO resource -> (resource -> IO r) -> SetupFunc resource
bracketSetupFunc IO resource
acquire resource -> IO r
release = (forall r. (resource -> IO r) -> IO r) -> SetupFunc resource
forall resource.
(forall r. (resource -> IO r) -> IO r) -> SetupFunc resource
SetupFunc ((forall r. (resource -> IO r) -> IO r) -> SetupFunc resource)
-> (forall r. (resource -> IO r) -> IO r) -> SetupFunc resource
forall a b. (a -> b) -> a -> b
$ \resource -> IO r
func -> IO resource -> (resource -> IO r) -> (resource -> IO r) -> IO r
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO resource
acquire resource -> IO r
release resource -> IO r
func

-- * Using 'SetupFunc' to define your test suite

-- | Use 'around' with a 'SetupFunc'
setupAround ::
  SetupFunc inner ->
  TestDefM outers inner result ->
  TestDefM outers any result
setupAround :: forall inner (outers :: [*]) result any.
SetupFunc inner
-> TestDefM outers inner result -> TestDefM outers any result
setupAround SetupFunc inner
setupFunc = (any -> SetupFunc inner)
-> TestDefM outers inner result -> TestDefM outers any result
forall oldInner newInner (outers :: [*]) result.
(oldInner -> SetupFunc newInner)
-> TestDefM outers newInner result
-> TestDefM outers oldInner result
setupAroundWith ((any -> SetupFunc inner)
 -> TestDefM outers inner result -> TestDefM outers any result)
-> (any -> SetupFunc inner)
-> TestDefM outers inner result
-> TestDefM outers any result
forall a b. (a -> b) -> a -> b
$ \any
_ -> SetupFunc inner
setupFunc

-- | Use 'aroundWith' with a 'SetupFunc'
setupAroundWith ::
  (oldInner -> SetupFunc newInner) ->
  TestDefM outers newInner result ->
  TestDefM outers oldInner result
setupAroundWith :: forall oldInner newInner (outers :: [*]) result.
(oldInner -> SetupFunc newInner)
-> TestDefM outers newInner result
-> TestDefM outers oldInner result
setupAroundWith oldInner -> SetupFunc newInner
takeOldInner = ((newInner -> IO ()) -> oldInner -> IO ())
-> TestDefM outers newInner result
-> TestDefM outers oldInner result
forall newInner oldInner (outers :: [*]) result.
((newInner -> IO ()) -> oldInner -> IO ())
-> TestDefM outers newInner result
-> TestDefM outers oldInner result
aroundWith (((newInner -> IO ()) -> oldInner -> IO ())
 -> TestDefM outers newInner result
 -> TestDefM outers oldInner result)
-> ((newInner -> IO ()) -> oldInner -> IO ())
-> TestDefM outers newInner result
-> TestDefM outers oldInner result
forall a b. (a -> b) -> a -> b
$ \newInner -> IO ()
takeNewInner oldInner
oldInner ->
  let SetupFunc forall r. (newInner -> IO r) -> IO r
provideNewInner = oldInner -> SetupFunc newInner
takeOldInner oldInner
oldInner
   in (newInner -> IO ()) -> IO ()
forall r. (newInner -> IO r) -> IO r
provideNewInner ((newInner -> IO ()) -> IO ()) -> (newInner -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \newInner
newInner -> newInner -> IO ()
takeNewInner newInner
newInner

-- | Use 'aroundWith'' with a 'SetupFunc'
setupAroundWith' ::
  (HContains outers outer) =>
  (outer -> oldInner -> SetupFunc newInner) ->
  TestDefM outers newInner result ->
  TestDefM outers oldInner result
setupAroundWith' :: forall (outers :: [*]) outer oldInner newInner result.
HContains outers outer =>
(outer -> oldInner -> SetupFunc newInner)
-> TestDefM outers newInner result
-> TestDefM outers oldInner result
setupAroundWith' outer -> oldInner -> SetupFunc newInner
f = ((outer -> newInner -> IO ()) -> outer -> oldInner -> IO ())
-> TestDefM outers newInner result
-> TestDefM outers oldInner result
forall newInner oldInner outer result (outers :: [*]).
HContains outers outer =>
((outer -> newInner -> IO ()) -> outer -> oldInner -> IO ())
-> TestDefM outers newInner result
-> TestDefM outers oldInner result
aroundWith' (((outer -> newInner -> IO ()) -> outer -> oldInner -> IO ())
 -> TestDefM outers newInner result
 -> TestDefM outers oldInner result)
-> ((outer -> newInner -> IO ()) -> outer -> oldInner -> IO ())
-> TestDefM outers newInner result
-> TestDefM outers oldInner result
forall a b. (a -> b) -> a -> b
$ \outer -> newInner -> IO ()
takeBoth outer
outer oldInner
oldInner ->
  let SetupFunc forall r. (newInner -> IO r) -> IO r
provideNewInner = outer -> oldInner -> SetupFunc newInner
f outer
outer oldInner
oldInner
   in (newInner -> IO ()) -> IO ()
forall r. (newInner -> IO r) -> IO r
provideNewInner ((newInner -> IO ()) -> IO ()) -> (newInner -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \newInner
newInner -> outer -> newInner -> IO ()
takeBoth outer
outer newInner
newInner

-- | Use all outer resources and the inner resource to provide a new inner resource
-- This is a more constrained version of 'setupAroundWith'' to more easily allow providing an inner resource based on multiple outer resources
setupAroundWithAll :: (HList outers -> oldInner -> SetupFunc newInner) -> TestDefM outers newInner result -> TestDefM outers oldInner result
setupAroundWithAll :: forall (outers :: [*]) oldInner newInner result.
(HList outers -> oldInner -> SetupFunc newInner)
-> TestDefM outers newInner result
-> TestDefM outers oldInner result
setupAroundWithAll = (HList outers -> oldInner -> SetupFunc newInner)
-> TestDefM outers newInner result
-> TestDefM outers oldInner result
forall (outers :: [*]) outer oldInner newInner result.
HContains outers outer =>
(outer -> oldInner -> SetupFunc newInner)
-> TestDefM outers newInner result
-> TestDefM outers oldInner result
setupAroundWith'

-- | Use 'aroundAll' with a 'SetupFunc'
setupAroundAll ::
  SetupFunc outer ->
  TestDefM (outer : outers) inner result ->
  TestDefM outers inner result
setupAroundAll :: forall outer (outers :: [*]) inner result.
SetupFunc outer
-> TestDefM (outer : outers) inner result
-> TestDefM outers inner result
setupAroundAll SetupFunc outer
sf = ((outer -> IO ()) -> IO ())
-> TestDefM (outer : outers) inner result
-> TestDefM outers inner result
forall outer (otherOuters :: [*]) inner result.
((outer -> IO ()) -> IO ())
-> TestDefM (outer : otherOuters) inner result
-> TestDefM otherOuters inner result
aroundAll (((outer -> IO ()) -> IO ())
 -> TestDefM (outer : outers) inner result
 -> TestDefM outers inner result)
-> ((outer -> IO ()) -> IO ())
-> TestDefM (outer : outers) inner result
-> TestDefM outers inner result
forall a b. (a -> b) -> a -> b
$ \outer -> IO ()
func -> SetupFunc outer -> forall r. (outer -> IO r) -> IO r
forall resource.
SetupFunc resource -> forall r. (resource -> IO r) -> IO r
unSetupFunc SetupFunc outer
sf outer -> IO ()
func

-- | Use 'aroundAllWith' with a 'SetupFunc'
setupAroundAllWith ::
  (oldOuter -> SetupFunc newOuter) ->
  TestDefM (newOuter ': oldOuter ': outers) inner result ->
  TestDefM (oldOuter ': outers) inner result
setupAroundAllWith :: forall oldOuter newOuter (outers :: [*]) inner result.
(oldOuter -> SetupFunc newOuter)
-> TestDefM (newOuter : oldOuter : outers) inner result
-> TestDefM (oldOuter : outers) inner result
setupAroundAllWith oldOuter -> SetupFunc newOuter
sf = ((newOuter -> IO ()) -> oldOuter -> IO ())
-> TestDefM (newOuter : oldOuter : outers) inner result
-> TestDefM (oldOuter : outers) inner result
forall newOuter oldOuter (otherOuters :: [*]) inner result.
((newOuter -> IO ()) -> oldOuter -> IO ())
-> TestDefM (newOuter : oldOuter : otherOuters) inner result
-> TestDefM (oldOuter : otherOuters) inner result
aroundAllWith (((newOuter -> IO ()) -> oldOuter -> IO ())
 -> TestDefM (newOuter : oldOuter : outers) inner result
 -> TestDefM (oldOuter : outers) inner result)
-> ((newOuter -> IO ()) -> oldOuter -> IO ())
-> TestDefM (newOuter : oldOuter : outers) inner result
-> TestDefM (oldOuter : outers) inner result
forall a b. (a -> b) -> a -> b
$ \newOuter -> IO ()
takeNewOuter oldOuter
oldOuter ->
  let SetupFunc forall r. (newOuter -> IO r) -> IO r
provideNewOuter = oldOuter -> SetupFunc newOuter
sf oldOuter
oldOuter
   in (newOuter -> IO ()) -> IO ()
forall r. (newOuter -> IO r) -> IO r
provideNewOuter ((newOuter -> IO ()) -> IO ()) -> (newOuter -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \newOuter
newOuter -> newOuter -> IO ()
takeNewOuter newOuter
newOuter