{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

-- |
--
-- Module      : Test.Tasty.Golden.Extra.GoldenVsToYAML
-- 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,
-- that you want to convert to YAML using the @Data.Yaml@ package.
module Test.Tasty.Golden.Extra.GoldenVsToYAML
  ( goldenVsToYaml,
    GoldenVsToYAML (..),
  )
where

import Data.Aeson
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as BL
import qualified Data.Yaml as Yaml
import Test.Tasty
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,
-- that you want to convert to YAML using the @Data.Yaml@ package.
--
-- Example use:
--
-- @
--  import MySchemasWithToJSONInstances.Person (Person)
--  import qualified Data.Aeson as Aeson
--  import System.FilePath ((\</\>))
--  import Test.Tasty.Golden.Extra.GoldenVsToYAML (GoldenVsToYAML (..))
--
--  tasty_FromJSON_ToYAML :: GoldenVsToYAML
--  tasty_FromJSON_ToYAML =
--    GoldenVsToYAML (goldenFilesPath \</\> "Person.golden.yaml") $
--      Aeson.eitherDecodeFileStrict @Person (goldenFilesPath \</\> "Person.json")
-- @
data GoldenVsToYAML = forall a. (Aeson.ToJSON a) => GoldenVsToYAML FilePath (IO a)

instance Discover.Tasty GoldenVsToYAML where
  tasty :: TastyInfo -> GoldenVsToYAML -> IO TestTree
tasty TastyInfo
info (GoldenVsToYAML 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
goldenVsToYaml (TastyInfo -> FilePath
Discover.nameOf TastyInfo
info) FilePath
ref IO a
act

-- | Helper function for creating a @TestTree@ for @ToJSON@-to-YAML golden tests.
-- Use when you want to test @ToJSON@ instances against a golden example of YAML
-- on disk.
--
-- Example use:
--
-- @
--  import MySchemasWithToJSONInstances.Person (Person)
--  import qualified Data.Aeson as Aeson
--  import System.FilePath ((\</\>))
--  import Test.Tasty.Golden.Extra.GoldenVsToYAML (goldenVsToYAML)
--
--  test_ToYAML :: TestTree
--  test_ToYAML = do
--    let inputFile = goldenFilesPath \</\> "Person.yaml"
--    goldenVsToYAML
--      "Test YAML serialization for Person"
--      (goldenFilesPath \</\> "Person.golden.yaml")
--      (Aeson.decodeFileStrict' @Person inputFile)
-- @
goldenVsToYaml ::
  forall a.
  (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
goldenVsToYaml :: forall a. ToJSON a => FilePath -> FilePath -> IO a -> TestTree
goldenVsToYaml 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 (Either ParseException Value)
forall a. FromJSON a => FilePath -> IO (Either ParseException a)
Yaml.decodeFileEither FilePath
fp IO (Either ParseException Value)
-> (Either ParseException 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 -> Either ParseException Value -> IO Value
forall a. FilePath -> Either ParseException a -> IO a
orFailTest 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
Yaml.encode)

orFailTest :: FilePath -> Either Yaml.ParseException a -> IO a
orFailTest :: forall a. FilePath -> Either ParseException a -> IO a
orFailTest FilePath
fp =
  (ParseException -> IO a)
-> (a -> IO a) -> Either ParseException a -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    ( FilePath -> IO a
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail
        (FilePath -> IO a)
-> (ParseException -> FilePath) -> ParseException -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\FilePath
t -> [FilePath] -> FilePath
forall a. Monoid a => [a] -> a
mconcat [FilePath
"Failed to decode file ", FilePath
fp, FilePath
"\n", FilePath
t])
        (FilePath -> FilePath)
-> (ParseException -> FilePath) -> ParseException -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseException -> FilePath
Yaml.prettyPrintParseException
    )
    a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure