{-# LANGUAGE ExistentialQuantification #-}

-- |
--
-- Module      : Test.Tasty.Golden.Extra.GoldenVsToJSON
-- Copyright   : (C) 2024 Bellroy Pty Ltd
-- License     : BSD-3-Clause
-- Maintainer  : Bellroy Tech Team <haskell@bellroy.com>
-- Stability   : experimental
--
-- These helpers are useful for creating golden tests for @ToJSON@ instances.
module Test.Tasty.Golden.Extra.GoldenVsToJSON
  ( GoldenVsToJSON (..),
    goldenVsToJson,
  )
where

import qualified Data.Aeson as Aeson
import Data.Aeson.Encode.Pretty (encodePretty)
import qualified Data.ByteString.Lazy as BL
import Test.Tasty (TestName, TestTree)
import qualified Test.Tasty.Discover as Discover
import Test.Tasty.Golden.Advanced (goldenTest)
import Test.Tasty.Golden.Extra.Internal (checkJsonDifference, maybeDifference)

-- | Tasty-discoverable type for creating golden tests for @ToJSON@ instances.
--
-- Example use:
--
-- @
--  import MySchemasWithToJSONInstances.Person (Person)
--  import qualified Data.Aeson as Aeson
--  import System.FilePath ((\</\>))
--  import Test.Tasty.Golden.Extra.GoldenVsToJSON (GoldenVsToJSON (..))
--
--  tasty_FromJSON_ToJSON :: GoldenVsToJSON
--  tasty_FromJSON_ToJSON =
--    GoldenVsToJSON (goldenFilesPath \</\> "Person.golden.json") $
--      Aeson.eitherDecodeFileStrict @Person (goldenFilesPath \</\> "Person.json")
-- @
data GoldenVsToJSON = forall a. (Aeson.ToJSON a) => GoldenVsToJSON FilePath (IO a)

instance Discover.Tasty GoldenVsToJSON where
  tasty :: TastyInfo -> GoldenVsToJSON -> IO TestTree
tasty TastyInfo
info (GoldenVsToJSON FilePath
ref IO a
act) = TestTree -> IO TestTree
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestTree -> IO TestTree) -> TestTree -> IO TestTree
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO a -> TestTree
forall a. ToJSON a => FilePath -> FilePath -> IO a -> TestTree
goldenVsToJson (TastyInfo -> FilePath
Discover.nameOf TastyInfo
info) FilePath
ref IO a
act

-- | Helper function for creating a @TestTree@ for @ToJSON@ golden tests.
-- Use when you want to test @ToJSON@ instances against a golden example on disk.
--
-- Example use:
--
-- @
--  import MySchemasWithToJSONInstances.Person (Person)
--  import qualified Data.Aeson as Aeson
--  import System.FilePath ((\</\>))
--  import Test.Tasty.Golden.Extra.GoldenVsToJSON (goldenVsToJSON)
--
--  test_ToJSON :: TestTree
--  test_ToJSON = do
--    let inputFile = goldenFilesPath \</\> "Person.json"
--    goldenVsToJSON
--      "Test ToJSON instance for Person"
--      (goldenFilesPath \</\> "Person.golden.json")
--      (Aeson.decodeFileStrict' @Person inputFile)
-- @
goldenVsToJson ::
  forall a.
  (Aeson.ToJSON a) =>
  -- | test name
  TestName ->
  -- | path to the «golden» file (the file that contains correct output)
  FilePath ->
  -- | action that returns an instance of the type whose instance is being tested
  IO a ->
  -- | the test verifies that the returned string is the same as the golden file contents
  TestTree
goldenVsToJson :: forall a. ToJSON a => FilePath -> FilePath -> IO a -> TestTree
goldenVsToJson FilePath
name FilePath
fp IO a
act =
  FilePath
-> IO Value
-> IO Value
-> (Value -> Value -> IO (Maybe FilePath))
-> (Value -> IO ())
-> TestTree
forall a.
FilePath
-> IO a
-> IO a
-> (a -> a -> IO (Maybe FilePath))
-> (a -> IO ())
-> TestTree
goldenTest
    FilePath
name
    (FilePath -> IO (Maybe Value)
forall a. FromJSON a => FilePath -> IO (Maybe a)
Aeson.decodeFileStrict FilePath
fp IO (Maybe Value) -> (Maybe Value -> IO Value) -> IO Value
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> Maybe Value -> IO Value
forall a. FilePath -> Maybe a -> IO a
orFailTest (FilePath
"Couldn't decode golden JSON file:" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
fp))
    (a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (a -> Value) -> IO a -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
act)
    (\Value
a Value
b -> Maybe FilePath -> IO (Maybe FilePath)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe FilePath -> IO (Maybe FilePath))
-> (JsonDifference -> Maybe FilePath)
-> JsonDifference
-> IO (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonDifference -> Maybe FilePath
maybeDifference (JsonDifference -> IO (Maybe FilePath))
-> JsonDifference -> IO (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ Value -> Value -> JsonDifference
checkJsonDifference Value
a Value
b)
    (FilePath -> ByteString -> IO ()
BL.writeFile FilePath
fp (ByteString -> IO ()) -> (Value -> ByteString) -> Value -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty)

orFailTest :: String -> Maybe a -> IO a
orFailTest :: forall a. FilePath -> Maybe a -> IO a
orFailTest FilePath
msg = IO a -> (a -> IO a) -> Maybe a -> IO a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (FilePath -> IO a
forall a. HasCallStack => FilePath -> a
error FilePath
msg) a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure