{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoFieldSelectors #-}

module Skeletest.Internal.Fixtures (
  Fixture (..),
  FixtureScope (..),
  FixtureScopeKey (..),
  getFixture,

  -- * Cleanup
  FixtureCleanup (..),
  noCleanup,
  withCleanup,
  cleanupFixtures,

  -- * Built-in fixtures
  FixtureSkeletestTmpDir (..),
  FixtureTmpDir (..),
) where

import Control.Concurrent (ThreadId, myThreadId)
import Control.Monad (forM)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.IORef (IORef, atomicModifyIORef, newIORef)
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Map.Ordered (OMap)
import Data.Map.Ordered qualified as OMap
import Data.Maybe (catMaybes)
import Data.Proxy (Proxy (..))
import Data.Text qualified as Text
import Data.Typeable (TypeRep, Typeable, eqT, typeOf, typeRep, (:~:) (Refl))
import Skeletest.Internal.Error (invariantViolation, skeletestError)
import Skeletest.Internal.TestInfo (getTestInfo)
import Skeletest.Internal.TestInfo qualified as TestInfo
import Skeletest.Internal.Utils.Map qualified as Map.Utils
import Skeletest.Internal.Utils.Text (showT)
import System.Directory (
  createDirectory,
  createDirectoryIfMissing,
  getTemporaryDirectory,
  removePathForcibly,
 )
import System.FilePath ((</>))
import System.IO.Unsafe (unsafePerformIO)
import System.Process (getCurrentPid)
import UnliftIO.Exception (throwIO, tryAny)

class (Typeable a) => Fixture a where
  -- | The scope of the fixture, defaults to per-test
  fixtureScope :: FixtureScope
  fixtureScope = FixtureScope
PerTestFixture

  fixtureAction :: IO (a, FixtureCleanup)

data FixtureScope
  = PerTestFixture
  | PerFileFixture
  | PerSessionFixture
  deriving (Int -> FixtureScope -> ShowS
[FixtureScope] -> ShowS
FixtureScope -> FilePath
(Int -> FixtureScope -> ShowS)
-> (FixtureScope -> FilePath)
-> ([FixtureScope] -> ShowS)
-> Show FixtureScope
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FixtureScope -> ShowS
showsPrec :: Int -> FixtureScope -> ShowS
$cshow :: FixtureScope -> FilePath
show :: FixtureScope -> FilePath
$cshowList :: [FixtureScope] -> ShowS
showList :: [FixtureScope] -> ShowS
Show)

data FixtureCleanup
  = NoCleanup
  | CleanupFunc (IO ())

data FixtureScopeKey
  = PerTestFixtureKey ThreadId
  | PerFileFixtureKey FilePath
  | PerSessionFixtureKey
  deriving (Int -> FixtureScopeKey -> ShowS
[FixtureScopeKey] -> ShowS
FixtureScopeKey -> FilePath
(Int -> FixtureScopeKey -> ShowS)
-> (FixtureScopeKey -> FilePath)
-> ([FixtureScopeKey] -> ShowS)
-> Show FixtureScopeKey
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FixtureScopeKey -> ShowS
showsPrec :: Int -> FixtureScopeKey -> ShowS
$cshow :: FixtureScopeKey -> FilePath
show :: FixtureScopeKey -> FilePath
$cshowList :: [FixtureScopeKey] -> ShowS
showList :: [FixtureScopeKey] -> ShowS
Show)

-- | A helper for specifying no cleanup.
noCleanup :: a -> (a, FixtureCleanup)
noCleanup :: forall a. a -> (a, FixtureCleanup)
noCleanup a
a = (a
a, FixtureCleanup
NoCleanup)

-- | A helper for defining the cleanup function in-line.
withCleanup :: a -> IO () -> (a, FixtureCleanup)
withCleanup :: forall a. a -> IO () -> (a, FixtureCleanup)
withCleanup a
a IO ()
cleanup = (a
a, IO () -> FixtureCleanup
CleanupFunc IO ()
cleanup)

-- | Load a fixture, initializing it if it hasn't been cached already.
getFixture :: forall a m. (Fixture a, MonadIO m) => m a
getFixture :: forall a (m :: * -> *). (Fixture a, MonadIO m) => m a
getFixture = IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ do
  (FixtureRegistry -> OMap TypeRep FixtureStatus
getScopedFixtures, (OMap TypeRep FixtureStatus -> OMap TypeRep FixtureStatus)
-> FixtureRegistry -> FixtureRegistry
updateScopedFixtures) <-
    (FixtureScopeKey
 -> (FixtureRegistry -> OMap TypeRep FixtureStatus,
     (OMap TypeRep FixtureStatus -> OMap TypeRep FixtureStatus)
     -> FixtureRegistry -> FixtureRegistry))
-> IO FixtureScopeKey
-> IO
     (FixtureRegistry -> OMap TypeRep FixtureStatus,
      (OMap TypeRep FixtureStatus -> OMap TypeRep FixtureStatus)
      -> FixtureRegistry -> FixtureRegistry)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FixtureScopeKey
-> (FixtureRegistry -> OMap TypeRep FixtureStatus,
    (OMap TypeRep FixtureStatus -> OMap TypeRep FixtureStatus)
    -> FixtureRegistry -> FixtureRegistry)
getScopedAccessors (IO FixtureScopeKey
 -> IO
      (FixtureRegistry -> OMap TypeRep FixtureStatus,
       (OMap TypeRep FixtureStatus -> OMap TypeRep FixtureStatus)
       -> FixtureRegistry -> FixtureRegistry))
-> IO FixtureScopeKey
-> IO
     (FixtureRegistry -> OMap TypeRep FixtureStatus,
      (OMap TypeRep FixtureStatus -> OMap TypeRep FixtureStatus)
      -> FixtureRegistry -> FixtureRegistry)
forall a b. (a -> b) -> a -> b
$
      case forall a. Fixture a => FixtureScope
fixtureScope @a of
        FixtureScope
PerTestFixture -> ThreadId -> FixtureScopeKey
PerTestFixtureKey (ThreadId -> FixtureScopeKey) -> IO ThreadId -> IO FixtureScopeKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ThreadId
myThreadId
        FixtureScope
PerFileFixture -> FilePath -> FixtureScopeKey
PerFileFixtureKey (FilePath -> FixtureScopeKey)
-> (TestInfo -> FilePath) -> TestInfo -> FixtureScopeKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.file) (TestInfo -> FixtureScopeKey) -> IO TestInfo -> IO FixtureScopeKey
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO TestInfo
forall (m :: * -> *). (MonadIO m, HasCallStack) => m TestInfo
getTestInfo
        FixtureScope
PerSessionFixture -> FixtureScopeKey -> IO FixtureScopeKey
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FixtureScopeKey
PerSessionFixtureKey

  let insertFixture :: FixtureStatus -> FixtureRegistry -> FixtureRegistry
insertFixture FixtureStatus
state = (OMap TypeRep FixtureStatus -> OMap TypeRep FixtureStatus)
-> FixtureRegistry -> FixtureRegistry
updateScopedFixtures (OMap TypeRep FixtureStatus
-> (TypeRep, FixtureStatus) -> OMap TypeRep FixtureStatus
forall k v. Ord k => OMap k v -> (k, v) -> OMap k v
OMap.>| (TypeRep
rep, FixtureStatus
state))
  let rmFixture :: FixtureRegistry -> FixtureRegistry
rmFixture = (OMap TypeRep FixtureStatus -> OMap TypeRep FixtureStatus)
-> FixtureRegistry -> FixtureRegistry
updateScopedFixtures (TypeRep -> OMap TypeRep FixtureStatus -> OMap TypeRep FixtureStatus
forall k v. Ord k => k -> OMap k v -> OMap k v
OMap.delete TypeRep
rep)

  Either Text (Maybe a)
cachedFixture <-
    (FixtureRegistry -> (FixtureRegistry, Either Text (Maybe a)))
-> IO (Either Text (Maybe a))
forall a. (FixtureRegistry -> (FixtureRegistry, a)) -> IO a
modifyFixtureRegistry ((FixtureRegistry -> (FixtureRegistry, Either Text (Maybe a)))
 -> IO (Either Text (Maybe a)))
-> (FixtureRegistry -> (FixtureRegistry, Either Text (Maybe a)))
-> IO (Either Text (Maybe a))
forall a b. (a -> b) -> a -> b
$ \FixtureRegistry
registry ->
      case TypeRep -> OMap TypeRep FixtureStatus -> Maybe FixtureStatus
forall k v. Ord k => k -> OMap k v -> Maybe v
OMap.lookup TypeRep
rep (OMap TypeRep FixtureStatus -> Maybe FixtureStatus)
-> OMap TypeRep FixtureStatus -> Maybe FixtureStatus
forall a b. (a -> b) -> a -> b
$ FixtureRegistry -> OMap TypeRep FixtureStatus
getScopedFixtures FixtureRegistry
registry of
        -- fixture has not been requested yet
        Maybe FixtureStatus
Nothing -> (FixtureStatus -> FixtureRegistry -> FixtureRegistry
insertFixture FixtureStatus
FixtureInProgress FixtureRegistry
registry, Maybe a -> Either Text (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing)
        -- fixture has already been requested
        Just (FixtureLoaded (a
fixture :: ty, FixtureCleanup
_)) ->
          case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @a @ty of
            Just a :~: a
Refl -> (FixtureRegistry
registry, Maybe a -> Either Text (Maybe a)
forall a b. b -> Either a b
Right (Maybe a -> Either Text (Maybe a))
-> Maybe a -> Either Text (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
a
fixture)
            Maybe (a :~: a)
Nothing ->
              FilePath -> (FixtureRegistry, Either Text (Maybe a))
forall a. HasCallStack => FilePath -> a
invariantViolation (FilePath -> (FixtureRegistry, Either Text (Maybe a)))
-> ([FilePath] -> FilePath)
-> [FilePath]
-> (FixtureRegistry, Either Text (Maybe a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath] -> FilePath
unwords ([FilePath] -> (FixtureRegistry, Either Text (Maybe a)))
-> [FilePath] -> (FixtureRegistry, Either Text (Maybe a))
forall a b. (a -> b) -> a -> b
$
                [ FilePath
"fixture registry contained incorrect types."
                , FilePath
"Expected: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeRep -> FilePath
forall a. Show a => a -> FilePath
show TypeRep
rep FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"."
                , FilePath
"Got: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> TypeRep -> FilePath
forall a. Show a => a -> FilePath
show (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
fixture)
                ]
        Just FixtureStatus
FixtureInProgress ->
          -- get list of fixtures causing a circular dependency
          let fixtures :: [TypeRep]
fixtures = ((TypeRep, FixtureStatus) -> TypeRep)
-> [(TypeRep, FixtureStatus)] -> [TypeRep]
forall a b. (a -> b) -> [a] -> [b]
map (TypeRep, FixtureStatus) -> TypeRep
forall a b. (a, b) -> a
fst ([(TypeRep, FixtureStatus)] -> [TypeRep])
-> (OMap TypeRep FixtureStatus -> [(TypeRep, FixtureStatus)])
-> OMap TypeRep FixtureStatus
-> [TypeRep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TypeRep, FixtureStatus) -> Bool)
-> [(TypeRep, FixtureStatus)] -> [(TypeRep, FixtureStatus)]
forall a. (a -> Bool) -> [a] -> [a]
filter (FixtureStatus -> Bool
isInProgress (FixtureStatus -> Bool)
-> ((TypeRep, FixtureStatus) -> FixtureStatus)
-> (TypeRep, FixtureStatus)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeRep, FixtureStatus) -> FixtureStatus
forall a b. (a, b) -> b
snd) ([(TypeRep, FixtureStatus)] -> [(TypeRep, FixtureStatus)])
-> (OMap TypeRep FixtureStatus -> [(TypeRep, FixtureStatus)])
-> OMap TypeRep FixtureStatus
-> [(TypeRep, FixtureStatus)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OMap TypeRep FixtureStatus -> [(TypeRep, FixtureStatus)]
forall k v. OMap k v -> [(k, v)]
OMap.assocs (OMap TypeRep FixtureStatus -> [TypeRep])
-> OMap TypeRep FixtureStatus -> [TypeRep]
forall a b. (a -> b) -> a -> b
$ FixtureRegistry -> OMap TypeRep FixtureStatus
getScopedFixtures FixtureRegistry
registry
              msg :: Text
msg =
                [Text] -> Text
Text.unwords
                  [ Text
"Found circular dependency when resolving fixtures:"
                  , Text -> [Text] -> Text
Text.intercalate Text
" -> " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (TypeRep -> Text) -> [TypeRep] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map TypeRep -> Text
forall a. Show a => a -> Text
showT ([TypeRep]
fixtures [TypeRep] -> [TypeRep] -> [TypeRep]
forall a. Semigroup a => a -> a -> a
<> [TypeRep
rep])
                  ]
           in (FixtureRegistry
registry, Text -> Either Text (Maybe a)
forall a b. a -> Either a b
Left Text
msg)

  case Either Text (Maybe a)
cachedFixture of
    -- error when getting fixture
    Left Text
msg -> Text -> IO a
forall (m :: * -> *) a. MonadIO m => Text -> m a
skeletestError Text
msg
    -- fixture was cached, return it
    Right (Just a
fixture) -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
fixture
    -- otherwise, execute it (allowing it to request other fixtures) and cache the result.
    Right Maybe a
Nothing -> do
      IO (a, FixtureCleanup)
-> IO (Either SomeException (a, FixtureCleanup))
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (forall a. Fixture a => IO (a, FixtureCleanup)
fixtureAction @a) IO (Either SomeException (a, FixtureCleanup))
-> (Either SomeException (a, FixtureCleanup) -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Left SomeException
e -> do
          (FixtureRegistry -> (FixtureRegistry, ())) -> IO ()
forall a. (FixtureRegistry -> (FixtureRegistry, a)) -> IO a
modifyFixtureRegistry ((FixtureRegistry -> (FixtureRegistry, ())) -> IO ())
-> (FixtureRegistry -> (FixtureRegistry, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FixtureRegistry
registry -> (FixtureRegistry -> FixtureRegistry
rmFixture FixtureRegistry
registry, ())
          SomeException -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
e
        Right result :: (a, FixtureCleanup)
result@(a
fixture, FixtureCleanup
_) -> do
          (FixtureRegistry -> (FixtureRegistry, ())) -> IO ()
forall a. (FixtureRegistry -> (FixtureRegistry, a)) -> IO a
modifyFixtureRegistry ((FixtureRegistry -> (FixtureRegistry, ())) -> IO ())
-> (FixtureRegistry -> (FixtureRegistry, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FixtureRegistry
registry -> (FixtureStatus -> FixtureRegistry -> FixtureRegistry
insertFixture ((a, FixtureCleanup) -> FixtureStatus
forall a. Typeable a => (a, FixtureCleanup) -> FixtureStatus
FixtureLoaded (a, FixtureCleanup)
result) FixtureRegistry
registry, ())
          a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
fixture
 where
  rep :: TypeRep
rep = Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)
  isInProgress :: FixtureStatus -> Bool
isInProgress = \case
    FixtureStatus
FixtureInProgress -> Bool
True
    FixtureStatus
_ -> Bool
False

-- | Clean up fixtures in the given scope.
--
-- Clean up functions are run in the reverse order the fixtures finished in.
-- For example, if a test asks for fixtures A and C, A asks for B, and C asks
-- for D, the fixtures should finish loading in order: B, A, D, C.
-- Cleanup should then go in order: C, D, A, B.
cleanupFixtures :: FixtureScopeKey -> IO ()
cleanupFixtures :: FixtureScopeKey -> IO ()
cleanupFixtures FixtureScopeKey
scopeKey = do
  -- get fixtures in the given scope and clear
  OMap TypeRep FixtureStatus
fixtures <-
    (FixtureRegistry -> (FixtureRegistry, OMap TypeRep FixtureStatus))
-> IO (OMap TypeRep FixtureStatus)
forall a. (FixtureRegistry -> (FixtureRegistry, a)) -> IO a
modifyFixtureRegistry ((FixtureRegistry -> (FixtureRegistry, OMap TypeRep FixtureStatus))
 -> IO (OMap TypeRep FixtureStatus))
-> (FixtureRegistry
    -> (FixtureRegistry, OMap TypeRep FixtureStatus))
-> IO (OMap TypeRep FixtureStatus)
forall a b. (a -> b) -> a -> b
$ \FixtureRegistry
registry ->
      ((OMap TypeRep FixtureStatus -> OMap TypeRep FixtureStatus)
-> FixtureRegistry -> FixtureRegistry
updateScopedFixtures (OMap TypeRep FixtureStatus
-> OMap TypeRep FixtureStatus -> OMap TypeRep FixtureStatus
forall a b. a -> b -> a
const OMap TypeRep FixtureStatus
forall k v. OMap k v
OMap.empty) FixtureRegistry
registry, FixtureRegistry -> OMap TypeRep FixtureStatus
getScopedFixtures FixtureRegistry
registry)

  [Maybe SomeException]
errors <-
    [FixtureStatus]
-> (FixtureStatus -> IO (Maybe SomeException))
-> IO [Maybe SomeException]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([FixtureStatus] -> [FixtureStatus]
forall a. [a] -> [a]
reverse ([FixtureStatus] -> [FixtureStatus])
-> (OMap TypeRep FixtureStatus -> [FixtureStatus])
-> OMap TypeRep FixtureStatus
-> [FixtureStatus]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TypeRep, FixtureStatus) -> FixtureStatus)
-> [(TypeRep, FixtureStatus)] -> [FixtureStatus]
forall a b. (a -> b) -> [a] -> [b]
map (TypeRep, FixtureStatus) -> FixtureStatus
forall a b. (a, b) -> b
snd ([(TypeRep, FixtureStatus)] -> [FixtureStatus])
-> (OMap TypeRep FixtureStatus -> [(TypeRep, FixtureStatus)])
-> OMap TypeRep FixtureStatus
-> [FixtureStatus]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OMap TypeRep FixtureStatus -> [(TypeRep, FixtureStatus)]
forall k v. OMap k v -> [(k, v)]
OMap.assocs (OMap TypeRep FixtureStatus -> [FixtureStatus])
-> OMap TypeRep FixtureStatus -> [FixtureStatus]
forall a b. (a -> b) -> a -> b
$ OMap TypeRep FixtureStatus
fixtures) ((FixtureStatus -> IO (Maybe SomeException))
 -> IO [Maybe SomeException])
-> (FixtureStatus -> IO (Maybe SomeException))
-> IO [Maybe SomeException]
forall a b. (a -> b) -> a -> b
$ \case
      FixtureStatus
FixtureInProgress -> Maybe SomeException -> IO (Maybe SomeException)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SomeException
forall a. Maybe a
Nothing
      FixtureLoaded (a
_, FixtureCleanup
NoCleanup) -> Maybe SomeException -> IO (Maybe SomeException)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SomeException
forall a. Maybe a
Nothing
      FixtureLoaded (a
_, CleanupFunc IO ()
io) -> Either SomeException () -> Maybe SomeException
forall {a} {b}. Either a b -> Maybe a
fromLeft (Either SomeException () -> Maybe SomeException)
-> IO (Either SomeException ()) -> IO (Maybe SomeException)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny IO ()
io

  -- throw the first error we encountered
  case [Maybe SomeException] -> [SomeException]
forall a. [Maybe a] -> [a]
catMaybes [Maybe SomeException]
errors of
    SomeException
e : [SomeException]
_ -> SomeException -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
e
    [] -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 where
  (FixtureRegistry -> OMap TypeRep FixtureStatus
getScopedFixtures, (OMap TypeRep FixtureStatus -> OMap TypeRep FixtureStatus)
-> FixtureRegistry -> FixtureRegistry
updateScopedFixtures) = FixtureScopeKey
-> (FixtureRegistry -> OMap TypeRep FixtureStatus,
    (OMap TypeRep FixtureStatus -> OMap TypeRep FixtureStatus)
    -> FixtureRegistry -> FixtureRegistry)
getScopedAccessors FixtureScopeKey
scopeKey
  fromLeft :: Either a b -> Maybe a
fromLeft = \case
    Left a
x -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
    Right b
_ -> Maybe a
forall a. Maybe a
Nothing

{----- Fixtures registry -----}

-- | The registry of active fixtures, in order of activation.
data FixtureRegistry = FixtureRegistry
  { FixtureRegistry -> OMap TypeRep FixtureStatus
sessionFixtures :: FixtureMap
  , FixtureRegistry -> Map FilePath (OMap TypeRep FixtureStatus)
fileFixtures :: Map FilePath FixtureMap
  , FixtureRegistry -> Map ThreadId (OMap TypeRep FixtureStatus)
testFixtures :: Map ThreadId FixtureMap
  }

type FixtureMap = OMap TypeRep FixtureStatus

data FixtureStatus
  = FixtureInProgress
  | forall a. (Typeable a) => FixtureLoaded (a, FixtureCleanup)

fixtureRegistryRef :: IORef FixtureRegistry
fixtureRegistryRef :: IORef FixtureRegistry
fixtureRegistryRef = IO (IORef FixtureRegistry) -> IORef FixtureRegistry
forall a. IO a -> a
unsafePerformIO (IO (IORef FixtureRegistry) -> IORef FixtureRegistry)
-> IO (IORef FixtureRegistry) -> IORef FixtureRegistry
forall a b. (a -> b) -> a -> b
$ FixtureRegistry -> IO (IORef FixtureRegistry)
forall a. a -> IO (IORef a)
newIORef FixtureRegistry
emptyFixtureRegistry
 where
  emptyFixtureRegistry :: FixtureRegistry
emptyFixtureRegistry =
    FixtureRegistry
      { sessionFixtures :: OMap TypeRep FixtureStatus
sessionFixtures = OMap TypeRep FixtureStatus
forall k v. OMap k v
OMap.empty
      , fileFixtures :: Map FilePath (OMap TypeRep FixtureStatus)
fileFixtures = Map FilePath (OMap TypeRep FixtureStatus)
forall k a. Map k a
Map.empty
      , testFixtures :: Map ThreadId (OMap TypeRep FixtureStatus)
testFixtures = Map ThreadId (OMap TypeRep FixtureStatus)
forall k a. Map k a
Map.empty
      }
{-# NOINLINE fixtureRegistryRef #-}

modifyFixtureRegistry :: (FixtureRegistry -> (FixtureRegistry, a)) -> IO a
modifyFixtureRegistry :: forall a. (FixtureRegistry -> (FixtureRegistry, a)) -> IO a
modifyFixtureRegistry = IORef FixtureRegistry
-> (FixtureRegistry -> (FixtureRegistry, a)) -> IO a
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef FixtureRegistry
fixtureRegistryRef

getScopedAccessors ::
  FixtureScopeKey ->
  ( FixtureRegistry -> FixtureMap
  , (FixtureMap -> FixtureMap) -> FixtureRegistry -> FixtureRegistry
  )
getScopedAccessors :: FixtureScopeKey
-> (FixtureRegistry -> OMap TypeRep FixtureStatus,
    (OMap TypeRep FixtureStatus -> OMap TypeRep FixtureStatus)
    -> FixtureRegistry -> FixtureRegistry)
getScopedAccessors FixtureScopeKey
scopeKey =
  case FixtureScopeKey
scopeKey of
    PerTestFixtureKey ThreadId
tid ->
      ( ThreadId
-> Map ThreadId (OMap TypeRep FixtureStatus)
-> OMap TypeRep FixtureStatus
forall {k1} k2 (t :: k1 -> *) (a :: k1).
(Ord k2, IsList (t a)) =>
k2 -> Map k2 (t a) -> t a
Map.Utils.findOrEmpty ThreadId
tid (Map ThreadId (OMap TypeRep FixtureStatus)
 -> OMap TypeRep FixtureStatus)
-> (FixtureRegistry -> Map ThreadId (OMap TypeRep FixtureStatus))
-> FixtureRegistry
-> OMap TypeRep FixtureStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.testFixtures)
      , \OMap TypeRep FixtureStatus -> OMap TypeRep FixtureStatus
f FixtureRegistry
registry -> FixtureRegistry
registry{testFixtures = Map.Utils.adjustNested f tid registry.testFixtures}
      )
    PerFileFixtureKey FilePath
fp ->
      ( FilePath
-> Map FilePath (OMap TypeRep FixtureStatus)
-> OMap TypeRep FixtureStatus
forall {k1} k2 (t :: k1 -> *) (a :: k1).
(Ord k2, IsList (t a)) =>
k2 -> Map k2 (t a) -> t a
Map.Utils.findOrEmpty FilePath
fp (Map FilePath (OMap TypeRep FixtureStatus)
 -> OMap TypeRep FixtureStatus)
-> (FixtureRegistry -> Map FilePath (OMap TypeRep FixtureStatus))
-> FixtureRegistry
-> OMap TypeRep FixtureStatus
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.fileFixtures)
      , \OMap TypeRep FixtureStatus -> OMap TypeRep FixtureStatus
f FixtureRegistry
registry -> FixtureRegistry
registry{fileFixtures = Map.Utils.adjustNested f fp registry.fileFixtures}
      )
    FixtureScopeKey
PerSessionFixtureKey ->
      ( (.sessionFixtures)
      , \OMap TypeRep FixtureStatus -> OMap TypeRep FixtureStatus
f FixtureRegistry
registry -> FixtureRegistry
registry{sessionFixtures = f registry.sessionFixtures}
      )

{----- Built-in fixtures -----}

-- | A fixture that provides a global temporary directory for internal Skeletest use.
newtype FixtureSkeletestTmpDir = FixtureSkeletestTmpDir FilePath

instance Fixture FixtureSkeletestTmpDir where
  fixtureScope :: FixtureScope
fixtureScope = FixtureScope
PerSessionFixture
  fixtureAction :: IO (FixtureSkeletestTmpDir, FixtureCleanup)
fixtureAction = do
    FilePath
tmpdir <- IO FilePath
getTemporaryDirectory
    Pid
pid <- IO Pid
getCurrentPid
    let dir :: FilePath
dir = FilePath
tmpdir FilePath -> ShowS
</> (FilePath
"skeletest-tmp-dir." FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Pid -> FilePath
forall a. Show a => a -> FilePath
show Pid
pid)
    FilePath -> IO ()
removePathForcibly FilePath
dir
    Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
dir
    (FixtureSkeletestTmpDir, FixtureCleanup)
-> IO (FixtureSkeletestTmpDir, FixtureCleanup)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((FixtureSkeletestTmpDir, FixtureCleanup)
 -> IO (FixtureSkeletestTmpDir, FixtureCleanup))
-> (IO () -> (FixtureSkeletestTmpDir, FixtureCleanup))
-> IO ()
-> IO (FixtureSkeletestTmpDir, FixtureCleanup)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FixtureSkeletestTmpDir
-> IO () -> (FixtureSkeletestTmpDir, FixtureCleanup)
forall a. a -> IO () -> (a, FixtureCleanup)
withCleanup (FilePath -> FixtureSkeletestTmpDir
FixtureSkeletestTmpDir FilePath
dir) (IO () -> IO (FixtureSkeletestTmpDir, FixtureCleanup))
-> IO () -> IO (FixtureSkeletestTmpDir, FixtureCleanup)
forall a b. (a -> b) -> a -> b
$
      FilePath -> IO ()
removePathForcibly FilePath
dir

-- | A fixture that provides a temporary directory that can be used in a test.
newtype FixtureTmpDir = FixtureTmpDir FilePath

instance Fixture FixtureTmpDir where
  fixtureAction :: IO (FixtureTmpDir, FixtureCleanup)
fixtureAction = do
    FixtureSkeletestTmpDir FilePath
tmpdir <- IO FixtureSkeletestTmpDir
forall a (m :: * -> *). (Fixture a, MonadIO m) => m a
getFixture
    let dir :: FilePath
dir = FilePath
tmpdir FilePath -> ShowS
</> FilePath
"test-tmp-dir"
    FilePath -> IO ()
removePathForcibly FilePath
dir
    FilePath -> IO ()
createDirectory FilePath
dir
    (FixtureTmpDir, FixtureCleanup)
-> IO (FixtureTmpDir, FixtureCleanup)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((FixtureTmpDir, FixtureCleanup)
 -> IO (FixtureTmpDir, FixtureCleanup))
-> (IO () -> (FixtureTmpDir, FixtureCleanup))
-> IO ()
-> IO (FixtureTmpDir, FixtureCleanup)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FixtureTmpDir -> IO () -> (FixtureTmpDir, FixtureCleanup)
forall a. a -> IO () -> (a, FixtureCleanup)
withCleanup (FilePath -> FixtureTmpDir
FixtureTmpDir FilePath
dir) (IO () -> IO (FixtureTmpDir, FixtureCleanup))
-> IO () -> IO (FixtureTmpDir, FixtureCleanup)
forall a b. (a -> b) -> a -> b
$
      FilePath -> IO ()
removePathForcibly FilePath
dir