Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Wrap Data.Aeson.Value in a newtype SafeValue #44

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open

Wrap Data.Aeson.Value in a newtype SafeValue #44

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
113 changes: 67 additions & 46 deletions src/Data/SafeJSON/Internal.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -9,9 +9,11 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
Expand Down Expand Up @@ -46,7 +48,7 @@
import Data.Functor.Identity (Identity(..))
import Data.Functor.Compose (Compose (..))
import Data.Functor.Product (Product (..))
import Data.Functor.Sum (Sum(..))

Check warning on line 51 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-21 

The import of ‘Data.Functor.Sum’ is redundant

Check warning on line 51 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver nightly 

The import of ‘Data.Functor.Sum’ is redundant

Check warning on line 51 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-22 

The import of ‘Data.Functor.Sum’ is redundant

Check warning on line 51 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-19 

The import of ‘Data.Functor.Sum’ is redundant

Check warning on line 51 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-20 

The import of ‘Data.Functor.Sum’ is redundant

Check warning on line 51 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-18 

The import of ‘Data.Functor.Sum’ is redundant
import Data.Hashable (Hashable)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashSet as HS (HashSet, fromList, toList)
Expand All @@ -55,7 +57,7 @@
import Data.IntSet (IntSet)
import qualified Data.List as List (intercalate, lookup)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Map as M (Map, singleton)

Check warning on line 60 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-21 

The import of ‘singleton’ from module ‘Data.Map’ is redundant

Check warning on line 60 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver nightly 

The import of ‘singleton’ from module ‘Data.Map’ is redundant

Check warning on line 60 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-22 

The import of ‘singleton’ from module ‘Data.Map’ is redundant

Check warning on line 60 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-19 

The import of ‘singleton’ from module ‘Data.Map’ is redundant

Check warning on line 60 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-20 

The import of ‘singleton’ from module ‘Data.Map’ is redundant

Check warning on line 60 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-18 

The import of ‘singleton’ from module ‘Data.Map’ is redundant
import Data.Maybe (fromMaybe, isJust, isNothing)
#if MIN_VERSION_base(4,11,0)
import Data.Monoid (Dual(..))
Expand Down Expand Up @@ -90,6 +92,7 @@
import Data.Void (Void)
import Data.Word (Word8, Word16, Word32, Word64)
import Foreign.C.Types (CTime)
import GHC.Generics (Generic)
import Numeric.Natural (Natural)
import Test.Tasty.QuickCheck (Arbitrary(..), shrinkIntegral)

Expand All @@ -103,6 +106,9 @@
import qualified Data.HashMap.Strict as Map (delete, insert, lookup, size, toList)
#endif

newtype SafeValue = SafeValue {unSafeValue :: Value}
deriving (Eq, Read, Show, Generic, Hashable, FromJSON, ToJSON)

-- | A type that can be converted from and to JSON with versioning baked
-- in, using 'Migrate' to automate migration between versions, reducing
-- headaches when the need arrises to modify JSON formats while old
Expand Down Expand Up @@ -131,9 +137,9 @@
-- can be modified if need be.
--
-- This function cannot be used directly. Use 'safeToJSON', instead.
safeTo :: a -> Contained Value
default safeTo :: ToJSON a => a -> Contained Value
safeTo = contain . toJSON
safeTo :: a -> Contained SafeValue
default safeTo :: ToJSON a => a -> Contained SafeValue
safeTo = contain . SafeValue .toJSON

-- | This method defines how a value should be parsed without also worrying
-- about writing out the version tag. The default implementation uses 'parseJSON',
Expand Down Expand Up @@ -251,8 +257,8 @@
-- * the version field did not have a number
--
-- @since 1.2.0.0
getVersion :: Value -> Maybe Int32
getVersion (Object o) =
getVersion :: SafeValue -> Maybe Int32
getVersion (SafeValue (Object o)) =
case Map.toList o of
[(k1, v1), (k2, v2)]
| k1 == dataVersionField && k2 == dataField -> parseInt v1
Expand All @@ -268,17 +274,17 @@
-- "{\"~v\":0,\"~d\":\"test\"}"
--
-- @since 1.0.0
setVersion' :: forall a. SafeJSON a => Version a -> Value -> Value
setVersion' :: forall a. SafeJSON a => Version a -> SafeValue -> SafeValue

Check warning on line 277 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-21 

Redundant constraint: SafeJSON a

Check warning on line 277 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver nightly 

Redundant constraint: SafeJSON a

Check warning on line 277 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-22 

Redundant constraint: SafeJSON a

Check warning on line 277 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-19 

• Redundant constraint: SafeJSON a

Check warning on line 277 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-20 

• Redundant constraint: SafeJSON a

Check warning on line 277 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-18 

• Redundant constraint: SafeJSON a
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I designed the setVersion functions to mainly be used to set the version when the value does not have one (taking a format from a third party who doesn't need to know about the versioning, for example)

So I'd say it would be more logical for the type to be Value -> SafeValue

setVersion' (Version mVersion) val =
case mVersion of
Nothing -> val
Just i -> case val of
Object o ->
SafeValue (Object o) ->
let vField = maybe versionField
(const dataVersionField)
$ dataVersionField `Map.lookup` o
in Object $ Map.insert vField (toJSON i) o
other -> object
in SafeValue $ Object $ Map.insert vField (toJSON i) o
other -> SafeValue $ object
[ dataVersionField .= i
, dataField .= other
]
Expand Down Expand Up @@ -315,7 +321,7 @@
-- @
--
-- @since 1.0.0
setVersion :: forall a. SafeJSON a => Value -> Value
setVersion :: forall a. SafeJSON a => SafeValue -> SafeValue
setVersion = setVersion' (version @a)

-- | /CAUTION: Only use this function if you know what you're doing./
Expand All @@ -328,17 +334,32 @@
-- should be hidden.
--
-- @since 1.0.0
removeVersion :: Value -> Value
removeVersion = \case
-- removeVersion :: SafeValue -> Value
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This commented-out section can be removed, right?

-- removeVersion = \case
-- SafeValue (Object o) -> go o
-- -- Recursively find all version tags and remove them.
-- SafeValue (Array a) -> SafeValue $ Array $ removeVersion <$> a
-- other -> unSafeValue other
-- -- Recursively find all version tags and remove them.
-- where go o = maybe regular removeVersion $ do
-- _ <- dataVersionField `Map.lookup` o
-- dataField `Map.lookup` o
-- where regular = SafeValue $ Object $ removeVersion <$> Map.delete versionField o

removeVersion :: SafeValue -> Value
removeVersion = removeVersion' . unSafeValue

removeVersion' :: Value -> Value
removeVersion' = \case
Object o -> go o
-- Recursively find all version tags and remove them.
Array a -> Array $ removeVersion <$> a
Array a -> Array $ removeVersion' <$> a
other -> other
-- Recursively find all version tags and remove them.
where go o = maybe regular removeVersion $ do
where go o = maybe regular removeVersion' $ do
_ <- dataVersionField `Map.lookup` o
dataField `Map.lookup` o
where regular = Object $ removeVersion <$> Map.delete versionField o
where regular = Object $ removeVersion' <$> Map.delete versionField o

instance Show (Version a) where
show (Version mi) = "Version " ++ showV mi
Expand Down Expand Up @@ -389,14 +410,14 @@

-- | Used to define 'kind'.
-- Extends a previous version.
extension :: (SafeJSON a, Migrate a) => Kind a

Check warning on line 413 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-21 

Redundant constraint: SafeJSON a

Check warning on line 413 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver nightly 

Redundant constraint: SafeJSON a

Check warning on line 413 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-22 

Redundant constraint: SafeJSON a

Check warning on line 413 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-19 

• Redundant constraint: SafeJSON a

Check warning on line 413 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-20 

• Redundant constraint: SafeJSON a

Check warning on line 413 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-18 

• Redundant constraint: SafeJSON a
extension = Extends Proxy

-- | Used to define 'kind'.
-- Types that are 'extended_base', are extended by a
-- future version and as such can migrate backward from
-- that future version. (cf. 'extended_extension', 'base')
extended_base :: (SafeJSON a, Migrate (Reverse a)) => Kind a

Check warning on line 420 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-21 

Redundant constraint: SafeJSON a

Check warning on line 420 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver nightly 

Redundant constraint: SafeJSON a

Check warning on line 420 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-22 

Redundant constraint: SafeJSON a

Check warning on line 420 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-19 

• Redundant constraint: SafeJSON a

Check warning on line 420 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-20 

• Redundant constraint: SafeJSON a

Check warning on line 420 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-18 

• Redundant constraint: SafeJSON a
extended_base = Extended base

-- | Used to define 'kind'.
Expand Down Expand Up @@ -446,7 +467,7 @@
-- __This function does not check consistency of the 'SafeJSON' instances.__
-- __It is advised to always 'Data.SafeJSON.Test.testConsistency' for all__
-- __your instances in a production setting.__
safeToJSON :: forall a. SafeJSON a => a -> Value
safeToJSON :: forall a. SafeJSON a => a -> SafeValue
safeToJSON a = case thisKind of
Base | isNothing i -> tojson
Extended Base | isNothing i -> tojson
Expand Down Expand Up @@ -932,7 +953,7 @@
safeFrom val = contain $
parseJSON val >>= traverse safeFromJSON
-- Nothing means do whatever Aeson thinks Nothing should be
safeTo Nothing = contain $ toJSON (Nothing :: Maybe Value)
safeTo Nothing = contain $ SafeValue $ toJSON (Nothing :: Maybe Value)
-- If there's something, keep it safe
safeTo (Just a) = contain $ safeToJSON a
typeName = typeName1
Expand All @@ -944,8 +965,8 @@
case eVal of
Left a -> Left <$> safeFromJSON a
Right b -> Right <$> safeFromJSON b
safeTo (Left a) = contain $ toJSON (Left $ safeToJSON a :: Either Value Void)
safeTo (Right b) = contain $ toJSON (Right $ safeToJSON b :: Either Void Value)
safeTo (Left a) = contain $ SafeValue $ toJSON (Left $ safeToJSON a :: Either SafeValue Void)
safeTo (Right b) = contain $ SafeValue $ toJSON (Right $ safeToJSON b :: Either Void SafeValue)
typeName = typeName2
version = noVersion

Expand All @@ -968,8 +989,8 @@
v <- parseJSON val
VG.convert <$> VG.mapM safeFromJSON (v :: V.Vector Value)

toGenericVector :: (SafeJSON a, VG.Vector v a) => v a -> Contained Value
toGenericVector = contain . toJSON . fmap safeToJSON . VG.toList
toGenericVector :: (SafeJSON a, VG.Vector v a) => v a -> Contained SafeValue
toGenericVector = contain . SafeValue . toJSON . fmap safeToJSON . VG.toList

instance SafeJSON a => SafeJSON (V.Vector a) where
safeFrom = fromGenericVector
Expand Down Expand Up @@ -1005,15 +1026,15 @@
instance {-# OVERLAPPABLE #-} SafeJSON a => SafeJSON [a] where
safeFrom val = contain $
parseJSON val >>= traverse safeFromJSON
safeTo as = contain . toJSON $ safeToJSON <$> as
safeTo as = contain . SafeValue . toJSON $ safeToJSON <$> as
typeName = typeName1
version = noVersion

#define BASIC_UNARY_FUNCTOR(T) \
instance SafeJSON a => SafeJSON (T a) where { \
safeFrom val = contain $ \
parseJSON val >>= traverse safeFromJSON; \
safeTo as = contain . toJSON $ safeToJSON <$> as; \
safeTo as = contain . SafeValue . toJSON $ safeToJSON <$> as; \
typeName = typeName1; \
version = noVersion }

Expand All @@ -1024,42 +1045,42 @@
instance SafeJSON a => SafeJSON (IntMap a) where
safeFrom val = contain $
IM.fromList <$> safeFromJSON val
safeTo as = contain . toJSON $ safeToJSON <$> as
safeTo as = contain . SafeValue . toJSON $ safeToJSON <$> as
typeName = typeName1
version = noVersion

instance (SafeJSON a) => SafeJSON (DList a) where
safeFrom val = contain $
DList.fromList <$> safeFromJSON val
safeTo as = contain . toJSON $ safeToJSON <$> as
safeTo as = contain . SafeValue . toJSON $ safeToJSON <$> as
typeName = typeName1
version = noVersion

instance (SafeJSON a, Ord a) => SafeJSON (S.Set a) where
safeFrom val = contain $
S.fromList <$> safeFromJSON val
safeTo as = contain . toJSON $ safeToJSON <$> S.toList as
safeTo as = contain . SafeValue . toJSON $ safeToJSON <$> S.toList as
typeName = typeName1
version = noVersion

instance (Ord k, FromJSONKey k, ToJSONKey k, SafeJSON a) => SafeJSON (Map k a) where
safeFrom val = contain $
parseJSON val >>= traverse safeFromJSON
safeTo as = contain . toJSON $ safeToJSON <$> as
safeTo as = contain . SafeValue . toJSON $ safeToJSON <$> as
typeName = typeName2
version = noVersion

instance (SafeJSON a, Eq a, Hashable a) => SafeJSON (HS.HashSet a) where

Check warning on line 1073 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-21 

• Redundant constraint: Eq a

Check warning on line 1073 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-20 

• Redundant constraint: Eq a
safeFrom val = contain $
HS.fromList <$> safeFromJSON val
safeTo as = contain . toJSON $ safeToJSON <$> HS.toList as
safeTo as = contain . SafeValue . toJSON $ safeToJSON <$> HS.toList as
typeName = typeName1
version = noVersion

instance (Hashable a, FromJSONKey a, ToJSONKey a, Eq a, SafeJSON b) => SafeJSON (HashMap a b) where

Check warning on line 1080 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-21 

• Redundant constraint: Eq a

Check warning on line 1080 in src/Data/SafeJSON/Internal.hs

View workflow job for this annotation

GitHub Actions / stack --resolver lts-20 

• Redundant constraint: Eq a
safeFrom val = contain $
parseJSON val >>= traverse safeFromJSON
safeTo as = contain . toJSON $ safeToJSON <$> as
safeTo as = contain . SafeValue . toJSON $ safeToJSON <$> as
typeName = typeName2
version = noVersion

Expand All @@ -1072,7 +1093,7 @@
#endif
parseJSON val >>=
traverse safeFromJSON
safeTo as = contain . toJSON $ safeToJSON <$> as
safeTo as = contain . SafeValue . toJSON $ safeToJSON <$> as
typeName = typeName1
version = noVersion
#endif
Expand All @@ -1083,7 +1104,7 @@
a <- safeFromJSON a'
b <- safeFromJSON b'
pure (a,b)
safeTo (a,b) = contain $ toJSON (safeToJSON a, safeToJSON b)
safeTo (a,b) = contain $ SafeValue $ toJSON (safeToJSON a, safeToJSON b)
typeName = typeName2
version = noVersion

Expand All @@ -1094,7 +1115,7 @@
b <- safeFromJSON b'
c <- safeFromJSON c'
pure (a,b,c)
safeTo (a,b,c) = contain $ toJSON (safeToJSON a, safeToJSON b, safeToJSON c)
safeTo (a,b,c) = contain $ SafeValue $ toJSON (safeToJSON a, safeToJSON b, safeToJSON c)
typeName = typeName3
version = noVersion

Expand All @@ -1106,7 +1127,7 @@
c <- safeFromJSON c'
d <- safeFromJSON d'
pure (a,b,c,d)
safeTo (a,b,c,d) = contain $ toJSON (safeToJSON a, safeToJSON b, safeToJSON c, safeToJSON d)
safeTo (a,b,c,d) = contain $ SafeValue $ toJSON (safeToJSON a, safeToJSON b, safeToJSON c, safeToJSON d)
typeName = typeName4
version = noVersion

Expand All @@ -1119,7 +1140,7 @@
d <- safeFromJSON d'
e <- safeFromJSON e'
pure (a,b,c,d,e)
safeTo (a,b,c,d,e) = contain $ toJSON (safeToJSON a, safeToJSON b, safeToJSON c, safeToJSON d, safeToJSON e)
safeTo (a,b,c,d,e) = contain $ SafeValue $ toJSON (safeToJSON a, safeToJSON b, safeToJSON c, safeToJSON d, safeToJSON e)
typeName = typeName5
version = noVersion

Expand All @@ -1131,23 +1152,23 @@
version = noVersion

-- | @since 1.1.2.0
instance (SafeJSON (f a), SafeJSON (g a)) => SafeJSON (Sum f g a) where
Copy link
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Why did you comment out this instance?

safeFrom = containWithObject "Sum" $ \o -> do
case Map.toList o of
[("InL", val)] -> InL <$> safeFromJSON val
[("InR", val)] -> InR <$> safeFromJSON val
_ -> fail "Sum expects an object with one field: \"InL\" or \"InR\""
safeTo = contain . safeToJSON . uncurry M.singleton . \case
InL fa -> ("InL" :: String, safeToJSON fa)
InR ga -> ("InR" :: String, safeToJSON ga)
typeName _ = "Sum"
version = noVersion
-- instance (SafeJSON (f a), SafeJSON (g a)) => SafeJSON (Sum f g a) where
-- safeFrom = containWithObject "Sum" $ \o -> do
-- case Map.toList o of
-- [("InL", val)] -> InL <$> safeFromJSON val
-- [("InR", val)] -> InR <$> safeFromJSON val
-- _ -> fail "Sum expects an object with one field: \"InL\" or \"InR\""
-- safeTo = contain . safeToJSON . uncurry M.singleton . \case
-- InL fa -> ("InL" :: String, safeToJSON fa)
-- InR ga -> ("InR" :: String, safeToJSON ga)
-- typeName _ = "Sum"
-- version = noVersion

-- | @since 1.1.2.0
instance (SafeJSON (f a), SafeJSON (g a)) => SafeJSON (Product f g a) where
safeFrom val = contain $ do
(f, g) <- parseJSON val
Pair <$> safeFromJSON f <*> safeFromJSON g
safeTo (Pair f g) = contain $ toJSON (safeToJSON f, safeToJSON g)
safeTo (Pair f g) = contain $ SafeValue $ toJSON (safeToJSON f, safeToJSON g)
typeName _ = "Product"
version = noVersion
18 changes: 9 additions & 9 deletions src/Data/SafeJSON/Test.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -101,14 +101,14 @@ testConsistency' = flip checkConsistency $ \_ -> return ()
-- prop> Just a == parseMaybe safeFromJSON (safeToJSON a)
testRoundTrip :: forall a. (Show a, Eq a, SafeJSON a) => a -> Assertion
testRoundTrip a = (typeName (Proxy :: Proxy a) <> ": to JSON and back not consistent") `assertEqual` Right a $
parseEither (safeFromJSON . safeToJSON) a
parseEither (safeFromJSON . unSafeValue . safeToJSON) a

-- | Tests that the following holds __for all @a@__:
--
-- prop> Just a == parseMaybe safeFromJSON (safeToJSON a)
testRoundTripProp' :: forall a. (Eq a, Show a, Arbitrary a, SafeJSON a) => Proxy a -> String -> TestTree
testRoundTripProp' _ s = testProperty s $ \a ->
Right (a :: a) == parseEither (safeFromJSON . safeToJSON) a
Right (a :: a) == parseEither (safeFromJSON . unSafeValue . safeToJSON) a

-- | Tests that the following holds for all @a@:
--
Expand All @@ -119,7 +119,7 @@ testRoundTripProp' _ s = testProperty s $ \a ->
-- > testRoundTripProp @MyType s
testRoundTripProp :: forall a. (Eq a, Show a, Arbitrary a, SafeJSON a) => String -> TestTree
testRoundTripProp s = testProperty s $ \a ->
Right (a :: a) == parseEither (safeFromJSON . safeToJSON) a
Right (a :: a) == parseEither (safeFromJSON . unSafeValue . safeToJSON) a

-- | Migration test. Mostly useful as regression test.
--
Expand Down Expand Up @@ -152,13 +152,13 @@ infix 1 >=?, <=?
-- through encoding and decoding to the newer type, is equivalent.
migrateRoundTrip :: forall a. (Eq a, Show a, SafeJSON a, Migrate a) => MigrateFrom a -> Assertion
migrateRoundTrip oldType = "Unexpected result of decoding encoded older type" `assertEqual` Right (migrate oldType :: a) $
parseEither (safeFromJSON . safeToJSON) oldType
parseEither (safeFromJSON . unSafeValue . safeToJSON) oldType

-- | Similar to 'migrateRoundTrip', but tests the migration from a newer type
-- to the older type, in case of a @'Migrate' ('Reverse' a)@ instance
migrateReverseRoundTrip :: forall a. (Eq a, Show a, SafeJSON a, Migrate (Reverse a)) => MigrateFrom (Reverse a) -> Assertion
migrateReverseRoundTrip newType = "Unexpected result of decoding encoded newer type" `assertEqual` Right (unReverse $ migrate newType :: a) $
parseEither (safeFromJSON . safeToJSON) newType
parseEither (safeFromJSON . unSafeValue . safeToJSON) newType

-- | Constraints for migrating from a previous version
type TestMigrate a b =
Expand All @@ -177,7 +177,7 @@ type TestMigrate a b =
-- prop> Just (migrate a) == parseMaybe safeFromJSON (safeToJSON a)
migrateRoundTripProp' :: forall a b. TestMigrate a b => Proxy (a,b) -> String -> TestTree
migrateRoundTripProp' _ s = testProperty s $ \a ->
Right (migrate a :: a) == parseEither (safeFromJSON . safeToJSON) a
Right (migrate a :: a) == parseEither (safeFromJSON . unSafeValue . safeToJSON) a

-- | This test verifies that direct migration, and migration
-- through encoding and decoding to the newer type, is equivalent
Expand All @@ -190,7 +190,7 @@ migrateRoundTripProp' _ s = testProperty s $ \a ->
-- > migrateRoundTripProp @NewType @OldType s
migrateRoundTripProp :: forall a b. TestMigrate a b => String -> TestTree
migrateRoundTripProp s = testProperty s $ \a ->
Right (migrate a :: a) == parseEither (safeFromJSON . safeToJSON) a
Right (migrate a :: a) == parseEither (safeFromJSON . unSafeValue . safeToJSON) a

-- | Constraints for migrating from a future version
type TestReverseMigrate a b =
Expand All @@ -208,7 +208,7 @@ type TestReverseMigrate a b =
-- prop> Just (unReverse $ migrate a) == parseMaybe safeFromJSON (safeToJSON a)
migrateReverseRoundTripProp' :: forall a b. TestReverseMigrate a b => Proxy (a,b) -> String -> TestTree
migrateReverseRoundTripProp' _ s = testProperty s $ \a ->
Right (unReverse $ migrate a :: a) == parseEither (safeFromJSON . safeToJSON) a
Right (unReverse $ migrate a :: a) == parseEither (safeFromJSON . unSafeValue . safeToJSON) a

-- | Similar to 'migrateRoundTripProp', but tests the migration from a newer type
-- to the older type, in case of a @'Migrate' ('Reverse' a)@ instance.
Expand All @@ -222,4 +222,4 @@ migrateReverseRoundTripProp' _ s = testProperty s $ \a ->
-- > migrateReverseRoundTripProp @OldType @NewType s
migrateReverseRoundTripProp :: forall a b. TestReverseMigrate a b => String -> TestTree
migrateReverseRoundTripProp s = testProperty s $ \a ->
Right (unReverse $ migrate a :: a) == parseEither (safeFromJSON . safeToJSON) a
Right (unReverse $ migrate a :: a) == parseEither (safeFromJSON . unSafeValue . safeToJSON) a
Loading