{-# LANGUAGE RankNTypes #-}

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

import Control.Category as Cat
import Control.Monad.IO.Class
import Test.Syd.Def.Around
import Test.Syd.Def.TestDefM
import Test.Syd.HList

-- | A function that can provide an 'new' given an 'old'.
--
-- You can think of this as a potentially-resource-aware version of 'old -> IO new'.
--
-- This type has a monad instance, which means you can now compose setup functions using regular do-notation.
newtype SetupFunc old new = SetupFunc
  { SetupFunc old new -> forall r. (new -> IO r) -> old -> IO r
unSetupFunc :: forall r. (new -> IO r) -> (old -> IO r)
  }

instance Functor (SetupFunc old) where
  fmap :: (a -> b) -> SetupFunc old a -> SetupFunc old b
fmap a -> b
f (SetupFunc forall r. (a -> IO r) -> old -> IO r
provideA) = (forall r. (b -> IO r) -> old -> IO r) -> SetupFunc old b
forall old new.
(forall r. (new -> IO r) -> old -> IO r) -> SetupFunc old new
SetupFunc ((forall r. (b -> IO r) -> old -> IO r) -> SetupFunc old b)
-> (forall r. (b -> IO r) -> old -> IO r) -> SetupFunc old b
forall a b. (a -> b) -> a -> b
$ \b -> IO r
takeB old
c ->
    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) -> old -> IO r
forall r. (a -> IO r) -> old -> IO r
provideA a -> IO r
takeA old
c

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

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

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

instance Category SetupFunc where
  id :: SetupFunc a a
id = (forall r. (a -> IO r) -> a -> IO r) -> SetupFunc a a
forall old new.
(forall r. (new -> IO r) -> old -> IO r) -> SetupFunc old new
SetupFunc forall a. a -> a
forall r. (a -> IO r) -> a -> IO r
Prelude.id
  . :: SetupFunc b c -> SetupFunc a b -> SetupFunc a c
(.) = SetupFunc b c -> SetupFunc a b -> SetupFunc a c
forall b c a. SetupFunc b c -> SetupFunc a b -> SetupFunc a c
composeSetupFunc

-- | Turn a simple provider function into a 'SetupFunc'.
--
-- 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)
makeSimpleSetupFunc ::
  (forall result. (resource -> IO result) -> IO result) ->
  SetupFunc () resource
makeSimpleSetupFunc :: (forall result. (resource -> IO result) -> IO result)
-> SetupFunc () resource
makeSimpleSetupFunc forall result. (resource -> IO result) -> IO result
provideA = (forall r. (resource -> IO r) -> () -> IO r)
-> SetupFunc () resource
forall old new.
(forall r. (new -> IO r) -> old -> IO r) -> SetupFunc old new
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
takeA () -> (resource -> IO r) -> IO r
forall result. (resource -> IO result) -> IO result
provideA ((resource -> IO r) -> IO r) -> (resource -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \resource
a -> resource -> IO r
takeA resource
a

-- | Use a 'SetupFunc ()' as a simple provider function.
--
-- This is the opposite of the 'makeSimpleSetupFunc' function
useSimpleSetupFunc ::
  SetupFunc () resource -> (forall result. (resource -> IO result) -> IO result)
useSimpleSetupFunc :: SetupFunc () resource
-> forall result. (resource -> IO result) -> IO result
useSimpleSetupFunc (SetupFunc forall r. (resource -> IO r) -> () -> IO r
provideAWithUnit) resource -> IO result
takeA = (resource -> IO result) -> () -> IO result
forall r. (resource -> IO r) -> () -> IO r
provideAWithUnit (\resource
a -> resource -> IO result
takeA resource
a) ()

-- | Wrap a function that produces a 'SetupFunc' to into a 'SetupFunc'.
--
-- This is useful to combine a given 'SetupFunc b' with other 'SetupFunc ()'s as follows:
--
-- > mySetupFunc :: SetupFunc B A
-- > mySetupFunc = wrapSetupFunc $ \b -> do
-- >   r <- setupSomething
-- >   c <- setupSomethingElse b r
-- >   pure $ somehowCombine c r
-- >
-- > setupSomething :: SetupFunc () R
-- > setupSomething :: B -> R -> SetupFunc () C
-- > somehowCombine :: C -> R -> A
wrapSetupFunc ::
  (old -> SetupFunc () new) ->
  SetupFunc old new
wrapSetupFunc :: (old -> SetupFunc () new) -> SetupFunc old new
wrapSetupFunc old -> SetupFunc () new
bFunc = (forall r. (new -> IO r) -> old -> IO r) -> SetupFunc old new
forall old new.
(forall r. (new -> IO r) -> old -> IO r) -> SetupFunc old new
SetupFunc ((forall r. (new -> IO r) -> old -> IO r) -> SetupFunc old new)
-> (forall r. (new -> IO r) -> old -> IO r) -> SetupFunc old new
forall a b. (a -> b) -> a -> b
$ \new -> IO r
takeA old
b ->
  let SetupFunc forall r. (new -> IO r) -> () -> IO r
provideAWithUnit = old -> SetupFunc () new
bFunc old
b
   in (new -> IO r) -> () -> IO r
forall r. (new -> IO r) -> () -> IO r
provideAWithUnit (\new
a -> new -> IO r
takeA new
a) ()

-- | Unwrap a 'SetupFunc' into a function that produces a 'SetupFunc'
--
-- This is the opposite of 'wrapSetupFunc'.
unwrapSetupFunc ::
  SetupFunc old new -> (old -> SetupFunc () new)
unwrapSetupFunc :: SetupFunc old new -> old -> SetupFunc () new
unwrapSetupFunc (SetupFunc forall r. (new -> IO r) -> old -> IO r
provideAWithB) old
b = (forall r. (new -> IO r) -> () -> IO r) -> SetupFunc () new
forall old new.
(forall r. (new -> IO r) -> old -> IO r) -> SetupFunc old new
SetupFunc ((forall r. (new -> IO r) -> () -> IO r) -> SetupFunc () new)
-> (forall r. (new -> IO r) -> () -> IO r) -> SetupFunc () new
forall a b. (a -> b) -> a -> b
$ \new -> IO r
takeA () ->
  (new -> IO r) -> old -> IO r
forall r. (new -> IO r) -> old -> IO r
provideAWithB (\new
a -> new -> IO r
takeA new
a) old
b

-- | Compose two setup functions.
--
-- This is '(.)' but for 'SetupFunc's
composeSetupFunc ::
  SetupFunc newer newest ->
  SetupFunc old newer ->
  SetupFunc old newest
composeSetupFunc :: SetupFunc newer newest
-> SetupFunc old newer -> SetupFunc old newest
composeSetupFunc (SetupFunc forall r. (newest -> IO r) -> newer -> IO r
provideAWithB) (SetupFunc forall r. (newer -> IO r) -> old -> IO r
provideBWithC) = (forall r. (newest -> IO r) -> old -> IO r) -> SetupFunc old newest
forall old new.
(forall r. (new -> IO r) -> old -> IO r) -> SetupFunc old new
SetupFunc ((forall r. (newest -> IO r) -> old -> IO r)
 -> SetupFunc old newest)
-> (forall r. (newest -> IO r) -> old -> IO r)
-> SetupFunc old newest
forall a b. (a -> b) -> a -> b
$ \newest -> IO r
takeA old
c ->
  (newer -> IO r) -> old -> IO r
forall r. (newer -> IO r) -> old -> IO r
provideBWithC
    ( \newer
b ->
        (newest -> IO r) -> newer -> IO r
forall r. (newest -> IO r) -> newer -> IO r
provideAWithB
          ( \newest
a -> newest -> IO r
takeA newest
a
          )
          newer
b
    )
    old
c

-- | Connect two setup functions.
--
-- This is basically 'flip (.)' but for 'SetupFunc's.
-- It's exactly 'flip composeSetupFunc'.
connectSetupFunc ::
  SetupFunc old newer ->
  SetupFunc newer newest ->
  SetupFunc old newest
connectSetupFunc :: SetupFunc old newer
-> SetupFunc newer newest -> SetupFunc old newest
connectSetupFunc = (SetupFunc newer newest
 -> SetupFunc old newer -> SetupFunc old newest)
-> SetupFunc old newer
-> SetupFunc newer newest
-> SetupFunc old newest
forall a b c. (a -> b -> c) -> b -> a -> c
flip SetupFunc newer newest
-> SetupFunc old newer -> SetupFunc old newest
forall b c a. SetupFunc b c -> SetupFunc a b -> SetupFunc a c
composeSetupFunc

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

-- | Use 'aroundWith' with a 'SetupFunc'
setupAroundWith ::
  SetupFunc oldInner newInner ->
  TestDefM outers newInner result ->
  TestDefM outers oldInner result
setupAroundWith :: SetupFunc oldInner newInner
-> TestDefM outers newInner result
-> TestDefM outers oldInner result
setupAroundWith (SetupFunc forall r. (newInner -> IO r) -> oldInner -> IO r
f) = ((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 ()
forall r. (newInner -> IO r) -> oldInner -> IO r
f

-- | Use 'aroundWith'' with a 'SetupFunc'
setupAroundWith' ::
  HContains outers outer =>
  (outer -> SetupFunc oldInner newInner) ->
  TestDefM outers newInner result ->
  TestDefM outers oldInner result
setupAroundWith' :: (outer -> SetupFunc oldInner newInner)
-> TestDefM outers newInner result
-> TestDefM outers oldInner result
setupAroundWith' outer -> SetupFunc oldInner newInner
setupFuncFunc = ((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 ()
takeAC outer
a oldInner
d ->
  let (SetupFunc forall r. (newInner -> IO r) -> oldInner -> IO r
provideCWithD) = outer -> SetupFunc oldInner newInner
setupFuncFunc outer
a
   in (newInner -> IO ()) -> oldInner -> IO ()
forall r. (newInner -> IO r) -> oldInner -> IO r
provideCWithD (\newInner
c -> outer -> newInner -> IO ()
takeAC outer
a newInner
c) oldInner
d