{-# LANGUAGE TypeFamilies #-}

-- This module is based on Test.Hspec.Golden from hspec-golden-0.2.0.0, which is MIT licensed.

module Test.Sandwich.Golden (
  -- * Main test function
  golden

  -- * Built-in Goldens.
  , goldenText
  , goldenString
  , goldenJSON
  , goldenShowable
  , mkGolden

  -- * Parameters for a 'Golden'.
  , goldenOutput
  , goldenWriteToFile
  , goldenReadFromFile
  , goldenFile
  , goldenActualFile
  , goldenFailFirstTime
  ) where

import Control.Exception.Safe
import Control.Monad
import Control.Monad.Free
import Control.Monad.IO.Class
import Data.Aeson as A
import qualified Data.ByteString.Lazy as BL
import Data.String.Interpolate
import qualified Data.Text as T
import qualified Data.Text.IO as T
import GHC.Stack
import System.Directory
import System.FilePath
import Test.Sandwich
import Test.Sandwich.Golden.Update
import Test.Sandwich.Types.Spec


data Golden a = Golden {
  -- | Name
  forall a. Golden a -> String
goldenName :: String
  -- | Expected output.
  , forall a. Golden a -> a
goldenOutput :: a
  -- | How to write into the golden file the file.
  , forall a. Golden a -> String -> a -> IO ()
goldenWriteToFile :: FilePath -> a -> IO ()
  -- | How to read the file.
  , forall a. Golden a -> String -> IO a
goldenReadFromFile :: FilePath -> IO a
  -- | Where to read/write the golden file for this test.
  , forall a. Golden a -> String
goldenFile :: FilePath
  -- | Where to save the actual file for this test. If it is @Nothing@ then no file is written.
  , forall a. Golden a -> Maybe String
goldenActualFile :: Maybe FilePath
  -- | Whether to record a failure the first time this test is run.
  , forall a. Golden a -> Bool
goldenFailFirstTime :: Bool
  }


-- | Make your own 'Golden' constructor by providing 'goldenWriteToFile' and 'goldenReadFromFile'.
mkGolden :: (FilePath -> a -> IO ()) -> (FilePath -> IO a) -> String -> a -> Golden a
mkGolden :: forall a.
(String -> a -> IO ())
-> (String -> IO a) -> String -> a -> Golden a
mkGolden String -> a -> IO ()
goldenWriteToFile String -> IO a
goldenReadFromFile String
name a
output = Golden {
  goldenName :: String
goldenName = String
name
  , goldenOutput :: a
goldenOutput = a
output
  , goldenWriteToFile :: String -> a -> IO ()
goldenWriteToFile = String -> a -> IO ()
goldenWriteToFile
  , goldenReadFromFile :: String -> IO a
goldenReadFromFile = String -> IO a
goldenReadFromFile
  , goldenFile :: String
goldenFile = String
defaultDirGoldenTest String -> String -> String
</> String
name String -> String -> String
</> String
"golden"
  , goldenActualFile :: Maybe String
goldenActualFile = forall a. a -> Maybe a
Just (String
defaultDirGoldenTest String -> String -> String
</> String
name String -> String -> String
</> String
"actual")
  , goldenFailFirstTime :: Bool
goldenFailFirstTime = Bool
False
  }

-- | Golden for a 'T.Text'.
goldenText :: String -> T.Text -> Golden T.Text
goldenText :: String -> Text -> Golden Text
goldenText = forall a.
(String -> a -> IO ())
-> (String -> IO a) -> String -> a -> Golden a
mkGolden String -> Text -> IO ()
T.writeFile String -> IO Text
T.readFile

-- | Golden for a 'String'.
goldenString :: String -> String -> Golden String
goldenString :: String -> String -> Golden String
goldenString = forall a.
(String -> a -> IO ())
-> (String -> IO a) -> String -> a -> Golden a
mkGolden String -> String -> IO ()
writeFile String -> IO String
readFile

-- | Golden for an Aeson value ('ToJSON'/'FromJSON').
goldenJSON :: (A.ToJSON a, A.FromJSON a) => String -> a -> Golden a
goldenJSON :: forall a. (ToJSON a, FromJSON a) => String -> a -> Golden a
goldenJSON = forall a.
(String -> a -> IO ())
-> (String -> IO a) -> String -> a -> Golden a
mkGolden (\String
f a
x -> String -> ByteString -> IO ()
BL.writeFile String
f forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
A.encode a
x) forall a b. (a -> b) -> a -> b
$ \String
f ->
  forall a. FromJSON a => String -> IO (Either String a)
eitherDecodeFileStrict' String
f forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left String
err -> forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
expectationFailure [i|Failed to decode JSON value in #{f}: #{err}|]
    Right a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- | Golden for a general 'Show'/'Read' type.
goldenShowable :: (Show a, Read a) => String -> a -> Golden a
goldenShowable :: forall a. (Show a, Read a) => String -> a -> Golden a
goldenShowable = forall a.
(String -> a -> IO ())
-> (String -> IO a) -> String -> a -> Golden a
mkGolden (\String
f a
x -> String -> String -> IO ()
writeFile String
f (forall a. Show a => a -> String
show a
x)) ((forall a. Read a => String -> a
read forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
readFile)

-- | Runs a Golden test.

golden :: (MonadIO m, MonadThrow m, Eq str, Show str) => Golden str -> Free (SpecCommand context m) ()
golden :: forall (m :: * -> *) str context.
(MonadIO m, MonadThrow m, Eq str, Show str) =>
Golden str -> Free (SpecCommand context m) ()
golden (Golden {str
Bool
String
Maybe String
String -> IO str
String -> str -> IO ()
goldenFailFirstTime :: Bool
goldenActualFile :: Maybe String
goldenFile :: String
goldenReadFromFile :: String -> IO str
goldenWriteToFile :: String -> str -> IO ()
goldenOutput :: str
goldenName :: String
goldenName :: forall a. Golden a -> String
goldenFailFirstTime :: forall a. Golden a -> Bool
goldenActualFile :: forall a. Golden a -> Maybe String
goldenFile :: forall a. Golden a -> String
goldenReadFromFile :: forall a. Golden a -> String -> IO a
goldenWriteToFile :: forall a. Golden a -> String -> a -> IO ()
goldenOutput :: forall a. Golden a -> a
..}) = forall context (m :: * -> *).
HasCallStack =>
String -> ExampleT context m () -> Free (SpecCommand context m) ()
it String
goldenName forall a b. (a -> b) -> a -> b
$ do
  let goldenTestDir :: String
goldenTestDir = String -> String
takeDirectory String
goldenFile
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
goldenTestDir
  Bool
goldenFileExist <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
goldenFile

  case Maybe String
goldenActualFile of
    Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just String
actual -> do
      -- It is recommended to always write the actual file
      let actualDir :: String
actualDir = String -> String
takeDirectory String
actual
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
actualDir
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> str -> IO ()
goldenWriteToFile String
actual str
goldenOutput

  if Bool -> Bool
not Bool
goldenFileExist
    then do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> str -> IO ()
goldenWriteToFile String
goldenFile str
goldenOutput
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
goldenFailFirstTime forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
expectationFailure [i|Failed due to first execution and goldenFailFirstTime=True.|]
    else do
       forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO str
goldenReadFromFile String
goldenFile) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
         str
x | str
x forall a. Eq a => a -> a -> Bool
== str
goldenOutput -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
         str
x -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Maybe CallStack -> ShowEqBox -> ShowEqBox -> FailureReason
ExpectedButGot (forall a. a -> Maybe a
Just HasCallStack => CallStack
callStack) (forall s. (Show s, Eq s) => s -> ShowEqBox
SEB str
x) (forall s. (Show s, Eq s) => s -> ShowEqBox
SEB str
goldenOutput)