Sarah Vaupel
72f5a9fb37
TODOs left: reimplement clean and help, sync static,well-known and assets between services
76 lines
3.1 KiB
Haskell
76 lines
3.1 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Test.QuickCheck.Classes.JSON
|
|
( jsonLaws
|
|
, jsonKeyLaws
|
|
) where
|
|
|
|
import ClassyPrelude
|
|
import Test.QuickCheck
|
|
import Test.QuickCheck.Property (failed, Property(..))
|
|
import Test.QuickCheck.Classes hiding (jsonLaws)
|
|
import Data.Aeson
|
|
import Data.Aeson.Encoding.Internal
|
|
import Data.Aeson.Types (parseEither)
|
|
import Data.Proxy
|
|
import Data.Coerce
|
|
|
|
jsonKeyLaws :: forall a. (Arbitrary a, FromJSONKey a, ToJSONKey a, Eq a, Show a, FromJSON a, ToJSON a) => Proxy a -> Laws
|
|
jsonKeyLaws _ = Laws "ToJSONKey/FromJSONKey"
|
|
[ ("Partial Isomorphism", property $ \(a :: a) -> partialIsomorphism a)
|
|
, ("Partial Isomorphism (List)", property $ \(as :: [a]) -> partialIsomorphism as)
|
|
, ("Encoding Equals Value", property $ \(a :: a)
|
|
-> let (toVal, toEnc) = case toJSONKey of
|
|
ToJSONKeyText toVal' toEnc' -> (String . toVal', retagEncoding . toEnc')
|
|
ToJSONKeyValue toVal' toEnc' -> (toVal', toEnc')
|
|
in eitherDecode (encodingToLazyByteString $ toEnc a) == Right (toVal a)
|
|
)
|
|
]
|
|
where
|
|
partialIsomorphism :: forall a'. (FromJSONKey a', ToJSONKey a', Eq a') => a' -> Property
|
|
partialIsomorphism a = case (toJSONKey, fromJSONKey) of
|
|
(ToJSONKeyText toVal _, FromJSONKeyCoerce)
|
|
-> property $ coerce (toVal a) == a
|
|
(ToJSONKeyText toVal _, FromJSONKeyText fromVal)
|
|
-> property $ fromVal (toVal a) == a
|
|
(ToJSONKeyText toVal _, FromJSONKeyTextParser parser)
|
|
-> property $ parseEither parser (toVal a) == Right a
|
|
(ToJSONKeyValue toVal _, FromJSONKeyValue parser)
|
|
-> property $ parseEither parser (toVal a) == Right a
|
|
(_, _)
|
|
-> property failed
|
|
|
|
jsonLaws :: (ToJSON a, FromJSON a, Show a, Arbitrary a, Eq a) => Proxy a -> Laws
|
|
jsonLaws p = Laws "ToJSON/FromJSON"
|
|
[ ("Partial Isomorphism", jsonEncodingPartialIsomorphism p)
|
|
, ("Encoding Equals Value", jsonEncodingEqualsValue p)
|
|
]
|
|
|
|
-- TODO: improve the quality of the error message if
|
|
-- something does not pass this test.
|
|
jsonEncodingEqualsValue :: forall a. (ToJSON a, Show a, Arbitrary a) => Proxy a -> Property
|
|
jsonEncodingEqualsValue _ = property $ \(a :: a) ->
|
|
case decode (encode a) of
|
|
Nothing -> False
|
|
Just (v :: Value) -> v == toJSON a
|
|
|
|
jsonEncodingPartialIsomorphism :: forall a. (ToJSON a, FromJSON a, Show a, Eq a, Arbitrary a) => Proxy a -> Property
|
|
jsonEncodingPartialIsomorphism _ = again $
|
|
MkProperty $
|
|
arbitrary >>= \(x :: a) ->
|
|
unProperty $
|
|
shrinking shrink x $ \x' ->
|
|
let desc1 = "Right"
|
|
desc2 = "Data.Aeson.eitherDecode . Data.Aeson.encode"
|
|
name1 = "Data.Aeson.encode a"
|
|
name2 = "Data.Aeson.eitherDecode (Data.Aeson.encode a)"
|
|
b1 = encode x'
|
|
b2 = eitherDecode b1
|
|
sb1 = show b1
|
|
sb2 = show b2
|
|
description = " Description: " ++ desc1 ++ " == " ++ desc2
|
|
err = description ++ "\n" ++ unlines (map (" " ++) (["a = " ++ show x'])) ++ " " ++ name1 ++ " = " ++ sb1 ++ "\n " ++ name2 ++ " = " ++ sb2
|
|
in counterexample err (Right x' == b2)
|