{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoFieldSelectors #-}

module Skeletest.Internal.Snapshot (
  -- * Running snapshot
  SnapshotContext (..),
  SnapshotResult (..),
  updateSnapshot,
  checkSnapshot,

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

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

  -- * Infrastructure
  getAndIncSnapshotIndex,
  SnapshotUpdateFlag (..),
) where

import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.Except (runExceptT, throwE)
import Data.Aeson qualified as Aeson
import Data.Aeson.Encode.Pretty qualified as Aeson
import Data.Char (isAlpha, isPrint)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import Data.Text.Lazy qualified as TextL
import Data.Text.Lazy.Encoding qualified as TextL
import Data.Typeable (Typeable)
import Data.Typeable qualified as Typeable
import Data.Void (absurd)
import Debug.RecoverRTTI (anythingToString)
import System.Directory (createDirectoryIfMissing)
import System.FilePath (replaceExtension, splitFileName, takeDirectory, (</>))
import System.IO.Error (isDoesNotExistError)
import System.IO.Unsafe (unsafePerformIO)
import UnliftIO.Exception (throwIO, try)
import UnliftIO.IORef (
  IORef,
  atomicModifyIORef',
  modifyIORef',
  newIORef,
  readIORef,
  writeIORef,
 )

import Skeletest.Internal.CLI (FlagSpec (..), IsFlag (..))
import Skeletest.Internal.Error (SkeletestError (..), invariantViolation)
import Skeletest.Internal.Fixtures (
  Fixture (..),
  FixtureScope (..),
  getFixture,
  noCleanup,
  withCleanup,
 )
import Skeletest.Internal.TestInfo (TestInfo (..), getTestInfo)
import Skeletest.Internal.Utils.Map qualified as Map.Utils

{----- Infrastructure -----}

data SnapshotTestFixture = SnapshotTestFixture
  { SnapshotTestFixture -> IORef Int
snapshotIndexRef :: IORef Int
  }

instance Fixture SnapshotTestFixture where
  fixtureAction :: IO (SnapshotTestFixture, FixtureCleanup)
fixtureAction = do
    snapshotIndexRef <- Int -> IO (IORef Int)
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef Int
0
    pure . noCleanup $ SnapshotTestFixture{..}

getAndIncSnapshotIndex :: (MonadIO m) => m Int
getAndIncSnapshotIndex :: forall (m :: * -> *). MonadIO m => m Int
getAndIncSnapshotIndex = do
  SnapshotTestFixture{snapshotIndexRef} <- m SnapshotTestFixture
forall a (m :: * -> *). (Fixture a, MonadIO m) => m a
getFixture
  atomicModifyIORef' snapshotIndexRef $ \Int
i -> (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
i)

data SnapshotFileFixture = SnapshotFileFixture
  { SnapshotFileFixture -> IORef (Maybe SnapshotFile)
snapshotFileRef :: IORef (Maybe SnapshotFile)
  }

instance Fixture SnapshotFileFixture where
  fixtureScope :: FixtureScope
fixtureScope = FixtureScope
PerFileFixture
  fixtureAction :: IO (SnapshotFileFixture, FixtureCleanup)
fixtureAction = do
    TestInfo{testFile} <- IO TestInfo
forall (m :: * -> *). MonadIO m => m TestInfo
getTestInfo
    let snapshotPath = String -> String
getSnapshotPath String
testFile

    mSnapshotFile <-
      try (Text.readFile snapshotPath) >>= \case
        Left IOError
e
          | IOError -> Bool
isDoesNotExistError IOError
e -> 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
          | Bool
otherwise -> IOError -> IO (Maybe SnapshotFile)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO IOError
e
        Right Text
contents ->
          case Text -> Maybe SnapshotFile
decodeSnapshotFile Text
contents of
            Just SnapshotFile
snapshotFile -> 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
snapshotFile
            Maybe SnapshotFile
Nothing -> SkeletestError -> IO (Maybe SnapshotFile)
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (SkeletestError -> IO (Maybe SnapshotFile))
-> SkeletestError -> IO (Maybe SnapshotFile)
forall a b. (a -> b) -> a -> b
$ String -> SkeletestError
SnapshotFileCorrupted String
snapshotPath
    let snapshotChanged SnapshotFile
newSnapshot = Maybe SnapshotFile
mSnapshotFile Maybe SnapshotFile -> Maybe SnapshotFile -> Bool
forall a. Eq a => a -> a -> Bool
/= SnapshotFile -> Maybe SnapshotFile
forall a. a -> Maybe a
Just SnapshotFile
newSnapshot

    snapshotFileRef <- newIORef mSnapshotFile
    pure . withCleanup SnapshotFileFixture{..} $
      -- write snapshot back out when file is done
      readIORef snapshotFileRef >>= \case
        Just SnapshotFile
snapshotFile | SnapshotFile -> Bool
snapshotChanged SnapshotFile
snapshotFile -> do
          Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> String
takeDirectory String
snapshotPath)
          String -> Text -> IO ()
Text.writeFile String
snapshotPath (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ SnapshotFile -> Text
encodeSnapshotFile (SnapshotFile -> Text) -> SnapshotFile -> Text
forall a b. (a -> b) -> a -> b
$ SnapshotFile -> SnapshotFile
normalizeSnapshotFile SnapshotFile
snapshotFile
        Maybe SnapshotFile
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

newtype SnapshotUpdateFlag = SnapshotUpdateFlag Bool

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

{----- Running snapshot -----}

data SnapshotContext = SnapshotContext
  { SnapshotContext -> [SnapshotRenderer]
snapshotRenderers :: [SnapshotRenderer]
  , SnapshotContext -> TestInfo
snapshotTestInfo :: TestInfo
  , SnapshotContext -> Int
snapshotIndex :: Int
  }

updateSnapshot :: (Typeable a, MonadIO m) => SnapshotContext -> a -> m ()
updateSnapshot :: forall a (m :: * -> *).
(Typeable a, MonadIO m) =>
SnapshotContext -> a -> m ()
updateSnapshot SnapshotContext
snapshotContext a
testResult = do
  SnapshotFileFixture{snapshotFileRef} <- m SnapshotFileFixture
forall a (m :: * -> *). (Fixture a, MonadIO m) => m a
getFixture
  modifyIORef' snapshotFileRef (Just . setSnapshot . fromMaybe emptySnapshotFile)
  where
    SnapshotContext
      { snapshotRenderers :: SnapshotContext -> [SnapshotRenderer]
snapshotRenderers = [SnapshotRenderer]
renderers
      , snapshotTestInfo :: SnapshotContext -> TestInfo
snapshotTestInfo = testInfo :: TestInfo
testInfo@TestInfo{Text
testModule :: Text
testModule :: TestInfo -> Text
testModule}
      , Int
snapshotIndex :: SnapshotContext -> Int
snapshotIndex :: Int
snapshotIndex
      } = SnapshotContext
snapshotContext

    emptySnapshotFile :: SnapshotFile
emptySnapshotFile =
      SnapshotFile
        { moduleName :: Text
moduleName = Text
testModule
        , snapshots :: Map TestIdentifier [SnapshotValue]
snapshots = Map TestIdentifier [SnapshotValue]
forall k a. Map k a
Map.empty
        }

    testIdentifier :: TestIdentifier
testIdentifier = TestInfo -> TestIdentifier
toTestIdentifier TestInfo
testInfo
    renderedTestResult :: SnapshotValue
renderedTestResult = [SnapshotRenderer] -> a -> SnapshotValue
forall a. Typeable a => [SnapshotRenderer] -> a -> SnapshotValue
renderVal [SnapshotRenderer]
renderers a
testResult
    setSnapshot :: SnapshotFile -> SnapshotFile
setSnapshot snapshotFile :: SnapshotFile
snapshotFile@SnapshotFile{Map TestIdentifier [SnapshotValue]
snapshots :: SnapshotFile -> Map TestIdentifier [SnapshotValue]
snapshots :: Map TestIdentifier [SnapshotValue]
snapshots} =
      let setForTest :: Map TestIdentifier [SnapshotValue]
-> Map TestIdentifier [SnapshotValue]
setForTest = ([SnapshotValue] -> [SnapshotValue])
-> TestIdentifier
-> Map TestIdentifier [SnapshotValue]
-> Map TestIdentifier [SnapshotValue]
forall k (t :: * -> *) a.
(Ord k, Foldable t, IsList (t a)) =>
(t a -> t a) -> k -> Map k (t a) -> Map k (t a)
Map.Utils.adjustNested (Int -> SnapshotValue -> [SnapshotValue] -> [SnapshotValue]
setAt Int
snapshotIndex SnapshotValue
renderedTestResult) TestIdentifier
testIdentifier
       in SnapshotFile
snapshotFile{snapshots = setForTest snapshots}

    -- Set the given snapshot at the given index. If the index is too large,
    -- fill in with empty snapshots.
    --
    -- >>> setAt 3 "x" ["a"] == ["a", "", "", "x"]
    setAt :: Int -> SnapshotValue -> [SnapshotValue] -> [SnapshotValue]
setAt Int
i0 SnapshotValue
v =
      let go :: Int -> [SnapshotValue] -> [SnapshotValue]
go = \cases
            Int
i [] -> Int -> SnapshotValue -> [SnapshotValue]
forall a. Int -> a -> [a]
replicate Int
i SnapshotValue
emptySnapshotVal [SnapshotValue] -> [SnapshotValue] -> [SnapshotValue]
forall a. Semigroup a => a -> a -> a
<> [SnapshotValue
v]
            Int
0 (SnapshotValue
_ : [SnapshotValue]
xs) -> SnapshotValue
v SnapshotValue -> [SnapshotValue] -> [SnapshotValue]
forall a. a -> [a] -> [a]
: [SnapshotValue]
xs
            Int
i (SnapshotValue
x : [SnapshotValue]
xs) -> SnapshotValue
x SnapshotValue -> [SnapshotValue] -> [SnapshotValue]
forall a. a -> [a] -> [a]
: Int -> [SnapshotValue] -> [SnapshotValue]
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [SnapshotValue]
xs
       in if Int
i0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
            then String -> [SnapshotValue] -> [SnapshotValue]
forall a. String -> a
invariantViolation (String -> [SnapshotValue] -> [SnapshotValue])
-> String -> [SnapshotValue] -> [SnapshotValue]
forall a b. (a -> b) -> a -> b
$ String
"Got negative snapshot index: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i0
            else Int -> [SnapshotValue] -> [SnapshotValue]
go Int
i0
    emptySnapshotVal :: SnapshotValue
emptySnapshotVal = SnapshotValue{snapshotContent :: Text
snapshotContent = Text
"", snapshotLang :: Maybe Text
snapshotLang = Maybe Text
forall a. Maybe a
Nothing}

data SnapshotResult
  = SnapshotMissing
  | SnapshotMatches
  | SnapshotDiff
      { SnapshotResult -> Text
snapshotContent :: Text
      , SnapshotResult -> Text
renderedTestResult :: Text
      }
  deriving (Int -> SnapshotResult -> String -> String
[SnapshotResult] -> String -> String
SnapshotResult -> String
(Int -> SnapshotResult -> String -> String)
-> (SnapshotResult -> String)
-> ([SnapshotResult] -> String -> String)
-> Show SnapshotResult
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SnapshotResult -> String -> String
showsPrec :: Int -> SnapshotResult -> String -> String
$cshow :: SnapshotResult -> String
show :: SnapshotResult -> String
$cshowList :: [SnapshotResult] -> String -> String
showList :: [SnapshotResult] -> String -> String
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)

checkSnapshot :: (Typeable a, MonadIO m) => SnapshotContext -> a -> m SnapshotResult
checkSnapshot :: forall a (m :: * -> *).
(Typeable a, MonadIO m) =>
SnapshotContext -> a -> m SnapshotResult
checkSnapshot SnapshotContext
snapshotContext a
testResult =
  (Either SnapshotResult Void -> SnapshotResult)
-> m (Either SnapshotResult Void) -> m SnapshotResult
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SnapshotResult -> SnapshotResult)
-> (Void -> SnapshotResult)
-> Either SnapshotResult Void
-> SnapshotResult
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SnapshotResult -> SnapshotResult
forall a. a -> a
id Void -> SnapshotResult
forall a. Void -> a
absurd) (m (Either SnapshotResult Void) -> m SnapshotResult)
-> (ExceptT SnapshotResult m Void
    -> m (Either SnapshotResult Void))
-> ExceptT SnapshotResult m Void
-> m SnapshotResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT SnapshotResult m Void -> m (Either SnapshotResult Void)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT SnapshotResult m Void -> m SnapshotResult)
-> ExceptT SnapshotResult m Void -> m SnapshotResult
forall a b. (a -> b) -> a -> b
$ do
    SnapshotFileFixture{snapshotFileRef} <- ExceptT SnapshotResult m SnapshotFileFixture
forall a (m :: * -> *). (Fixture a, MonadIO m) => m a
getFixture
    fileSnapshots <-
      readIORef snapshotFileRef >>= \case
        Maybe SnapshotFile
Nothing -> SnapshotResult
-> ExceptT SnapshotResult m (Map TestIdentifier [SnapshotValue])
forall {e} {a}. e -> ExceptT e m a
returnE SnapshotResult
SnapshotMissing
        Just SnapshotFile{Map TestIdentifier [SnapshotValue]
snapshots :: SnapshotFile -> Map TestIdentifier [SnapshotValue]
snapshots :: Map TestIdentifier [SnapshotValue]
snapshots} -> Map TestIdentifier [SnapshotValue]
-> ExceptT SnapshotResult m (Map TestIdentifier [SnapshotValue])
forall a. a -> ExceptT SnapshotResult m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map TestIdentifier [SnapshotValue]
snapshots

    let snapshots = TestIdentifier
-> Map TestIdentifier [SnapshotValue] -> [SnapshotValue]
forall {k1} k2 (t :: k1 -> *) (a :: k1).
(Ord k2, IsList (t a)) =>
k2 -> Map k2 (t a) -> t a
Map.Utils.findOrEmpty (TestInfo -> TestIdentifier
toTestIdentifier TestInfo
testInfo) Map TestIdentifier [SnapshotValue]
fileSnapshots
    snapshot <- maybe (returnE SnapshotMissing) pure $ safeIndex snapshots snapshotIndex

    let (snapshotContent, renderedTestResult) = (getContent snapshot, getContent renderedTestResultVal)
    returnE $
      if snapshotContent == renderedTestResult
        then SnapshotMatches
        else SnapshotDiff{snapshotContent, renderedTestResult}
  where
    SnapshotContext
      { snapshotRenderers :: SnapshotContext -> [SnapshotRenderer]
snapshotRenderers = [SnapshotRenderer]
renderers
      , snapshotTestInfo :: SnapshotContext -> TestInfo
snapshotTestInfo = TestInfo
testInfo
      , Int
snapshotIndex :: SnapshotContext -> Int
snapshotIndex :: Int
snapshotIndex
      } = SnapshotContext
snapshotContext

    returnE :: e -> ExceptT e m a
returnE = e -> ExceptT e m a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE
    renderedTestResultVal :: SnapshotValue
renderedTestResultVal = [SnapshotRenderer] -> a -> SnapshotValue
forall a. Typeable a => [SnapshotRenderer] -> a -> SnapshotValue
renderVal [SnapshotRenderer]
renderers a
testResult

    safeIndex :: [a] -> t -> Maybe a
safeIndex [a]
xs0 t
i0 =
      let go :: t -> [a] -> Maybe a
go = \cases
            t
_ [] -> Maybe a
forall a. Maybe a
Nothing
            t
0 (a
x : [a]
_) -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
            t
i (a
_ : [a]
xs) -> t -> [a] -> Maybe a
go (t
i t -> t -> t
forall a. Num a => a -> a -> a
- t
1) [a]
xs
       in if t
i0 t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
0 then Maybe a
forall a. Maybe a
Nothing else t -> [a] -> Maybe a
forall {a}. t -> [a] -> Maybe a
go t
i0 [a]
xs0

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

data SnapshotFile = SnapshotFile
  { SnapshotFile -> Text
moduleName :: Text
  , SnapshotFile -> Map TestIdentifier [SnapshotValue]
snapshots :: Map TestIdentifier [SnapshotValue]
  -- ^ full test identifier => snapshots
  -- e.g. ["group1", "group2", "returns val1 and val2"] => ["val1", "val2"]
  }
  deriving (Int -> SnapshotFile -> String -> String
[SnapshotFile] -> String -> String
SnapshotFile -> String
(Int -> SnapshotFile -> String -> String)
-> (SnapshotFile -> String)
-> ([SnapshotFile] -> String -> String)
-> Show SnapshotFile
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SnapshotFile -> String -> String
showsPrec :: Int -> SnapshotFile -> String -> String
$cshow :: SnapshotFile -> String
show :: SnapshotFile -> String
$cshowList :: [SnapshotFile] -> String -> String
showList :: [SnapshotFile] -> String -> String
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)

data SnapshotValue = SnapshotValue
  { SnapshotValue -> Text
snapshotContent :: Text
  , SnapshotValue -> Maybe Text
snapshotLang :: Maybe Text
  }
  deriving (Int -> SnapshotValue -> String -> String
[SnapshotValue] -> String -> String
SnapshotValue -> String
(Int -> SnapshotValue -> String -> String)
-> (SnapshotValue -> String)
-> ([SnapshotValue] -> String -> String)
-> Show SnapshotValue
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> SnapshotValue -> String -> String
showsPrec :: Int -> SnapshotValue -> String -> String
$cshow :: SnapshotValue -> String
show :: SnapshotValue -> String
$cshowList :: [SnapshotValue] -> String -> String
showList :: [SnapshotValue] -> String -> String
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)

getContent :: SnapshotValue -> Text
getContent :: SnapshotValue -> Text
getContent SnapshotValue{Text
snapshotContent :: SnapshotValue -> Text
snapshotContent :: Text
snapshotContent} = Text
snapshotContent

type TestIdentifier = [Text]

getSnapshotPath :: FilePath -> FilePath
getSnapshotPath :: String -> String
getSnapshotPath String
testFile = String
testDir String -> String -> String
</> String
"__snapshots__" String -> String -> String
</> String
snapshotFileName
  where
    (String
testDir, String
testFileName) = String -> (String, String)
splitFileName String
testFile
    snapshotFileName :: String
snapshotFileName = String -> String -> String
replaceExtension String
testFileName String
".snap.md"

toTestIdentifier :: TestInfo -> TestIdentifier
toTestIdentifier :: TestInfo -> TestIdentifier
toTestIdentifier TestInfo{TestIdentifier
testContexts :: TestIdentifier
testContexts :: TestInfo -> TestIdentifier
testContexts, Text
testName :: Text
testName :: TestInfo -> Text
testName} = TestIdentifier
testContexts TestIdentifier -> TestIdentifier -> TestIdentifier
forall a. Semigroup a => a -> a -> a
<> [Text
testName]

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

    parseSections ::
      SnapshotFile
      -- \^ The parsed snapshot file so far
      -> Maybe [Text]
      -- \^ The current test identifier, if one is set
      -> [Text]
      -- \^ The rest of the lines to process
      -> Maybe SnapshotFile
    parseSections :: SnapshotFile
-> Maybe TestIdentifier -> TestIdentifier -> Maybe SnapshotFile
parseSections snapshotFile :: SnapshotFile
snapshotFile@SnapshotFile{Map TestIdentifier [SnapshotValue]
snapshots :: SnapshotFile -> Map TestIdentifier [SnapshotValue]
snapshots :: Map TestIdentifier [SnapshotValue]
snapshots} Maybe TestIdentifier
mTest = \case
      [] -> SnapshotFile -> Maybe SnapshotFile
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SnapshotFile
snapshotFile
      Text
line : TestIdentifier
rest
        -- ignore empty lines
        | Text
"" <- Text -> Text
Text.strip Text
line -> SnapshotFile
-> Maybe TestIdentifier -> TestIdentifier -> Maybe SnapshotFile
parseSections SnapshotFile
snapshotFile Maybe TestIdentifier
mTest TestIdentifier
rest
        -- found a test section
        | Just Text
sectionName <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"## " Text
line -> do
            let testIdentifier :: TestIdentifier
testIdentifier = (Text -> Text) -> TestIdentifier -> TestIdentifier
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Text.strip (TestIdentifier -> TestIdentifier)
-> TestIdentifier -> TestIdentifier
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> TestIdentifier
Text -> Text -> TestIdentifier
Text.splitOn Text
" / " Text
sectionName
            let snapshotFile' :: SnapshotFile
snapshotFile' = SnapshotFile
snapshotFile{snapshots = Map.insert testIdentifier [] snapshots}
            SnapshotFile
-> Maybe TestIdentifier -> TestIdentifier -> Maybe SnapshotFile
parseSections SnapshotFile
snapshotFile' (TestIdentifier -> Maybe TestIdentifier
forall a. a -> Maybe a
Just TestIdentifier
testIdentifier) TestIdentifier
rest
        -- found the beginning of a snapshot
        | Just Text
lang <- (Text -> Text -> Maybe Text
Text.stripPrefix Text
"```" (Text -> Maybe Text) -> (Text -> Text) -> Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip) Text
line -> do
            testIdentifier <- Maybe TestIdentifier
mTest
            (snapshot, rest') <- parseSnapshot [] rest
            let
              snapshotVal =
                SnapshotValue
                  { snapshotContent :: Text
snapshotContent = Text
snapshot
                  , snapshotLang :: Maybe Text
snapshotLang = 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{snapshots = Map.adjust (<> [snapshotVal]) testIdentifier snapshots}
            parseSections snapshotFile' mTest rest'
        -- anything else is invalid
        | Bool
otherwise -> Maybe SnapshotFile
forall a. Maybe a
Nothing

    parseSnapshot :: TestIdentifier -> TestIdentifier -> Maybe (Text, TestIdentifier)
parseSnapshot TestIdentifier
snapshot = \case
      [] -> Maybe (Text, TestIdentifier)
forall a. Maybe a
Nothing
      Text
line : TestIdentifier
rest
        | Text
"```" <- Text -> Text
Text.strip Text
line -> (Text, TestIdentifier) -> Maybe (Text, TestIdentifier)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestIdentifier -> Text
Text.unlines TestIdentifier
snapshot, TestIdentifier
rest)
        | Bool
otherwise -> TestIdentifier -> TestIdentifier -> Maybe (Text, TestIdentifier)
parseSnapshot (TestIdentifier
snapshot TestIdentifier -> TestIdentifier -> TestIdentifier
forall a. Semigroup a => a -> a -> a
<> [Text
line]) TestIdentifier
rest

encodeSnapshotFile :: SnapshotFile -> Text
encodeSnapshotFile :: SnapshotFile -> Text
encodeSnapshotFile SnapshotFile{Map TestIdentifier [SnapshotValue]
Text
moduleName :: SnapshotFile -> Text
snapshots :: SnapshotFile -> Map TestIdentifier [SnapshotValue]
moduleName :: Text
snapshots :: Map TestIdentifier [SnapshotValue]
..} =
  Text -> TestIdentifier -> Text
Text.intercalate Text
"\n" (TestIdentifier -> Text) -> TestIdentifier -> Text
forall a b. (a -> b) -> a -> b
$
    Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a
h1 Text
moduleName Text -> TestIdentifier -> TestIdentifier
forall a. a -> [a] -> [a]
: ((TestIdentifier, [SnapshotValue]) -> TestIdentifier)
-> [(TestIdentifier, [SnapshotValue])] -> TestIdentifier
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (TestIdentifier, [SnapshotValue]) -> TestIdentifier
toSection (Map TestIdentifier [SnapshotValue]
-> [(TestIdentifier, [SnapshotValue])]
forall k a. Map k a -> [(k, a)]
Map.toList Map TestIdentifier [SnapshotValue]
snapshots)
  where
    toSection :: (TestIdentifier, [SnapshotValue]) -> TestIdentifier
toSection (TestIdentifier
testIdentifier, [SnapshotValue]
snaps) =
      Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a
h2 (Text -> TestIdentifier -> Text
Text.intercalate Text
" / " TestIdentifier
testIdentifier) Text -> TestIdentifier -> TestIdentifier
forall a. a -> [a] -> [a]
: (SnapshotValue -> Text) -> [SnapshotValue] -> TestIdentifier
forall a b. (a -> b) -> [a] -> [b]
map SnapshotValue -> Text
codeBlock [SnapshotValue]
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 :: SnapshotValue -> Text
codeBlock SnapshotValue{Maybe Text
Text
snapshotContent :: SnapshotValue -> Text
snapshotLang :: SnapshotValue -> Maybe Text
snapshotContent :: Text
snapshotLang :: Maybe Text
..} =
      TestIdentifier -> 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
"" Maybe Text
snapshotLang Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"
        , Text
snapshotContent
        , Text
"```\n"
        ]

normalizeSnapshotFile :: SnapshotFile -> SnapshotFile
normalizeSnapshotFile :: SnapshotFile -> SnapshotFile
normalizeSnapshotFile file :: SnapshotFile
file@SnapshotFile{Map TestIdentifier [SnapshotValue]
snapshots :: SnapshotFile -> Map TestIdentifier [SnapshotValue]
snapshots :: Map TestIdentifier [SnapshotValue]
snapshots} =
  SnapshotFile
file
    { snapshots = Map.fromList . map normalize . Map.toList $ snapshots
    }
  where
    normalize :: (TestIdentifier, [SnapshotValue])
-> (TestIdentifier, [SnapshotValue])
normalize (TestIdentifier
testIdentifier, [SnapshotValue]
vals) =
      ( (Text -> Text) -> TestIdentifier -> TestIdentifier
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
sanitizeSlashes (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip) TestIdentifier
testIdentifier
      , (SnapshotValue -> SnapshotValue)
-> [SnapshotValue] -> [SnapshotValue]
forall a b. (a -> b) -> [a] -> [b]
map SnapshotValue -> SnapshotValue
normalizeSnapshotVal [SnapshotValue]
vals
      )

    sanitizeSlashes :: Text -> Text
sanitizeSlashes = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
Text.replace Text
" /" Text
" \\/"

    sanitizeNonPrint :: Text -> Text
sanitizeNonPrint = (Char -> Text) -> Text -> Text
Text.concatMap ((Char -> Text) -> Text -> Text) -> (Char -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ \case
      Char
c | (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isPrint) Char
c -> 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
. String -> Text
Text.pack (String -> Text) -> (Char -> String) -> Char -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String
forall a. Show a => a -> String
show (Char -> Text) -> Char -> Text
forall a b. (a -> b) -> a -> b
$ Char
c
      Char
c -> Char -> Text
Text.singleton Char
c

{----- Renderers -----}

data SnapshotRenderer
  = forall a.
  (Typeable a) =>
  SnapshotRenderer
  { ()
render :: a -> Text
  , SnapshotRenderer -> Maybe Text
snapshotLang :: Maybe Text
  }

plainRenderer :: (Typeable a) => (a -> Text) -> SnapshotRenderer
plainRenderer :: forall a. Typeable a => (a -> Text) -> SnapshotRenderer
plainRenderer a -> Text
render =
  SnapshotRenderer
    { a -> Text
render :: a -> Text
render :: a -> Text
render
    , snapshotLang :: Maybe Text
snapshotLang = Maybe Text
forall a. Maybe a
Nothing
    }

renderWithShow :: forall a. (Typeable a, Show a) => SnapshotRenderer
renderWithShow :: forall a. (Typeable a, Show a) => SnapshotRenderer
renderWithShow = (a -> Text) -> SnapshotRenderer
forall a. Typeable a => (a -> Text) -> SnapshotRenderer
plainRenderer (String -> Text
Text.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show @a)

defaultSnapshotRenderers :: [SnapshotRenderer]
defaultSnapshotRenderers :: [SnapshotRenderer]
defaultSnapshotRenderers =
  [ forall a. Typeable a => (a -> Text) -> SnapshotRenderer
plainRenderer @String String -> Text
Text.pack
  , forall a. Typeable a => (a -> Text) -> SnapshotRenderer
plainRenderer @Text Text -> Text
forall a. a -> a
id
  , SnapshotRenderer
jsonRenderer
  ]
  where
    jsonRenderer :: SnapshotRenderer
jsonRenderer =
      SnapshotRenderer
        { render :: Value -> Text
render = LazyText -> Text
TextL.toStrict (LazyText -> Text) -> (Value -> LazyText) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> LazyText
TextL.decodeUtf8 (ByteString -> LazyText)
-> (Value -> ByteString) -> Value -> LazyText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
Aeson.encodePretty @Aeson.Value
        , snapshotLang :: Maybe Text
snapshotLang = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"json"
        }

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
          { snapshotContent :: Text
snapshotContent = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. a -> String
anythingToString a
a
          , snapshotLang :: Maybe Text
snapshotLang = Maybe Text
forall a. Maybe a
Nothing
          }
      SnapshotValue
rendered : [SnapshotValue]
_ -> SnapshotValue
rendered
  where
    tryRender :: SnapshotRenderer -> Maybe SnapshotValue
tryRender SnapshotRenderer{Maybe Text
a -> Text
render :: ()
snapshotLang :: SnapshotRenderer -> Maybe Text
render :: a -> Text
snapshotLang :: Maybe Text
..} =
      let toValue :: a -> SnapshotValue
toValue a
v = SnapshotValue{snapshotContent :: Text
snapshotContent = a -> Text
render a
v, Maybe Text
snapshotLang :: Maybe Text
snapshotLang :: Maybe Text
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{Maybe Text
Text
snapshotContent :: SnapshotValue -> Text
snapshotLang :: SnapshotValue -> Maybe Text
snapshotContent :: Text
snapshotLang :: Maybe Text
..} =
  SnapshotValue
    { snapshotContent :: Text
snapshotContent = Text -> Text
normalizeTrailingNewlines Text
snapshotContent
    , snapshotLang :: Maybe Text
snapshotLang = 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
<$> Maybe Text
snapshotLang
    }
  where
    collapse :: Maybe Text -> Maybe Text
collapse = \case
      Just Text
"" -> Maybe Text
forall a. Maybe a
Nothing
      Maybe Text
m -> Maybe Text
m

    -- 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"

snapshotRenderersRef :: IORef [SnapshotRenderer]
snapshotRenderersRef :: IORef [SnapshotRenderer]
snapshotRenderersRef = IO (IORef [SnapshotRenderer]) -> IORef [SnapshotRenderer]
forall a. IO a -> a
unsafePerformIO (IO (IORef [SnapshotRenderer]) -> IORef [SnapshotRenderer])
-> IO (IORef [SnapshotRenderer]) -> IORef [SnapshotRenderer]
forall a b. (a -> b) -> a -> b
$ [SnapshotRenderer] -> IO (IORef [SnapshotRenderer])
forall (m :: * -> *) a. MonadIO m => a -> m (IORef a)
newIORef []
{-# NOINLINE snapshotRenderersRef #-}

setSnapshotRenderers :: [SnapshotRenderer] -> IO ()
setSnapshotRenderers :: [SnapshotRenderer] -> IO ()
setSnapshotRenderers = IORef [SnapshotRenderer] -> [SnapshotRenderer] -> IO ()
forall (m :: * -> *) a. MonadIO m => IORef a -> a -> m ()
writeIORef IORef [SnapshotRenderer]
snapshotRenderersRef

getSnapshotRenderers :: (MonadIO m) => m [SnapshotRenderer]
getSnapshotRenderers :: forall (m :: * -> *). MonadIO m => m [SnapshotRenderer]
getSnapshotRenderers = IORef [SnapshotRenderer] -> m [SnapshotRenderer]
forall (m :: * -> *) a. MonadIO m => IORef a -> m a
readIORef IORef [SnapshotRenderer]
snapshotRenderersRef