{-# LANGUAGE TypeFamilies #-}

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

-- | Functions for [golden testing](https://ro-che.info/articles/2017-12-04-golden-tests).

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.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
import UnliftIO.Exception


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 = String -> Maybe String
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 = (String -> Text -> IO ())
-> (String -> IO Text) -> String -> Text -> Golden Text
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 = (String -> String -> IO ())
-> (String -> IO String) -> String -> String -> Golden String
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 = (String -> a -> IO ())
-> (String -> IO a) -> String -> a -> Golden a
forall a.
(String -> a -> IO ())
-> (String -> IO a) -> String -> a -> Golden a
mkGolden (\String
f a
x -> String -> ByteString -> IO ()
BL.writeFile String
f (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode a
x) ((String -> IO a) -> String -> a -> Golden a)
-> (String -> IO a) -> String -> a -> Golden a
forall a b. (a -> b) -> a -> b
$ \String
f ->
  String -> IO (Either String a)
forall a. FromJSON a => String -> IO (Either String a)
eitherDecodeFileStrict' String
f IO (Either String a) -> (Either String a -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left String
err -> String -> IO a
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => String -> m a
expectationFailure [i|Failed to decode JSON value in #{f}: #{err}|]
    Right a
x -> a -> IO a
forall a. a -> IO a
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 = (String -> a -> IO ())
-> (String -> IO a) -> String -> a -> Golden a
forall a.
(String -> a -> IO ())
-> (String -> IO a) -> String -> a -> Golden a
mkGolden (\String
f a
x -> String -> String -> IO ()
writeFile String
f (a -> String
forall a. Show a => a -> String
show a
x)) ((String -> a
forall a. Read a => String -> a
read (String -> a) -> IO String -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (IO String -> IO a) -> (String -> IO String) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO String
readFile)

-- | Runs a Golden test.

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

  case Maybe String
goldenActualFile of
    Maybe String
Nothing -> () -> ExampleT context m ()
forall a. a -> ExampleT context m a
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
      IO () -> ExampleT context m ()
forall a. IO a -> ExampleT context m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExampleT context m ()) -> IO () -> ExampleT context m ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
actualDir
      IO () -> ExampleT context m ()
forall a. IO a -> ExampleT context m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExampleT context m ()) -> IO () -> ExampleT context m ()
forall a b. (a -> b) -> a -> b
$ String -> str -> IO ()
goldenWriteToFile String
actual str
goldenOutput

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