{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoFieldSelectors #-}

module Skeletest.Internal.Snapshot (
  -- * Predicate
  matchesSnapshot,

  -- * Rendering
  X.SnapshotRenderer (..),
  X.setSnapshotRenderers,
  X.getSnapshotRenderers,
  X.plainRenderer,
  X.renderWithShow,

  -- ** SnapshotFile
  SnapshotFile (..),
  SnapshotTestId,
  mkSnapshotTestId,
  SnapshotValue (..),
  decodeSnapshotFile,
  encodeSnapshotFile,
  normalizeSnapshotFile,

  -- * Plugin
  snapshotPlugin,
) where

import Control.Monad (guard, unless, when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Except qualified as Except
import Control.Monad.Trans.Maybe qualified as Maybe
import Control.Monad.Trans.State.Strict qualified as State
import Data.Char (isAlpha, isPrint)
import Data.Foldable qualified as Seq (toList)
import Data.List (sortOn)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map.Merge.Strict qualified as Map
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import Data.Sequence (Seq)
import Data.Sequence qualified as Seq
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import Data.Typeable (Typeable)
import Data.Typeable qualified as Typeable
import Data.Void (absurd)
import Debug.RecoverRTTI (anythingToString)
import Skeletest.Internal.CLI (FlagSpec (..), IsFlag (..), getFlag)
import Skeletest.Internal.CLI qualified as CLI
import Skeletest.Internal.Error (skeletestError)
import Skeletest.Internal.Exit (TestExitCode (..))
import Skeletest.Internal.Fixtures (
  Fixture (..),
  FixtureScope (..),
  getFixture,
  noCleanup,
  withCleanup,
 )
import Skeletest.Internal.Hooks qualified as Hooks
import Skeletest.Internal.Paths (listTestFiles, readTestFile)
import Skeletest.Internal.Predicate (
  Predicate (..),
  PredicateFuncResult (..),
  ShowFailCtx (..),
 )
import Skeletest.Internal.Snapshot.Renderer (
  SnapshotRenderer (..),
  defaultSnapshotRenderers,
  getSnapshotRenderers,
 )
import Skeletest.Internal.Snapshot.Renderer qualified as X
import Skeletest.Internal.TestInfo (TestInfo (..), getTestInfo)
import Skeletest.Internal.Utils.Color qualified as Color
import Skeletest.Internal.Utils.Diff (showLineDiff)
import Skeletest.Internal.Utils.Term qualified as Term
import Skeletest.Internal.Utils.Text (pluralize, showT)
import Skeletest.Plugin (Hooks (..), Plugin (..), Spec, SpecInfo (..), SpecTest (..), SpecTree (..), TestResult (..), defaultHooks, defaultPlugin, getSpecTrees)
import System.FilePath (
  replaceExtension,
  splitFileName,
  takeDirectory,
  takeExtensions,
  (</>),
 )
import System.IO.Error (isDoesNotExistError)
import System.IO.Unsafe (unsafePerformIO)
import UnliftIO.Directory (createDirectoryIfMissing, removeFile)
import UnliftIO.Exception (handleJust)
import UnliftIO.IORef (
  IORef,
  atomicModifyIORef',
  modifyIORef',
  newIORef,
  readIORef,
 )

-- | A predicate checking if the input matches the snapshot.
-- See the "Snapshot tests" section in the README.
--
-- >>> user `shouldSatisfy` P.matchesSnapshot
matchesSnapshot :: (Typeable a, MonadIO m) => Predicate m a
matchesSnapshot :: forall a (m :: * -> *). (Typeable a, MonadIO m) => Predicate m a
matchesSnapshot =
  Predicate
    { predicateFunc :: a -> m PredicateFuncResult
predicateFunc = \a
actual -> do
        SnapshotUpdateFlag Bool
doUpdate <- m SnapshotUpdateFlag
forall a (m :: * -> *). (MonadIO m, IsFlag a) => m a
getFlag
        SnapshotChecker forall a. Typeable a => a -> IO SnapshotResult
check <-
          if Bool
doUpdate
            then (.checker) (UpdateSnapshotFixture -> SnapshotChecker)
-> m UpdateSnapshotFixture -> m SnapshotChecker
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Fixture a, MonadIO m) => m a
getFixture @UpdateSnapshotFixture
            else (.checker) (CheckSnapshotFixture -> SnapshotChecker)
-> m CheckSnapshotFixture -> m SnapshotChecker
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Fixture a, MonadIO m) => m a
getFixture @CheckSnapshotFixture
        SnapshotResult
result <- IO SnapshotResult -> m SnapshotResult
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO SnapshotResult -> m SnapshotResult)
-> IO SnapshotResult -> m SnapshotResult
forall a b. (a -> b) -> a -> b
$ a -> IO SnapshotResult
forall a. Typeable a => a -> IO SnapshotResult
check a
actual
        PredicateFuncResult -> m PredicateFuncResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          PredicateFuncResult
            { predicateSuccess :: Bool
predicateSuccess = SnapshotResult
result SnapshotResult -> SnapshotResult -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotResult
SnapshotMatches
            , predicateExplain :: Text
predicateExplain =
                Text -> [Text] -> Text
Text.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
                  case SnapshotResult
result of
                    SnapshotMissing Text
renderedVal ->
                      [ Text
"Snapshot does not exist. Update snapshot with --update."
                      , (Text, Text) -> (Text, Text) -> Text
showLineDiff (Text
"expected", Text
"") (Text
"actual", Text
renderedVal)
                      ]
                    SnapshotResult
SnapshotMatches ->
                      [ Text
"Matches snapshot"
                      ]
                    SnapshotDiff Text
snapshot Text
renderedActual ->
                      [ Text
"Result differed from snapshot. Update snapshot with --update."
                      , (Text, Text) -> (Text, Text) -> Text
showLineDiff (Text
"expected", Text
snapshot) (Text
"actual", Text
renderedActual)
                      ]
            , predicateShowFailCtx :: ShowFailCtx
predicateShowFailCtx = ShowFailCtx
HideFailCtx
            }
    , predicateDisp :: Text
predicateDisp = Text
"matches snapshot"
    , predicateDispNeg :: Text
predicateDispNeg = Text
"does not match snapshot"
    }

{----- Plugin -----}

snapshotPlugin :: Plugin
snapshotPlugin :: Plugin
snapshotPlugin =
  Plugin
defaultPlugin
    { hooks = snapshotsHook
    , cliFlags = [CLI.flag @SnapshotUpdateFlag]
    , snapshotRenderers = defaultSnapshotRenderers
    }

newtype SnapshotUpdateFlag = SnapshotUpdateFlag Bool

instance IsFlag SnapshotUpdateFlag where
  flagName :: FilePath
flagName = FilePath
"update"
  flagShort :: Maybe Char
flagShort = Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'u'
  flagHelp :: FilePath
flagHelp = FilePath
"Update snapshots"
  flagSpec :: FlagSpec SnapshotUpdateFlag
flagSpec = (Bool -> SnapshotUpdateFlag) -> FlagSpec SnapshotUpdateFlag
forall a. (Bool -> a) -> FlagSpec a
SwitchFlag Bool -> SnapshotUpdateFlag
SnapshotUpdateFlag

data SnapshotChecker = SnapshotChecker (forall a. (Typeable a) => a -> IO SnapshotResult)

data SnapshotResult
  = SnapshotMissing
      { SnapshotResult -> Text
renderedVal :: Text
      }
  | SnapshotMatches
  | SnapshotDiff
      { SnapshotResult -> Text
snapshotContent :: Text
      , SnapshotResult -> Text
renderedTestResult :: Text
      }
  deriving (Int -> SnapshotResult -> ShowS
[SnapshotResult] -> ShowS
SnapshotResult -> FilePath
(Int -> SnapshotResult -> ShowS)
-> (SnapshotResult -> FilePath)
-> ([SnapshotResult] -> ShowS)
-> Show SnapshotResult
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapshotResult -> ShowS
showsPrec :: Int -> SnapshotResult -> ShowS
$cshow :: SnapshotResult -> FilePath
show :: SnapshotResult -> FilePath
$cshowList :: [SnapshotResult] -> ShowS
showList :: [SnapshotResult] -> ShowS
Show, SnapshotResult -> SnapshotResult -> Bool
(SnapshotResult -> SnapshotResult -> Bool)
-> (SnapshotResult -> SnapshotResult -> Bool) -> Eq SnapshotResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SnapshotResult -> SnapshotResult -> Bool
== :: SnapshotResult -> SnapshotResult -> Bool
$c/= :: SnapshotResult -> SnapshotResult -> Bool
/= :: SnapshotResult -> SnapshotResult -> Bool
Eq)

snapshotsHook :: Hooks
snapshotsHook :: Hooks
snapshotsHook =
  Hooks
defaultHooks
    { modifySpecRegistry = Hooks.mkPreHook_ $ \ModifySpecRegistryHookContext
_ SpecRegistry
registry -> do
        -- Collect before the applyTestSelections hook to check for snapshots
        -- that don't correspond to any tests anymore
        IORef SnapshotInfoStore
-> (SnapshotInfoStore -> SnapshotInfoStore) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef SnapshotInfoStore
snapshotInfoStoreRef ((SnapshotInfoStore -> SnapshotInfoStore) -> IO ())
-> (SnapshotInfoStore -> SnapshotInfoStore) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SnapshotInfoStore
store ->
          SnapshotInfoStore
store
            { allSnapshotTestIds =
                Map.fromList
                  [ (getSnapshotPath specPath, getTestIds spec)
                  | SpecInfo{..} <- registry
                  ]
            }
        () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , runTest =
        Hooks.mkHook_
          ( \RunTestHookContext
_ ()
_ -> do
              SnapshotUpdateFlag Bool
isUpdate <- IO SnapshotUpdateFlag
forall a (m :: * -> *). (MonadIO m, IsFlag a) => m a
getFlag
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isUpdate (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                -- Always initialize the file fixture to ensure snapshots get
                -- cleaned up for a test that removed all `P.matchesSnapshot`
                -- checks
                UpdateSnapshotFixture_File
_ <- forall a (m :: * -> *). (Fixture a, MonadIO m) => m a
getFixture @UpdateSnapshotFixture_File
                () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          )
          ( \RunTestHookContext
ctx ()
_ TestResult
result -> do
              SnapshotUpdateFlag Bool
isUpdate <- IO SnapshotUpdateFlag
forall a (m :: * -> *). (MonadIO m, IsFlag a) => m a
getFlag
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when TestResult
result.status.success (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                if Bool
isUpdate
                  then TestInfo -> IO ()
recordSnapshotsToFileFixture RunTestHookContext
ctx.testInfo
                  else TestInfo -> IO ()
checkExtraTestSnapshots RunTestHookContext
ctx.testInfo
              () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          )
    , runSpecs = Hooks.mkPostHook $ \RunSpecsHookContext
_ SpecRegistry
_ TestExitCode
code -> do
        SnapshotUpdateFlag Bool
isUpdate <- IO SnapshotUpdateFlag
forall a (m :: * -> *). (MonadIO m, IsFlag a) => m a
getFlag
        if Bool
isUpdate
          then IO ()
removeOutdatedSnapshots IO () -> IO TestExitCode -> IO TestExitCode
forall a b. IO a -> IO b -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TestExitCode -> IO TestExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestExitCode
code
          else TestExitCode -> IO TestExitCode
checkOutdatedSnapshots TestExitCode
code
    , modifyTestSummary = Hooks.mkPreHook $ \ModifyTestSummaryHookContext
_ Text
summary -> do
        Text
snapshotSummary <- IO Text
getSnapshotSummary
        Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Text
summary Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
snapshotSummary
    }

-- | Snapshot-related information to store globally.
data SnapshotInfoStore = SnapshotInfoStore
  { SnapshotInfoStore -> Map FilePath [SnapshotTestId]
allSnapshotTestIds :: !(Map FilePath [SnapshotTestId])
  -- ^ Map from a test file's snapshot path to all test ids in the file
  , SnapshotInfoStore -> Set FilePath
snapshotFilesWithExtraSnapshots :: !(Set FilePath)
  -- ^ Snapshot files that contain tests that contain extraneous snapshots.
  , SnapshotInfoStore -> Int
numSnapshotsUpdated :: !Int
  -- ^ Number of snapshots that were updated
  , SnapshotInfoStore -> Int
numSnapshotFilesCleanedUp :: !Int
  -- ^ Number of snapshot files that were cleaned up
  }

-- | Map from "Test file's snapshot path" => "All test ids in the test file"
snapshotInfoStoreRef :: IORef SnapshotInfoStore
snapshotInfoStoreRef :: IORef SnapshotInfoStore
snapshotInfoStoreRef =
  IO (IORef SnapshotInfoStore) -> IORef SnapshotInfoStore
forall a. IO a -> a
unsafePerformIO (IO (IORef SnapshotInfoStore) -> IORef SnapshotInfoStore)
-> (SnapshotInfoStore -> IO (IORef SnapshotInfoStore))
-> SnapshotInfoStore
-> IORef SnapshotInfoStore
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapshotInfoStore -> IO (IORef SnapshotInfoStore)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef (SnapshotInfoStore -> IORef SnapshotInfoStore)
-> SnapshotInfoStore -> IORef SnapshotInfoStore
forall a b. (a -> b) -> a -> b
$
    SnapshotInfoStore
      { allSnapshotTestIds :: Map FilePath [SnapshotTestId]
allSnapshotTestIds = Map FilePath [SnapshotTestId]
forall k a. Map k a
Map.empty
      , snapshotFilesWithExtraSnapshots :: Set FilePath
snapshotFilesWithExtraSnapshots = Set FilePath
forall a. Set a
Set.empty
      , numSnapshotsUpdated :: Int
numSnapshotsUpdated = Int
0
      , numSnapshotFilesCleanedUp :: Int
numSnapshotFilesCleanedUp = Int
0
      }
{-# NOINLINE snapshotInfoStoreRef #-}

getTestIds :: Spec -> [SnapshotTestId]
getTestIds :: Spec -> [SnapshotTestId]
getTestIds = (SpecTree -> [SnapshotTestId]) -> [SpecTree] -> [SnapshotTestId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Seq Text -> SpecTree -> [SnapshotTestId]
go Seq Text
forall a. Seq a
Seq.empty) ([SpecTree] -> [SnapshotTestId])
-> (Spec -> [SpecTree]) -> Spec -> [SnapshotTestId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Spec -> [SpecTree]
getSpecTrees
 where
  go :: Seq Text -> SpecTree -> [SnapshotTestId]
go Seq Text
context = \case
    group :: SpecTree
group@SpecTree_Group{} -> (SpecTree -> [SnapshotTestId]) -> [SpecTree] -> [SnapshotTestId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Seq Text -> SpecTree -> [SnapshotTestId]
go (Seq Text
context Seq Text -> Text -> Seq Text
forall a. Seq a -> a -> Seq a
Seq.|> SpecTree
group.label)) SpecTree
group.trees
    SpecTree_Test SpecTest
test -> [[Text] -> SnapshotTestId
mkSnapshotTestId ([Text] -> SnapshotTestId)
-> (Seq Text -> [Text]) -> Seq Text -> SnapshotTestId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Text -> [Text]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Seq.toList (Seq Text -> SnapshotTestId) -> Seq Text -> SnapshotTestId
forall a b. (a -> b) -> a -> b
$ Seq Text
context Seq Text -> Text -> Seq Text
forall a. Seq a -> a -> Seq a
Seq.|> SpecTest
test.name]

-- | Detect outdated snapshots, returning the filepath to the outdated
-- snapshot and the action to clean it up.
detectOutdatedSnapshots :: IO [(FilePath, IO ())]
detectOutdatedSnapshots :: IO [(FilePath, IO ())]
detectOutdatedSnapshots = do
  [FilePath]
allSnapshotFiles <- (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isSnapshotFile ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [FilePath]
listTestFiles
  SnapshotInfoStore
store <- IORef SnapshotInfoStore -> IO SnapshotInfoStore
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef SnapshotInfoStore
snapshotInfoStoreRef
  let allTests :: Map FilePath (Set SnapshotTestId)
allTests = ([SnapshotTestId] -> Set SnapshotTestId)
-> Map FilePath [SnapshotTestId]
-> Map FilePath (Set SnapshotTestId)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map [SnapshotTestId] -> Set SnapshotTestId
forall a. Ord a => [a] -> Set a
Set.fromList SnapshotInfoStore
store.allSnapshotTestIds
  (FilePath -> IO (Maybe (FilePath, IO ())))
-> [FilePath] -> IO [(FilePath, IO ())]
forall {f :: * -> *} {a} {a}.
Monad f =>
(a -> f (Maybe a)) -> [a] -> f [a]
mapMaybeM (Map FilePath (Set SnapshotTestId)
-> FilePath -> IO (Maybe (FilePath, IO ()))
detectOutdated Map FilePath (Set SnapshotTestId)
allTests) [FilePath]
allSnapshotFiles
 where
  isSnapshotFile :: FilePath -> Bool
isSnapshotFile FilePath
fp = ShowS
takeExtensions FilePath
fp FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
".snap.md"
  mapMaybeM :: (a -> f (Maybe a)) -> [a] -> f [a]
mapMaybeM a -> f (Maybe a)
f = ([Maybe a] -> [a]) -> f [Maybe a] -> f [a]
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes (f [Maybe a] -> f [a]) -> ([a] -> f [Maybe a]) -> [a] -> f [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f (Maybe a)) -> [a] -> f [Maybe a]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM a -> f (Maybe a)
f

  detectOutdated :: Map FilePath (Set SnapshotTestId)
-> FilePath -> IO (Maybe (FilePath, IO ()))
detectOutdated Map FilePath (Set SnapshotTestId)
allTests = (FilePath -> ExceptT (IO ()) IO ())
-> FilePath -> IO (Maybe (FilePath, IO ()))
runDetectOutdatedM ((FilePath -> ExceptT (IO ()) IO ())
 -> FilePath -> IO (Maybe (FilePath, IO ())))
-> (FilePath -> ExceptT (IO ()) IO ())
-> FilePath
-> IO (Maybe (FilePath, IO ()))
forall a b. (a -> b) -> a -> b
$ \FilePath
snapshotFilePath -> do
    Set SnapshotTestId
testIds <-
      case FilePath
-> Map FilePath (Set SnapshotTestId) -> Maybe (Set SnapshotTestId)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
snapshotFilePath Map FilePath (Set SnapshotTestId)
allTests of
        Just Set SnapshotTestId
testIds -> Set SnapshotTestId -> ExceptT (IO ()) IO (Set SnapshotTestId)
forall a. a -> ExceptT (IO ()) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set SnapshotTestId
testIds
        -- If Nothing, snapshot file does not correspond to any tests
        Maybe (Set SnapshotTestId)
Nothing -> IO () -> ExceptT (IO ()) IO (Set SnapshotTestId)
forall {e} {a}. e -> ExceptT e IO a
returnOutdated (IO () -> ExceptT (IO ()) IO (Set SnapshotTestId))
-> IO () -> ExceptT (IO ()) IO (Set SnapshotTestId)
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall {m :: * -> *}. MonadIO m => FilePath -> m ()
cleanupFile FilePath
snapshotFilePath

    Text
contents <- IO Text -> ExceptT (IO ()) IO Text
forall a. IO a -> ExceptT (IO ()) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ExceptT (IO ()) IO Text)
-> IO Text -> ExceptT (IO ()) IO Text
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Text
Text.readFile FilePath
snapshotFilePath

    SnapshotFile
snapshotFile <-
      case Text -> Maybe SnapshotFile
decodeSnapshotFile Text
contents of
        Just SnapshotFile
file -> SnapshotFile -> ExceptT (IO ()) IO SnapshotFile
forall a. a -> ExceptT (IO ()) IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapshotFile
file
        -- If Nothing, snapshot file is corrupted; we'll treat it the same as outdated.
        -- If this happens when '--update' is passed, it means no more tests in
        -- the file have snapshots, since it would've been regenerated. So just
        -- remove the snapshot file if we still encounter this.
        Maybe SnapshotFile
Nothing -> IO () -> ExceptT (IO ()) IO SnapshotFile
forall {e} {a}. e -> ExceptT e IO a
returnOutdated (IO () -> ExceptT (IO ()) IO SnapshotFile)
-> IO () -> ExceptT (IO ()) IO SnapshotFile
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall {m :: * -> *}. MonadIO m => FilePath -> m ()
cleanupFile FilePath
snapshotFilePath

    let outdatedSnapshots :: Set SnapshotTestId
outdatedSnapshots = Map SnapshotTestId [SnapshotValue] -> Set SnapshotTestId
forall k a. Map k a -> Set k
Map.keysSet SnapshotFile
snapshotFile.snapshots Set SnapshotTestId -> Set SnapshotTestId -> Set SnapshotTestId
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set SnapshotTestId
testIds
    Bool -> ExceptT (IO ()) IO () -> ExceptT (IO ()) IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set SnapshotTestId -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set SnapshotTestId
outdatedSnapshots) (ExceptT (IO ()) IO () -> ExceptT (IO ()) IO ())
-> ExceptT (IO ()) IO () -> ExceptT (IO ()) IO ()
forall a b. (a -> b) -> a -> b
$
      IO () -> ExceptT (IO ()) IO ()
forall {e} {a}. e -> ExceptT e IO a
returnOutdated (IO () -> ExceptT (IO ()) IO ()) -> IO () -> ExceptT (IO ()) IO ()
forall a b. (a -> b) -> a -> b
$ do
        IORef SnapshotInfoStore
-> (SnapshotInfoStore -> SnapshotInfoStore) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef SnapshotInfoStore
snapshotInfoStoreRef ((SnapshotInfoStore -> SnapshotInfoStore) -> IO ())
-> (SnapshotInfoStore -> SnapshotInfoStore) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SnapshotInfoStore
store ->
          SnapshotInfoStore
store{numSnapshotsUpdated = store.numSnapshotsUpdated + length outdatedSnapshots}
        let snapshots' :: Map SnapshotTestId [SnapshotValue]
snapshots' = Map SnapshotTestId [SnapshotValue]
-> Set SnapshotTestId -> Map SnapshotTestId [SnapshotValue]
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.withoutKeys SnapshotFile
snapshotFile.snapshots Set SnapshotTestId
outdatedSnapshots
        FilePath -> SnapshotFile -> IO ()
saveSnapshotFile FilePath
snapshotFilePath SnapshotFile
snapshotFile{snapshots = snapshots'}

  cleanupFile :: FilePath -> m ()
cleanupFile FilePath
path = do
    IORef SnapshotInfoStore
-> (SnapshotInfoStore -> SnapshotInfoStore) -> m ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef SnapshotInfoStore
snapshotInfoStoreRef ((SnapshotInfoStore -> SnapshotInfoStore) -> m ())
-> (SnapshotInfoStore -> SnapshotInfoStore) -> m ()
forall a b. (a -> b) -> a -> b
$ \SnapshotInfoStore
store ->
      SnapshotInfoStore
store{numSnapshotFilesCleanedUp = store.numSnapshotFilesCleanedUp + 1}
    FilePath -> m ()
forall {m :: * -> *}. MonadIO m => FilePath -> m ()
removeFile FilePath
path

  runDetectOutdatedM ::
    (FilePath -> Except.ExceptT (IO ()) IO ()) ->
    FilePath ->
    IO (Maybe (FilePath, IO ()))
  runDetectOutdatedM :: (FilePath -> ExceptT (IO ()) IO ())
-> FilePath -> IO (Maybe (FilePath, IO ()))
runDetectOutdatedM FilePath -> ExceptT (IO ()) IO ()
action FilePath
fp =
    (IO () -> Maybe (FilePath, IO ()))
-> (() -> Maybe (FilePath, IO ()))
-> Either (IO ()) ()
-> Maybe (FilePath, IO ())
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\IO ()
io -> (FilePath, IO ()) -> Maybe (FilePath, IO ())
forall a. a -> Maybe a
Just (FilePath
fp, IO ()
io)) (\()
_ -> Maybe (FilePath, IO ())
forall a. Maybe a
Nothing)
      (Either (IO ()) () -> Maybe (FilePath, IO ()))
-> IO (Either (IO ()) ()) -> IO (Maybe (FilePath, IO ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT (IO ()) IO () -> IO (Either (IO ()) ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT (FilePath -> ExceptT (IO ()) IO ()
action FilePath
fp)
  returnOutdated :: e -> ExceptT e IO a
returnOutdated = e -> ExceptT e IO a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
Except.throwE

removeOutdatedSnapshots :: IO ()
removeOutdatedSnapshots :: IO ()
removeOutdatedSnapshots = ((FilePath, IO ()) -> IO ()) -> [(FilePath, IO ())] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (FilePath, IO ()) -> IO ()
forall a b. (a, b) -> b
snd ([(FilePath, IO ())] -> IO ()) -> IO [(FilePath, IO ())] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [(FilePath, IO ())]
detectOutdatedSnapshots

checkOutdatedSnapshots :: TestExitCode -> IO TestExitCode
checkOutdatedSnapshots :: TestExitCode -> IO TestExitCode
checkOutdatedSnapshots TestExitCode
code = do
  [FilePath]
outdated <- ((FilePath, IO ()) -> FilePath)
-> [(FilePath, IO ())] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, IO ()) -> FilePath
forall a b. (a, b) -> a
fst ([(FilePath, IO ())] -> [FilePath])
-> IO [(FilePath, IO ())] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(FilePath, IO ())]
detectOutdatedSnapshots
  SnapshotInfoStore
store <- IORef SnapshotInfoStore -> IO SnapshotInfoStore
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef SnapshotInfoStore
snapshotInfoStoreRef
  let outdated' :: Set FilePath
outdated' = [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
Set.fromList [FilePath]
outdated Set FilePath -> Set FilePath -> Set FilePath
forall a. Semigroup a => a -> a -> a
<> SnapshotInfoStore
store.snapshotFilesWithExtraSnapshots
  if Set FilePath -> Bool
forall a. Set a -> Bool
Set.null Set FilePath
outdated'
    then TestExitCode -> IO TestExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestExitCode
code
    else do
      (Text -> IO ()) -> [Text] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> IO ()
Term.output ([Text] -> IO ()) -> ([[Text]] -> [Text]) -> [[Text]] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> IO ()) -> [[Text]] -> IO ()
forall a b. (a -> b) -> a -> b
$
        [ [Text
""]
        , [Text
"╓─ 🚨 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
Color.bold Text
"Outdated snapshots detected" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ────────────────"]
        , [Text
"║  * " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack FilePath
fp | FilePath
fp <- Set FilePath -> [FilePath]
forall a. Set a -> [a]
Set.toAscList Set FilePath
outdated']
        , [Text
"║"]
        , [Text
"║  Update/remove these files with --update."]
        , [Text
"╙─────────────────────────────────────────────────"]
        ]
      TestExitCode -> IO TestExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestExitCode
ExitOutdatedSnapshots

getSnapshotSummary :: IO Text
getSnapshotSummary :: IO Text
getSnapshotSummary = do
  SnapshotInfoStore
store <- IORef SnapshotInfoStore -> IO SnapshotInfoStore
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef SnapshotInfoStore
snapshotInfoStoreRef
  Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> ([[Text]] -> Text) -> [[Text]] -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.unlines ([Text] -> Text) -> ([[Text]] -> [Text]) -> [[Text]] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> IO Text) -> [[Text]] -> IO Text
forall a b. (a -> b) -> a -> b
$
    [ Bool -> Text -> [Text]
forall {a}. Bool -> a -> [a]
when_ (SnapshotInfoStore
store.numSnapshotsUpdated Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$
        Text
"➤ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
forall a. (Num a, Eq a, Show a) => a -> Text -> Text
pluralize SnapshotInfoStore
store.numSnapshotsUpdated Text
"snapshot" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" updated"
    , Bool -> Text -> [Text]
forall {a}. Bool -> a -> [a]
when_ (SnapshotInfoStore
store.numSnapshotFilesCleanedUp Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$
        Text
"➤ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
forall a. (Num a, Eq a, Show a) => a -> Text -> Text
pluralize SnapshotInfoStore
store.numSnapshotFilesCleanedUp Text
"snapshot file" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" cleaned up"
    ]
 where
  when_ :: Bool -> a -> [a]
when_ Bool
p a
x = if Bool
p then [a
x] else []

{----- Update snapshot -----}

-- | Collect snapshots for all tests in a file.
-- When test file is done, merge new snapshots into the existing snapshot file
-- and write to disk if it's changed.
data UpdateSnapshotFixture_File = UpdateSnapshotFixture_File
  { UpdateSnapshotFixture_File
-> IORef (Map SnapshotTestId [SnapshotValue])
newFileSnapshotsRef :: IORef (Map SnapshotTestId [SnapshotValue])
  }

instance Fixture UpdateSnapshotFixture_File where
  fixtureScope :: FixtureScope
fixtureScope = FixtureScope
PerFileFixture
  fixtureAction :: IO (UpdateSnapshotFixture_File, FixtureCleanup)
fixtureAction = do
    TestInfo
testInfo <- IO TestInfo
forall (m :: * -> *). (MonadIO m, HasCallStack) => m TestInfo
getTestInfo
    IORef (Map SnapshotTestId [SnapshotValue])
newFileSnapshotsRef <- Map SnapshotTestId [SnapshotValue]
-> IO (IORef (Map SnapshotTestId [SnapshotValue]))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Map SnapshotTestId [SnapshotValue]
forall k a. Map k a
Map.empty
    (UpdateSnapshotFixture_File, FixtureCleanup)
-> IO (UpdateSnapshotFixture_File, FixtureCleanup)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((UpdateSnapshotFixture_File, FixtureCleanup)
 -> IO (UpdateSnapshotFixture_File, FixtureCleanup))
-> (IO () -> (UpdateSnapshotFixture_File, FixtureCleanup))
-> IO ()
-> IO (UpdateSnapshotFixture_File, FixtureCleanup)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateSnapshotFixture_File
-> IO () -> (UpdateSnapshotFixture_File, FixtureCleanup)
forall a. a -> IO () -> (a, FixtureCleanup)
withCleanup UpdateSnapshotFixture_File{IORef (Map SnapshotTestId [SnapshotValue])
newFileSnapshotsRef :: IORef (Map SnapshotTestId [SnapshotValue])
newFileSnapshotsRef :: IORef (Map SnapshotTestId [SnapshotValue])
newFileSnapshotsRef} (IO () -> IO (UpdateSnapshotFixture_File, FixtureCleanup))
-> IO () -> IO (UpdateSnapshotFixture_File, FixtureCleanup)
forall a b. (a -> b) -> a -> b
$ do
      TestInfo -> IORef (Map SnapshotTestId [SnapshotValue]) -> IO ()
finalizeUpdateSnapshotFixture TestInfo
testInfo IORef (Map SnapshotTestId [SnapshotValue])
newFileSnapshotsRef

data UpdateSnapshotFixture = UpdateSnapshotFixture
  { UpdateSnapshotFixture -> SnapshotChecker
checker :: SnapshotChecker
  , UpdateSnapshotFixture -> IORef (Seq SnapshotValue)
newSnapshotsRef :: IORef (Seq SnapshotValue)
  }

instance Fixture UpdateSnapshotFixture where
  fixtureScope :: FixtureScope
fixtureScope = FixtureScope
PerTestFixture
  fixtureAction :: IO (UpdateSnapshotFixture, FixtureCleanup)
fixtureAction = do
    IORef (Seq SnapshotValue)
newSnapshotsRef <- Seq SnapshotValue -> IO (IORef (Seq SnapshotValue))
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Seq SnapshotValue
forall a. Seq a
Seq.empty
    let checker :: SnapshotChecker
checker = (forall a. Typeable a => a -> IO SnapshotResult) -> SnapshotChecker
SnapshotChecker (IORef (Seq SnapshotValue) -> a -> IO SnapshotResult
forall a.
Typeable a =>
IORef (Seq SnapshotValue) -> a -> IO SnapshotResult
recordSnapshot IORef (Seq SnapshotValue)
newSnapshotsRef)
    (UpdateSnapshotFixture, FixtureCleanup)
-> IO (UpdateSnapshotFixture, FixtureCleanup)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((UpdateSnapshotFixture, FixtureCleanup)
 -> IO (UpdateSnapshotFixture, FixtureCleanup))
-> (UpdateSnapshotFixture, FixtureCleanup)
-> IO (UpdateSnapshotFixture, FixtureCleanup)
forall a b. (a -> b) -> a -> b
$ UpdateSnapshotFixture -> (UpdateSnapshotFixture, FixtureCleanup)
forall a. a -> (a, FixtureCleanup)
noCleanup UpdateSnapshotFixture{SnapshotChecker
checker :: SnapshotChecker
checker :: SnapshotChecker
checker, IORef (Seq SnapshotValue)
newSnapshotsRef :: IORef (Seq SnapshotValue)
newSnapshotsRef :: IORef (Seq SnapshotValue)
newSnapshotsRef}

-- | Collect `P.matchesSnapshot` results into a list per test.
recordSnapshot :: (Typeable a) => IORef (Seq SnapshotValue) -> a -> IO SnapshotResult
recordSnapshot :: forall a.
Typeable a =>
IORef (Seq SnapshotValue) -> a -> IO SnapshotResult
recordSnapshot IORef (Seq SnapshotValue)
newSnapshotsRef a
val = do
  [SnapshotRenderer]
renderers <- IO [SnapshotRenderer]
forall (m :: * -> *). MonadIO m => m [SnapshotRenderer]
getSnapshotRenderers
  let newSnapshotVal :: SnapshotValue
newSnapshotVal = [SnapshotRenderer] -> a -> SnapshotValue
forall a. Typeable a => [SnapshotRenderer] -> a -> SnapshotValue
renderVal [SnapshotRenderer]
renderers a
val
  IORef (Seq SnapshotValue)
-> (Seq SnapshotValue -> Seq SnapshotValue) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef (Seq SnapshotValue)
newSnapshotsRef (Seq SnapshotValue -> SnapshotValue -> Seq SnapshotValue
forall a. Seq a -> a -> Seq a
Seq.|> SnapshotValue
newSnapshotVal)
  SnapshotResult -> IO SnapshotResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapshotResult
SnapshotMatches

-- | Copy snapshots to the file fixture when test is over.
recordSnapshotsToFileFixture :: TestInfo -> IO ()
recordSnapshotsToFileFixture :: TestInfo -> IO ()
recordSnapshotsToFileFixture TestInfo
testInfo = do
  UpdateSnapshotFixture_File{IORef (Map SnapshotTestId [SnapshotValue])
newFileSnapshotsRef :: UpdateSnapshotFixture_File
-> IORef (Map SnapshotTestId [SnapshotValue])
newFileSnapshotsRef :: IORef (Map SnapshotTestId [SnapshotValue])
newFileSnapshotsRef} <- IO UpdateSnapshotFixture_File
forall a (m :: * -> *). (Fixture a, MonadIO m) => m a
getFixture
  UpdateSnapshotFixture{IORef (Seq SnapshotValue)
newSnapshotsRef :: UpdateSnapshotFixture -> IORef (Seq SnapshotValue)
newSnapshotsRef :: IORef (Seq SnapshotValue)
newSnapshotsRef} <- IO UpdateSnapshotFixture
forall a (m :: * -> *). (Fixture a, MonadIO m) => m a
getFixture
  [SnapshotValue]
newSnapshots <- Seq SnapshotValue -> [SnapshotValue]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Seq.toList (Seq SnapshotValue -> [SnapshotValue])
-> IO (Seq SnapshotValue) -> IO [SnapshotValue]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Seq SnapshotValue) -> IO (Seq SnapshotValue)
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Seq SnapshotValue)
newSnapshotsRef
  IORef (Map SnapshotTestId [SnapshotValue])
-> (Map SnapshotTestId [SnapshotValue]
    -> Map SnapshotTestId [SnapshotValue])
-> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef (Map SnapshotTestId [SnapshotValue])
newFileSnapshotsRef (SnapshotTestId
-> [SnapshotValue]
-> Map SnapshotTestId [SnapshotValue]
-> Map SnapshotTestId [SnapshotValue]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (TestInfo -> SnapshotTestId
getSnapshotTestId TestInfo
testInfo) [SnapshotValue]
newSnapshots)

finalizeUpdateSnapshotFixture :: TestInfo -> IORef (Map SnapshotTestId [SnapshotValue]) -> IO ()
finalizeUpdateSnapshotFixture :: TestInfo -> IORef (Map SnapshotTestId [SnapshotValue]) -> IO ()
finalizeUpdateSnapshotFixture TestInfo
testInfo IORef (Map SnapshotTestId [SnapshotValue])
newFileSnapshotsRef = do
  let snapshotPath :: FilePath
snapshotPath = ShowS
getSnapshotPath TestInfo
testInfo.file
  SnapshotFile
snapshotFile <-
    FilePath -> IO SnapshotFileLoadResult
loadSnapshotFile FilePath
snapshotPath IO SnapshotFileLoadResult
-> (SnapshotFileLoadResult -> IO SnapshotFile) -> IO SnapshotFile
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      SnapshotFileLoadResult_Exists SnapshotFile
file -> SnapshotFile -> IO SnapshotFile
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapshotFile
file
      SnapshotFileLoadResult
_ -> SnapshotFile -> IO SnapshotFile
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapshotFile -> IO SnapshotFile)
-> SnapshotFile -> IO SnapshotFile
forall a b. (a -> b) -> a -> b
$ Text -> SnapshotFile
emptySnapshotFile (FilePath -> Text
Text.pack TestInfo
testInfo.file)
  Map SnapshotTestId [SnapshotValue]
newSnapshots <- ([SnapshotValue] -> [SnapshotValue])
-> Map SnapshotTestId [SnapshotValue]
-> Map SnapshotTestId [SnapshotValue]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map [SnapshotValue] -> [SnapshotValue]
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Seq.toList (Map SnapshotTestId [SnapshotValue]
 -> Map SnapshotTestId [SnapshotValue])
-> IO (Map SnapshotTestId [SnapshotValue])
-> IO (Map SnapshotTestId [SnapshotValue])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef (Map SnapshotTestId [SnapshotValue])
-> IO (Map SnapshotTestId [SnapshotValue])
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef (Map SnapshotTestId [SnapshotValue])
newFileSnapshotsRef
  let snapshots' :: Map SnapshotTestId [SnapshotValue]
snapshots' = Map SnapshotTestId [SnapshotValue]
-> Map SnapshotTestId [SnapshotValue]
-> Map SnapshotTestId [SnapshotValue]
forall {t :: * -> *} {k} {a}.
(Foldable t, Ord k) =>
Map k (t a) -> Map k (t a) -> Map k (t a)
mergeSnapshots SnapshotFile
snapshotFile.snapshots Map SnapshotTestId [SnapshotValue]
newSnapshots
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Map SnapshotTestId [SnapshotValue]
snapshots' Map SnapshotTestId [SnapshotValue]
-> Map SnapshotTestId [SnapshotValue] -> Bool
forall a. Eq a => a -> a -> Bool
/= SnapshotFile
snapshotFile.snapshots) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    IORef SnapshotInfoStore
-> (SnapshotInfoStore -> SnapshotInfoStore) -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef SnapshotInfoStore
snapshotInfoStoreRef ((SnapshotInfoStore -> SnapshotInfoStore) -> IO ())
-> (SnapshotInfoStore -> SnapshotInfoStore) -> IO ()
forall a b. (a -> b) -> a -> b
$ \SnapshotInfoStore
store ->
      SnapshotInfoStore
store{numSnapshotsUpdated = store.numSnapshotsUpdated + countChanges snapshotFile.snapshots snapshots'}
    FilePath -> SnapshotFile -> IO ()
saveSnapshotFile FilePath
snapshotPath SnapshotFile
snapshotFile{snapshots = snapshots'}
 where
  countChanges :: Map k [a] -> Map k [a] -> Int
countChanges Map k [a]
old Map k [a]
new =
    (State Int (Map k ()) -> Int -> Int)
-> Int -> State Int (Map k ()) -> Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Int (Map k ()) -> Int -> Int
forall s a. State s a -> s -> s
State.execState Int
0 (State Int (Map k ()) -> Int) -> State Int (Map k ()) -> Int
forall a b. (a -> b) -> a -> b
$
      WhenMissing (StateT Int Identity) k [a] ()
-> WhenMissing (StateT Int Identity) k [a] ()
-> WhenMatched (StateT Int Identity) k [a] [a] ()
-> Map k [a]
-> Map k [a]
-> State Int (Map k ())
forall (f :: * -> *) k a c b.
(Applicative f, Ord k) =>
WhenMissing f k a c
-> WhenMissing f k b c
-> WhenMatched f k a b c
-> Map k a
-> Map k b
-> f (Map k c)
Map.mergeA
        ( (k -> [a] -> StateT Int Identity ())
-> WhenMissing (StateT Int Identity) k [a] ()
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> f y) -> WhenMissing f k x y
Map.traverseMissing ((k -> [a] -> StateT Int Identity ())
 -> WhenMissing (StateT Int Identity) k [a] ())
-> (k -> [a] -> StateT Int Identity ())
-> WhenMissing (StateT Int Identity) k [a] ()
forall a b. (a -> b) -> a -> b
$ \k
_ [a]
snaps -> do
            (Int -> Int) -> StateT Int Identity ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify' (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
snaps)
        )
        ( (k -> [a] -> StateT Int Identity ())
-> WhenMissing (StateT Int Identity) k [a] ()
forall (f :: * -> *) k x y.
Applicative f =>
(k -> x -> f y) -> WhenMissing f k x y
Map.traverseMissing ((k -> [a] -> StateT Int Identity ())
 -> WhenMissing (StateT Int Identity) k [a] ())
-> (k -> [a] -> StateT Int Identity ())
-> WhenMissing (StateT Int Identity) k [a] ()
forall a b. (a -> b) -> a -> b
$ \k
_ [a]
snaps -> do
            (Int -> Int) -> StateT Int Identity ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify' (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
snaps)
        )
        ( (k -> [a] -> [a] -> StateT Int Identity ())
-> WhenMatched (StateT Int Identity) k [a] [a] ()
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> f z) -> WhenMatched f k x y z
Map.zipWithAMatched ((k -> [a] -> [a] -> StateT Int Identity ())
 -> WhenMatched (StateT Int Identity) k [a] [a] ())
-> (k -> [a] -> [a] -> StateT Int Identity ())
-> WhenMatched (StateT Int Identity) k [a] [a] ()
forall a b. (a -> b) -> a -> b
$ \k
_ [a]
snapsOld [a]
snapsNew -> do
            let (Set a
snapsOld', Set a
snapsNew') = ([a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [a]
snapsOld, [a] -> Set a
forall a. Ord a => [a] -> Set a
Set.fromList [a]
snapsNew)
            let added :: Int
added = Set a -> Int
forall a. Set a -> Int
Set.size (Set a -> Int) -> Set a -> Int
forall a b. (a -> b) -> a -> b
$ Set a
snapsNew' Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set a
snapsOld'
            let removed :: Int
removed = Set a -> Int
forall a. Set a -> Int
Set.size (Set a -> Int) -> Set a -> Int
forall a b. (a -> b) -> a -> b
$ Set a
snapsOld' Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set a
snapsNew'
            (Int -> Int) -> StateT Int Identity ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify' (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
added Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
removed))
        )
        Map k [a]
old
        Map k [a]
new

  -- Merge snapshots, to avoid clearing snapshots of tests that were deselected.
  -- Extraneous snapshots will be cleared by 'detectOutdatedSnapshots'.
  mergeSnapshots :: Map k (t a) -> Map k (t a) -> Map k (t a)
mergeSnapshots Map k (t a)
old Map k (t a)
new =
    (t a -> Bool) -> Map k (t a) -> Map k (t a)
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Bool -> Bool
not (Bool -> Bool) -> (t a -> Bool) -> t a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t a -> Bool
forall a. t a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (Map k (t a) -> Map k (t a)) -> Map k (t a) -> Map k (t a)
forall a b. (a -> b) -> a -> b
$
      SimpleWhenMissing k (t a) (t a)
-> SimpleWhenMissing k (t a) (t a)
-> SimpleWhenMatched k (t a) (t a) (t a)
-> Map k (t a)
-> Map k (t a)
-> Map k (t a)
forall k a c b.
Ord k =>
SimpleWhenMissing k a c
-> SimpleWhenMissing k b c
-> SimpleWhenMatched k a b c
-> Map k a
-> Map k b
-> Map k c
Map.merge
        SimpleWhenMissing k (t a) (t a)
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
Map.preserveMissing -- Keep snapshots for tests that weren't run
        SimpleWhenMissing k (t a) (t a)
forall (f :: * -> *) k x. Applicative f => WhenMissing f k x x
Map.preserveMissing -- Add new snapshots
        ((k -> t a -> t a -> t a) -> SimpleWhenMatched k (t a) (t a) (t a)
forall (f :: * -> *) k x y z.
Applicative f =>
(k -> x -> y -> z) -> WhenMatched f k x y z
Map.zipWithMatched ((k -> t a -> t a -> t a) -> SimpleWhenMatched k (t a) (t a) (t a))
-> (k -> t a -> t a -> t a)
-> SimpleWhenMatched k (t a) (t a) (t a)
forall a b. (a -> b) -> a -> b
$ \k
_ t a
_o t a
n -> t a
n) -- Overwrite old snapshots
        Map k (t a)
old
        Map k (t a)
new

{----- Check snapshot -----}

data CheckSnapshotFixture_File = CheckSnapshotFixture_File
  { CheckSnapshotFixture_File -> Maybe SnapshotFile
mSnapshotFile :: Maybe SnapshotFile
  }

instance Fixture CheckSnapshotFixture_File where
  fixtureScope :: FixtureScope
fixtureScope = FixtureScope
PerFileFixture
  fixtureAction :: IO (CheckSnapshotFixture_File, FixtureCleanup)
fixtureAction = do
    FilePath
testFile <- (.file) (TestInfo -> FilePath) -> IO TestInfo -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO TestInfo
forall (m :: * -> *). (MonadIO m, HasCallStack) => m TestInfo
getTestInfo
    let snapshotPath :: FilePath
snapshotPath = ShowS
getSnapshotPath FilePath
testFile
    Maybe SnapshotFile
mSnapshotFile <-
      FilePath -> IO SnapshotFileLoadResult
loadSnapshotFile FilePath
snapshotPath IO SnapshotFileLoadResult
-> (SnapshotFileLoadResult -> IO (Maybe SnapshotFile))
-> IO (Maybe SnapshotFile)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        SnapshotFileLoadResult_Exists SnapshotFile
file -> Maybe SnapshotFile -> IO (Maybe SnapshotFile)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe SnapshotFile -> IO (Maybe SnapshotFile))
-> Maybe SnapshotFile -> IO (Maybe SnapshotFile)
forall a b. (a -> b) -> a -> b
$ SnapshotFile -> Maybe SnapshotFile
forall a. a -> Maybe a
Just SnapshotFile
file
        SnapshotFileLoadResult
SnapshotFileLoadResult_Missing -> Maybe SnapshotFile -> IO (Maybe SnapshotFile)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SnapshotFile
forall a. Maybe a
Nothing
        SnapshotFileLoadResult
SnapshotFileLoadResult_Corrupted -> Text -> IO (Maybe SnapshotFile)
forall (m :: * -> *) a. MonadIO m => Text -> m a
skeletestError (Text -> IO (Maybe SnapshotFile))
-> Text -> IO (Maybe SnapshotFile)
forall a b. (a -> b) -> a -> b
$ Text
"Snapshot file was corrupted: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack FilePath
snapshotPath
    (CheckSnapshotFixture_File, FixtureCleanup)
-> IO (CheckSnapshotFixture_File, FixtureCleanup)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CheckSnapshotFixture_File, FixtureCleanup)
 -> IO (CheckSnapshotFixture_File, FixtureCleanup))
-> (CheckSnapshotFixture_File, FixtureCleanup)
-> IO (CheckSnapshotFixture_File, FixtureCleanup)
forall a b. (a -> b) -> a -> b
$ CheckSnapshotFixture_File
-> (CheckSnapshotFixture_File, FixtureCleanup)
forall a. a -> (a, FixtureCleanup)
noCleanup CheckSnapshotFixture_File{Maybe SnapshotFile
mSnapshotFile :: Maybe SnapshotFile
mSnapshotFile :: Maybe SnapshotFile
mSnapshotFile}

data CheckSnapshotFixture = CheckSnapshotFixture
  { CheckSnapshotFixture -> SnapshotChecker
checker :: SnapshotChecker
  , CheckSnapshotFixture -> IORef Int
snapshotIndexRef :: IORef Int
  }

instance Fixture CheckSnapshotFixture where
  fixtureScope :: FixtureScope
fixtureScope = FixtureScope
PerTestFixture
  fixtureAction :: IO (CheckSnapshotFixture, FixtureCleanup)
fixtureAction = do
    TestInfo
testInfo <- IO TestInfo
forall (m :: * -> *). (MonadIO m, HasCallStack) => m TestInfo
getTestInfo
    IORef Int
snapshotIndexRef <- Int -> IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Int
0
    let checker :: SnapshotChecker
checker = (forall a. Typeable a => a -> IO SnapshotResult) -> SnapshotChecker
SnapshotChecker (TestInfo -> IORef Int -> a -> IO SnapshotResult
forall a.
Typeable a =>
TestInfo -> IORef Int -> a -> IO SnapshotResult
runCheckSnapshot TestInfo
testInfo IORef Int
snapshotIndexRef)
    (CheckSnapshotFixture, FixtureCleanup)
-> IO (CheckSnapshotFixture, FixtureCleanup)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((CheckSnapshotFixture, FixtureCleanup)
 -> IO (CheckSnapshotFixture, FixtureCleanup))
-> (CheckSnapshotFixture, FixtureCleanup)
-> IO (CheckSnapshotFixture, FixtureCleanup)
forall a b. (a -> b) -> a -> b
$ CheckSnapshotFixture -> (CheckSnapshotFixture, FixtureCleanup)
forall a. a -> (a, FixtureCleanup)
noCleanup CheckSnapshotFixture{SnapshotChecker
checker :: SnapshotChecker
checker :: SnapshotChecker
checker, IORef Int
snapshotIndexRef :: IORef Int
snapshotIndexRef :: IORef Int
snapshotIndexRef}

runCheckSnapshot :: (Typeable a) => TestInfo -> IORef Int -> a -> IO SnapshotResult
runCheckSnapshot :: forall a.
Typeable a =>
TestInfo -> IORef Int -> a -> IO SnapshotResult
runCheckSnapshot TestInfo
testInfo IORef Int
snapshotIndexRef a
val = ExceptT SnapshotResult IO Void -> IO SnapshotResult
forall {b}. ExceptT b IO Void -> IO b
runReturnE (ExceptT SnapshotResult IO Void -> IO SnapshotResult)
-> ExceptT SnapshotResult IO Void -> IO SnapshotResult
forall a b. (a -> b) -> a -> b
$ do
  CheckSnapshotFixture_File{Maybe SnapshotFile
mSnapshotFile :: CheckSnapshotFixture_File -> Maybe SnapshotFile
mSnapshotFile :: Maybe SnapshotFile
mSnapshotFile} <- ExceptT SnapshotResult IO CheckSnapshotFixture_File
forall a (m :: * -> *). (Fixture a, MonadIO m) => m a
getFixture
  [SnapshotRenderer]
renderers <- ExceptT SnapshotResult IO [SnapshotRenderer]
forall (m :: * -> *). MonadIO m => m [SnapshotRenderer]
getSnapshotRenderers

  let newSnapshotVal :: SnapshotValue
newSnapshotVal = [SnapshotRenderer] -> a -> SnapshotValue
forall a. Typeable a => [SnapshotRenderer] -> a -> SnapshotValue
renderVal [SnapshotRenderer]
renderers a
val
      snapshotMissing :: SnapshotResult
snapshotMissing = Text -> SnapshotResult
SnapshotMissing SnapshotValue
newSnapshotVal.content

  Int
index <- IORef Int -> (Int -> (Int, Int)) -> ExceptT SnapshotResult IO Int
forall (m :: * -> *) a b.
MonadIO m =>
IORef a -> (a -> (a, b)) -> m b
atomicModifyIORef' IORef Int
snapshotIndexRef ((Int -> (Int, Int)) -> ExceptT SnapshotResult IO Int)
-> (Int -> (Int, Int)) -> ExceptT SnapshotResult IO Int
forall a b. (a -> b) -> a -> b
$ \Int
index -> (Int
index Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
index)

  SnapshotFile
snapshotFile <- ExceptT SnapshotResult IO SnapshotFile
-> (SnapshotFile -> ExceptT SnapshotResult IO SnapshotFile)
-> Maybe SnapshotFile
-> ExceptT SnapshotResult IO SnapshotFile
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SnapshotResult -> ExceptT SnapshotResult IO SnapshotFile
forall {e} {a}. e -> ExceptT e IO a
returnE SnapshotResult
snapshotMissing) SnapshotFile -> ExceptT SnapshotResult IO SnapshotFile
forall a. a -> ExceptT SnapshotResult IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SnapshotFile
mSnapshotFile
  let testSnapshots :: [SnapshotValue]
testSnapshots = [SnapshotValue]
-> SnapshotTestId
-> Map SnapshotTestId [SnapshotValue]
-> [SnapshotValue]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] (TestInfo -> SnapshotTestId
getSnapshotTestId TestInfo
testInfo) SnapshotFile
snapshotFile.snapshots
  SnapshotValue
snapshot <-
    ExceptT SnapshotResult IO SnapshotValue
-> (NonEmpty SnapshotValue
    -> ExceptT SnapshotResult IO SnapshotValue)
-> Maybe (NonEmpty SnapshotValue)
-> ExceptT SnapshotResult IO SnapshotValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SnapshotResult -> ExceptT SnapshotResult IO SnapshotValue
forall {e} {a}. e -> ExceptT e IO a
returnE SnapshotResult
snapshotMissing) (SnapshotValue -> ExceptT SnapshotResult IO SnapshotValue
forall a. a -> ExceptT SnapshotResult IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapshotValue -> ExceptT SnapshotResult IO SnapshotValue)
-> (NonEmpty SnapshotValue -> SnapshotValue)
-> NonEmpty SnapshotValue
-> ExceptT SnapshotResult IO SnapshotValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty SnapshotValue -> SnapshotValue
forall a. NonEmpty a -> a
NonEmpty.head) (Maybe (NonEmpty SnapshotValue)
 -> ExceptT SnapshotResult IO SnapshotValue)
-> Maybe (NonEmpty SnapshotValue)
-> ExceptT SnapshotResult IO SnapshotValue
forall a b. (a -> b) -> a -> b
$
      ([SnapshotValue] -> Maybe (NonEmpty SnapshotValue)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty ([SnapshotValue] -> Maybe (NonEmpty SnapshotValue))
-> ([SnapshotValue] -> [SnapshotValue])
-> [SnapshotValue]
-> Maybe (NonEmpty SnapshotValue)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [SnapshotValue] -> [SnapshotValue]
forall a. Int -> [a] -> [a]
drop Int
index) [SnapshotValue]
testSnapshots

  SnapshotResult -> ExceptT SnapshotResult IO Void
forall {e} {a}. e -> ExceptT e IO a
returnE (SnapshotResult -> ExceptT SnapshotResult IO Void)
-> SnapshotResult -> ExceptT SnapshotResult IO Void
forall a b. (a -> b) -> a -> b
$
    if SnapshotValue
snapshot.content Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== SnapshotValue
newSnapshotVal.content
      then SnapshotResult
SnapshotMatches
      else
        SnapshotDiff
          { snapshotContent :: Text
snapshotContent = SnapshotValue
snapshot.content
          , renderedTestResult :: Text
renderedTestResult = SnapshotValue
newSnapshotVal.content
          }
 where
  runReturnE :: ExceptT b IO Void -> IO b
runReturnE = (Either b Void -> b) -> IO (Either b Void) -> IO b
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((b -> b) -> (Void -> b) -> Either b Void -> b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either b -> b
forall a. a -> a
id Void -> b
forall a. Void -> a
absurd) (IO (Either b Void) -> IO b)
-> (ExceptT b IO Void -> IO (Either b Void))
-> ExceptT b IO Void
-> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT b IO Void -> IO (Either b Void)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
Except.runExceptT
  returnE :: e -> ExceptT e IO a
returnE = e -> ExceptT e IO a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
Except.throwE

-- | Check if the snapshot file contains any extra snapshots for the current test
checkExtraTestSnapshots :: TestInfo -> IO ()
checkExtraTestSnapshots :: TestInfo -> IO ()
checkExtraTestSnapshots TestInfo
testInfo = do
  CheckSnapshotFixture_File{Maybe SnapshotFile
mSnapshotFile :: CheckSnapshotFixture_File -> Maybe SnapshotFile
mSnapshotFile :: Maybe SnapshotFile
mSnapshotFile} <- IO CheckSnapshotFixture_File
forall a (m :: * -> *). (Fixture a, MonadIO m) => m a
getFixture
  (Maybe () -> ()) -> IO (Maybe ()) -> IO ()
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Maybe () -> ()
forall a. a -> Maybe a -> a
fromMaybe ()) (IO (Maybe ()) -> IO ())
-> (MaybeT IO () -> IO (Maybe ())) -> MaybeT IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT IO () -> IO (Maybe ())
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
Maybe.runMaybeT (MaybeT IO () -> IO ()) -> MaybeT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    SnapshotFile
snapshotFile <- Maybe SnapshotFile -> MaybeT IO SnapshotFile
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
Maybe.hoistMaybe Maybe SnapshotFile
mSnapshotFile
    [SnapshotValue]
testSnapshots <- Maybe [SnapshotValue] -> MaybeT IO [SnapshotValue]
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
Maybe.hoistMaybe (Maybe [SnapshotValue] -> MaybeT IO [SnapshotValue])
-> Maybe [SnapshotValue] -> MaybeT IO [SnapshotValue]
forall a b. (a -> b) -> a -> b
$ SnapshotTestId
-> Map SnapshotTestId [SnapshotValue] -> Maybe [SnapshotValue]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (TestInfo -> SnapshotTestId
getSnapshotTestId TestInfo
testInfo) SnapshotFile
snapshotFile.snapshots
    CheckSnapshotFixture{IORef Int
snapshotIndexRef :: CheckSnapshotFixture -> IORef Int
snapshotIndexRef :: IORef Int
snapshotIndexRef} <- MaybeT IO CheckSnapshotFixture
forall a (m :: * -> *). (Fixture a, MonadIO m) => m a
getFixture
    Int
index <- IORef Int -> MaybeT IO Int
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef Int
snapshotIndexRef
    Bool -> MaybeT IO () -> MaybeT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([SnapshotValue] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SnapshotValue]
testSnapshots Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
index) (MaybeT IO () -> MaybeT IO ()) -> MaybeT IO () -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ do
      let snapshotPath :: FilePath
snapshotPath = ShowS
getSnapshotPath ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
Text.unpack SnapshotFile
snapshotFile.testFile
      IORef SnapshotInfoStore
-> (SnapshotInfoStore -> SnapshotInfoStore) -> MaybeT IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> (a -> a) -> m ()
modifyIORef' IORef SnapshotInfoStore
snapshotInfoStoreRef ((SnapshotInfoStore -> SnapshotInfoStore) -> MaybeT IO ())
-> (SnapshotInfoStore -> SnapshotInfoStore) -> MaybeT IO ()
forall a b. (a -> b) -> a -> b
$ \SnapshotInfoStore
store ->
        SnapshotInfoStore
store
          { snapshotFilesWithExtraSnapshots =
              Set.insert snapshotPath store.snapshotFilesWithExtraSnapshots
          }

{----- Snapshot file -----}

data SnapshotFile = SnapshotFile
  { SnapshotFile -> Text
testFile :: Text
  , SnapshotFile -> Map SnapshotTestId [SnapshotValue]
snapshots :: Map SnapshotTestId [SnapshotValue]
  -- ^ Map from test identifier to its snapshots, e.g.
  -- "group1 ≫ group2 ≫ returns val1 and val2" => ["val1", "val2"]
  }
  deriving (Int -> SnapshotFile -> ShowS
[SnapshotFile] -> ShowS
SnapshotFile -> FilePath
(Int -> SnapshotFile -> ShowS)
-> (SnapshotFile -> FilePath)
-> ([SnapshotFile] -> ShowS)
-> Show SnapshotFile
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapshotFile -> ShowS
showsPrec :: Int -> SnapshotFile -> ShowS
$cshow :: SnapshotFile -> FilePath
show :: SnapshotFile -> FilePath
$cshowList :: [SnapshotFile] -> ShowS
showList :: [SnapshotFile] -> ShowS
Show, SnapshotFile -> SnapshotFile -> Bool
(SnapshotFile -> SnapshotFile -> Bool)
-> (SnapshotFile -> SnapshotFile -> Bool) -> Eq SnapshotFile
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SnapshotFile -> SnapshotFile -> Bool
== :: SnapshotFile -> SnapshotFile -> Bool
$c/= :: SnapshotFile -> SnapshotFile -> Bool
/= :: SnapshotFile -> SnapshotFile -> Bool
Eq)

newtype SnapshotTestId = SnapshotTestId Text
  deriving (Int -> SnapshotTestId -> ShowS
[SnapshotTestId] -> ShowS
SnapshotTestId -> FilePath
(Int -> SnapshotTestId -> ShowS)
-> (SnapshotTestId -> FilePath)
-> ([SnapshotTestId] -> ShowS)
-> Show SnapshotTestId
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapshotTestId -> ShowS
showsPrec :: Int -> SnapshotTestId -> ShowS
$cshow :: SnapshotTestId -> FilePath
show :: SnapshotTestId -> FilePath
$cshowList :: [SnapshotTestId] -> ShowS
showList :: [SnapshotTestId] -> ShowS
Show, SnapshotTestId -> SnapshotTestId -> Bool
(SnapshotTestId -> SnapshotTestId -> Bool)
-> (SnapshotTestId -> SnapshotTestId -> Bool) -> Eq SnapshotTestId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SnapshotTestId -> SnapshotTestId -> Bool
== :: SnapshotTestId -> SnapshotTestId -> Bool
$c/= :: SnapshotTestId -> SnapshotTestId -> Bool
/= :: SnapshotTestId -> SnapshotTestId -> Bool
Eq, Eq SnapshotTestId
Eq SnapshotTestId =>
(SnapshotTestId -> SnapshotTestId -> Ordering)
-> (SnapshotTestId -> SnapshotTestId -> Bool)
-> (SnapshotTestId -> SnapshotTestId -> Bool)
-> (SnapshotTestId -> SnapshotTestId -> Bool)
-> (SnapshotTestId -> SnapshotTestId -> Bool)
-> (SnapshotTestId -> SnapshotTestId -> SnapshotTestId)
-> (SnapshotTestId -> SnapshotTestId -> SnapshotTestId)
-> Ord SnapshotTestId
SnapshotTestId -> SnapshotTestId -> Bool
SnapshotTestId -> SnapshotTestId -> Ordering
SnapshotTestId -> SnapshotTestId -> SnapshotTestId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SnapshotTestId -> SnapshotTestId -> Ordering
compare :: SnapshotTestId -> SnapshotTestId -> Ordering
$c< :: SnapshotTestId -> SnapshotTestId -> Bool
< :: SnapshotTestId -> SnapshotTestId -> Bool
$c<= :: SnapshotTestId -> SnapshotTestId -> Bool
<= :: SnapshotTestId -> SnapshotTestId -> Bool
$c> :: SnapshotTestId -> SnapshotTestId -> Bool
> :: SnapshotTestId -> SnapshotTestId -> Bool
$c>= :: SnapshotTestId -> SnapshotTestId -> Bool
>= :: SnapshotTestId -> SnapshotTestId -> Bool
$cmax :: SnapshotTestId -> SnapshotTestId -> SnapshotTestId
max :: SnapshotTestId -> SnapshotTestId -> SnapshotTestId
$cmin :: SnapshotTestId -> SnapshotTestId -> SnapshotTestId
min :: SnapshotTestId -> SnapshotTestId -> SnapshotTestId
Ord)

data SnapshotValue = SnapshotValue
  { SnapshotValue -> Text
content :: Text
  , SnapshotValue -> Maybe Text
lang :: Maybe Text
  }
  deriving (Int -> SnapshotValue -> ShowS
[SnapshotValue] -> ShowS
SnapshotValue -> FilePath
(Int -> SnapshotValue -> ShowS)
-> (SnapshotValue -> FilePath)
-> ([SnapshotValue] -> ShowS)
-> Show SnapshotValue
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SnapshotValue -> ShowS
showsPrec :: Int -> SnapshotValue -> ShowS
$cshow :: SnapshotValue -> FilePath
show :: SnapshotValue -> FilePath
$cshowList :: [SnapshotValue] -> ShowS
showList :: [SnapshotValue] -> ShowS
Show, SnapshotValue -> SnapshotValue -> Bool
(SnapshotValue -> SnapshotValue -> Bool)
-> (SnapshotValue -> SnapshotValue -> Bool) -> Eq SnapshotValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SnapshotValue -> SnapshotValue -> Bool
== :: SnapshotValue -> SnapshotValue -> Bool
$c/= :: SnapshotValue -> SnapshotValue -> Bool
/= :: SnapshotValue -> SnapshotValue -> Bool
Eq, Eq SnapshotValue
Eq SnapshotValue =>
(SnapshotValue -> SnapshotValue -> Ordering)
-> (SnapshotValue -> SnapshotValue -> Bool)
-> (SnapshotValue -> SnapshotValue -> Bool)
-> (SnapshotValue -> SnapshotValue -> Bool)
-> (SnapshotValue -> SnapshotValue -> Bool)
-> (SnapshotValue -> SnapshotValue -> SnapshotValue)
-> (SnapshotValue -> SnapshotValue -> SnapshotValue)
-> Ord SnapshotValue
SnapshotValue -> SnapshotValue -> Bool
SnapshotValue -> SnapshotValue -> Ordering
SnapshotValue -> SnapshotValue -> SnapshotValue
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SnapshotValue -> SnapshotValue -> Ordering
compare :: SnapshotValue -> SnapshotValue -> Ordering
$c< :: SnapshotValue -> SnapshotValue -> Bool
< :: SnapshotValue -> SnapshotValue -> Bool
$c<= :: SnapshotValue -> SnapshotValue -> Bool
<= :: SnapshotValue -> SnapshotValue -> Bool
$c> :: SnapshotValue -> SnapshotValue -> Bool
> :: SnapshotValue -> SnapshotValue -> Bool
$c>= :: SnapshotValue -> SnapshotValue -> Bool
>= :: SnapshotValue -> SnapshotValue -> Bool
$cmax :: SnapshotValue -> SnapshotValue -> SnapshotValue
max :: SnapshotValue -> SnapshotValue -> SnapshotValue
$cmin :: SnapshotValue -> SnapshotValue -> SnapshotValue
min :: SnapshotValue -> SnapshotValue -> SnapshotValue
Ord)

mkSnapshotTestId :: [Text] -> SnapshotTestId
mkSnapshotTestId :: [Text] -> SnapshotTestId
mkSnapshotTestId =
  Text -> SnapshotTestId
SnapshotTestId
    (Text -> SnapshotTestId)
-> ([Text] -> Text) -> [Text] -> SnapshotTestId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate Text
" ≫ "
    ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
sanitizeNonPrint (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
sanitizeArrows (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip)
 where
  sanitizeArrows :: Text -> Text
sanitizeArrows = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"≫" Text
">>"

  -- Replace non-print characters with their escaped representations
  sanitizeNonPrint :: Text -> Text
sanitizeNonPrint Text
s =
    case (Char -> Bool) -> Text -> (Text, Text)
Text.break (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isPrint) Text
s of
      (Text
_, Text
"") -> Text
s -- quick exit in common case where text names are all printable chars
      (Text
pre, Text
post) -> Text
pre Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Char -> Text) -> Text -> Text
Text.concatMap Char -> Text
escapeChar Text
post
   where
    escapeChar :: Char -> Text
escapeChar Char
c =
      if Char -> Bool
isPrint Char
c
        then Char -> Text
Text.singleton Char
c
        else Int -> Text -> Text
Text.drop Int
1 (Text -> Text) -> (Char -> Text) -> Char -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Text -> Text
Text.dropEnd Int
1 (Text -> Text) -> (Char -> Text) -> Char -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
forall a. Show a => a -> Text
showT (Char -> Text) -> Char -> Text
forall a b. (a -> b) -> a -> b
$ Char
c

getSnapshotTestId :: TestInfo -> SnapshotTestId
getSnapshotTestId :: TestInfo -> SnapshotTestId
getSnapshotTestId TestInfo
testInfo = [Text] -> SnapshotTestId
mkSnapshotTestId ([Text] -> SnapshotTestId) -> [Text] -> SnapshotTestId
forall a b. (a -> b) -> a -> b
$ TestInfo
testInfo.contexts [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [TestInfo
testInfo.name]

getSnapshotPath :: FilePath -> FilePath
getSnapshotPath :: ShowS
getSnapshotPath FilePath
testFile = ShowS
stripDotSlash ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ FilePath
testDir FilePath -> ShowS
</> FilePath
"__snapshots__" FilePath -> ShowS
</> FilePath
snapshotFileName
 where
  (FilePath
testDir, FilePath
testFileName) = FilePath -> (FilePath, FilePath)
splitFileName FilePath
testFile
  snapshotFileName :: FilePath
snapshotFileName = FilePath -> ShowS
replaceExtension FilePath
testFileName FilePath
".snap.md"
  stripDotSlash :: ShowS
stripDotSlash = \case
    Char
'.' : Char
'/' : FilePath
dir -> FilePath
dir
    FilePath
dir -> FilePath
dir

emptySnapshotFile :: Text -> SnapshotFile
emptySnapshotFile :: Text -> SnapshotFile
emptySnapshotFile Text
testFile =
  SnapshotFile
    { Text
testFile :: Text
testFile :: Text
testFile
    , snapshots :: Map SnapshotTestId [SnapshotValue]
snapshots = Map SnapshotTestId [SnapshotValue]
forall k a. Map k a
Map.empty
    }

data SnapshotFileLoadResult
  = SnapshotFileLoadResult_Missing
  | SnapshotFileLoadResult_Corrupted
  | SnapshotFileLoadResult_Exists SnapshotFile

loadSnapshotFile :: FilePath -> IO SnapshotFileLoadResult
loadSnapshotFile :: FilePath -> IO SnapshotFileLoadResult
loadSnapshotFile FilePath
path =
  (IOError -> IO SnapshotFileLoadResult)
-> IO SnapshotFileLoadResult -> IO SnapshotFileLoadResult
forall {a}. (IOError -> IO a) -> IO a -> IO a
handleDNE (\IOError
_ -> SnapshotFileLoadResult -> IO SnapshotFileLoadResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapshotFileLoadResult
SnapshotFileLoadResult_Missing) (IO SnapshotFileLoadResult -> IO SnapshotFileLoadResult)
-> IO SnapshotFileLoadResult -> IO SnapshotFileLoadResult
forall a b. (a -> b) -> a -> b
$ do
    Text
contents <- FilePath -> IO Text
readTestFile FilePath
path
    SnapshotFileLoadResult -> IO SnapshotFileLoadResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SnapshotFileLoadResult -> IO SnapshotFileLoadResult)
-> SnapshotFileLoadResult -> IO SnapshotFileLoadResult
forall a b. (a -> b) -> a -> b
$
      case Text -> Maybe SnapshotFile
decodeSnapshotFile Text
contents of
        Just SnapshotFile
file -> SnapshotFile -> SnapshotFileLoadResult
SnapshotFileLoadResult_Exists SnapshotFile
file
        Maybe SnapshotFile
Nothing -> SnapshotFileLoadResult
SnapshotFileLoadResult_Corrupted
 where
  handleDNE :: (IOError -> IO a) -> IO a -> IO a
handleDNE = (IOError -> Maybe IOError) -> (IOError -> IO a) -> IO a -> IO a
forall (m :: * -> *) e b a.
(MonadUnliftIO m, Exception e) =>
(e -> Maybe b) -> (b -> m a) -> m a -> m a
handleJust (\IOError
e -> Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (IOError -> Bool
isDoesNotExistError IOError
e) Maybe () -> Maybe IOError -> Maybe IOError
forall a b. Maybe a -> Maybe b -> Maybe b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> IOError -> Maybe IOError
forall a. a -> Maybe a
Just IOError
e)

saveSnapshotFile :: FilePath -> SnapshotFile -> IO ()
saveSnapshotFile :: FilePath -> SnapshotFile -> IO ()
saveSnapshotFile FilePath
path SnapshotFile
snapshotFile =
  if Map SnapshotTestId [SnapshotValue] -> Bool
forall k a. Map k a -> Bool
Map.null SnapshotFile
snapshotFile.snapshots
    then FilePath -> IO ()
forall {m :: * -> *}. MonadIO m => FilePath -> m ()
removeFile FilePath
path
    else do
      SnapshotTestId -> Int
rankTestId <- SnapshotInfoStore -> SnapshotTestId -> Int
forall {p} {k}.
(HasField "allSnapshotTestIds" p (Map FilePath [k]), Ord k) =>
p -> k -> Int
mkRankTestId (SnapshotInfoStore -> SnapshotTestId -> Int)
-> IO SnapshotInfoStore -> IO (SnapshotTestId -> Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef SnapshotInfoStore -> IO SnapshotInfoStore
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef SnapshotInfoStore
snapshotInfoStoreRef
      Bool -> FilePath -> IO ()
forall (m :: * -> *). MonadIO m => Bool -> FilePath -> m ()
createDirectoryIfMissing Bool
True (ShowS
takeDirectory FilePath
path)
      FilePath -> Text -> IO ()
Text.writeFile FilePath
path (Text -> IO ()) -> (SnapshotFile -> Text) -> SnapshotFile -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SnapshotTestId -> Int) -> SnapshotFile -> Text
encodeSnapshotFile SnapshotTestId -> Int
rankTestId (SnapshotFile -> Text)
-> (SnapshotFile -> SnapshotFile) -> SnapshotFile -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SnapshotFile -> SnapshotFile
normalizeSnapshotFile (SnapshotFile -> IO ()) -> SnapshotFile -> IO ()
forall a b. (a -> b) -> a -> b
$
        SnapshotFile
snapshotFile
 where
  mkRankTestId :: p -> k -> Int
mkRankTestId p
store =
    let testIds :: [k]
testIds = [k] -> FilePath -> Map FilePath [k] -> [k]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] FilePath
path p
store.allSnapshotTestIds
        testIdToRank :: Map k Int
testIdToRank = [(k, Int)] -> Map k Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(k, Int)] -> Map k Int) -> [(k, Int)] -> Map k Int
forall a b. (a -> b) -> a -> b
$ [k] -> [Int] -> [(k, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [k]
testIds [Int
0 ..]
     in \k
testId ->
          Int -> k -> Map k Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault
            (forall a. Bounded a => a
maxBound @Int) -- Shouldn't happen, but just in case
            k
testId
            Map k Int
testIdToRank

decodeSnapshotFile :: Text -> Maybe SnapshotFile
decodeSnapshotFile :: Text -> Maybe SnapshotFile
decodeSnapshotFile = [Text] -> Maybe SnapshotFile
parseFile ([Text] -> Maybe SnapshotFile)
-> (Text -> [Text]) -> Text -> Maybe SnapshotFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.lines
 where
  parseFile :: [Text] -> Maybe SnapshotFile
parseFile = \case
    Text
line : [Text]
rest
      | Just Text
testFile <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"# " Text
line -> do
          let snapshotFile :: SnapshotFile
snapshotFile =
                SnapshotFile
                  { testFile :: Text
testFile = Text -> Text
Text.strip Text
testFile
                  , snapshots :: Map SnapshotTestId [SnapshotValue]
snapshots = Map SnapshotTestId [SnapshotValue]
forall k a. Map k a
Map.empty
                  }
          SnapshotFile
-> Maybe SnapshotTestId -> [Text] -> Maybe SnapshotFile
parseSections SnapshotFile
snapshotFile Maybe SnapshotTestId
forall a. Maybe a
Nothing [Text]
rest
    [Text]
_ -> Maybe SnapshotFile
forall a. Maybe a
Nothing

  parseSections ::
    SnapshotFile -> -- The parsed snapshot file so far
    Maybe SnapshotTestId -> -- The current test identifier, if one is set
    [Text] -> -- The rest of the lines to process
    Maybe SnapshotFile
  parseSections :: SnapshotFile
-> Maybe SnapshotTestId -> [Text] -> Maybe SnapshotFile
parseSections SnapshotFile
snapshotFile Maybe SnapshotTestId
mTest = \case
    [] -> SnapshotFile -> Maybe SnapshotFile
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapshotFile
snapshotFile
    Text
line : [Text]
rest
      -- ignore empty lines
      | Text
"" <- Text -> Text
Text.strip Text
line -> SnapshotFile
-> Maybe SnapshotTestId -> [Text] -> Maybe SnapshotFile
parseSections SnapshotFile
snapshotFile Maybe SnapshotTestId
mTest [Text]
rest
      -- found a test section
      | Just Text
sectionName <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"## " Text
line -> do
          let testIdentifier :: SnapshotTestId
testIdentifier
                -- Backwards compat, skeletest < 0.4 separated with "/"
                | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text
"≫" Text -> Text -> Bool
`Text.isInfixOf` Text
sectionName = [Text] -> SnapshotTestId
mkSnapshotTestId ([Text] -> SnapshotTestId) -> [Text] -> SnapshotTestId
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
" / " Text
sectionName
                | Bool
otherwise = Text -> SnapshotTestId
SnapshotTestId Text
sectionName
          let snapshotFile' :: SnapshotFile
snapshotFile' = SnapshotFile
snapshotFile{snapshots = Map.insert testIdentifier [] snapshotFile.snapshots}
          SnapshotFile
-> Maybe SnapshotTestId -> [Text] -> Maybe SnapshotFile
parseSections SnapshotFile
snapshotFile' (SnapshotTestId -> Maybe SnapshotTestId
forall a. a -> Maybe a
Just SnapshotTestId
testIdentifier) [Text]
rest
      -- found the beginning of a snapshot
      | Just Text
lang <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"```" Text
line -> do
          SnapshotTestId
testIdentifier <- Maybe SnapshotTestId
mTest
          (Text
snapshot, [Text]
rest') <- Seq Text -> [Text] -> Maybe (Text, [Text])
parseSnapshot Seq Text
forall a. Seq a
Seq.empty [Text]
rest
          let
            snapshotVal :: SnapshotValue
snapshotVal =
              SnapshotValue
                { content :: Text
content = Text
snapshot
                , lang :: Maybe Text
lang = if Text -> Bool
Text.null Text
lang then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
lang
                }
            snapshotFile' :: SnapshotFile
snapshotFile' = SnapshotFile
snapshotFile{snapshots = Map.adjust (<> [snapshotVal]) testIdentifier snapshotFile.snapshots}
          SnapshotFile
-> Maybe SnapshotTestId -> [Text] -> Maybe SnapshotFile
parseSections SnapshotFile
snapshotFile' Maybe SnapshotTestId
mTest [Text]
rest'
      -- anything else is invalid
      | Bool
otherwise -> Maybe SnapshotFile
forall a. Maybe a
Nothing

  parseSnapshot :: Seq Text -> [Text] -> Maybe (Text, [Text])
parseSnapshot Seq Text
snapshot = \case
    [] -> Maybe (Text, [Text])
forall a. Maybe a
Nothing
    Text
line : [Text]
rest
      | Text
"```" <- Text
line -> (Text, [Text]) -> Maybe (Text, [Text])
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> Text
Text.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Seq Text -> [Text]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Seq.toList Seq Text
snapshot, [Text]
rest)
      | Bool
otherwise -> Seq Text -> [Text] -> Maybe (Text, [Text])
parseSnapshot (Seq Text
snapshot Seq Text -> Text -> Seq Text
forall a. Seq a -> a -> Seq a
Seq.|> Text
line) [Text]
rest

encodeSnapshotFile :: (SnapshotTestId -> Int) -> SnapshotFile -> Text
encodeSnapshotFile :: (SnapshotTestId -> Int) -> SnapshotFile -> Text
encodeSnapshotFile SnapshotTestId -> Int
rankTestId SnapshotFile
snapshotFile =
  Text -> [Text] -> Text
Text.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a
h1 SnapshotFile
snapshotFile.testFile Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ((SnapshotTestId, [SnapshotValue]) -> [Text])
-> [(SnapshotTestId, [SnapshotValue])] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (SnapshotTestId, [SnapshotValue]) -> [Text]
forall {a}.
(HasField "lang" a (Maybe Text), HasField "content" a Text) =>
(SnapshotTestId, [a]) -> [Text]
toSection [(SnapshotTestId, [SnapshotValue])]
snapshots
 where
  snapshots :: [(SnapshotTestId, [SnapshotValue])]
snapshots = ((SnapshotTestId, [SnapshotValue]) -> Int)
-> [(SnapshotTestId, [SnapshotValue])]
-> [(SnapshotTestId, [SnapshotValue])]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (SnapshotTestId -> Int
rankTestId (SnapshotTestId -> Int)
-> ((SnapshotTestId, [SnapshotValue]) -> SnapshotTestId)
-> (SnapshotTestId, [SnapshotValue])
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SnapshotTestId, [SnapshotValue]) -> SnapshotTestId
forall a b. (a, b) -> a
fst) ([(SnapshotTestId, [SnapshotValue])]
 -> [(SnapshotTestId, [SnapshotValue])])
-> (Map SnapshotTestId [SnapshotValue]
    -> [(SnapshotTestId, [SnapshotValue])])
-> Map SnapshotTestId [SnapshotValue]
-> [(SnapshotTestId, [SnapshotValue])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map SnapshotTestId [SnapshotValue]
-> [(SnapshotTestId, [SnapshotValue])]
forall k a. Map k a -> [(k, a)]
Map.toList (Map SnapshotTestId [SnapshotValue]
 -> [(SnapshotTestId, [SnapshotValue])])
-> Map SnapshotTestId [SnapshotValue]
-> [(SnapshotTestId, [SnapshotValue])]
forall a b. (a -> b) -> a -> b
$ SnapshotFile
snapshotFile.snapshots
  toSection :: (SnapshotTestId, [a]) -> [Text]
toSection (SnapshotTestId Text
testId, [a]
snaps) = Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a
h2 Text
testId Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (a -> Text) -> [a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map a -> Text
forall {r}.
(HasField "lang" r (Maybe Text), HasField "content" r Text) =>
r -> Text
codeBlock [a]
snaps

  h1 :: a -> a
h1 a
s = a
"# " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"\n"
  h2 :: a -> a
h2 a
s = a
"## " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"\n"
  codeBlock :: r -> Text
codeBlock r
snapshot =
    [Text] -> Text
Text.concat
      [ Text
"```" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" r
snapshot.lang Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
      , r
snapshot.content
      , Text
"```\n"
      ]

normalizeSnapshotFile :: SnapshotFile -> SnapshotFile
normalizeSnapshotFile :: SnapshotFile -> SnapshotFile
normalizeSnapshotFile SnapshotFile
file =
  SnapshotFile
file
    { snapshots = map normalizeSnapshotVal <$> file.snapshots
    }

{----- Render values -----}

renderVal :: (Typeable a) => [SnapshotRenderer] -> a -> SnapshotValue
renderVal :: forall a. Typeable a => [SnapshotRenderer] -> a -> SnapshotValue
renderVal [SnapshotRenderer]
renderers a
a =
  SnapshotValue -> SnapshotValue
normalizeSnapshotVal (SnapshotValue -> SnapshotValue) -> SnapshotValue -> SnapshotValue
forall a b. (a -> b) -> a -> b
$
    case (SnapshotRenderer -> Maybe SnapshotValue)
-> [SnapshotRenderer] -> [SnapshotValue]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SnapshotRenderer -> Maybe SnapshotValue
tryRender [SnapshotRenderer]
renderers of
      [] ->
        SnapshotValue
          { content :: Text
content = FilePath -> Text
Text.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ a -> FilePath
forall a. a -> FilePath
anythingToString a
a
          , lang :: Maybe Text
lang = Maybe Text
forall a. Maybe a
Nothing
          }
      SnapshotValue
rendered : [SnapshotValue]
_ -> SnapshotValue
rendered
 where
  tryRender :: SnapshotRenderer -> Maybe SnapshotValue
tryRender renderer :: SnapshotRenderer
renderer@SnapshotRenderer{a -> Text
render :: a -> Text
render :: ()
render} =
    let toValue :: a -> SnapshotValue
toValue a
v = SnapshotValue{content :: Text
content = a -> Text
render a
v, lang :: Maybe Text
lang = SnapshotRenderer
renderer.snapshotLang}
     in a -> SnapshotValue
toValue (a -> SnapshotValue) -> Maybe a -> Maybe SnapshotValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
Typeable.cast a
a

normalizeSnapshotVal :: SnapshotValue -> SnapshotValue
normalizeSnapshotVal :: SnapshotValue -> SnapshotValue
normalizeSnapshotVal SnapshotValue
snapshot =
  SnapshotValue
    { content :: Text
content =
        Text -> Text
normalizeTrailingNewlines
          (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
sanitizeBackTicks
          (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ SnapshotValue
snapshot.content
    , lang :: Maybe Text
lang = Maybe Text -> Maybe Text
collapse (Maybe Text -> Maybe Text) -> Maybe Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
Text.filter Char -> Bool
isAlpha (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SnapshotValue
snapshot.lang
    }
 where
  collapse :: Maybe Text -> Maybe Text
collapse = \case
    Just Text
"" -> Maybe Text
forall a. Maybe a
Nothing
    Maybe Text
m -> Maybe Text
m

  sanitizeBackTicks :: Text -> Text
sanitizeBackTicks = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
"```" Text
"\\`\\`\\`"
  -- Ensure there's exactly one trailing newline.
  normalizeTrailingNewlines :: Text -> Text
normalizeTrailingNewlines Text
s = (Char -> Bool) -> Text -> Text
Text.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"