-- | Expectations on JSON 'Value's
--
-- Semantics:
--
-- +--------------------------+-------------------+-------------------+
-- | Assertion that fails on: | extra Object keys | wrong Array order +
-- +==========================+===================+===================+
-- | 'shouldBeJson'           | Yes               | Yes               |
-- +--------------------------+-------------------+-------------------+
-- | 'shouldBeUnorderedJson'  | Yes               | No                |
-- +--------------------------+-------------------+-------------------+
-- | 'shouldMatchJson'        | No                | No                |
-- +--------------------------+-------------------+-------------------+
-- | 'shouldMatchOrderedJson' | No                | Yes               |
-- +--------------------------+-------------------+-------------------+
--
module Test.Hspec.Expectations.Json
  ( shouldBeJson
  , shouldBeUnorderedJson
  , shouldMatchJson
  , shouldMatchOrderedJson

  -- * As predicates
  -- | These are only created when a specific need arises
  , matchesJson
  )
where

import Prelude

import Data.Aeson
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Encoding (decodeUtf8)
import GHC.Stack
import Test.Hspec.Expectations.Json.Internal

-- $setup
-- >>> :set -XQuasiQuotes
-- >>> import Data.Aeson.QQ (aesonQQ)
-- >>> import Test.HUnit.Lang (HUnitFailure(..), formatFailureReason)
-- >>> import Control.Exception (handle)
-- >>> let printFailure (HUnitFailure _ r) = putStr $ formatFailureReason r
-- >>> let catchFailure f = handle printFailure $ f >> putStrLn "<passed>"

-- | Compare two JSON values, with a useful diff
--
-- >>> :{
-- catchFailure $
--   [aesonQQ| { "a": true, "b": false } |] `shouldBeJson`
--   [aesonQQ| { "a": true, "b": false } |]
-- :}
-- <passed>
--
-- >>> :{
-- catchFailure $
--   [aesonQQ| { "a": true, "b": false } |] `shouldBeJson`
--   [aesonQQ| { "a": true, "b": true  } |]
-- :}
--    {
--        "a": true,
-- ---    "b": true
-- +++    "b": false
--    }
--
shouldBeJson :: HasCallStack => Value -> Value -> IO ()
shouldBeJson :: Value -> Value -> IO ()
shouldBeJson Value
a Value
b = HasCallStack => Bool -> Text -> Text -> IO ()
Bool -> Text -> Text -> IO ()
assertBoolWithDiff (Value
a Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
b) (Value -> Text
toText Value
b) (Value -> Text
toText Value
a)
  where toText :: Value -> Text
toText = Text -> Text
toStrict (Text -> Text) -> (Value -> Text) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text) -> (Value -> ByteString) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
encodePretty (Value -> ByteString) -> (Value -> Value) -> Value -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Value
normalizeScientific

infix 1 `shouldBeJson`

-- | 'shouldBeJson', ignoring Array ordering
--
-- >>> :{
-- catchFailure $
--   [aesonQQ| { "a": [true, false], "b": false } |] `shouldBeUnorderedJson`
--   [aesonQQ| { "a": [false, true], "b": false } |]
-- :}
-- <passed>
--
-- >>> :{
-- catchFailure $
--   [aesonQQ| { "a": [true, false], "b": false, "c": true } |] `shouldBeUnorderedJson`
--   [aesonQQ| { "a": [false, true], "b": true             } |]
-- :}
--    {
--        "a": [
--            false,
--            true
--        ],
-- ---    "b": true
-- +++    "b": false,
-- +++    "c": true
--    }
--
shouldBeUnorderedJson :: HasCallStack => Value -> Value -> IO ()
shouldBeUnorderedJson :: Value -> Value -> IO ()
shouldBeUnorderedJson Value
a Value
b = Value -> Value
sortJsonArrays Value
a HasCallStack => Value -> Value -> IO ()
Value -> Value -> IO ()
`shouldBeJson` Value -> Value
sortJsonArrays Value
b

infix 1 `shouldBeUnorderedJson`

-- | 'shouldBeJson', ignoring extra Object keys or Array ordering
--
-- >>> :{
-- catchFailure $
--   [aesonQQ| { "a": [true, false], "b": false, "c": true } |] `shouldMatchJson`
--   [aesonQQ| { "a": [false, true], "b": false            } |]
-- :}
-- <passed>
--
-- >>> :{
-- catchFailure $
--   [aesonQQ| { "a": [true, false], "b": false, "c": true } |] `shouldMatchJson`
--   [aesonQQ| { "a": [false, true], "b": true             } |]
-- :}
--    {
--        "a": [
--            false,
--            true
--        ],
-- ---    "b": true
-- +++    "b": false
--    }
--
shouldMatchJson :: HasCallStack => Value -> Value -> IO ()
shouldMatchJson :: Value -> Value -> IO ()
shouldMatchJson Value
sup Value
sub =
  Value -> Value
sortJsonArrays (Superset -> Subset -> Value
pruneJson (Value -> Superset
Superset Value
sup) (Value -> Subset
Subset Value
sub))
    HasCallStack => Value -> Value -> IO ()
Value -> Value -> IO ()
`shouldBeJson` Value -> Value
sortJsonArrays Value
sub

infix 1 `shouldMatchJson`

-- | Compare JSON values with the same semantics as 'shouldMatchJson'
matchesJson :: Value -> Value -> Bool
matchesJson :: Value -> Value -> Bool
matchesJson Value
sup Value
sub =
  Value -> Value
sortJsonArrays (Superset -> Subset -> Value
pruneJson (Value -> Superset
Superset Value
sup) (Value -> Subset
Subset Value
sub)) Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Value
sortJsonArrays Value
sub

-- | 'shouldBeJson', ignoring extra Object keys
--
-- >>> :{
-- catchFailure $
--   [aesonQQ| { "a": [true, false], "b": false, "c": true } |] `shouldMatchOrderedJson`
--   [aesonQQ| { "a": [true, false], "b": false            } |]
-- :}
-- <passed>
--
-- >>> :{
-- catchFailure $
--   [aesonQQ| { "a": [true, false], "b": false, "c": true } |] `shouldMatchOrderedJson`
--   [aesonQQ| { "a": [false, true], "b": true             } |]
-- :}
--    {
--        "a": [
-- ---        false,
-- ---        true
-- +++        true,
-- +++        false
--        ],
-- ---    "b": true
-- +++    "b": false
--    }
--
shouldMatchOrderedJson :: HasCallStack => Value -> Value -> IO ()
shouldMatchOrderedJson :: Value -> Value -> IO ()
shouldMatchOrderedJson Value
sup Value
sub =
  Superset -> Subset -> Value
pruneJson (Value -> Superset
Superset Value
sup) (Value -> Subset
Subset Value
sub) HasCallStack => Value -> Value -> IO ()
Value -> Value -> IO ()
`shouldBeJson` Value
sub

infix 1 `shouldMatchOrderedJson`