module Hedgehog.Golden.Aeson
(
goldenProperty
, goldenProperty'
) where
import Prelude
import Control.Monad (forM_)
import Control.Monad.IO.Class (MonadIO(..))
import Data.Algorithm.Diff (Diff(..), getDiff)
import Data.Aeson (FromJSON, ToJSON, (.=), (.:))
import qualified Data.Aeson as Aeson (eitherDecodeStrict)
import qualified Data.Aeson.Types as Aeson
import Data.Aeson.Encode.Pretty (Config(..), Indent(..), encodePretty', defConfig)
import qualified Data.ByteString.Lazy as ByteString (toStrict)
import Data.Proxy (Proxy(..))
import Data.Sequence (Seq)
import Data.Text (Text)
import qualified Data.Text as Text (intercalate, lines, pack, replace, unpack)
import qualified Data.Text.Encoding as Text (decodeUtf8, encodeUtf8)
import qualified Data.Text.IO as Text (readFile, writeFile)
import Data.Typeable (Typeable, typeRep)
import Hedgehog (Gen, Property, PropertyT, Seed(..))
import Hedgehog (success)
import qualified Hedgehog.Internal.Seed as Seed
import Hedgehog.Internal.Source
import Hedgehog.Internal.Property (Log(..), Property(..), PropertyConfig(..))
import Hedgehog.Internal.Property (TerminationCriteria(..))
import Hedgehog.Internal.Property (defaultConfig, evalM, failWith, writeLog)
import Hedgehog.Golden.Sample (genSamples)
import Hedgehog.Golden.Types (GoldenTest(..), ValueGenerator, ValueReader)
import qualified Hedgehog.Golden.Internal.Source as Source
import System.Directory (createDirectoryIfMissing, doesFileExist, getCurrentDirectory)
goldenProperty :: forall a
. HasCallStack
=> Typeable a
=> FromJSON a
=> ToJSON a
=> Gen a -> Property
goldenProperty :: Gen a -> Property
goldenProperty = (HasCallStack => Gen a -> Property) -> Gen a -> Property
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Gen a -> Property) -> Gen a -> Property)
-> (HasCallStack => Gen a -> Property) -> Gen a -> Property
forall a b. (a -> b) -> a -> b
$ FilePath -> Gen a -> Property
forall a.
(HasCallStack, Typeable a, FromJSON a, ToJSON a) =>
FilePath -> Gen a -> Property
goldenProperty' FilePath
"golden/"
goldenProperty' :: forall a
. HasCallStack
=> Typeable a
=> FromJSON a
=> ToJSON a
=> FilePath -> Gen a -> Property
goldenProperty' :: FilePath -> Gen a -> Property
goldenProperty' FilePath
baseDir Gen a
gen = (HasCallStack => Property) -> Property
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => Property) -> Property)
-> (HasCallStack => Property) -> Property
forall a b. (a -> b) -> a -> b
$
PropertyConfig -> PropertyT IO () -> Property
Property PropertyConfig
config (PropertyT IO () -> Property)
-> (PropertyT IO () -> PropertyT IO ())
-> PropertyT IO ()
-> Property
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PropertyT IO () -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, MonadCatch m, HasCallStack) =>
m a -> m a
evalM (PropertyT IO () -> Property) -> PropertyT IO () -> Property
forall a b. (a -> b) -> a -> b
$
FilePath -> Gen a -> PropertyT IO GoldenTest
forall a (m :: * -> *).
(Typeable a, FromJSON a, ToJSON a, MonadIO m) =>
FilePath -> Gen a -> m GoldenTest
goldenTest FilePath
baseDir Gen a
gen PropertyT IO GoldenTest
-> (GoldenTest -> PropertyT IO ()) -> PropertyT IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
NewFile FilePath
fileName ValueGenerator
valGen -> do
HasCallStack =>
FilePath -> FilePath -> ValueGenerator -> PropertyT IO ()
FilePath -> FilePath -> ValueGenerator -> PropertyT IO ()
newGoldenFile FilePath
baseDir FilePath
fileName ValueGenerator
valGen
ExistingFile FilePath
fileName ValueGenerator
valGen Maybe ValueReader
readerM ->
HasCallStack =>
FilePath
-> FilePath
-> ValueGenerator
-> Maybe ValueReader
-> PropertyT IO ()
FilePath
-> FilePath
-> ValueGenerator
-> Maybe ValueReader
-> PropertyT IO ()
existingGoldenFile FilePath
baseDir FilePath
fileName ValueGenerator
valGen Maybe ValueReader
readerM
where
config :: PropertyConfig
config = PropertyConfig
defaultConfig
{ propertyTerminationCriteria :: TerminationCriteria
propertyTerminationCriteria = TestLimit -> TerminationCriteria
NoConfidenceTermination TestLimit
1
, propertyShrinkLimit :: ShrinkLimit
propertyShrinkLimit = ShrinkLimit
0
}
newGoldenFile :: HasCallStack => FilePath -> FilePath -> ValueGenerator -> PropertyT IO ()
newGoldenFile :: FilePath -> FilePath -> ValueGenerator -> PropertyT IO ()
newGoldenFile FilePath
basePath FilePath
fileName ValueGenerator
gen = do
Seed
seed <- PropertyT IO Seed
forall (m :: * -> *). MonadIO m => m Seed
Seed.random
IO () -> PropertyT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PropertyT IO ()) -> IO () -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
basePath
FilePath -> Text -> IO ()
Text.writeFile (FilePath
fileName FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".new") (Text -> IO ()) -> (Seed -> Text) -> Seed -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate Text
"\n" ([Text] -> Text) -> ValueGenerator -> Seed -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueGenerator
gen (Seed -> IO ()) -> Seed -> IO ()
forall a b. (a -> b) -> a -> b
$ Seed
seed
FilePath
currentDir <- IO FilePath -> PropertyT IO FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> PropertyT IO FilePath)
-> IO FilePath -> PropertyT IO FilePath
forall a b. (a -> b) -> a -> b
$ IO FilePath
getCurrentDirectory
Log -> PropertyT IO ()
forall (m :: * -> *). MonadTest m => Log -> m ()
writeLog (Log -> PropertyT IO ())
-> (FilePath -> Log) -> FilePath -> PropertyT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Log
Footnote (FilePath -> PropertyT IO ()) -> FilePath -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"New golden file generated in: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
currentDir FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
fileName FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".new"
Maybe Diff -> FilePath -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> FilePath -> m a
failWith Maybe Diff
forall a. Maybe a
Nothing FilePath
"No previous golden file exists"
existingGoldenFile ::
HasCallStack
=> FilePath -> FilePath -> ValueGenerator -> Maybe ValueReader -> PropertyT IO ()
existingGoldenFile :: FilePath
-> FilePath
-> ValueGenerator
-> Maybe ValueReader
-> PropertyT IO ()
existingGoldenFile FilePath
basePath FilePath
fp ValueGenerator
gen Maybe ValueReader
reader = PropertyT IO (Either FilePath (Seed, [Text]))
getSeedAndLines PropertyT IO (Either FilePath (Seed, [Text]))
-> (Either FilePath (Seed, [Text]) -> PropertyT IO ())
-> PropertyT IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right (Seed
seed, [Text]
existingLines) ->
let
comparison :: [Diff Text]
comparison =
[Text] -> [Text] -> [Diff Text]
forall t. Eq t => [t] -> [t] -> [Diff t]
getDiff [Text]
existingLines ([Text] -> [Diff Text]) -> [Text] -> [Diff Text]
forall a b. (a -> b) -> a -> b
$ ValueGenerator
gen Seed
seed
hasDifference :: [Diff a] -> Bool
hasDifference = (Diff a -> Bool) -> [Diff a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Diff a -> Bool) -> [Diff a] -> Bool)
-> (Diff a -> Bool) -> [Diff a] -> Bool
forall a b. (a -> b) -> a -> b
$ \case
Both a
_ a
_ -> Bool
False
First a
_ -> Bool
True
Second a
_ -> Bool
True
runDecodeTest :: PropertyT IO ()
runDecodeTest = Maybe ValueReader
-> (ValueReader -> PropertyT IO ()) -> PropertyT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe ValueReader
reader ((ValueReader -> PropertyT IO ()) -> PropertyT IO ())
-> (ValueReader -> PropertyT IO ()) -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ \ValueReader
r ->
(Text -> PropertyT IO ())
-> (() -> PropertyT IO ()) -> Either Text () -> PropertyT IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(Maybe Diff -> FilePath -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> FilePath -> m a
failWith Maybe Diff
forall a. Maybe a
Nothing (FilePath -> PropertyT IO ())
-> (Text -> FilePath) -> Text -> PropertyT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
(<>) FilePath
"Failed to deserialize with error: " (FilePath -> FilePath) -> (Text -> FilePath) -> Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
Text.unpack)
(PropertyT IO () -> () -> PropertyT IO ()
forall a b. a -> b -> a
const PropertyT IO ()
forall (m :: * -> *). MonadTest m => m ()
success)
(ValueReader
r ValueReader -> ([Text] -> Text) -> [Text] -> Either Text ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate Text
"\n" ([Text] -> Either Text ()) -> [Text] -> Either Text ()
forall a b. (a -> b) -> a -> b
$ [Text]
existingLines)
in
if [Diff Text] -> Bool
forall a. [Diff a] -> Bool
hasDifference [Diff Text]
comparison then do
IO () -> PropertyT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PropertyT IO ()) -> IO () -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ do
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
False FilePath
basePath
FilePath -> Text -> IO ()
Text.writeFile (FilePath
fp FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".gen") (Text -> IO ()) -> (Seed -> Text) -> Seed -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate Text
"\n" ([Text] -> Text) -> ValueGenerator -> Seed -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueGenerator
gen (Seed -> IO ()) -> Seed -> IO ()
forall a b. (a -> b) -> a -> b
$ Seed
seed
Log -> PropertyT IO ()
forall (m :: * -> *). MonadTest m => Log -> m ()
writeLog (Log -> PropertyT IO ())
-> (FilePath -> Log) -> FilePath -> PropertyT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Log
Footnote (FilePath -> PropertyT IO ()) -> FilePath -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$
FilePath
"Different file generated as: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
fp FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".gen"
Maybe Diff -> FilePath -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> FilePath -> m a
failWith Maybe Diff
forall a. Maybe a
Nothing (FilePath -> PropertyT IO ())
-> ([Text] -> FilePath) -> [Text] -> PropertyT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
Text.unpack (Text -> FilePath) -> ([Text] -> Text) -> [Text] -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
Text.intercalate Text
"\n" ([Text] -> PropertyT IO ()) -> [Text] -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$
[ Text
"Failed in serialization comparison"
, Text
""
, Text -> Text
Source.yellow Text
"Difference when generating: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack FilePath
fp
, [Diff Text] -> Text
printDifference [Diff Text]
comparison
]
else
PropertyT IO ()
runDecodeTest
Left FilePath
err ->
Maybe Diff -> FilePath -> PropertyT IO ()
forall (m :: * -> *) a.
(MonadTest m, HasCallStack) =>
Maybe Diff -> FilePath -> m a
failWith Maybe Diff
forall a. Maybe a
Nothing (FilePath -> PropertyT IO ()) -> FilePath -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Couldn't read previous golden file (" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
fp FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
") because: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
err
where
getSeedAndLines :: PropertyT IO (Either FilePath (Seed, [Text]))
getSeedAndLines = IO (Either FilePath (Seed, [Text]))
-> PropertyT IO (Either FilePath (Seed, [Text]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either FilePath (Seed, [Text]))
-> PropertyT IO (Either FilePath (Seed, [Text])))
-> IO (Either FilePath (Seed, [Text]))
-> PropertyT IO (Either FilePath (Seed, [Text]))
forall a b. (a -> b) -> a -> b
$ do
Text
fileContents <- FilePath -> IO Text
Text.readFile FilePath
fp
Either FilePath (Seed, [Text])
-> IO (Either FilePath (Seed, [Text]))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FilePath (Seed, [Text])
-> IO (Either FilePath (Seed, [Text])))
-> (Text -> Either FilePath (Seed, [Text]))
-> Text
-> IO (Either FilePath (Seed, [Text]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Seed -> (Seed, [Text]))
-> Either FilePath Seed -> Either FilePath (Seed, [Text])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, Text -> [Text]
Text.lines Text
fileContents) (Either FilePath Seed -> Either FilePath (Seed, [Text]))
-> (Text -> Either FilePath Seed)
-> Text
-> Either FilePath (Seed, [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either FilePath Seed
decodeSeed (Text -> IO (Either FilePath (Seed, [Text])))
-> Text -> IO (Either FilePath (Seed, [Text]))
forall a b. (a -> b) -> a -> b
$ Text
fileContents
printDifference :: [Diff Text] -> Text
printDifference :: [Diff Text] -> Text
printDifference
= Text -> [Text] -> Text
Text.intercalate Text
"\n"
([Text] -> Text) -> ([Diff Text] -> [Text]) -> [Diff Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text] -> [Text]
Source.wrap Text
Source.boxTop Text
Source.boxBottom
([Text] -> [Text])
-> ([Diff Text] -> [Text]) -> [Diff Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Diff Text] -> [Text]
addLineNumbers Int
1
([Diff Text] -> [Text])
-> ([Diff Text] -> [Diff Text]) -> [Diff Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Diff Text] -> [Diff Text]
renderDiff
where
renderDiff :: [Diff Text] -> [Diff Text]
renderDiff :: [Diff Text] -> [Diff Text]
renderDiff =
(Diff Text -> Diff Text) -> [Diff Text] -> [Diff Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Diff Text -> Diff Text) -> [Diff Text] -> [Diff Text])
-> (Diff Text -> Diff Text) -> [Diff Text] -> [Diff Text]
forall a b. (a -> b) -> a -> b
$ \case
Both Text
text Text
_ -> Text -> Text -> Diff Text
forall a. a -> a -> Diff a
Both (Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text) (Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text)
First Text
text -> Text -> Diff Text
forall a. a -> Diff a
First (Text -> Diff Text) -> Text -> Diff Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
Source.red (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text
Second Text
text -> Text -> Diff Text
forall a. a -> Diff a
Second (Text -> Diff Text) -> Text -> Diff Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
Source.green (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
"+" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text
addLineNumbers :: Int -> [Diff Text] -> [Text]
addLineNumbers :: Int -> [Diff Text] -> [Text]
addLineNumbers Int
_ [] = []
addLineNumbers Int
i (Diff Text
d : [Diff Text]
ds) = case Diff Text
d of
Both Text
text Text
_ ->
Int -> Text -> Text
Source.addLineNumber Int
i Text
text Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Int -> [Diff Text] -> [Text]
addLineNumbers (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Diff Text]
ds
First Text
text ->
Int -> Text -> Text
Source.addLineNumber Int
i Text
text Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Int -> [Diff Text] -> [Text]
addLineNumbers Int
i [Diff Text]
ds
Second Text
text ->
Int -> Text -> Text
Source.addLineNumber Int
i Text
text Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Int -> [Diff Text] -> [Text]
addLineNumbers (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Diff Text]
ds
goldenTest :: forall a m
. Typeable a
=> FromJSON a
=> ToJSON a
=> MonadIO m
=> FilePath -> Gen a -> m GoldenTest
goldenTest :: FilePath -> Gen a -> m GoldenTest
goldenTest FilePath
prefix Gen a
gen = do
let
typeName :: Text
typeName = Text -> Text -> Text -> Text
Text.replace Text
" " Text
"_" (FilePath -> Text
Text.pack (FilePath -> Text) -> (Proxy a -> FilePath) -> Proxy a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> FilePath
forall a. Show a => a -> FilePath
show (TypeRep -> FilePath)
-> (Proxy a -> TypeRep) -> Proxy a -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a -> Text) -> Proxy a -> Text
forall a b. (a -> b) -> a -> b
$ Proxy a
forall k (t :: k). Proxy t
Proxy @a)
fileName :: FilePath
fileName = FilePath
prefix FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
Text.unpack Text
typeName FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".json"
aesonValueGenerator :: ValueGenerator
aesonValueGenerator Seed
seed = Text -> [Text]
Text.lines (Text -> [Text]) -> (Seq a -> Text) -> Seq a -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seed -> Seq a -> Text
forall a. ToJSON a => Seed -> Seq a -> Text
encodeGolden Seed
seed (Seq a -> [Text]) -> Seq a -> [Text]
forall a b. (a -> b) -> a -> b
$ Seed -> Gen a -> Seq a
forall a. Seed -> Gen a -> Seq a
genSamples Seed
seed Gen a
gen
aesonValueReader :: ValueReader
aesonValueReader Text
t =
(FilePath -> Either Text ())
-> ((Seed, Seq a) -> Either Text ())
-> Either FilePath (Seed, Seq a)
-> Either Text ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ValueReader
forall a b. a -> Either a b
Left ValueReader -> (FilePath -> Text) -> FilePath -> Either Text ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack) (Either Text () -> (Seed, Seq a) -> Either Text ()
forall a b. a -> b -> a
const (Either Text () -> (Seed, Seq a) -> Either Text ())
-> Either Text () -> (Seed, Seq a) -> Either Text ()
forall a b. (a -> b) -> a -> b
$ () -> Either Text ()
forall a b. b -> Either a b
Right ()) (Either FilePath (Seed, Seq a) -> Either Text ())
-> Either FilePath (Seed, Seq a) -> Either Text ()
forall a b. (a -> b) -> a -> b
$
ByteString -> Either FilePath Object
forall a. FromJSON a => ByteString -> Either FilePath a
Aeson.eitherDecodeStrict (Text -> ByteString
Text.encodeUtf8 Text
t) Either FilePath Object
-> (Object -> Either FilePath (Seed, Seq a))
-> Either FilePath (Seed, Seq a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FromJSON a => Object -> Either FilePath (Seed, Seq a)
forall a. FromJSON a => Object -> Either FilePath (Seed, Seq a)
decodeGolden @a
Bool
fileExists <- IO Bool -> m Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> m Bool) -> IO Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Bool
doesFileExist FilePath
fileName
GoldenTest -> m GoldenTest
forall (f :: * -> *) a. Applicative f => a -> f a
pure (GoldenTest -> m GoldenTest) -> GoldenTest -> m GoldenTest
forall a b. (a -> b) -> a -> b
$ if Bool
fileExists then
FilePath -> ValueGenerator -> Maybe ValueReader -> GoldenTest
ExistingFile FilePath
fileName ValueGenerator
aesonValueGenerator (ValueReader -> Maybe ValueReader
forall a. a -> Maybe a
Just ValueReader
aesonValueReader)
else
FilePath -> ValueGenerator -> GoldenTest
NewFile FilePath
fileName ValueGenerator
aesonValueGenerator
encodeGolden :: ToJSON a => Seed -> Seq a -> Text
encodeGolden :: Seed -> Seq a -> Text
encodeGolden Seed
seed Seq a
samples =
let
aesonSeed :: Seed -> Value
aesonSeed (Seed Word64
value Word64
gamma) =
[Pair] -> Value
Aeson.object [ Text
"value" Text -> Word64 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Word64
value, Text
"gamma" Text -> Word64 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Word64
gamma ]
encodePretty :: Value -> Text
encodePretty =
ByteString -> Text
Text.decodeUtf8 (ByteString -> Text) -> (Value -> ByteString) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
ByteString.toStrict (ByteString -> ByteString)
-> (Value -> ByteString) -> Value -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Value -> ByteString
forall a. ToJSON a => Config -> a -> ByteString
encodePretty' Config
defConfig
{ confIndent :: Indent
confIndent = Int -> Indent
Spaces Int
2
, confCompare :: Text -> Text -> Ordering
confCompare = Text -> Text -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
}
in
Value -> Text
encodePretty (Value -> Text) -> Value -> Text
forall a b. (a -> b) -> a -> b
$
[Pair] -> Value
Aeson.object [ Text
"seed" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Seed -> Value
aesonSeed Seed
seed, Text
"samples" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Seq a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON Seq a
samples ]
decodeSeed :: Text -> Either String Seed
decodeSeed :: Text -> Either FilePath Seed
decodeSeed Text
text =
let
getSeed :: Aeson.Object -> Either String Seed
getSeed :: Object -> Either FilePath Seed
getSeed =
(Object -> Parser Seed) -> Object -> Either FilePath Seed
forall a b. (a -> Parser b) -> a -> Either FilePath b
Aeson.parseEither ((Object -> Parser Seed) -> Object -> Either FilePath Seed)
-> (Object -> Parser Seed) -> Object -> Either FilePath Seed
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
Word64
value <- Object
obj Object -> Text -> Parser Object
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"seed" Parser Object -> (Object -> Parser Word64) -> Parser Word64
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Object -> Text -> Parser Word64
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"value")
Word64
gamma <- Object
obj Object -> Text -> Parser Object
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"seed" Parser Object -> (Object -> Parser Word64) -> Parser Word64
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Object -> Text -> Parser Word64
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"gamma")
Seed -> Parser Seed
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Seed -> Parser Seed) -> Seed -> Parser Seed
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Seed
Seed Word64
value Word64
gamma
in
ByteString -> Either FilePath Object
forall a. FromJSON a => ByteString -> Either FilePath a
Aeson.eitherDecodeStrict (Text -> ByteString
Text.encodeUtf8 Text
text) Either FilePath Object
-> (Object -> Either FilePath Seed) -> Either FilePath Seed
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Object -> Either FilePath Seed
getSeed
decodeGolden :: FromJSON a => Aeson.Object -> Either String (Seed, Seq a)
decodeGolden :: Object -> Either FilePath (Seed, Seq a)
decodeGolden = (Object -> Parser (Seed, Seq a))
-> Object -> Either FilePath (Seed, Seq a)
forall a b. (a -> Parser b) -> a -> Either FilePath b
Aeson.parseEither ((Object -> Parser (Seed, Seq a))
-> Object -> Either FilePath (Seed, Seq a))
-> (Object -> Parser (Seed, Seq a))
-> Object
-> Either FilePath (Seed, Seq a)
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
Word64
value <- Object
obj Object -> Text -> Parser Object
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"seed" Parser Object -> (Object -> Parser Word64) -> Parser Word64
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Object -> Text -> Parser Word64
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"value")
Word64
gamma <- Object
obj Object -> Text -> Parser Object
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"seed" Parser Object -> (Object -> Parser Word64) -> Parser Word64
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Object -> Text -> Parser Word64
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"gamma")
Seq a
samples <- Object
obj Object -> Text -> Parser (Seq a)
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"samples"
(Seed, Seq a) -> Parser (Seed, Seq a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> Word64 -> Seed
Seed Word64
value Word64
gamma, Seq a
samples)