{-# LANGUAGE RankNTypes #-}

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 'a' given a 'b'.
--
-- You can think of this as a potentially-resource-aware version of 'b -> IO a'.
newtype SetupFunc b a = SetupFunc
  { SetupFunc b a -> forall r. (a -> IO r) -> b -> IO r
unSetupFunc :: forall r. (a -> IO r) -> (b -> IO r)
  }

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

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

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

instance MonadIO (SetupFunc c) where
  liftIO :: IO a -> SetupFunc c a
liftIO IO a
ioFunc = (forall r. (a -> IO r) -> c -> IO r) -> SetupFunc c a
forall b a. (forall r. (a -> IO r) -> b -> IO r) -> SetupFunc b a
SetupFunc ((forall r. (a -> IO r) -> c -> IO r) -> SetupFunc c a)
-> (forall r. (a -> IO r) -> c -> IO r) -> SetupFunc c a
forall a b. (a -> b) -> a -> b
$ \a -> IO r
takeA c
_ -> 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 b a. (forall r. (a -> IO r) -> b -> IO r) -> SetupFunc b a
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 r. (a -> IO r) -> IO r) -> SetupFunc () a
makeSimpleSetupFunc :: (forall r. (a -> IO r) -> IO r) -> SetupFunc () a
makeSimpleSetupFunc forall r. (a -> IO r) -> IO r
provideA = (forall r. (a -> IO r) -> () -> IO r) -> SetupFunc () a
forall b a. (forall r. (a -> IO r) -> b -> IO r) -> SetupFunc b a
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 () -> (a -> IO r) -> IO r
forall r. (a -> IO r) -> IO r
provideA ((a -> IO r) -> IO r) -> (a -> IO r) -> IO r
forall a b. (a -> b) -> a -> b
$ \a
a -> a -> IO r
takeA a
a

-- | Use a 'SetupFunc ()' as a simple provider function.
--
-- This is the opposite of the 'makeSimpleSetupFunc' function
useSimpleSetupFunc :: SetupFunc () a -> (forall r. (a -> IO r) -> IO r)
useSimpleSetupFunc :: SetupFunc () a -> forall r. (a -> IO r) -> IO r
useSimpleSetupFunc (SetupFunc forall r. (a -> IO r) -> () -> IO r
provideAWithUnit) a -> IO r
takeA = (a -> IO r) -> () -> IO r
forall r. (a -> IO r) -> () -> IO r
provideAWithUnit (\a
a -> a -> IO r
takeA a
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 :: (b -> SetupFunc () a) -> SetupFunc b a
wrapSetupFunc :: (b -> SetupFunc () a) -> SetupFunc b a
wrapSetupFunc b -> SetupFunc () a
bFunc = (forall r. (a -> IO r) -> b -> IO r) -> SetupFunc b a
forall b a. (forall r. (a -> IO r) -> b -> IO r) -> SetupFunc b a
SetupFunc ((forall r. (a -> IO r) -> b -> IO r) -> SetupFunc b a)
-> (forall r. (a -> IO r) -> b -> IO r) -> SetupFunc b a
forall a b. (a -> b) -> a -> b
$ \a -> IO r
takeA b
b ->
  let SetupFunc forall r. (a -> IO r) -> () -> IO r
provideAWithUnit = b -> SetupFunc () a
bFunc b
b
   in (a -> IO r) -> () -> IO r
forall r. (a -> IO r) -> () -> IO r
provideAWithUnit (\a
a -> a -> IO r
takeA a
a) ()

-- | Unwrap a 'SetupFunc' into a function that produces a 'SetupFunc'
--
-- This is the opposite of 'wrapSetupFunc'.
unwrapSetupFunc :: SetupFunc b a -> (b -> SetupFunc () a)
unwrapSetupFunc :: SetupFunc b a -> b -> SetupFunc () a
unwrapSetupFunc (SetupFunc forall r. (a -> IO r) -> b -> IO r
provideAWithB) b
b = (forall r. (a -> IO r) -> () -> IO r) -> SetupFunc () a
forall b a. (forall r. (a -> IO r) -> b -> IO r) -> SetupFunc b a
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 () ->
  (a -> IO r) -> b -> IO r
forall r. (a -> IO r) -> b -> IO r
provideAWithB (\a
a -> a -> IO r
takeA a
a) b
b

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

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

-- | Use 'around' with a 'SetupFunc'
setupAround :: SetupFunc () c -> TestDefM a c e -> TestDefM a () e
setupAround :: SetupFunc () c -> TestDefM a c e -> TestDefM a () e
setupAround = SetupFunc () c -> TestDefM a c e -> TestDefM a () e
forall d c (a :: [*]) e.
SetupFunc d c -> TestDefM a c e -> TestDefM a d e
setupAroundWith

-- | Use 'aroundWith' with a 'SetupFunc'
setupAroundWith :: SetupFunc d c -> TestDefM a c e -> TestDefM a d e
setupAroundWith :: SetupFunc d c -> TestDefM a c e -> TestDefM a d e
setupAroundWith (SetupFunc forall r. (c -> IO r) -> d -> IO r
f) = ((c -> IO ()) -> d -> IO ()) -> TestDefM a c e -> TestDefM a d e
forall (a :: [*]) c d r.
((c -> IO ()) -> d -> IO ()) -> TestDefM a c r -> TestDefM a d r
aroundWith (c -> IO ()) -> d -> IO ()
forall r. (c -> IO r) -> d -> IO r
f

-- | Use 'aroundWith'' with a 'SetupFunc'
setupAroundWith' :: HContains l a => (a -> SetupFunc d c) -> TestDefM l c e -> TestDefM l d e
setupAroundWith' :: (a -> SetupFunc d c) -> TestDefM l c e -> TestDefM l d e
setupAroundWith' a -> SetupFunc d c
setupFuncFunc = ((a -> c -> IO ()) -> a -> d -> IO ())
-> TestDefM l c e -> TestDefM l d e
forall a c d r (u :: [*]).
HContains u a =>
((a -> c -> IO ()) -> a -> d -> IO ())
-> TestDefM u c r -> TestDefM u d r
aroundWith' (((a -> c -> IO ()) -> a -> d -> IO ())
 -> TestDefM l c e -> TestDefM l d e)
-> ((a -> c -> IO ()) -> a -> d -> IO ())
-> TestDefM l c e
-> TestDefM l d e
forall a b. (a -> b) -> a -> b
$ \a -> c -> IO ()
takeAC a
a d
d ->
  let (SetupFunc forall r. (c -> IO r) -> d -> IO r
provideCWithD) = a -> SetupFunc d c
setupFuncFunc a
a
   in (c -> IO ()) -> d -> IO ()
forall r. (c -> IO r) -> d -> IO r
provideCWithD (\c
c -> a -> c -> IO ()
takeAC a
a c
c) d
d