{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}

module Hedgehog.Extras.Test.Golden
  ( diffVsGoldenFile,
    diffFileVsGoldenFile,
    diffVsGoldenFileExcludeTrace,
  ) where

import           Control.Applicative
import           Control.Exception.Lifted
import           Control.Monad
import           Control.Monad.IO.Class (MonadIO (liftIO))
import           Control.Monad.Trans.Control
import           Data.Algorithm.Diff (PolyDiff (Both), getGroupedDiff)
import           Data.Algorithm.DiffOutput (ppDiff)
import           Data.Bool
import           Data.Eq
import           Data.Function
import           Data.Map (Map)
import           Data.Maybe
import           Data.Monoid
import           Data.String
import           GHC.Stack (HasCallStack, callStack)
import           Hedgehog (MonadTest)
import           Hedgehog.Extras.Test.Base (failMessage)
import           System.Directory (canonicalizePath, getCurrentDirectory)
import           System.FilePath (takeDirectory)
import           System.FilePath.Posix (makeRelative)
import           System.IO (FilePath, IO)

import qualified Control.Concurrent.QSem as IO
import qualified Control.Concurrent.STM as STM
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified GHC.Stack as GHC
import qualified Hedgehog.Extras.Test.Base as H
import qualified Hedgehog.Extras.Test.File as H
import qualified Hedgehog.Internal.Property as H
import qualified System.Directory as IO
import qualified System.Environment as IO
import qualified System.IO as IO
import qualified System.IO.Unsafe as IO

semBracket :: ()
  => MonadIO m
  => MonadBaseControl IO m
  => IO.QSem
  -> m a
  -> m a
semBracket :: forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
QSem -> m a -> m a
semBracket QSem
sem =
  m () -> m () -> m a -> m a
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> m b -> m c -> m c
bracket_
    (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (QSem -> IO ()
IO.waitQSem QSem
sem))
    (IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (QSem -> IO ()
IO.signalQSem QSem
sem))

-- | The file to log whenever a golden file is referenced.
mGoldenFileLogFile :: Maybe FilePath
mGoldenFileLogFile :: Maybe FilePath
mGoldenFileLogFile = IO (Maybe FilePath) -> Maybe FilePath
forall a. IO a -> a
IO.unsafePerformIO (IO (Maybe FilePath) -> Maybe FilePath)
-> IO (Maybe FilePath) -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$
  FilePath -> IO (Maybe FilePath)
IO.lookupEnv FilePath
"GOLDEN_FILE_LOG_FILE"

-- | Whether the test should create the golden files if the files do not exist.
createGoldenFiles :: Bool
createGoldenFiles :: Bool
createGoldenFiles = IO Bool -> Bool
forall a. IO a -> a
IO.unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
  Maybe FilePath
value <- FilePath -> IO (Maybe FilePath)
IO.lookupEnv FilePath
"CREATE_GOLDEN_FILES"
  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
value Maybe FilePath -> Maybe FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"1"

-- | Whether the test should recreate the golden files if the files already exist.
recreateGoldenFiles :: Bool
recreateGoldenFiles :: Bool
recreateGoldenFiles = IO Bool -> Bool
forall a. IO a -> a
IO.unsafePerformIO (IO Bool -> Bool) -> IO Bool -> Bool
forall a b. (a -> b) -> a -> b
$ do
  Maybe FilePath
value <- FilePath -> IO (Maybe FilePath)
IO.lookupEnv FilePath
"RECREATE_GOLDEN_FILES"
  Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Maybe FilePath
value Maybe FilePath -> Maybe FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"1"

writeGoldenFile :: ()
  => HasCallStack
  => MonadIO m
  => MonadTest m
  => FilePath
  -> String
  -> m ()
writeGoldenFile :: forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadTest m) =>
FilePath -> FilePath -> m ()
writeGoldenFile FilePath
goldenFile FilePath
actualContent = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  FilePath -> m ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Creating golden file " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
goldenFile
  FilePath -> m ()
forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
FilePath -> m ()
H.createDirectoryIfMissing_ (FilePath -> FilePath
takeDirectory FilePath
goldenFile)
  FilePath -> FilePath -> m ()
forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
FilePath -> FilePath -> m ()
H.writeFile FilePath
goldenFile FilePath
actualContent

reportGoldenFileMissing :: ()
  => HasCallStack
  => MonadIO m
  => MonadTest m
  => FilePath
  -> m ()
reportGoldenFileMissing :: forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadTest m) =>
FilePath -> m ()
reportGoldenFileMissing FilePath
goldenFile = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  FilePath -> m ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines
    [ FilePath
"Golden file " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
goldenFile FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" does not exist."
    , FilePath
"To create it, run with CREATE_GOLDEN_FILES=1."
    , FilePath
"To recreate it, run with RECREATE_GOLDEN_FILES=1."
    ]
  m ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
H.failure

checkAgainstGoldenFile :: ()
  => HasCallStack
  => MonadIO m
  => MonadTest m
  => FilePath
  -> [String]
  -> m ()
checkAgainstGoldenFile :: forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadTest m) =>
FilePath -> [FilePath] -> m ()
checkAgainstGoldenFile FilePath
goldenFile [FilePath]
actualLines = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  [FilePath]
referenceLines <- FilePath -> [FilePath]
List.lines (FilePath -> [FilePath]) -> m FilePath -> m [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> m FilePath
forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
FilePath -> m FilePath
H.readFile FilePath
goldenFile
  let difference :: [Diff [FilePath]]
difference = [FilePath] -> [FilePath] -> [Diff [FilePath]]
forall a. Eq a => [a] -> [a] -> [Diff [a]]
getGroupedDiff [FilePath]
actualLines [FilePath]
referenceLines
  case [Diff [FilePath]]
difference of
    []       -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [Both{}] -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    [Diff [FilePath]]
_        -> do
      FilePath -> m ()
forall (m :: * -> *).
(MonadTest m, HasCallStack) =>
FilePath -> m ()
H.note_ (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unlines
        [ FilePath
"Golden test failed against the golden file."
        , FilePath
"To recreate golden file, run with RECREATE_GOLDEN_FILES=1."
        ]
      CallStack -> FilePath -> m ()
forall (m :: * -> *) a. MonadTest m => CallStack -> FilePath -> m a
failMessage CallStack
HasCallStack => CallStack
callStack (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ [Diff [FilePath]] -> FilePath
ppDiff [Diff [FilePath]]
difference

tvGoldenFileSems :: STM.TVar (Map FilePath IO.QSem)
tvGoldenFileSems :: TVar (Map FilePath QSem)
tvGoldenFileSems = IO (TVar (Map FilePath QSem)) -> TVar (Map FilePath QSem)
forall a. IO a -> a
IO.unsafePerformIO (IO (TVar (Map FilePath QSem)) -> TVar (Map FilePath QSem))
-> IO (TVar (Map FilePath QSem)) -> TVar (Map FilePath QSem)
forall a b. (a -> b) -> a -> b
$ Map FilePath QSem -> IO (TVar (Map FilePath QSem))
forall a. a -> IO (TVar a)
STM.newTVarIO Map FilePath QSem
forall a. Monoid a => a
mempty
{-# NOINLINE tvGoldenFileSems #-}

getGoldenFileSem :: FilePath -> IO IO.QSem
getGoldenFileSem :: FilePath -> IO QSem
getGoldenFileSem FilePath
filePath = do
  QSem
newSem <- Int -> IO QSem
IO.newQSem Int
1

  STM QSem -> IO QSem
forall a. STM a -> IO a
STM.atomically (STM QSem -> IO QSem) -> STM QSem -> IO QSem
forall a b. (a -> b) -> a -> b
$ do
    Map FilePath QSem
sems <- TVar (Map FilePath QSem) -> STM (Map FilePath QSem)
forall a. TVar a -> STM a
STM.readTVar TVar (Map FilePath QSem)
tvGoldenFileSems
    case FilePath -> Map FilePath QSem -> Maybe QSem
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup FilePath
filePath Map FilePath QSem
sems of
      Just QSem
sem -> QSem -> STM QSem
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return QSem
sem
      Maybe QSem
Nothing  -> do
        let newGoldenFileSems :: Map FilePath QSem
newGoldenFileSems = FilePath -> QSem -> Map FilePath QSem -> Map FilePath QSem
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert FilePath
filePath QSem
newSem Map FilePath QSem
sems
        TVar (Map FilePath QSem) -> Map FilePath QSem -> STM ()
forall a. TVar a -> a -> STM ()
STM.writeTVar TVar (Map FilePath QSem)
tvGoldenFileSems Map FilePath QSem
newGoldenFileSems
        QSem -> STM QSem
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return QSem
newSem

-- | Diff contents against the golden file.  If CREATE_GOLDEN_FILES environment is
-- set to "1", then should the golden file not exist it would be created.  If
-- RECREATE_GOLDEN_FILES is set to "1", then should the golden file exist it would
-- be recreated. If GOLDEN_FILE_LOG_FILE is set to a filename, then the golden file
-- path will be logged to the specified file.
--
-- Set the environment variable when you intend to generate or re-generate the golden
-- file for example when running the test for the first time or if the golden file
-- genuinely needs to change.
--
-- To re-generate a golden file you must also delete the golden file because golden
-- files are never overwritten.
--
-- TODO: Improve the help output by saying the difference of
-- each input.
diffVsGoldenFile
  :: HasCallStack
  => MonadIO m
  => MonadBaseControl IO m
  => MonadTest m
  => String   -- ^ Actual content
  -> FilePath -- ^ Reference file
  -> m ()
diffVsGoldenFile :: forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadBaseControl IO m, MonadTest m) =>
FilePath -> FilePath -> m ()
diffVsGoldenFile FilePath
actualContent FilePath
goldenFile =
  (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
    FilePath
realPath <- IO FilePath -> m FilePath
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
canonicalizePath FilePath
goldenFile
    FilePath
cwd <- IO FilePath -> m FilePath
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO FilePath
getCurrentDirectory

    let relativeGoldenPath :: FilePath
relativeGoldenPath = FilePath -> FilePath -> FilePath
makeRelative FilePath
cwd FilePath
realPath

    QSem
sem <- IO QSem -> m QSem
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO QSem -> m QSem) -> IO QSem -> m QSem
forall a b. (a -> b) -> a -> b
$ FilePath -> IO QSem
getGoldenFileSem FilePath
relativeGoldenPath

    (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ QSem -> m () -> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
QSem -> m a -> m a
semBracket QSem
sem (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
      Maybe FilePath -> (FilePath -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe FilePath
mGoldenFileLogFile ((FilePath -> m ()) -> m ()) -> (FilePath -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \FilePath
logFile ->
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
IO.appendFile FilePath
logFile (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
goldenFile FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"\n"

      Bool
fileExists <- IO Bool -> m Bool
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
IO.doesFileExist FilePath
goldenFile

      if
        | Bool
recreateGoldenFiles -> FilePath -> FilePath -> m ()
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadTest m) =>
FilePath -> FilePath -> m ()
writeGoldenFile FilePath
goldenFile FilePath
actualContent
        | Bool
fileExists          -> FilePath -> [FilePath] -> m ()
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadTest m) =>
FilePath -> [FilePath] -> m ()
checkAgainstGoldenFile FilePath
goldenFile [FilePath]
actualLines
        | Bool
createGoldenFiles   -> FilePath -> FilePath -> m ()
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadTest m) =>
FilePath -> FilePath -> m ()
writeGoldenFile FilePath
goldenFile FilePath
actualContent
        | Bool
otherwise           -> FilePath -> m ()
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadTest m) =>
FilePath -> m ()
reportGoldenFileMissing FilePath
goldenFile

  where
    actualLines :: [FilePath]
actualLines = FilePath -> [FilePath]
List.lines FilePath
actualContent

-- | Diff file against the golden file.  If CREATE_GOLDEN_FILES environment is
-- set to "1", then should the gold file not exist it would be created.  If
-- GOLDEN_FILE_LOG_FILE is set to a filename, then the golden file path will be
-- logged to the specified file.
--
-- Set the environment variable when you intend to generate or re-generate the golden
-- file for example when running the test for the first time or if the golden file
-- genuinely needs to change.
--
-- To re-generate a golden file you must also delete the golden file because golden
-- files are never overwritten.
diffFileVsGoldenFile
  :: HasCallStack
  => MonadBaseControl IO m
  => MonadIO m
  => MonadTest m
  => FilePath -- ^ Actual file
  -> FilePath -- ^ Reference file
  -> m ()
diffFileVsGoldenFile :: forall (m :: * -> *).
(HasCallStack, MonadBaseControl IO m, MonadIO m, MonadTest m) =>
FilePath -> FilePath -> m ()
diffFileVsGoldenFile FilePath
actualFile FilePath
referenceFile = (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
  FilePath
contents <- FilePath -> m FilePath
forall (m :: * -> *).
(MonadTest m, MonadIO m, HasCallStack) =>
FilePath -> m FilePath
H.readFile FilePath
actualFile
  FilePath -> FilePath -> m ()
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadBaseControl IO m, MonadTest m) =>
FilePath -> FilePath -> m ()
diffVsGoldenFile FilePath
contents FilePath
referenceFile

-- | Diff contents against the golden file, excluding the trace.  If CREATE_GOLDEN_FILES environment is
-- set to "1", then should the golden file not exist it would be created.  If
-- RECREATE_GOLDEN_FILES is set to "1", then should the golden file exist it would
-- be recreated. If GOLDEN_FILE_LOG_FILE is set to a filename, then the golden file
-- path will be logged to the specified file.
--
-- Set the environment variable when you intend to generate or re-generate the golden
-- file for example when running the test for the first time or if the golden file
-- genuinely needs to change.
--
-- To re-generate a golden file you must also delete the golden file because golden
-- files are never overwritten.
diffVsGoldenFileExcludeTrace
  :: MonadBaseControl IO m
  => MonadIO m
  => MonadTest m
  => HasCallStack
  => String -> FilePath -> m ()
diffVsGoldenFileExcludeTrace :: forall (m :: * -> *).
(MonadBaseControl IO m, MonadIO m, MonadTest m, HasCallStack) =>
FilePath -> FilePath -> m ()
diffVsGoldenFileExcludeTrace FilePath
inputString FilePath
refFile =
  (HasCallStack => m ()) -> m ()
forall a. HasCallStack => (HasCallStack => a) -> a
GHC.withFrozenCallStack ((HasCallStack => m ()) -> m ()) -> (HasCallStack => m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ do
    case [Text] -> Maybe (Text, [Text])
forall a. [a] -> Maybe (a, [a])
List.uncons ([Text] -> Maybe (Text, [Text])) -> [Text] -> Maybe (Text, [Text])
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
"CallStack" (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
Text.pack FilePath
inputString of
      Just (Text
stackTraceRemoved, [Text]
_) -> FilePath -> FilePath -> m ()
forall (m :: * -> *).
(HasCallStack, MonadIO m, MonadBaseControl IO m, MonadTest m) =>
FilePath -> FilePath -> m ()
diffVsGoldenFile (Text -> FilePath
Text.unpack Text
stackTraceRemoved) FilePath
refFile
      Maybe (Text, [Text])
Nothing ->
        Maybe Diff -> FilePath -> m ()
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> FilePath -> m a
H.failWith Maybe Diff
forall a. Maybe a
Nothing (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$
          [FilePath] -> FilePath
List.unlines
            [ FilePath
"Input string was empty"
            , FilePath
"Reference file: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
refFile
            ]