Add new Normalizer and options to support omitted nulls (#18)

Introduces a new way to configure matching with a new
`shouldBeJsonNormalized` function. You pick how comparison is done by
using a combination of `Normalizer`s that run on the actual and expected
payloads

.restyled.yaml

@@ -1,7 +1,5 @@
+restylers_version: dev
 restylers:
-  - brittany:
-      include:
-        - "**/*.hs"
-        - "!library/Test/Hspec/Expectations/Json/Internal.hs" # CPP
-
+  - fourmolu
+  - "!stylish-haskell"
   - "*"

CHANGELOG.md

@@ -1,5 +1,10 @@
 ## [_Unreleased_](https://github.com/freckle/hspec-expectations-json/compare/v1.0.1.0...main)
 
+## [v1.0.2.0](https://github.com/freckle/hspec-expectations-json/compare/v1.0.1.1...v1.0.2.0)
+
+- Add `shouldBeJsonNormalized` and `Normalizer` to better support configurable matching
+- Added new option for `treatNullsAsMissing` that will treat nulls fields as if they are the same as omitted ones when doing a comparison
+
 ## [v1.0.1.1](https://github.com/freckle/hspec-expectations-json/compare/v1.0.1.0...v1.0.1.1)
 
 - Add invariant for all matchers for equality. (ex: forall a. a `shouldMatchJson` a)

fourmolu.yaml

@@ -0,0 +1,15 @@
+indentation: 2
+column-limit: 80 # ignored until v12 / ghc-9.6
+function-arrows: leading
+comma-style: leading # default
+import-export-style: leading
+indent-wheres: false # default
+record-brace-space: true
+newlines-between-decls: 1 # default
+haddock-style: single-line
+let-style: mixed
+in-style: left-align
+single-constraint-parens: never # ignored until v12 / ghc-9.6
+unicode: never # default
+respectful: true # default
+fixities: [] # default

hspec-expectations-json.cabal

@@ -4,10 +4,10 @@ cabal-version: 1.18
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 19cac3e800b693fe2abef985d22d3e12b8fa461d817f987c2279a69ca839ccad
+-- hash: 088c15398e478d5dc849fc5c4cca94a30a77df897ef2b42ecd8b0106672134d2
 
 name:           hspec-expectations-json
-version:        1.0.0.7
+version:        1.0.2.0
 synopsis:       Hspec expectations for JSON Values
 description:    Hspec expectations for JSON Values
                 .

library/Test/Hspec/Expectations/Json.hs

@@ -13,15 +13,26 @@
 -- +--------------------------+-------------------+-------------------+
 -- | 'shouldMatchOrderedJson' | No                | Yes               |
 -- +--------------------------+-------------------+-------------------+
---
 module Test.Hspec.Expectations.Json
-  ( shouldBeJson
+  ( shouldMatchJson
+  , shouldBeJson
+  , shouldBeJsonNormalized
+  , Normalizer
+  , defaultNormalizer
+  , treatNullsAsMissing
+  , ignoreArrayOrdering
+  , subsetActualToExpected
+  , expandHeterogenousArrays
+
+    -- * Legacy API
+
+    -- | Prefer to use shouldBeJsonNormalized with the appropriate 'Normalizer'
   , shouldBeUnorderedJson
-  , shouldMatchJson
   , shouldMatchOrderedJson
 
-  -- * As predicates
-  -- | These are only created when a specific need arises
+    -- * As predicates
+
+    -- | These are only created when a specific need arises
   , matchesJson
   ) where
 
@@ -30,10 +41,21 @@ import Prelude
 import Control.Monad (unless)
 import Data.Aeson
 import Data.Aeson.Encode.Pretty (encodePretty)
+import Data.Bifunctor
+import Data.Semigroup (Endo (..))
 import Data.Text.Lazy (toStrict)
 import Data.Text.Lazy.Encoding (decodeUtf8)
 import GHC.Stack
 import Test.Hspec.Expectations.Json.Internal
+  ( Subset (..)
+  , Superset (..)
+  , assertBoolWithDiff
+  , filterNullFields
+  , normalizeScientific
+  , pruneJson
+  , sortJsonArrays
+  )
+import qualified Test.Hspec.Expectations.Json.Internal as Internal
 
 -- $setup
 -- >>> :set -XQuasiQuotes
@@ -43,6 +65,48 @@ import Test.Hspec.Expectations.Json.Internal
 -- >>> let printFailure (HUnitFailure _ r) = putStr $ formatFailureReason r
 -- >>> let catchFailure f = handle printFailure $ f >> putStrLn "<passed>"
 
+newtype Actual a = Actual a
+  deriving (Functor)
+
+newtype Expected a = Expected a
+  deriving (Functor)
+
+newtype Normalizer = Normalizer
+  { normalize :: Endo (Actual Value, Expected Value)
+  }
+  deriving newtype (Semigroup, Monoid)
+
+normalizeBoth :: (Value -> Value) -> Normalizer
+normalizeBoth f = Normalizer $ Endo $ bimap (fmap f) (fmap f)
+
+treatNullsAsMissing :: Normalizer
+treatNullsAsMissing = normalizeBoth filterNullFields
+
+ignoreArrayOrdering :: Normalizer
+ignoreArrayOrdering = normalizeBoth sortJsonArrays
+
+expandHeterogenousArrays :: Normalizer
+expandHeterogenousArrays = normalizeBoth Internal.expandHeterogenousArrays
+
+subsetActualToExpected :: Normalizer
+subsetActualToExpected = Normalizer $ Endo go
+ where
+  go (Actual a, Expected b) =
+    let a' = pruneJson (Superset a) (Subset b)
+    in  (Actual a', Expected b)
+
+defaultNormalizer :: Normalizer
+defaultNormalizer =
+  ignoreArrayOrdering <> subsetActualToExpected
+
+shouldBeJsonNormalized :: HasCallStack => Normalizer -> Value -> Value -> IO ()
+shouldBeJsonNormalized normalizer a b =
+  unless (a == b) $
+    assertBoolWithDiff (a' == b') (toText b) (toText a)
+ where
+  toText = toStrict . decodeUtf8 . encodePretty . normalizeScientific
+  (Actual a', Expected b') = appEndo (normalize normalizer) (Actual a, Expected b)
+
 -- | Compare two JSON values, with a useful diff
 --
 -- >>> :{
@@ -62,10 +126,8 @@ import Test.Hspec.Expectations.Json.Internal
 -- ---    "b": true
 -- +++    "b": false
 --    }
---
 shouldBeJson :: HasCallStack => Value -> Value -> IO ()
-shouldBeJson a b = assertBoolWithDiff (a == b) (toText b) (toText a)
-  where toText = toStrict . decodeUtf8 . encodePretty . normalizeScientific
+shouldBeJson = shouldBeJsonNormalized mempty
 
 infix 1 `shouldBeJson`
 
@@ -92,10 +154,8 @@ infix 1 `shouldBeJson`
 -- +++    "b": false,
 -- +++    "c": true
 --    }
---
 shouldBeUnorderedJson :: HasCallStack => Value -> Value -> IO ()
-shouldBeUnorderedJson a b =
-  unless (a == b) $ sortJsonArrays a `shouldBeJson` sortJsonArrays b
+shouldBeUnorderedJson = shouldBeJsonNormalized ignoreArrayOrdering
 
 infix 1 `shouldBeUnorderedJson`
 
@@ -121,22 +181,16 @@ infix 1 `shouldBeUnorderedJson`
 -- ---    "b": true
 -- +++    "b": false
 --    }
---
 shouldMatchJson :: HasCallStack => Value -> Value -> IO ()
-shouldMatchJson sup sub =
-  unless (sup == sub)
-    $ sortJsonArrays (pruneJson (Superset sup) (Subset sub))
-    `shouldBeJson` sortJsonArrays sub
+shouldMatchJson = shouldBeJsonNormalized defaultNormalizer
 
 infix 1 `shouldMatchJson`
 
 -- | Compare JSON values with the same semantics as 'shouldMatchJson'
 matchesJson :: Value -> Value -> Bool
-matchesJson sup sub =
-  sup
-    == sub
-    || sortJsonArrays (pruneJson (Superset sup) (Subset sub))
-    == sortJsonArrays sub
+matchesJson sup sub = sup == sub || sup' == sub'
+ where
+  (Actual sup', Expected sub') = appEndo (normalize defaultNormalizer) (Actual sup, Expected sub)
 
 -- | 'shouldBeJson', ignoring extra Object keys
 --
@@ -162,9 +216,7 @@ matchesJson sup sub =
 -- ---    "b": true
 -- +++    "b": false
 --    }
---
 shouldMatchOrderedJson :: HasCallStack => Value -> Value -> IO ()
-shouldMatchOrderedJson sup sub =
-  unless (sup == sub) $ pruneJson (Superset sup) (Subset sub) `shouldBeJson` sub
+shouldMatchOrderedJson = shouldBeJsonNormalized subsetActualToExpected
 
 infix 1 `shouldMatchOrderedJson`

library/Test/Hspec/Expectations/Json/Color.hs

@@ -1,11 +1,11 @@
 module Test.Hspec.Expectations.Json.Color
-  ( Color(..)
+  ( Color (..)
   , getColorize
   ) where
 
 import Prelude
 
-import Control.Monad.IO.Class (MonadIO(..))
+import Control.Monad.IO.Class (MonadIO (..))
 import System.Environment (lookupEnv)
 import System.IO (hIsTerminalDevice, stdout)
 
@@ -18,10 +18,12 @@ getColorize = do
   shouldColorize <-
     liftIO $ (||) <$> isGitHubActions <*> hIsTerminalDevice stdout
 
-  pure $ if shouldColorize
-    then \c x -> escape Reset <> escape c <> x <> escape Reset
-    else \_ x -> x
-  where isGitHubActions = (== Just "true") <$> lookupEnv "GITHUB_ACTIONS"
+  pure $
+    if shouldColorize
+      then \c x -> escape Reset <> escape c <> x <> escape Reset
+      else \_ x -> x
+ where
+  isGitHubActions = (== Just "true") <$> lookupEnv "GITHUB_ACTIONS"
 
 escape :: Color -> String
 escape = \case