Add roundtripfromfile

src/Test/Aeson/GenericSpecs.hs

@@ -22,13 +22,17 @@ module Test.Aeson.GenericSpecs
     goldenSpecs
   , roundtripSpecs
   , roundtripAndGoldenSpecs
+  , roundtripFromFile
+  , roundtripFromFileWithSettings
 
   -- * ToADTArbitrary testing
   , goldenADTSpecs
   , roundtripADTSpecs
   , roundtripAndGoldenSpecsWithSettings
   , roundtripAndGoldenADTSpecs
   , roundtripAndGoldenADTSpecsWithSettings
+  , roundtripADTFromFile
+  , roundtripADTFromFileWithSettings
 
   -- * Make Files
   , mkGoldenFileForType
@@ -51,6 +55,8 @@ import           Test.Aeson.Internal.ADT.GoldenSpecs    (goldenADTSpecs, mkGolde
 import           Test.Aeson.Internal.ADT.RoundtripSpecs (roundtripADTSpecs)
 import           Test.Aeson.Internal.GoldenSpecs        (goldenSpecs)
 import           Test.Aeson.Internal.RoundtripSpecs     (roundtripSpecs)
+import qualified Test.Aeson.Internal.RoundtripFromFile
+import qualified Test.Aeson.Internal.ADT.RoundtripFromFile
 import           Test.Aeson.Internal.Utils
 import           Test.Hspec
 import           Test.QuickCheck
@@ -89,3 +95,23 @@ roundtripAndGoldenADTSpecsWithSettings :: forall a.
 roundtripAndGoldenADTSpecsWithSettings settings proxy = do
   roundtripADTSpecs proxy
   goldenADTSpecs settings proxy
+
+roundtripFromFile :: forall a. 
+  (Arbitrary a, Typeable a, Eq a, Show a, ToJSON a, FromJSON a)
+  => Proxy a -> Spec
+roundtripFromFile = roundtripFromFileWithSettings defaultSettings
+
+roundtripFromFileWithSettings :: forall a. 
+  (Arbitrary a, Typeable a, Eq a, Show a, ToJSON a, FromJSON a)
+  => Settings -> Proxy a -> Spec
+roundtripFromFileWithSettings = Test.Aeson.Internal.RoundtripFromFile.roundtripFromFile
+
+roundtripADTFromFile :: forall a. 
+  (ToADTArbitrary a, Typeable a, Eq a, Show a, ToJSON a, FromJSON a)
+  => Proxy a -> Spec
+roundtripADTFromFile = roundtripADTFromFileWithSettings defaultSettings
+
+roundtripADTFromFileWithSettings :: forall a. 
+  (ToADTArbitrary a, Typeable a, Eq a, Show a, ToJSON a, FromJSON a)
+  => Settings -> Proxy a -> Spec
+roundtripADTFromFileWithSettings = Test.Aeson.Internal.ADT.RoundtripFromFile.roundtripADTFromFile

src/Test/Aeson/Internal/ADT/GoldenSpecs.hs

@@ -64,13 +64,16 @@ goldenADTSpecs settings proxy = goldenADTSpecsWithNote settings proxy Nothing
 -- 'describe' function.
 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)
+goldenADTSpecsWithNote settings proxy mNote = do
+  (moduleName,typeName,constructors) <- runIO $ generateInfoFromADT proxy
   describe ("JSON encoding of " ++ typeName ++ note) $
     mapM_ (testConstructor settings moduleName typeName) constructors
   where
     note = maybe "" (" " ++) mNote
 
+generateInfoFromADT :: ToADTArbitrary a => Proxy a -> IO (String, String, [ConstructorArbitraryPair a])
+generateInfoFromADT proxy = fmap (\x -> (adtModuleName x, adtTypeName x, adtCAPs x)) <$> generate $ toADTArbitrary proxy
+
 -- | 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 ()))
@@ -91,7 +94,7 @@ testConstructor Settings{..} moduleName typeName cap =
         doCreate <- isJust <$> lookupEnv "CREATE_MISSING_GOLDEN"
         if doCreate
           then createGoldenFile sampleSize cap goldenFile
-          else expectationFailure $ "Missing golden file: " <> goldenFile
+          else expectationFailure $ "Missing golden file: " ++ goldenFile
   where
     goldenFile = mkGoldenFilePath topDir mModuleName typeName cap
     topDir = case goldenDirectoryOption of

src/Test/Aeson/Internal/ADT/RoundtripFromFile.hs

@@ -0,0 +1,95 @@
+{-|
+Module      : Test.Aeson.Internal.RoundtripFromFile
+Description : Golden tests for Arbitrary
+Copyright   : (c) Plow Technologies, 2022
+License     : BSD3
+Maintainer  : [email protected]
+Stability   : Beta
+
+Internal module, use at your own risk.
+-}
+
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RankNTypes #-}
+module Test.Aeson.Internal.ADT.RoundtripFromFile where
+
+import           Control.Exception
+import           Control.Monad
+
+import           Data.Aeson
+import           Data.ByteString.Lazy hiding (putStrLn)
+import           Data.Maybe (isJust)
+import           Data.Proxy
+import           Data.Typeable
+
+import           Prelude hiding (readFile, writeFile)
+
+import           System.Directory
+import           System.Environment (lookupEnv)
+
+import           Test.Aeson.Internal.Utils
+import           Test.Hspec
+import           Test.HUnit.Lang (HUnitFailure)
+import           Test.Aeson.Internal.RandomSamples
+import           Test.Aeson.Internal.ADT.GoldenSpecs
+import           Test.QuickCheck.Arbitrary.ADT
+
+
+
+roundtripADTFromFile :: forall a. 
+  (Typeable a, ToADTArbitrary a, Eq a, Show a, ToJSON a, FromJSON a)
+  => Settings -> Proxy a -> Spec
+roundtripADTFromFile settings proxy = do
+  (moduleName,typeName,constructors) <- runIO $ generateInfoFromADT proxy
+  describe ("JSON encoding of " ++ typeName) $
+    mapM_ (testConstructorRoundtrip settings moduleName typeName) constructors
+
+testConstructorRoundtrip :: forall a. (Eq a, Show a, FromJSON a, ToJSON a, ToADTArbitrary a) =>
+  Settings -> String -> String -> ConstructorArbitraryPair a -> SpecWith ( Arg (IO ()))
+testConstructorRoundtrip Settings{..} moduleName typeName cap = do
+  it ("produces the same JSON as is found in " ++ goldenFile) $ do
+    createMissing <- isJust <$> lookupEnv "CREATE_MISSING_GOLDEN"
+    fileExist <- doesFileExist goldenFile
+    if fileExist then
+      runTestFromFile (Proxy @a) goldenFile 
+        `catches` 
+          [ 
+            Handler (\(err :: HUnitFailure) -> fixIfFlag err), 
+            Handler (\(err :: AesonDecodeError) -> fixIfFlag err)
+          ]
+    else if createMissing then
+      createGoldenFile sampleSize cap goldenFile
+    else
+      expectationFailure $ "Missing golden file: " ++ 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
+
+    fixIfFlag err = do
+      doFix <- isJust <$> lookupEnv "RECREATE_BROKEN_GOLDEN"
+      if doFix then do
+        createGoldenFile sampleSize cap goldenFile
+      else 
+        throwIO err
+
+runTestFromFile :: forall a . (Eq a, Show a, ToJSON a, FromJSON a) => Proxy a -> String -> IO ()
+runTestFromFile _proxy goldenFile = do
+  bytes <- readFile goldenFile
+  case decode bytes of
+    Just (randomSamples :: RandomSamples Value) -> 
+      let jsonList = samples randomSamples in
+      case traverse fromJSON jsonList  of
+        Data.Aeson.Success (decodedData :: [a]) ->
+          fmap toJSON decodedData `shouldBe` jsonList
+        Data.Aeson.Error err -> expectationFailure err
+    Nothing -> expectationFailure "Cannot decode JSON"

src/Test/Aeson/Internal/GoldenSpecs.hs

@@ -14,6 +14,7 @@ Internal module, use at your own risk.
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE RankNTypes #-}
 module Test.Aeson.Internal.GoldenSpecs where
 
@@ -90,7 +91,7 @@ goldenSpecsWithNotePlain settings@Settings{..} typeNameInfo@(TypeNameInfo{typeNa
           doCreate <- isJust <$> lookupEnv "CREATE_MISSING_GOLDEN"
           if doCreate
             then createGoldenfile settings proxy goldenFile
-            else expectationFailure $ "Missing golden file: " <> goldenFile
+            else expectationFailure $ "Missing golden file: " ++ goldenFile
 
 
 -- | The golden files already exist. Serialize values with the same seed from
@@ -188,4 +189,4 @@ mkRandomSamples sampleSize Proxy rSeed = RandomSamples rSeed <$> generate gen
   where
     correctedSampleSize = if sampleSize <= 0 then 1 else sampleSize
     gen :: Gen [a]
-    gen = setSeed (fromIntegral rSeed) $ replicateM correctedSampleSize (arbitrary :: Gen a)
+    gen = setSeed (fromIntegral rSeed) $ replicateM correctedSampleSize (arbitrary :: Gen a)

src/Test/Aeson/Internal/RoundtripFromFile.hs

@@ -0,0 +1,83 @@
+{-|
+Module      : Test.Aeson.Internal.RoundtripFromFile
+Description : Golden tests for Arbitrary
+Copyright   : (c) Plow Technologies, 2022
+License     : BSD3
+Maintainer  : [email protected]
+Stability   : Beta
+
+Internal module, use at your own risk.
+-}
+
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RankNTypes #-}
+module Test.Aeson.Internal.RoundtripFromFile where
+
+import           Control.Exception
+import           Control.Monad
+
+import           Data.Aeson
+import           Data.ByteString.Lazy hiding (putStrLn)
+import           Data.Maybe (isJust)
+import           Data.Proxy
+import           Data.Typeable
+
+import           Prelude hiding (readFile, writeFile)
+
+import           System.Directory
+import           System.Environment (lookupEnv)
+import           System.FilePath
+
+import           Test.Aeson.Internal.Utils
+import           Test.Hspec
+import           Test.HUnit.Lang (HUnitFailure)
+import           Test.QuickCheck
+import           Test.Aeson.Internal.RandomSamples
+import           Test.Aeson.Internal.GoldenSpecs
+
+
+roundtripFromFile :: forall a. 
+  (Typeable a, Arbitrary a, Eq a, Show a, ToJSON a, FromJSON a)
+  => Settings -> Proxy a -> Spec
+roundtripFromFile settings proxy = do
+  typeNameInfo    <- runIO $ mkTypeNameInfo settings proxy
+  let goldenFile = mkGoldenFile typeNameInfo
+
+  createMissing <- runIO $ isJust <$> lookupEnv "CREATE_MISSING_GOLDEN"
+  let fixIfFlag err = do
+        doFix <- isJust <$> lookupEnv "RECREATE_BROKEN_GOLDEN"
+        if doFix then do
+          createGoldenfile settings proxy goldenFile
+        else 
+          throwIO err
+  describe ("JSON encoding of " ++ addBrackets  (unTypeName $ typeNameTypeName typeNameInfo)) $
+    it ("produces the same JSON as is found in " ++ goldenFile) $ do
+
+      fileExist <- doesFileExist goldenFile
+      if fileExist then
+        runTestFromFile proxy goldenFile 
+          `catches` 
+            [ 
+              Handler (\(err :: HUnitFailure) -> fixIfFlag err), 
+              Handler (\(err :: AesonDecodeError) -> fixIfFlag err)
+            ]
+      else if createMissing then
+        createGoldenfile settings proxy goldenFile
+      else
+        expectationFailure $ "Missing golden file: " ++ goldenFile
+
+runTestFromFile :: forall a . (Eq a, Show a, ToJSON a, FromJSON a) => Proxy a -> String -> IO ()
+runTestFromFile _proxy goldenFile = do
+  bytes <- readFile goldenFile
+  case decode bytes of
+    Just (randomSamples :: RandomSamples Value) -> 
+      let jsonList = samples randomSamples in
+      case traverse fromJSON jsonList  of
+        Data.Aeson.Success (decodedData :: [a]) ->
+          fmap toJSON decodedData `shouldBe` jsonList
+        Data.Aeson.Error err -> expectationFailure err
+    Nothing -> expectationFailure "Cannot decode JSON"

test/Test/Aeson/GenericSpecsSpec.hs

@@ -82,27 +82,27 @@ spec = do
         else return ()
 
       -- files for Person and SumType do not exist
-      -- create them by running goldenADTSpecs
+      -- create them by running goldenSpecs
       _ <- hspecSilently $ goldenSpecs (defaultSettings {goldenDirectoryOption = CustomDirectoryName topDir}) (Proxy :: Proxy T.Person)
       _ <- hspecSilently $ goldenSpecs (defaultSettings {goldenDirectoryOption = CustomDirectoryName topDir}) (Proxy :: Proxy T.SumType)
 
       doesFileExist "json-tests/Person.json"  `shouldReturn` True
       doesFileExist "json-tests/SumType.json" `shouldReturn` True
 
-    it "goldenADTSpecs should pass for existing golden files in which model types and serialization have not changed" $ do
+    it "goldenSpecs should pass for existing golden files in which model types and serialization have not changed" $ do
       (s1,_) <- hspecSilently $ goldenSpecs defaultSettings (Proxy :: Proxy T.Person)
       (s2,_) <- hspecSilently $ goldenSpecs defaultSettings (Proxy :: Proxy T.SumType)
       (summaryFailures s1 + summaryFailures s2) `shouldBe` 0
 
-    it "goldenADTSpecs for types which have changed the values of ToJSON or FromJSON keys should fail to match the goldenFiles" $ do
+    it "goldenSpecs for types which have changed the values of ToJSON or FromJSON keys should fail to match the goldenFiles" $ do
       (s1,_) <- hspecSilently $ goldenSpecs defaultSettings (Proxy :: Proxy TBS.Person)
       summaryFailures s1 `shouldBe` 1
 
-    it "goldenADTSpecs for types which have changed the values of ToJSON or FromJSON keys should fail to match the goldenFiles" $ do
+    it "goldenSpecs for types which have changed the values of ToJSON or FromJSON keys should fail to match the goldenFiles" $ do
       (s1,_) <- hspecSilently $ goldenSpecs defaultSettings (Proxy :: Proxy TNS.Person)
       summaryFailures s1 `shouldBe` 1
 
-    it "goldenADTSpecs for types which have altered the name of the selector and using generic implementation of ToJSON and FromJSON should fail to match the goldenFiles" $ do
+    it "goldenSpecs for types which have altered the name of the selector and using generic implementation of ToJSON and FromJSON should fail to match the goldenFiles" $ do
       (s1,_) <- hspecSilently $ goldenSpecs defaultSettings (Proxy :: Proxy TAS.Person)
       summaryFailures s1 `shouldBe` 1
 
@@ -285,6 +285,41 @@ spec = do
       doesFileExist "golden/SumType/SumType2.json" `shouldReturn` True
       doesFileExist "golden/SumType/SumType3.json" `shouldReturn` True
 
+  describe "roundtripFromFile" $ do
+    it "Should pass if serialization is OK" $ do
+      (s1,_) <- hspecSilently $ roundtripFromFile (Proxy :: Proxy T.Person)
+      summaryFailures s1 `shouldBe` 0
+    it "roundtripFromFile for types which have changed the values of ToJSON or FromJSON keys should fail to match the goldenFiles" $ do
+      (s1,_) <- hspecSilently $ roundtripFromFile (Proxy :: Proxy TBS.Person)
+      summaryFailures s1 `shouldBe` 1
+
+    it "roundtripFromFile for types which have changed the values of ToJSON or FromJSON keys should fail to match the goldenFiles" $ do
+      (s1,_) <- hspecSilently $ roundtripFromFile (Proxy :: Proxy TNS.Person)
+      summaryFailures s1 `shouldBe` 1
+
+    it "roundtripFromFile for types which have altered the name of the selector and using generic implementation of ToJSON and FromJSON should fail to match the goldenFiles" $ do
+      (s1,_) <- hspecSilently $ roundtripFromFile (Proxy :: Proxy TAS.Person)
+      summaryFailures s1 `shouldBe` 1
+
+  describe "roundtripADTFromFile" $ do
+    it "Should pass if serialization is OK" $ do
+      (s1,_) <- hspecSilently $ roundtripADTFromFile (Proxy :: Proxy T.Person)
+      summaryFailures s1 `shouldBe` 0
+    it "roundtripADTFromFile for types which have changed the values of ToJSON or FromJSON keys should fail to match the goldenFiles" $ do
+      (s1,_) <- hspecSilently $ roundtripADTFromFile (Proxy :: Proxy TBS.Person)
+      summaryFailures s1 `shouldBe` 1
+
+    it "roundtripADTFromFile for types which have changed the values of ToJSON or FromJSON keys should fail to match the goldenFiles" $ do
+      (s1,_) <- hspecSilently $ roundtripADTFromFile (Proxy :: Proxy TNS.Person)
+      summaryFailures s1 `shouldBe` 1
+
+    it "roundtripADTFromFile for types which have altered the name of the selector and using generic implementation of ToJSON and FromJSON should fail to match the goldenFiles" $ do
+      (s1,_) <- hspecSilently $ roundtripADTFromFile (Proxy :: Proxy TAS.Person)
+      summaryFailures s1 `shouldBe` 1
+
+
+
+
 
 
 main :: IO ()