-- | A golden testing suite based on @tasty-golden@, specialized to 'FileLayout'
-- and prioritizing checking @diff@s of whole directories:
--
-- <https://hackage-content.haskell.org/package/tasty-golden-2.3.6>
--
-- Run your test suite with @--accept@ to accept files as the new golden tests.
module Drasil.FileHandling.GoldenTesting
  ( goldenTestingGroup,
    GoldenTestCase,
    goldenTest,
  )
where

import Data.Proxy (Proxy (..))
import Drasil.FileHandling.CommonPaths (localPath)
import Drasil.FileHandling.FileLayout (FileLayout, OverwritePolicy(..), name, writeFiles)
import Drasil.FileHandling.FilePath (toPath)
import System.Directory.OsPath (createDirectoryIfMissing, removePathForcibly)
import System.Exit (ExitCode (ExitSuccess))
import System.OsPath (OsPath, decodeUtf, (</>))
import System.Process (readProcessWithExitCode)
import Test.Tasty (TestTree, testGroup, withResource)
import Test.Tasty.Options (IsOption (..), OptionDescription (..), flagCLParser, lookupOption, safeReadBool)
import Test.Tasty.Providers (IsTest (..), TestName, singleTest, testFailed, testPassed)

-- | Internal: @tasty@ CLI option for accepting fresh artifacts as the new
-- golden.
newtype AcceptTests = AcceptTests Bool

instance IsOption AcceptTests where
  defaultValue :: AcceptTests
defaultValue = Bool -> AcceptTests
AcceptTests Bool
False
  parseValue :: String -> Maybe AcceptTests
parseValue = (Bool -> AcceptTests) -> Maybe Bool -> Maybe AcceptTests
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> AcceptTests
AcceptTests (Maybe Bool -> Maybe AcceptTests)
-> (String -> Maybe Bool) -> String -> Maybe AcceptTests
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Bool
safeReadBool
  optionName :: Tagged AcceptTests String
optionName = String -> Tagged AcceptTests String
forall a. a -> Tagged AcceptTests a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"accept"
  optionHelp :: Tagged AcceptTests String
optionHelp = String -> Tagged AcceptTests String
forall a. a -> Tagged AcceptTests a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
"Accept actual results as new golden outputs."
  optionCLParser :: Parser AcceptTests
optionCLParser = Maybe Char -> AcceptTests -> Parser AcceptTests
forall v. IsOption v => Maybe Char -> v -> Parser v
flagCLParser Maybe Char
forall a. Maybe a
Nothing (Bool -> AcceptTests
AcceptTests Bool
True)

-- | A golden test case.
newtype GoldenTestCase = GTC
  { -- | A 'TestTree' waiting on the target folder and the golden artifacts folder.
    GoldenTestCase -> OsPath -> OsPath -> TestTree
unGTC :: OsPath -> OsPath -> TestTree
  }

-- | Create a golden testing group relative to a main build folder and golden
-- artifacts folder.
goldenTestingGroup ::
  -- | The relative directory where newly generated files should be written.
  OsPath ->
  -- | The relative directory where the expected/golden files are stored.
  OsPath ->
  -- | The name of the test group (e.g., @"Golden Tests"@).
  TestName ->
  -- | A list of golden test cases to run.
  [GoldenTestCase] ->
  TestTree
goldenTestingGroup :: OsPath -> OsPath -> String -> [GoldenTestCase] -> TestTree
goldenTestingGroup OsPath
buildPath OsPath
goldenPath String
groupName [GoldenTestCase]
mkTests =
  IO () -> (() -> IO ()) -> (IO () -> TestTree) -> TestTree
forall a. IO a -> (a -> IO ()) -> (IO a -> TestTree) -> TestTree
withResource
    IO ()
setup
    (IO () -> () -> IO ()
forall a b. a -> b -> a
const (IO () -> () -> IO ()) -> IO () -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
    ( TestTree -> IO () -> TestTree
forall a b. a -> b -> a
const (TestTree -> IO () -> TestTree) -> TestTree -> IO () -> TestTree
forall a b. (a -> b) -> a -> b
$
        String -> [TestTree] -> TestTree
testGroup String
groupName ((GoldenTestCase -> TestTree) -> [GoldenTestCase] -> [TestTree]
forall a b. (a -> b) -> [a] -> [b]
map (\GoldenTestCase
gt -> GoldenTestCase -> OsPath -> OsPath -> TestTree
unGTC GoldenTestCase
gt OsPath
buildPath OsPath
goldenPath) [GoldenTestCase]
mkTests)
    )
  where
    setup :: IO ()
setup = do
      Bool -> OsPath -> IO ()
createDirectoryIfMissing Bool
True (OsPath -> IO ()) -> OsPath -> IO ()
forall a b. (a -> b) -> a -> b
$ OsPath
localPath OsPath -> OsPath -> OsPath
</> OsPath
buildPath
      Bool -> OsPath -> IO ()
createDirectoryIfMissing Bool
True (OsPath -> IO ()) -> OsPath -> IO ()
forall a b. (a -> b) -> a -> b
$ OsPath
localPath OsPath -> OsPath -> OsPath
</> OsPath
goldenPath

-- | Internal: Tasty golden test representation.
--
-- 1. Adds an @--accept@ CLI option.
-- 2. Uses system @diff@ command to compare freshly built artifacts with golden
--    ones.
data GoldenTest = GoldenTest OsPath OsPath OsPath (OsPath -> IO ())

instance IsTest GoldenTest where
  testOptions :: Tagged GoldenTest [OptionDescription]
testOptions = [OptionDescription] -> Tagged GoldenTest [OptionDescription]
forall a. a -> Tagged GoldenTest a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Proxy AcceptTests -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy AcceptTests
forall {k} (t :: k). Proxy t
Proxy :: Proxy AcceptTests)]
  run :: OptionSet -> GoldenTest -> (Progress -> IO ()) -> IO Result
run OptionSet
opts (GoldenTest OsPath
build OsPath
golden OsPath
target OsPath -> IO ()
action) Progress -> IO ()
_ = do
    let AcceptTests Bool
accept = OptionSet -> AcceptTests
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
        buildPath :: OsPath
buildPath = OsPath
localPath OsPath -> OsPath -> OsPath
</> OsPath
build
        goldenPath :: OsPath
goldenPath = OsPath
localPath OsPath -> OsPath -> OsPath
</> OsPath
golden

        buildTarget :: OsPath
buildTarget = OsPath
buildPath OsPath -> OsPath -> OsPath
</> OsPath
target
        goldenTarget :: OsPath
goldenTarget = OsPath
goldenPath OsPath -> OsPath -> OsPath
</> OsPath
target

    String
buildTargetStr <- OsPath -> IO String
forall (m :: * -> *). MonadThrow m => OsPath -> m String
decodeUtf OsPath
buildTarget
    String
goldenTargetStr <- OsPath -> IO String
forall (m :: * -> *). MonadThrow m => OsPath -> m String
decodeUtf OsPath
goldenTarget

    if Bool
accept
      then do
        OsPath -> IO ()
removePathForcibly OsPath
goldenTarget
        OsPath -> IO ()
action OsPath
goldenPath
        Result -> IO Result
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$
          String -> Result
testPassed (String -> Result) -> String -> Result
forall a b. (a -> b) -> a -> b
$
            String
"Accepted fresh artifacts as golden for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
goldenTargetStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
      else do
        OsPath -> IO ()
removePathForcibly OsPath
buildTarget
        OsPath -> IO ()
action OsPath
buildPath
        (ExitCode
exitCode, String
stdout, String
stderr) <-
          String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode
            String
"diff"
            [ String
"-ru",
              String
"--color=always",
              String
"--strip-trailing-cr",
              String
goldenTargetStr,
              String
buildTargetStr
            ]
            String
""
        case ExitCode
exitCode of
          ExitCode
ExitSuccess -> Result -> IO Result
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> Result
testPassed String
""
          ExitCode
_ -> Result -> IO Result
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> IO Result) -> Result -> IO Result
forall a b. (a -> b) -> a -> b
$ String -> Result
testFailed (String -> Result) -> String -> Result
forall a b. (a -> b) -> a -> b
$
            String
"Outputs differ:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stdout String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stderr String -> String -> String
forall a. [a] -> [a] -> [a]
++
            String
"\nIf this is expected, you can accept the changes using `stack test --test-arguments=\"--accept\"`"

-- | Create a golden test case for a given 'FileLayout'. Within the context of a
-- 'goldenTestingGroup', will be dumped to the build folder and compared with
-- the golden artifacts folder.
goldenTest :: TestName -> FileLayout -> GoldenTestCase
goldenTest :: String -> FileLayout -> GoldenTestCase
goldenTest String
tName FileLayout
layout = (OsPath -> OsPath -> TestTree) -> GoldenTestCase
GTC ((OsPath -> OsPath -> TestTree) -> GoldenTestCase)
-> (OsPath -> OsPath -> TestTree) -> GoldenTestCase
forall a b. (a -> b) -> a -> b
$
  \OsPath
buildRoot OsPath
goldenRoot ->
    String -> GoldenTest -> TestTree
forall t. IsTest t => String -> t -> TestTree
singleTest
      String
tName
      ( OsPath -> OsPath -> OsPath -> (OsPath -> IO ()) -> GoldenTest
GoldenTest
          OsPath
buildRoot
          OsPath
goldenRoot
          (PathSegment -> OsPath
toPath (FileLayout -> PathSegment
name FileLayout
layout))
          (\OsPath
p -> OverwritePolicy -> OsPath -> FileLayout -> IO ()
writeFiles OverwritePolicy
NeverOverwrite OsPath
p FileLayout
layout)
      )