-- 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)