{-|
Module      : Test.Aeson.Internal.ADT.GoldenSpecs
Description : Golden tests for ToADTArbitrary
Copyright   : (c) Plow Technologies, 2016
License     : BSD3
Maintainer  : mchaver@gmail.com
Stability   : Beta

Internal module, use at your own risk.
-}

{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}

module Test.Aeson.Internal.ADT.GoldenSpecs where

import           Control.Arrow
import           Control.Exception
import           Control.Monad

import           Data.Aeson                (ToJSON, FromJSON)
import           Data.ByteString.Lazy      (writeFile, readFile)
import           Data.Int                  (Int32)
import           Data.Maybe                (isJust)
import           Data.Proxy

import           Prelude            hiding (writeFile,readFile)

import           System.Directory
import           System.Environment        (lookupEnv)
import           System.FilePath
import           System.Random

import           Test.Aeson.Internal.RandomSamples
import           Test.Aeson.Internal.Utils
import           Test.Hspec
import           Test.HUnit.Lang (HUnitFailure)
import           Test.QuickCheck
import           Test.QuickCheck.Arbitrary.ADT

-- | Tests to ensure that JSON encoding has not unintentionally changed. This
-- could be caused by the following:
--
-- - A type's instances of `ToJSON` or 'FromJSON' have changed.
-- - Selectors have been edited, added or deleted.
-- - You have changed version of Aeson the way Aeson serialization has changed
--   works.
--
-- If you run this function and the golden files do not
-- exist, it will create them for each constructor. It they do exist, it will
-- compare with golden file if it exists. Golden file encodes json format of a
-- type. It is recommended that you put the golden files under revision control
-- to help monitor changes.
goldenADTSpecs :: forall a. (ToADTArbitrary a, Eq a, Show a, ToJSON a, FromJSON a) =>
  Settings -> Proxy a -> Spec
goldenADTSpecs :: Settings -> Proxy a -> Spec
goldenADTSpecs settings :: Settings
settings proxy :: Proxy a
proxy = Settings -> Proxy a -> Maybe String -> Spec
forall a.
(ToADTArbitrary a, Eq a, Show a, ToJSON a, FromJSON a) =>
Settings -> Proxy a -> Maybe String -> Spec
goldenADTSpecsWithNote Settings
settings Proxy a
proxy Maybe String
forall a. Maybe a
Nothing

-- | same as 'goldenADTSpecs' but has the option of passing a note to the
-- 'describe' function.
goldenADTSpecsWithNote :: forall a. (ToADTArbitrary a, Eq a, Show a, ToJSON a, FromJSON a) =>
  Settings -> Proxy a -> Maybe String -> Spec
goldenADTSpecsWithNote :: Settings -> Proxy a -> Maybe String -> Spec
goldenADTSpecsWithNote settings :: Settings
settings Proxy mNote :: Maybe String
mNote = do
  (moduleName :: String
moduleName,(typeName :: String
typeName,constructors :: [ConstructorArbitraryPair a]
constructors)) <- IO (String, (String, [ConstructorArbitraryPair a]))
-> SpecM () (String, (String, [ConstructorArbitraryPair a]))
forall r a. IO r -> SpecM a r
runIO (IO (String, (String, [ConstructorArbitraryPair a]))
 -> SpecM () (String, (String, [ConstructorArbitraryPair a])))
-> IO (String, (String, [ConstructorArbitraryPair a]))
-> SpecM () (String, (String, [ConstructorArbitraryPair a]))
forall a b. (a -> b) -> a -> b
$ (ADTArbitrary a
 -> (String, (String, [ConstructorArbitraryPair a])))
-> IO (ADTArbitrary a)
-> IO (String, (String, [ConstructorArbitraryPair a]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ADTArbitrary a -> String
forall a. ADTArbitrary a -> String
adtModuleName (ADTArbitrary a -> String)
-> (ADTArbitrary a -> (String, [ConstructorArbitraryPair a]))
-> ADTArbitrary a
-> (String, (String, [ConstructorArbitraryPair a]))
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ADTArbitrary a -> String
forall a. ADTArbitrary a -> String
adtTypeName (ADTArbitrary a -> String)
-> (ADTArbitrary a -> [ConstructorArbitraryPair a])
-> ADTArbitrary a
-> (String, [ConstructorArbitraryPair a])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ADTArbitrary a -> [ConstructorArbitraryPair a]
forall a. ADTArbitrary a -> [ConstructorArbitraryPair a]
adtCAPs) (IO (ADTArbitrary a)
 -> IO (String, (String, [ConstructorArbitraryPair a])))
-> (Gen (ADTArbitrary a) -> IO (ADTArbitrary a))
-> Gen (ADTArbitrary a)
-> IO (String, (String, [ConstructorArbitraryPair a]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (ADTArbitrary a) -> IO (ADTArbitrary a)
forall a. Gen a -> IO a
generate (Gen (ADTArbitrary a)
 -> IO (String, (String, [ConstructorArbitraryPair a])))
-> Gen (ADTArbitrary a)
-> IO (String, (String, [ConstructorArbitraryPair a]))
forall a b. (a -> b) -> a -> b
$ Proxy a -> Gen (ADTArbitrary a)
forall a. ToADTArbitrary a => Proxy a -> Gen (ADTArbitrary a)
toADTArbitrary (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe ("JSON encoding of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typeName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
note) (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$
    (ConstructorArbitraryPair a -> Spec)
-> [ConstructorArbitraryPair a] -> Spec
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Settings
-> String
-> String
-> ConstructorArbitraryPair a
-> SpecWith (Arg (IO ()))
forall a.
(Eq a, Show a, FromJSON a, ToJSON a, ToADTArbitrary a) =>
Settings
-> String
-> String
-> ConstructorArbitraryPair a
-> SpecWith (Arg (IO ()))
testConstructor Settings
settings String
moduleName String
typeName) [ConstructorArbitraryPair a]
constructors
  where
    note :: String
note = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" (" " String -> String -> String
forall a. [a] -> [a] -> [a]
++) Maybe String
mNote

-- | test a single set of values from a constructor for a given type.
testConstructor :: forall a. (Eq a, Show a, FromJSON a, ToJSON a, ToADTArbitrary a) =>
  Settings -> String -> String -> ConstructorArbitraryPair a -> SpecWith ( Arg (IO ()))
testConstructor :: Settings
-> String
-> String
-> ConstructorArbitraryPair a
-> SpecWith (Arg (IO ()))
testConstructor Settings{..} moduleName :: String
moduleName typeName :: String
typeName cap :: ConstructorArbitraryPair a
cap =
  String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it ("produces the same JSON as is found in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
goldenFile) (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    Bool
exists <- String -> IO Bool
doesFileExist String
goldenFile
    let fixIfFlag :: e -> IO ()
fixIfFlag err :: e
err = do
          Bool
doFix <- Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv "RECREATE_BROKEN_GOLDEN"
          if Bool
doFix
            then Int -> ConstructorArbitraryPair a -> String -> IO ()
forall a.
(ToJSON a, ToADTArbitrary a) =>
Int -> ConstructorArbitraryPair a -> String -> IO ()
createGoldenFile Int
sampleSize ConstructorArbitraryPair a
cap String
goldenFile
            else e -> IO ()
forall e a. Exception e => e -> IO a
throwIO e
err
    if Bool
exists
      then RandomMismatchOption
-> String
-> Maybe String
-> String
-> ConstructorArbitraryPair a
-> String
-> IO ()
forall a.
(Show a, Eq a, FromJSON a, ToJSON a, ToADTArbitrary a) =>
RandomMismatchOption
-> String
-> Maybe String
-> String
-> ConstructorArbitraryPair a
-> String
-> IO ()
compareWithGolden RandomMismatchOption
randomMismatchOption String
topDir Maybe String
mModuleName String
typeName ConstructorArbitraryPair a
cap String
goldenFile
        IO () -> [Handler ()] -> IO ()
forall a. IO a -> [Handler a] -> IO a
`catches` [ (HUnitFailure -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(HUnitFailure
err :: HUnitFailure) -> HUnitFailure -> IO ()
forall e. Exception e => e -> IO ()
fixIfFlag HUnitFailure
err)
                  , (AesonDecodeError -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\(AesonDecodeError
err :: AesonDecodeError) -> AesonDecodeError -> IO ()
forall e. Exception e => e -> IO ()
fixIfFlag AesonDecodeError
err)
                  ]
      else do
        Bool
doCreate <- Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv "CREATE_MISSING_GOLDEN"
        if Bool
doCreate
          then Int -> ConstructorArbitraryPair a -> String -> IO ()
forall a.
(ToJSON a, ToADTArbitrary a) =>
Int -> ConstructorArbitraryPair a -> String -> IO ()
createGoldenFile Int
sampleSize ConstructorArbitraryPair a
cap String
goldenFile
          else HasCallStack => String -> IO ()
String -> IO ()
expectationFailure (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Missing golden file: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
goldenFile
  where
    goldenFile :: String
goldenFile = String
-> Maybe String -> String -> ConstructorArbitraryPair a -> String
forall a.
String
-> Maybe String -> String -> ConstructorArbitraryPair a -> String
mkGoldenFilePath String
topDir Maybe String
mModuleName String
typeName ConstructorArbitraryPair a
cap
    topDir :: String
topDir = case GoldenDirectoryOption
goldenDirectoryOption of
      GoldenDirectory -> "golden"
      CustomDirectoryName d :: String
d -> String
d
    mModuleName :: Maybe String
mModuleName = case Bool
useModuleNameAsSubDirectory of
      True  -> String -> Maybe String
forall a. a -> Maybe a
Just String
moduleName
      False -> Maybe String
forall a. Maybe a
Nothing

-- | The golden files already exist. Serialize values with the same seed from
-- the golden files of each constructor and compare.
compareWithGolden :: forall a. (Show a, Eq a, FromJSON a, ToJSON a, ToADTArbitrary a) =>
  RandomMismatchOption -> String -> Maybe String -> String -> ConstructorArbitraryPair a -> FilePath -> IO ()
compareWithGolden :: RandomMismatchOption
-> String
-> Maybe String
-> String
-> ConstructorArbitraryPair a
-> String
-> IO ()
compareWithGolden randomOption :: RandomMismatchOption
randomOption topDir :: String
topDir mModuleName :: Maybe String
mModuleName typeName :: String
typeName cap :: ConstructorArbitraryPair a
cap goldenFile :: String
goldenFile = do
  Int32
goldenSeed <- ByteString -> IO Int32
readSeed (ByteString -> IO Int32) -> IO ByteString -> IO Int32
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO ByteString
readFile String
goldenFile
  Int
sampleSize <- ByteString -> IO Int
readSampleSize (ByteString -> IO Int) -> IO ByteString -> IO Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO ByteString
readFile String
goldenFile
  RandomSamples a
newSamples <- Int -> Proxy a -> String -> Int32 -> IO (RandomSamples a)
forall a.
ToADTArbitrary a =>
Int -> Proxy a -> String -> Int32 -> IO (RandomSamples a)
mkRandomADTSamplesForConstructor Int
sampleSize (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) (ConstructorArbitraryPair a -> String
forall a. ConstructorArbitraryPair a -> String
capConstructor ConstructorArbitraryPair a
cap) Int32
goldenSeed
  IO () -> IO () -> IO ()
forall b c. IO c -> IO b -> IO b
whenFails (RandomSamples a -> IO ()
forall a. ToJSON a => a -> IO ()
writeComparisonFile RandomSamples a
newSamples) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    ByteString
goldenBytes <- String -> IO ByteString
readFile String
goldenFile
    RandomSamples a
goldenSamples :: RandomSamples a <- ByteString -> IO (RandomSamples a)
forall a. FromJSON a => ByteString -> IO a
aesonDecodeIO ByteString
goldenBytes
    if RandomSamples a
newSamples RandomSamples a -> RandomSamples a -> Bool
forall a. Eq a => a -> a -> Bool
== RandomSamples a
goldenSamples
      then
        -- random samples match; test encoding of samples (the above check only tested the decoding)
        RandomSamples a -> ByteString
forall a. ToJSON a => a -> ByteString
encodePrettySortedKeys RandomSamples a
newSamples ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
goldenBytes Bool -> Bool -> IO ()
forall a. (HasCallStack, Show a, Eq a) => a -> a -> IO ()
`shouldBe` Bool
True
      else do
        let
          -- whether to pass the test or fail due to random value mismatch
          finalResult :: IO ()
finalResult =
            case RandomMismatchOption
randomOption of
              RandomMismatchWarning -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              RandomMismatchError -> HasCallStack => String -> IO ()
String -> IO ()
expectationFailure "New random samples generated from seed in golden file do not match samples in golden file."

        -- do a fallback test to determine whether the mismatch is due to a random sample change only,
        -- or due to a change in encoding
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
          "WARNING: New random samples do not match those in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
goldenFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
          "  Testing round-trip decoding/encoding of golden file."
        let reencodedGoldenSamples :: ByteString
reencodedGoldenSamples = RandomSamples a -> ByteString
forall a. ToJSON a => a -> ByteString
encodePrettySortedKeys RandomSamples a
goldenSamples
        if ByteString
reencodedGoldenSamples ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
goldenBytes
          then
            -- pass the test because round-trip decode/encode still gives the same bytes
            IO ()
finalResult
          else do
            -- how significant is the serialization change?
            RandomSamples a -> IO ()
forall a. ToJSON a => a -> IO ()
writeReencodedComparisonFile RandomSamples a
goldenSamples
            RandomSamples a
testSamples :: RandomSamples a <- ByteString -> IO (RandomSamples a)
forall a. FromJSON a => ByteString -> IO a
aesonDecodeIO ByteString
reencodedGoldenSamples
            let
              failureMessage :: String
failureMessage =
                if RandomSamples a
testSamples RandomSamples a -> RandomSamples a -> Bool
forall a. Eq a => a -> a -> Bool
== RandomSamples a
goldenSamples
                  then
                    "Encoding has changed in a minor way; still can read old encodings. See " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
faultyReencodedFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ "."
                  else
                    "Encoding has changed in a major way; cannot read old encodings. See " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
faultyReencodedFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ "."
            HasCallStack => String -> IO ()
String -> IO ()
expectationFailure String
failureMessage
            IO ()
finalResult
  where
    whenFails :: forall b c. IO c -> IO b -> IO b
    whenFails :: IO c -> IO b -> IO b
whenFails = (IO b -> IO c -> IO b) -> IO c -> IO b -> IO b
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO b -> IO c -> IO b
forall a b. IO a -> IO b -> IO a
onException

    faultyFile :: String
faultyFile = String
-> Maybe String -> String -> ConstructorArbitraryPair a -> String
forall a.
String
-> Maybe String -> String -> ConstructorArbitraryPair a -> String
mkFaultyFilePath String
topDir Maybe String
mModuleName String
typeName ConstructorArbitraryPair a
cap
    faultyReencodedFile :: String
faultyReencodedFile = String
-> Maybe String -> String -> ConstructorArbitraryPair a -> String
forall a.
String
-> Maybe String -> String -> ConstructorArbitraryPair a -> String
mkFaultyReencodedFilePath String
topDir Maybe String
mModuleName String
typeName ConstructorArbitraryPair a
cap

    writeComparisonFile :: a -> IO ()
writeComparisonFile newSamples :: a
newSamples = do
      String -> ByteString -> IO ()
writeFile String
faultyFile (a -> ByteString
forall a. ToJSON a => a -> ByteString
encodePrettySortedKeys a
newSamples)
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
        "INFO: Written the current encodings into " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
faultyFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ "."
    writeReencodedComparisonFile :: a -> IO ()
writeReencodedComparisonFile samples :: a
samples = do
      String -> ByteString -> IO ()
writeFile String
faultyReencodedFile (a -> ByteString
forall a. ToJSON a => a -> ByteString
encodePrettySortedKeys a
samples)
      String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
        "INFO: Written the re-encodings into " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
faultyReencodedFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ "."

-- | The golden files do not exist. Create them for each constructor.
createGoldenFile :: forall a. (ToJSON a, ToADTArbitrary a) =>
  Int -> ConstructorArbitraryPair a -> FilePath -> IO ()
createGoldenFile :: Int -> ConstructorArbitraryPair a -> String -> IO ()
createGoldenFile sampleSize :: Int
sampleSize cap :: ConstructorArbitraryPair a
cap goldenFile :: String
goldenFile = do
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> String
takeDirectory String
goldenFile)
  Int32
rSeed <- IO Int32
forall a. Random a => IO a
randomIO :: IO Int32
  RandomSamples a
rSamples <- Int -> Proxy a -> String -> Int32 -> IO (RandomSamples a)
forall a.
ToADTArbitrary a =>
Int -> Proxy a -> String -> Int32 -> IO (RandomSamples a)
mkRandomADTSamplesForConstructor Int
sampleSize (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) (ConstructorArbitraryPair a -> String
forall a. ConstructorArbitraryPair a -> String
capConstructor ConstructorArbitraryPair a
cap) Int32
rSeed
  String -> ByteString -> IO ()
writeFile String
goldenFile (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ RandomSamples a -> ByteString
forall a. ToJSON a => a -> ByteString
encodePrettySortedKeys RandomSamples a
rSamples

  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
    "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    "WARNING: Running for the first time, not testing anything.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    "  Created " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
goldenFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ " containing random samples,\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    "  will compare JSON encodings with this from now on.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    "  Please, consider putting " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
goldenFile String -> String -> String
forall a. [a] -> [a] -> [a]
++ " under version control."

-- | Create the file path for the golden file. Optionally use the module name to
-- help avoid name collissions. Different modules can have types of the same
-- name.
mkGoldenFilePath :: forall a. FilePath -> Maybe FilePath -> FilePath -> ConstructorArbitraryPair a -> FilePath
mkGoldenFilePath :: String
-> Maybe String -> String -> ConstructorArbitraryPair a -> String
mkGoldenFilePath topDir :: String
topDir mModuleName :: Maybe String
mModuleName typeName :: String
typeName cap :: ConstructorArbitraryPair a
cap =
  case Maybe String
mModuleName of
    Nothing -> String
topDir String -> String -> String
</> String
typeName String -> String -> String
</> ConstructorArbitraryPair a -> String
forall a. ConstructorArbitraryPair a -> String
capConstructor ConstructorArbitraryPair a
cap String -> String -> String
<.> "json"
    Just moduleName :: String
moduleName -> String
topDir String -> String -> String
</> String
moduleName String -> String -> String
</> String
typeName String -> String -> String
</> ConstructorArbitraryPair a -> String
forall a. ConstructorArbitraryPair a -> String
capConstructor ConstructorArbitraryPair a
cap String -> String -> String
<.> "json"

-- | Create the file path to save results from a failed golden test. Optionally
-- use the module name to help avoid name collisions.  Different modules can
-- have types of the same name.
mkFaultyFilePath :: forall a. FilePath -> Maybe FilePath -> FilePath -> ConstructorArbitraryPair a -> FilePath
mkFaultyFilePath :: String
-> Maybe String -> String -> ConstructorArbitraryPair a -> String
mkFaultyFilePath topDir :: String
topDir mModuleName :: Maybe String
mModuleName typeName :: String
typeName cap :: ConstructorArbitraryPair a
cap =
  case Maybe String
mModuleName of
    Nothing -> String
topDir String -> String -> String
</> String
typeName String -> String -> String
</> ConstructorArbitraryPair a -> String
forall a. ConstructorArbitraryPair a -> String
capConstructor ConstructorArbitraryPair a
cap String -> String -> String
<.> "faulty" String -> String -> String
<.> "json"
    Just moduleName :: String
moduleName -> String
topDir String -> String -> String
</> String
moduleName String -> String -> String
</> String
typeName String -> String -> String
</> ConstructorArbitraryPair a -> String
forall a. ConstructorArbitraryPair a -> String
capConstructor ConstructorArbitraryPair a
cap String -> String -> String
<.> "faulty" String -> String -> String
<.> "json"

-- | Create the file path to save results from a failed fallback golden test. Optionally
-- use the module name to help avoid name collisions.  Different modules can
-- have types of the same name.
mkFaultyReencodedFilePath :: forall a. FilePath -> Maybe FilePath -> FilePath -> ConstructorArbitraryPair a -> FilePath
mkFaultyReencodedFilePath :: String
-> Maybe String -> String -> ConstructorArbitraryPair a -> String
mkFaultyReencodedFilePath topDir :: String
topDir mModuleName :: Maybe String
mModuleName typeName :: String
typeName cap :: ConstructorArbitraryPair a
cap =
  case Maybe String
mModuleName of
    Nothing -> String
topDir String -> String -> String
</> String
typeName String -> String -> String
</> ConstructorArbitraryPair a -> String
forall a. ConstructorArbitraryPair a -> String
capConstructor ConstructorArbitraryPair a
cap String -> String -> String
<.> "faulty" String -> String -> String
<.> "reencoded" String -> String -> String
<.> "json"
    Just moduleName :: String
moduleName -> String
topDir String -> String -> String
</> String
moduleName String -> String -> String
</> String
typeName String -> String -> String
</> ConstructorArbitraryPair a -> String
forall a. ConstructorArbitraryPair a -> String
capConstructor ConstructorArbitraryPair a
cap String -> String -> String
<.> "faulty" String -> String -> String
<.> "reencoded" String -> String -> String
<.> "json"

-- | Create a number of arbitrary instances of a particular constructor given
-- a sample size and a random seed.
mkRandomADTSamplesForConstructor :: forall a. (ToADTArbitrary a) =>
  Int -> Proxy a -> String -> Int32 -> IO (RandomSamples a)
mkRandomADTSamplesForConstructor :: Int -> Proxy a -> String -> Int32 -> IO (RandomSamples a)
mkRandomADTSamplesForConstructor sampleSize :: Int
sampleSize Proxy conName :: String
conName rSeed :: Int32
rSeed = do
  [ADTArbitrary a]
generatedADTs <- Gen [ADTArbitrary a] -> IO [ADTArbitrary a]
forall a. Gen a -> IO a
generate Gen [ADTArbitrary a]
gen
  let caps :: [ConstructorArbitraryPair a]
caps         = [[ConstructorArbitraryPair a]] -> [ConstructorArbitraryPair a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ConstructorArbitraryPair a]] -> [ConstructorArbitraryPair a])
-> [[ConstructorArbitraryPair a]] -> [ConstructorArbitraryPair a]
forall a b. (a -> b) -> a -> b
$ ADTArbitrary a -> [ConstructorArbitraryPair a]
forall a. ADTArbitrary a -> [ConstructorArbitraryPair a]
adtCAPs (ADTArbitrary a -> [ConstructorArbitraryPair a])
-> [ADTArbitrary a] -> [[ConstructorArbitraryPair a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ADTArbitrary a]
generatedADTs
      filteredCAPs :: [ConstructorArbitraryPair a]
filteredCAPs = (ConstructorArbitraryPair a -> Bool)
-> [ConstructorArbitraryPair a] -> [ConstructorArbitraryPair a]
forall a. (a -> Bool) -> [a] -> [a]
filter (\x :: ConstructorArbitraryPair a
x -> ConstructorArbitraryPair a -> String
forall a. ConstructorArbitraryPair a -> String
capConstructor ConstructorArbitraryPair a
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
conName) [ConstructorArbitraryPair a]
caps
      arbs :: [a]
arbs         = ConstructorArbitraryPair a -> a
forall a. ConstructorArbitraryPair a -> a
capArbitrary (ConstructorArbitraryPair a -> a)
-> [ConstructorArbitraryPair a] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ConstructorArbitraryPair a]
filteredCAPs
  RandomSamples a -> IO (RandomSamples a)
forall (m :: * -> *) a. Monad m => a -> m a
return (RandomSamples a -> IO (RandomSamples a))
-> RandomSamples a -> IO (RandomSamples a)
forall a b. (a -> b) -> a -> b
$ Int32 -> [a] -> RandomSamples a
forall a. Int32 -> [a] -> RandomSamples a
RandomSamples Int32
rSeed [a]
arbs
  where
    correctedSampleSize :: Int
correctedSampleSize = if Int
sampleSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 then 1 else Int
sampleSize
    gen :: Gen [ADTArbitrary a]
gen = Int -> Gen [ADTArbitrary a] -> Gen [ADTArbitrary a]
forall a. Int -> Gen a -> Gen a
setSeed (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
rSeed) (Gen [ADTArbitrary a] -> Gen [ADTArbitrary a])
-> Gen [ADTArbitrary a] -> Gen [ADTArbitrary a]
forall a b. (a -> b) -> a -> b
$ Int -> Gen (ADTArbitrary a) -> Gen [ADTArbitrary a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
correctedSampleSize (Proxy a -> Gen (ADTArbitrary a)
forall a. ToADTArbitrary a => Proxy a -> Gen (ADTArbitrary a)
toADTArbitrary (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a))

-- | Make a Golden File for the Proxy of a type if the file does not exist.
mkGoldenFileForType :: forall a. (ToJSON a, ToADTArbitrary a) => Int -> Proxy a -> FilePath -> IO ()
mkGoldenFileForType :: Int -> Proxy a -> String -> IO ()
mkGoldenFileForType sampleSize :: Int
sampleSize Proxy goldenPath :: String
goldenPath = do
  (typeName :: String
typeName, constructors :: [ConstructorArbitraryPair a]
constructors) <- (ADTArbitrary a -> (String, [ConstructorArbitraryPair a]))
-> IO (ADTArbitrary a) -> IO (String, [ConstructorArbitraryPair a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ADTArbitrary a -> String
forall a. ADTArbitrary a -> String
adtTypeName (ADTArbitrary a -> String)
-> (ADTArbitrary a -> [ConstructorArbitraryPair a])
-> ADTArbitrary a
-> (String, [ConstructorArbitraryPair a])
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ADTArbitrary a -> [ConstructorArbitraryPair a]
forall a. ADTArbitrary a -> [ConstructorArbitraryPair a]
adtCAPs) (IO (ADTArbitrary a) -> IO (String, [ConstructorArbitraryPair a]))
-> (Gen (ADTArbitrary a) -> IO (ADTArbitrary a))
-> Gen (ADTArbitrary a)
-> IO (String, [ConstructorArbitraryPair a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (ADTArbitrary a) -> IO (ADTArbitrary a)
forall a. Gen a -> IO a
generate (Gen (ADTArbitrary a) -> IO (String, [ConstructorArbitraryPair a]))
-> Gen (ADTArbitrary a)
-> IO (String, [ConstructorArbitraryPair a])
forall a b. (a -> b) -> a -> b
$ Proxy a -> Gen (ADTArbitrary a)
forall a. ToADTArbitrary a => Proxy a -> Gen (ADTArbitrary a)
toADTArbitrary (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
  (ConstructorArbitraryPair a -> IO ())
-> [ConstructorArbitraryPair a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
    (\constructor :: ConstructorArbitraryPair a
constructor -> do
        let goldenFile :: String
goldenFile = String
goldenPath String -> String -> String
</> String
typeName String -> String -> String
</> ConstructorArbitraryPair a -> String
forall a. ConstructorArbitraryPair a -> String
capConstructor ConstructorArbitraryPair a
constructor String -> String -> String
<.> ".json"
        Bool
exists <- String -> IO Bool
doesFileExist String
goldenFile
        if Bool
exists
          then () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          else do
            Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> String
takeDirectory String
goldenFile)
            Int32
rSeed <- IO Int32
forall a. Random a => IO a
randomIO :: IO Int32
            RandomSamples a
rSamples <- Int -> Proxy a -> String -> Int32 -> IO (RandomSamples a)
forall a.
ToADTArbitrary a =>
Int -> Proxy a -> String -> Int32 -> IO (RandomSamples a)
mkRandomADTSamplesForConstructor Int
sampleSize (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) (ConstructorArbitraryPair a -> String
forall a. ConstructorArbitraryPair a -> String
capConstructor ConstructorArbitraryPair a
constructor) Int32
rSeed
            String -> ByteString -> IO ()
writeFile String
goldenFile (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ RandomSamples a -> ByteString
forall a. ToJSON a => a -> ByteString
encodePrettySortedKeys RandomSamples a
rSamples
    ) [ConstructorArbitraryPair a]
constructors