module Test.Hspec.Expectations.Json.Internal
(
assertBoolWithDiff
, Superset(..)
, Subset(..)
, pruneJson
, Sortable(..)
, sortJsonArrays
, vectorSortOn
, normalizeScientific
)
where
import Prelude
import Data.Aeson
import Data.Algorithm.Diff (PolyDiff(..), getDiff)
import qualified Data.HashMap.Strict as HashMap
import Data.List (sortOn)
import qualified Data.Scientific as Scientific
import Data.Text (Text)
import qualified Data.Text as T
import Data.Vector (Vector)
import qualified Data.Vector as V
import GHC.Stack (HasCallStack)
import qualified Test.HUnit as HUnit
assertBoolWithDiff :: HasCallStack => Bool -> Text -> Text -> IO ()
assertBoolWithDiff asserting expected got =
flip HUnit.assertBool asserting . unlines . map addSign $ getDiff
(lines (T.unpack expected))
(lines (T.unpack got))
where
addSign = \case
Both _ s -> " " ++ s
First s -> "---" ++ s
Second s -> "+++" ++ s
newtype Superset = Superset Value
newtype Subset = Subset Value
pruneJson :: Superset -> Subset -> Value
pruneJson (Superset sup) (Subset sub) = case (sup, sub) of
(Object a, Object b) -> Object
$ HashMap.intersectionWith (\x y -> pruneJson (Superset x) (Subset y)) a b
(Array a, Array b) -> Array $ case b V.!? 0 of
Nothing -> a
Just y -> (\x -> pruneJson (Superset x) (Subset y)) <$> a
(x, _) -> x
newtype Sortable = Sortable Value
deriving newtype Eq
instance Ord Sortable where
Sortable a `compare` Sortable b = case (a, b) of
(String x, String y) -> x `compare` y
(Number x, Number y) -> x `compare` y
(Bool x, Bool y) -> x `compare` y
(Null, Null) -> EQ
(Array x, Array y) -> V.map Sortable x `compare` V.map Sortable y
(Object x, Object y) ->
HashMap.map Sortable x `compare` HashMap.map Sortable y
(x, y) -> arbitraryRank x `compare` arbitraryRank y
where
arbitraryRank :: Value -> Int
arbitraryRank = \case
Object{} -> 5
Array{} -> 4
String{} -> 3
Number{} -> 2
Bool{} -> 1
Null -> 0
sortJsonArrays :: Value -> Value
sortJsonArrays = \case
Array v -> Array $ vectorSortOn Sortable $ sortJsonArrays <$> v
Object hm -> Object $ HashMap.map sortJsonArrays hm
x@String{} -> x
x@Number{} -> x
x@Bool{} -> x
x@Null{} -> x
vectorSortOn :: Ord b => (a -> b) -> Vector a -> Vector a
vectorSortOn f v = v V.// zip [0 ..] sorted
where sorted = sortOn f $ V.toList v
normalizeScientific :: Value -> Value
normalizeScientific = \case
Object hm -> Object $ HashMap.map normalizeScientific hm
Array vs -> Array $ normalizeScientific <$> vs
x@String{} -> x
Number sci ->
Number $ Scientific.fromFloatDigits @Double $ Scientific.toRealFloat sci
x@Bool{} -> x
x@Null -> x