module Test.Aeson.Internal.ADT.GoldenSpecs where
import Control.Arrow
import Control.Exception
import Control.Monad
import Data.Aeson (ToJSON, FromJSON)
import qualified Data.Aeson as A
import Data.Aeson.Encode.Pretty
import Data.ByteString.Lazy (writeFile, readFile)
import Data.Proxy
import Prelude hiding (writeFile,readFile)
import System.Directory
import System.FilePath
import System.Random
import Test.Aeson.Internal.RandomSamples
import Test.Aeson.Internal.Utils
import Test.Hspec
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.ADT
goldenADTSpecs :: forall a. (ToADTArbitrary a, Eq a, Show a, ToJSON a, FromJSON a) =>
Settings -> Proxy a -> Spec
goldenADTSpecs settings proxy = goldenADTSpecsWithNote settings proxy Nothing
goldenADTSpecsWithNote :: forall a. (ToADTArbitrary a, Eq a, Show a, ToJSON a, FromJSON a) =>
Settings -> Proxy a -> Maybe String -> Spec
goldenADTSpecsWithNote settings Proxy mNote = do
(moduleName,(typeName,constructors)) <- runIO $ fmap (adtModuleName &&& adtTypeName &&& adtCAPs) <$> generate $ toADTArbitrary (Proxy :: Proxy a)
describe ("JSON encoding of " ++ typeName ++ note) $
mapM_ (testConstructor settings moduleName typeName) constructors
where
note = maybe "" (" " ++) mNote
testConstructor :: forall a. (Eq a, Show a, FromJSON a, ToJSON a, ToADTArbitrary a) =>
Settings -> String -> String -> ConstructorArbitraryPair a -> SpecWith ( Arg (IO ()))
testConstructor Settings{..} moduleName typeName cap = do
it ("produces the same JSON as is found in " ++ goldenFile) $ do
exists <- doesFileExist goldenFile
if exists
then compareWithGolden topDir mModuleName typeName cap goldenFile
else createGoldenFile sampleSize cap goldenFile
where
goldenFile = mkGoldenFilePath topDir mModuleName typeName cap
topDir = case goldenDirectoryOption of
GoldenDirectory -> "golden"
CustomDirectoryName d -> d
mModuleName = case useModuleNameAsSubDirectory of
True -> Just moduleName
False -> Nothing
compareWithGolden :: forall a. (Show a, Eq a, FromJSON a, ToJSON a, ToADTArbitrary a) =>
String -> Maybe String -> String -> ConstructorArbitraryPair a -> FilePath -> IO ()
compareWithGolden topDir mModuleName typeName cap goldenFile = do
goldenSeed <- readSeed =<< readFile goldenFile
sampleSize <- readSampleSize =<< readFile goldenFile
newSamples <- mkRandomADTSamplesForConstructor sampleSize (Proxy :: Proxy a) (capConstructor cap) goldenSeed
whenFails (writeComparisonFile newSamples) $ do
goldenSamples :: RandomSamples a <-
either (throwIO . ErrorCall) return =<<
A.eitherDecode' <$>
readFile goldenFile
newSamples `shouldBe` goldenSamples
where
whenFails :: forall b c. IO c -> IO b -> IO b
whenFails = flip onException
faultyFile = mkFaultyFilePath topDir mModuleName typeName cap
writeComparisonFile newSamples = do
writeFile faultyFile (encodePretty newSamples)
putStrLn $
"\n" ++
"INFO: Written the current encodings into " ++ faultyFile ++ "."
createGoldenFile :: forall a. (ToJSON a, ToADTArbitrary a) =>
Int -> ConstructorArbitraryPair a -> FilePath -> IO ()
createGoldenFile sampleSize cap goldenFile = do
createDirectoryIfMissing True (takeDirectory goldenFile)
rSeed <- randomIO :: IO Int
rSamples <- mkRandomADTSamplesForConstructor sampleSize (Proxy :: Proxy a) (capConstructor cap) rSeed
writeFile goldenFile $ encodePretty rSamples
putStrLn $
"\n" ++
"WARNING: Running for the first time, not testing anything.\n" ++
" Created " ++ goldenFile ++ " containing random samples,\n" ++
" will compare JSON encodings with this from now on.\n" ++
" Please, consider putting " ++ goldenFile ++ " under version control."
mkGoldenFilePath :: forall a. FilePath -> Maybe FilePath -> FilePath -> ConstructorArbitraryPair a -> FilePath
mkGoldenFilePath topDir mModuleName typeName cap =
case mModuleName of
Nothing -> topDir </> typeName </> capConstructor cap <.> "json"
Just moduleName -> topDir </> moduleName </> typeName </> capConstructor cap <.> "json"
mkFaultyFilePath :: forall a. FilePath -> Maybe FilePath -> FilePath -> ConstructorArbitraryPair a -> FilePath
mkFaultyFilePath topDir mModuleName typeName cap =
case mModuleName of
Nothing -> topDir </> typeName </> capConstructor cap <.> "faulty" <.> "json"
Just moduleName -> topDir </> moduleName </> typeName </> capConstructor cap <.> "faulty" <.> "json"
mkRandomADTSamplesForConstructor :: forall a. (ToADTArbitrary a) =>
Int -> Proxy a -> String -> Int -> IO (RandomSamples a)
mkRandomADTSamplesForConstructor sampleSize Proxy conName rSeed = do
generatedADTs <- generate gen
let caps = concat $ adtCAPs <$> generatedADTs
filteredCAPs = filter (\x -> capConstructor x == conName) caps
arbs = capArbitrary <$> filteredCAPs
return $ RandomSamples rSeed arbs
where
correctedSampleSize = if sampleSize <= 0 then 1 else sampleSize
gen = setSeed rSeed $ replicateM correctedSampleSize (toADTArbitrary (Proxy :: Proxy a))
mkGoldenFileForType :: forall a. (ToJSON a, ToADTArbitrary a) => Int -> Proxy a -> FilePath -> IO ()
mkGoldenFileForType sampleSize Proxy goldenPath = do
(typeName, constructors) <- fmap (adtTypeName &&& adtCAPs) <$> generate $ toADTArbitrary (Proxy :: Proxy a)
mapM_
(\constructor -> do
let goldenFile = goldenPath </> typeName </> capConstructor constructor <.> ".json"
exists <- doesFileExist goldenFile
if exists
then pure ()
else do
createDirectoryIfMissing True (takeDirectory goldenFile)
rSeed <- randomIO :: IO Int
rSamples <- mkRandomADTSamplesForConstructor sampleSize (Proxy :: Proxy a) (capConstructor constructor) rSeed
writeFile goldenFile $ encodePretty rSamples
) constructors