{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Aeson.Match.QQ.Internal.Match where

import           Control.Applicative (liftA2)
import           Control.Monad (unless)
import           Data.Aeson ((.=))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.KeyMap as Aeson (toHashMapText)
import           Data.Either.Validation (Validation(..), eitherToValidation)
import           Data.Foldable (for_, toList)
import           Data.Bool (bool)
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import           Data.List.NonEmpty (NonEmpty)
import           Data.Maybe (mapMaybe)
import qualified Data.Set as Set
import           Data.String (IsString(..))
import           Data.Text (Text)
import           Data.Vector (Vector)
import qualified Data.Vector as Vector
import           Prelude hiding (any, null)

import           Aeson.Match.QQ.Internal.Value (Value(..), Box(..), TypeSig(..), Type(..), Nullable(..))


match
  :: Value Aeson.Value
  -> Aeson.Value
  -> Validation (NonEmpty VE) (HashMap Text Aeson.Value)
match :: Value Value
-> Value -> Validation (NonEmpty VE) (HashMap Text Value)
match =
  [PathElem]
-> Value Value
-> Value
-> Validation (NonEmpty VE) (HashMap Text Value)
go []
 where
  go :: [PathElem]
-> Value Value
-> Value
-> Validation (NonEmpty VE) (HashMap Text Value)
go [PathElem]
path Value Value
matcher Value
given = do
    let mismatched :: Validation (NonEmpty VE) a
mismatched = [PathElem] -> Value Value -> Value -> Validation (NonEmpty VE) a
forall a.
[PathElem] -> Value Value -> Value -> Validation (NonEmpty VE) a
mismatch ([PathElem] -> [PathElem]
forall a. [a] -> [a]
reverse [PathElem]
path) Value Value
matcher Value
given
    case (Value Value
matcher, Value
given) of
      (Any Maybe TypeSig
holeTypeO Maybe Text
nameO, Value
val) -> do
        Maybe TypeSig
-> (TypeSig -> Validation (NonEmpty VE) ())
-> Validation (NonEmpty VE) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe TypeSig
holeTypeO ((TypeSig -> Validation (NonEmpty VE) ())
 -> Validation (NonEmpty VE) ())
-> (TypeSig -> Validation (NonEmpty VE) ())
-> Validation (NonEmpty VE) ()
forall a b. (a -> b) -> a -> b
$ \TypeSig
holeType ->
          Bool -> Validation (NonEmpty VE) () -> Validation (NonEmpty VE) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TypeSig -> Value -> Bool
holeTypeMatch TypeSig
holeType Value
val)
            Validation (NonEmpty VE) ()
forall a. Validation (NonEmpty VE) a
mismatched
        pure (HashMap Text Value
-> (Text -> HashMap Text Value) -> Maybe Text -> HashMap Text Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe HashMap Text Value
forall a. Monoid a => a
mempty (\Text
name -> Text -> Value -> HashMap Text Value
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton Text
name Value
val) Maybe Text
nameO)
      (Value Value
Null, Value
Aeson.Null) ->
        HashMap Text Value -> Validation (NonEmpty VE) (HashMap Text Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMap Text Value
forall a. Monoid a => a
mempty
      (Value Value
Null, Value
_) -> do
        Validation (NonEmpty VE) Any
forall a. Validation (NonEmpty VE) a
mismatched
        pure HashMap Text Value
forall a. Monoid a => a
mempty
      (Bool Bool
b, Aeson.Bool Bool
b') -> do
        Bool -> Validation (NonEmpty VE) () -> Validation (NonEmpty VE) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
b Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
b') Validation (NonEmpty VE) ()
forall a. Validation (NonEmpty VE) a
mismatched
        pure HashMap Text Value
forall a. Monoid a => a
mempty
      (Bool Bool
_, Value
_) -> do
        Validation (NonEmpty VE) Any
forall a. Validation (NonEmpty VE) a
mismatched
        pure HashMap Text Value
forall a. Monoid a => a
mempty
      (Number Scientific
n, Aeson.Number Scientific
n') -> do
        Bool -> Validation (NonEmpty VE) () -> Validation (NonEmpty VE) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Scientific
n Scientific -> Scientific -> Bool
forall a. Eq a => a -> a -> Bool
== Scientific
n') Validation (NonEmpty VE) ()
forall a. Validation (NonEmpty VE) a
mismatched
        pure HashMap Text Value
forall a. Monoid a => a
mempty
      (Number Scientific
_, Value
_) -> do
        Validation (NonEmpty VE) Any
forall a. Validation (NonEmpty VE) a
mismatched
        pure HashMap Text Value
forall a. Monoid a => a
mempty
      (String Text
str, Aeson.String Text
str') -> do
        Bool -> Validation (NonEmpty VE) () -> Validation (NonEmpty VE) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
str Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
str') Validation (NonEmpty VE) ()
forall a. Validation (NonEmpty VE) a
mismatched
        pure HashMap Text Value
forall a. Monoid a => a
mempty
      (String Text
_, Value
_) -> do
        Validation (NonEmpty VE) Any
forall a. Validation (NonEmpty VE) a
mismatched
        pure HashMap Text Value
forall a. Monoid a => a
mempty
      (Array Box {Vector (Value Value)
knownValues :: forall a. Box a -> a
knownValues :: Vector (Value Value)
knownValues, Bool
extendable :: forall a. Box a -> Bool
extendable :: Bool
extendable}, Aeson.Array Array
arr) ->
        let
          fold :: (Int -> t -> f (HashMap k v)) -> Vector t -> f (HashMap k v)
fold Int -> t -> f (HashMap k v)
f =
            (Int -> t -> f (HashMap k v) -> f (HashMap k v))
-> f (HashMap k v) -> Vector t -> f (HashMap k v)
forall a b. (Int -> a -> b -> b) -> b -> Vector a -> b
Vector.ifoldr (\Int
i t
v f (HashMap k v)
a -> (HashMap k v -> HashMap k v -> HashMap k v)
-> f (HashMap k v) -> f (HashMap k v) -> f (HashMap k v)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 HashMap k v -> HashMap k v -> HashMap k v
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HashMap.union f (HashMap k v)
a (Int -> t -> f (HashMap k v)
f Int
i t
v)) (HashMap k v -> f (HashMap k v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMap k v
forall a. Monoid a => a
mempty)
          extraValues :: Array
extraValues =
            Int -> Array -> Array
forall a. Int -> Vector a -> Vector a
Vector.drop (Vector (Value Value) -> Int
forall a. Vector a -> Int
Vector.length Vector (Value Value)
knownValues) Array
arr
        in
          Bool -> Validation (NonEmpty VE) () -> Validation (NonEmpty VE) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
            (Bool
extendable Bool -> Bool -> Bool
|| Array -> Bool
forall a. Vector a -> Bool
Vector.null Array
extraValues)
            ([PathElem] -> Array -> Validation (NonEmpty VE) ()
forall a. [PathElem] -> Array -> Validation (NonEmpty VE) a
extraArrayValues ([PathElem] -> [PathElem]
forall a. [a] -> [a]
reverse [PathElem]
path) Array
extraValues) Validation (NonEmpty VE) ()
-> Validation (NonEmpty VE) (HashMap Text Value)
-> Validation (NonEmpty VE) (HashMap Text Value)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
          (Int
 -> Value Value -> Validation (NonEmpty VE) (HashMap Text Value))
-> Vector (Value Value)
-> Validation (NonEmpty VE) (HashMap Text Value)
forall (f :: * -> *) k t v.
(Applicative f, Hashable k) =>
(Int -> t -> f (HashMap k v)) -> Vector t -> f (HashMap k v)
fold
            (\Int
i Value Value
v -> Validation (NonEmpty VE) (HashMap Text Value)
-> (Value -> Validation (NonEmpty VE) (HashMap Text Value))
-> Maybe Value
-> Validation (NonEmpty VE) (HashMap Text Value)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([PathElem]
-> PathElem -> Validation (NonEmpty VE) (HashMap Text Value)
forall a. [PathElem] -> PathElem -> Validation (NonEmpty VE) a
missingPathElem ([PathElem] -> [PathElem]
forall a. [a] -> [a]
reverse [PathElem]
path) (Int -> PathElem
Idx Int
i)) ([PathElem]
-> Value Value
-> Value
-> Validation (NonEmpty VE) (HashMap Text Value)
go (Int -> PathElem
Idx Int
i PathElem -> [PathElem] -> [PathElem]
forall a. a -> [a] -> [a]
: [PathElem]
path) Value Value
v) (Array
arr Array -> Int -> Maybe Value
forall a. Vector a -> Int -> Maybe a
Vector.!? Int
i))
            Vector (Value Value)
knownValues
      (Array Box (Vector (Value Value))
_, Value
_) -> do
        Validation (NonEmpty VE) Any
forall a. Validation (NonEmpty VE) a
mismatched
        pure HashMap Text Value
forall a. Monoid a => a
mempty
      (ArrayUO Box (Vector (Value Value))
box, Aeson.Array Array
arr) ->
        Validation (NonEmpty VE) (HashMap Text Value)
-> [PathElem]
-> Box (Vector (Value Value))
-> Array
-> Validation (NonEmpty VE) (HashMap Text Value)
matchArrayUO Validation (NonEmpty VE) (HashMap Text Value)
forall a. Validation (NonEmpty VE) a
mismatched [PathElem]
path Box (Vector (Value Value))
box Array
arr
      (ArrayUO Box (Vector (Value Value))
_, Value
_) -> do
        Validation (NonEmpty VE) Any
forall a. Validation (NonEmpty VE) a
mismatched
        pure HashMap Text Value
forall a. Monoid a => a
mempty
      (Object Box {HashMap Text (Value Value)
knownValues :: HashMap Text (Value Value)
knownValues :: forall a. Box a -> a
knownValues, Bool
extendable :: Bool
extendable :: forall a. Box a -> Bool
extendable}, Aeson.Object (Object -> HashMap Text Value
forall v. KeyMap v -> HashMap Text v
Aeson.toHashMapText -> HashMap Text Value
o)) ->
        let fold :: (t -> t -> f (HashMap k v)) -> HashMap t t -> f (HashMap k v)
fold t -> t -> f (HashMap k v)
f =
              (t -> t -> f (HashMap k v) -> f (HashMap k v))
-> f (HashMap k v) -> HashMap t t -> f (HashMap k v)
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HashMap.foldrWithKey (\t
k t
v f (HashMap k v)
a -> (HashMap k v -> HashMap k v -> HashMap k v)
-> f (HashMap k v) -> f (HashMap k v) -> f (HashMap k v)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 HashMap k v -> HashMap k v -> HashMap k v
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HashMap.union f (HashMap k v)
a (t -> t -> f (HashMap k v)
f t
k t
v)) (HashMap k v -> f (HashMap k v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMap k v
forall a. Monoid a => a
mempty)
            extraValues :: HashMap Text Value
extraValues =
              HashMap Text Value
-> HashMap Text (Value Value) -> HashMap Text Value
forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
HashMap.difference HashMap Text Value
o HashMap Text (Value Value)
knownValues
        in
          Bool -> Validation (NonEmpty VE) () -> Validation (NonEmpty VE) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
            (Bool
extendable Bool -> Bool -> Bool
|| HashMap Text Value -> Bool
forall k v. HashMap k v -> Bool
HashMap.null HashMap Text Value
extraValues)
            ([PathElem] -> HashMap Text Value -> Validation (NonEmpty VE) ()
forall a.
[PathElem] -> HashMap Text Value -> Validation (NonEmpty VE) a
extraObjectValues ([PathElem] -> [PathElem]
forall a. [a] -> [a]
reverse [PathElem]
path) HashMap Text Value
extraValues) Validation (NonEmpty VE) ()
-> Validation (NonEmpty VE) (HashMap Text Value)
-> Validation (NonEmpty VE) (HashMap Text Value)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
          (Text
 -> Value Value -> Validation (NonEmpty VE) (HashMap Text Value))
-> HashMap Text (Value Value)
-> Validation (NonEmpty VE) (HashMap Text Value)
forall (f :: * -> *) k t t v.
(Applicative f, Hashable k) =>
(t -> t -> f (HashMap k v)) -> HashMap t t -> f (HashMap k v)
fold
            (\Text
k Value Value
v -> Validation (NonEmpty VE) (HashMap Text Value)
-> (Value -> Validation (NonEmpty VE) (HashMap Text Value))
-> Maybe Value
-> Validation (NonEmpty VE) (HashMap Text Value)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([PathElem]
-> PathElem -> Validation (NonEmpty VE) (HashMap Text Value)
forall a. [PathElem] -> PathElem -> Validation (NonEmpty VE) a
missingPathElem ([PathElem] -> [PathElem]
forall a. [a] -> [a]
reverse [PathElem]
path) (Text -> PathElem
Key Text
k)) ([PathElem]
-> Value Value
-> Value
-> Validation (NonEmpty VE) (HashMap Text Value)
go (Text -> PathElem
Key Text
k PathElem -> [PathElem] -> [PathElem]
forall a. a -> [a] -> [a]
: [PathElem]
path) Value Value
v) (Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
k HashMap Text Value
o))
            HashMap Text (Value Value)
knownValues
      (Object Box (HashMap Text (Value Value))
_, Value
_) -> do
        Validation (NonEmpty VE) Any
forall a. Validation (NonEmpty VE) a
mismatched
        pure HashMap Text Value
forall a. Monoid a => a
mempty
      (Ext Value
val, Value
val') -> do
        Bool -> Validation (NonEmpty VE) () -> Validation (NonEmpty VE) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Value
val Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
val') Validation (NonEmpty VE) ()
forall a. Validation (NonEmpty VE) a
mismatched
        pure HashMap Text Value
forall a. Monoid a => a
mempty

holeTypeMatch :: TypeSig -> Aeson.Value -> Bool
holeTypeMatch :: TypeSig -> Value -> Bool
holeTypeMatch TypeSig
type_ Value
val =
  case (TypeSig
type_, Value
val) of
    (TypeSig {nullable :: TypeSig -> Nullable
nullable = Nullable
Nullable}, Value
Aeson.Null) -> Bool
True
    (TypeSig {type_ :: TypeSig -> Type
type_ = Type
BoolT} , Aeson.Bool {}) -> Bool
True
    (TypeSig {type_ :: TypeSig -> Type
type_ = Type
NumberT} , Aeson.Number {}) -> Bool
True
    (TypeSig {type_ :: TypeSig -> Type
type_ = Type
StringT} , Aeson.String {}) -> Bool
True
    (TypeSig {type_ :: TypeSig -> Type
type_ = Type
ArrayT} , Aeson.Array {}) -> Bool
True
    (TypeSig {type_ :: TypeSig -> Type
type_ = Type
ObjectT} , Aeson.Object {}) -> Bool
True
    (TypeSig
_, Value
_) -> Bool
False

matchArrayUO
  :: Validation (NonEmpty VE) (HashMap Text Aeson.Value)
  -> Path
  -> Box (Vector (Value Aeson.Value))
  -> Vector Aeson.Value
  -> Validation (NonEmpty VE) (HashMap Text Aeson.Value)
matchArrayUO :: Validation (NonEmpty VE) (HashMap Text Value)
-> [PathElem]
-> Box (Vector (Value Value))
-> Array
-> Validation (NonEmpty VE) (HashMap Text Value)
matchArrayUO Validation (NonEmpty VE) (HashMap Text Value)
mismatched [PathElem]
path Box {Vector (Value Value)
knownValues :: Vector (Value Value)
knownValues :: forall a. Box a -> a
knownValues, Bool
extendable :: Bool
extendable :: forall a. Box a -> Bool
extendable} Array
xs = do
  -- Collect possible indices in `xs` for each position in `knownValues`.
  let indices :: [[(Int, HashMap Text Value)]]
indices = (Value Value -> [(Int, HashMap Text Value)])
-> [Value Value] -> [[(Int, HashMap Text Value)]]
forall a b. (a -> b) -> [a] -> [b]
map ([Value] -> Value Value -> [(Int, HashMap Text Value)]
collectMatchingIndices (Array -> [Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
xs)) (Vector (Value Value) -> [Value Value]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Vector (Value Value)
knownValues)
  -- Find all unique valid ways to map each position in `knownValues` to
  -- a member of `xs`.
  case [[(Int, HashMap Text Value)]] -> [[(Int, HashMap Text Value)]]
allIndicesAssignments [[(Int, HashMap Text Value)]]
indices of
    -- If no assignment has been found, we give up.
    [] ->
      Validation (NonEmpty VE) (HashMap Text Value)
mismatched
    [(Int, HashMap Text Value)]
ivs : [[(Int, HashMap Text Value)]]
_
      -- If some positions in `knownValues` cannot be mapped to
      -- anything in `xs`, we give up.
      | [(Int, HashMap Text Value)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, HashMap Text Value)]
ivs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Vector (Value Value) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Vector (Value Value)
knownValues ->
        Validation (NonEmpty VE) (HashMap Text Value)
mismatched
      -- If there are some members of `xs` that aren't matched by
      -- anything in `knownValues`, we check if the pattern is
      -- extendable.
      | [(Int, HashMap Text Value)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, HashMap Text Value)]
ivs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Array -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Array
xs Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
extendable -> do
        let is :: Set Int
is = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList (((Int, HashMap Text Value) -> Int)
-> [(Int, HashMap Text Value)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, HashMap Text Value) -> Int
forall a b. (a, b) -> a
fst [(Int, HashMap Text Value)]
ivs)
            extraValues :: Array
extraValues = (Int -> Value -> Bool) -> Array -> Array
forall a. (Int -> a -> Bool) -> Vector a -> Vector a
Vector.ifilter (\Int
i Value
_ -> Bool -> Bool
not (Int
i Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
is)) Array
xs
        [PathElem]
-> Array -> Validation (NonEmpty VE) (HashMap Text Value)
forall a. [PathElem] -> Array -> Validation (NonEmpty VE) a
extraArrayValues ([PathElem] -> [PathElem]
forall a. [a] -> [a]
reverse [PathElem]
path) Array
extraValues
      | Bool
otherwise ->
        HashMap Text Value -> Validation (NonEmpty VE) (HashMap Text Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((Int, HashMap Text Value) -> HashMap Text Value)
-> [(Int, HashMap Text Value)] -> HashMap Text Value
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Int, HashMap Text Value) -> HashMap Text Value
forall a b. (a, b) -> b
snd [(Int, HashMap Text Value)]
ivs)
 where
  collectMatchingIndices :: [Value] -> Value Value -> [(Int, HashMap Text Value)]
collectMatchingIndices [Value]
is Value Value
knownValue =
    (Int -> Value -> Maybe (Int, HashMap Text Value))
-> [Value] -> [(Int, HashMap Text Value)]
forall a b. (Int -> a -> Maybe b) -> [a] -> [b]
imapMaybe Int -> Value -> Maybe (Int, HashMap Text Value)
forall a. a -> Value -> Maybe (a, HashMap Text Value)
matchingIndex [Value]
is
   where
    matchingIndex :: a -> Value -> Maybe (a, HashMap Text Value)
matchingIndex a
i Value
x =
      case Value Value
-> Value -> Validation (NonEmpty VE) (HashMap Text Value)
match Value Value
knownValue Value
x of
        Success HashMap Text Value
vs ->
          (a, HashMap Text Value) -> Maybe (a, HashMap Text Value)
forall a. a -> Maybe a
Just (a
i, HashMap Text Value
vs)
        Failure NonEmpty VE
_ ->
          Maybe (a, HashMap Text Value)
forall a. Maybe a
Nothing
  allIndicesAssignments :: [[(Int, HashMap Text Value)]] -> [[(Int, HashMap Text Value)]]
allIndicesAssignments = ([I] -> [(Int, HashMap Text Value)])
-> [[I]] -> [[(Int, HashMap Text Value)]]
forall a b. (a -> b) -> [a] -> [b]
map ((I -> (Int, HashMap Text Value))
-> [I] -> [(Int, HashMap Text Value)]
forall a b. (a -> b) -> [a] -> [b]
map I -> (Int, HashMap Text Value)
unI) ([[I]] -> [[(Int, HashMap Text Value)]])
-> ([[(Int, HashMap Text Value)]] -> [[I]])
-> [[(Int, HashMap Text Value)]]
-> [[(Int, HashMap Text Value)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[I]] -> [[I]]
cleanUp ([[I]] -> [[I]])
-> ([[(Int, HashMap Text Value)]] -> [[I]])
-> [[(Int, HashMap Text Value)]]
-> [[I]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Int -> [[(Int, HashMap Text Value)]] -> [[I]]
go Set Int
forall a. Set a
Set.empty
   where
    go :: Set Int -> [[(Int, HashMap Text Value)]] -> [[I]]
go Set Int
_ [] = [[]]
    go Set Int
known ([(Int, HashMap Text Value)]
is : [[(Int, HashMap Text Value)]]
iss) = do
      (Int
i, HashMap Text Value
vs) <- [(Int, HashMap Text Value)]
is
      [[I]] -> [[I]] -> Bool -> [[I]]
forall a. a -> a -> Bool -> a
bool (([I] -> [I]) -> [[I]] -> [[I]]
forall a b. (a -> b) -> [a] -> [b]
map ((Int, HashMap Text Value) -> I
I (Int
i, HashMap Text Value
vs) I -> [I] -> [I]
forall a. a -> [a] -> [a]
:) (Set Int -> [[(Int, HashMap Text Value)]] -> [[I]]
go (Int -> Set Int -> Set Int
forall a. Ord a => a -> Set a -> Set a
Set.insert Int
i Set Int
known) [[(Int, HashMap Text Value)]]
iss)) [] (Int
i Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
known)
    cleanUp :: [[I]] -> [[I]]
cleanUp =
      Set [I] -> [[I]]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set [I] -> [[I]]) -> ([[I]] -> Set [I]) -> [[I]] -> [[I]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[I]] -> Set [I]
forall a. Ord a => [a] -> Set a
Set.fromList ([[I]] -> Set [I]) -> ([[I]] -> [[I]]) -> [[I]] -> Set [I]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([I] -> [I]) -> [[I]] -> [[I]]
forall a b. (a -> b) -> [a] -> [b]
map (Set I -> [I]
forall a. Set a -> [a]
Set.toAscList (Set I -> [I]) -> ([I] -> Set I) -> [I] -> [I]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [I] -> Set I
forall a. Ord a => [a] -> Set a
Set.fromList)

newtype I = I { I -> (Int, HashMap Text Value)
unI :: (Int, HashMap Text Aeson.Value) }

instance Eq I where
  I (Int
a, HashMap Text Value
_) == :: I -> I -> Bool
== I (Int
b, HashMap Text Value
_) =
    Int
a Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
b

instance Ord I where
  I (Int
a, HashMap Text Value
_) compare :: I -> I -> Ordering
`compare` I (Int
b, HashMap Text Value
_) =
    Int
a Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` Int
b

mismatch :: Path -> Value Aeson.Value -> Aeson.Value -> Validation (NonEmpty VE) a
mismatch :: [PathElem] -> Value Value -> Value -> Validation (NonEmpty VE) a
mismatch [PathElem]
path Value Value
matcher Value
given =
  VE -> Validation (NonEmpty VE) a
forall e a. e -> Validation (NonEmpty e) a
throwE (Mismatch -> VE
Mismatch MkMismatch :: [PathElem] -> Value Value -> Value -> Mismatch
MkMismatch {[PathElem]
Value
Value Value
$sel:given:MkMismatch :: Value
$sel:matcher:MkMismatch :: Value Value
$sel:path:MkMismatch :: [PathElem]
given :: Value
matcher :: Value Value
path :: [PathElem]
..})

missingPathElem :: Path -> PathElem -> Validation (NonEmpty VE) a
missingPathElem :: [PathElem] -> PathElem -> Validation (NonEmpty VE) a
missingPathElem [PathElem]
path PathElem
missing =
  VE -> Validation (NonEmpty VE) a
forall e a. e -> Validation (NonEmpty e) a
throwE (MissingPathElem -> VE
MissingPathElem MkMissingPathElem :: [PathElem] -> PathElem -> MissingPathElem
MkMissingPathElem {[PathElem]
PathElem
$sel:missing:MkMissingPathElem :: PathElem
$sel:path:MkMissingPathElem :: [PathElem]
missing :: PathElem
path :: [PathElem]
..})

extraArrayValues :: Path -> Vector Aeson.Value -> Validation (NonEmpty VE) a
extraArrayValues :: [PathElem] -> Array -> Validation (NonEmpty VE) a
extraArrayValues [PathElem]
path Array
values =
  VE -> Validation (NonEmpty VE) a
forall e a. e -> Validation (NonEmpty e) a
throwE (ExtraArrayValues -> VE
ExtraArrayValues MkExtraArrayValues :: [PathElem] -> Array -> ExtraArrayValues
MkExtraArrayValues {[PathElem]
Array
$sel:values:MkExtraArrayValues :: Array
$sel:path:MkExtraArrayValues :: [PathElem]
values :: Array
path :: [PathElem]
..})

extraObjectValues :: Path -> HashMap Text Aeson.Value -> Validation (NonEmpty VE) a
extraObjectValues :: [PathElem] -> HashMap Text Value -> Validation (NonEmpty VE) a
extraObjectValues [PathElem]
path HashMap Text Value
values =
  VE -> Validation (NonEmpty VE) a
forall e a. e -> Validation (NonEmpty e) a
throwE (ExtraObjectValues -> VE
ExtraObjectValues MkExtraObjectValues :: [PathElem] -> HashMap Text Value -> ExtraObjectValues
MkExtraObjectValues {[PathElem]
HashMap Text Value
$sel:values:MkExtraObjectValues :: HashMap Text Value
$sel:path:MkExtraObjectValues :: [PathElem]
values :: HashMap Text Value
path :: [PathElem]
..})

throwE :: e -> Validation (NonEmpty e) a
throwE :: e -> Validation (NonEmpty e) a
throwE =
  Either (NonEmpty e) a -> Validation (NonEmpty e) a
forall e a. Either e a -> Validation e a
eitherToValidation (Either (NonEmpty e) a -> Validation (NonEmpty e) a)
-> (e -> Either (NonEmpty e) a) -> e -> Validation (NonEmpty e) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty e -> Either (NonEmpty e) a
forall a b. a -> Either a b
Left (NonEmpty e -> Either (NonEmpty e) a)
-> (e -> NonEmpty e) -> e -> Either (NonEmpty e) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> NonEmpty e
forall (f :: * -> *) a. Applicative f => a -> f a
pure

data VE
  = Mismatch Mismatch
  | MissingPathElem MissingPathElem
  | ExtraArrayValues ExtraArrayValues
  | ExtraObjectValues ExtraObjectValues
    deriving (Int -> VE -> ShowS
[VE] -> ShowS
VE -> String
(Int -> VE -> ShowS)
-> (VE -> String) -> ([VE] -> ShowS) -> Show VE
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VE] -> ShowS
$cshowList :: [VE] -> ShowS
show :: VE -> String
$cshow :: VE -> String
showsPrec :: Int -> VE -> ShowS
$cshowsPrec :: Int -> VE -> ShowS
Show, VE -> VE -> Bool
(VE -> VE -> Bool) -> (VE -> VE -> Bool) -> Eq VE
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VE -> VE -> Bool
$c/= :: VE -> VE -> Bool
== :: VE -> VE -> Bool
$c== :: VE -> VE -> Bool
Eq)

instance Aeson.ToJSON VE where
  toJSON :: VE -> Value
toJSON =
    [Pair] -> Value
Aeson.object ([Pair] -> Value) -> (VE -> [Pair]) -> VE -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      Mismatch Mismatch
v ->
        [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"mismatch" :: Text)
        , Key
"value" Key -> Mismatch -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Mismatch
v
        ]
      MissingPathElem MissingPathElem
v ->
        [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"missing-path-elem" :: Text)
        , Key
"value" Key -> MissingPathElem -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= MissingPathElem
v
        ]
      ExtraArrayValues ExtraArrayValues
v ->
        [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"extra-array-values" :: Text)
        , Key
"value" Key -> ExtraArrayValues -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ExtraArrayValues
v
        ]
      ExtraObjectValues ExtraObjectValues
v ->
        [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"extra-object-values" :: Text)
        , Key
"value" Key -> ExtraObjectValues -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ExtraObjectValues
v
        ]

data MissingPathElem = MkMissingPathElem
  { MissingPathElem -> [PathElem]
path :: Path
  , MissingPathElem -> PathElem
missing :: PathElem
  } deriving (Int -> MissingPathElem -> ShowS
[MissingPathElem] -> ShowS
MissingPathElem -> String
(Int -> MissingPathElem -> ShowS)
-> (MissingPathElem -> String)
-> ([MissingPathElem] -> ShowS)
-> Show MissingPathElem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MissingPathElem] -> ShowS
$cshowList :: [MissingPathElem] -> ShowS
show :: MissingPathElem -> String
$cshow :: MissingPathElem -> String
showsPrec :: Int -> MissingPathElem -> ShowS
$cshowsPrec :: Int -> MissingPathElem -> ShowS
Show, MissingPathElem -> MissingPathElem -> Bool
(MissingPathElem -> MissingPathElem -> Bool)
-> (MissingPathElem -> MissingPathElem -> Bool)
-> Eq MissingPathElem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MissingPathElem -> MissingPathElem -> Bool
$c/= :: MissingPathElem -> MissingPathElem -> Bool
== :: MissingPathElem -> MissingPathElem -> Bool
$c== :: MissingPathElem -> MissingPathElem -> Bool
Eq)

instance Aeson.ToJSON MissingPathElem where
  toJSON :: MissingPathElem -> Value
toJSON MkMissingPathElem {[PathElem]
PathElem
missing :: PathElem
path :: [PathElem]
$sel:missing:MkMissingPathElem :: MissingPathElem -> PathElem
$sel:path:MkMissingPathElem :: MissingPathElem -> [PathElem]
..} =
    [Pair] -> Value
Aeson.object
      [ Key
"path" Key -> [PathElem] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [PathElem]
path
      , Key
"missing" Key -> PathElem -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= PathElem
missing
      ]

data Mismatch = MkMismatch
  { Mismatch -> [PathElem]
path :: Path
  , Mismatch -> Value Value
matcher :: Value Aeson.Value
  , Mismatch -> Value
given :: Aeson.Value
  } deriving (Int -> Mismatch -> ShowS
[Mismatch] -> ShowS
Mismatch -> String
(Int -> Mismatch -> ShowS)
-> (Mismatch -> String) -> ([Mismatch] -> ShowS) -> Show Mismatch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mismatch] -> ShowS
$cshowList :: [Mismatch] -> ShowS
show :: Mismatch -> String
$cshow :: Mismatch -> String
showsPrec :: Int -> Mismatch -> ShowS
$cshowsPrec :: Int -> Mismatch -> ShowS
Show, Mismatch -> Mismatch -> Bool
(Mismatch -> Mismatch -> Bool)
-> (Mismatch -> Mismatch -> Bool) -> Eq Mismatch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mismatch -> Mismatch -> Bool
$c/= :: Mismatch -> Mismatch -> Bool
== :: Mismatch -> Mismatch -> Bool
$c== :: Mismatch -> Mismatch -> Bool
Eq)

instance Aeson.ToJSON Mismatch where
  toJSON :: Mismatch -> Value
toJSON MkMismatch {[PathElem]
Value
Value Value
given :: Value
matcher :: Value Value
path :: [PathElem]
$sel:given:MkMismatch :: Mismatch -> Value
$sel:matcher:MkMismatch :: Mismatch -> Value Value
$sel:path:MkMismatch :: Mismatch -> [PathElem]
..} =
    [Pair] -> Value
Aeson.object
      [ Key
"path" Key -> [PathElem] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [PathElem]
path
      , Key
"matcher" Key -> Value Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value Value
matcher
      , Key
"given" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
given
      ]

data ExtraArrayValues = MkExtraArrayValues
  { ExtraArrayValues -> [PathElem]
path :: Path
  , ExtraArrayValues -> Array
values :: Vector Aeson.Value
  } deriving (Int -> ExtraArrayValues -> ShowS
[ExtraArrayValues] -> ShowS
ExtraArrayValues -> String
(Int -> ExtraArrayValues -> ShowS)
-> (ExtraArrayValues -> String)
-> ([ExtraArrayValues] -> ShowS)
-> Show ExtraArrayValues
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExtraArrayValues] -> ShowS
$cshowList :: [ExtraArrayValues] -> ShowS
show :: ExtraArrayValues -> String
$cshow :: ExtraArrayValues -> String
showsPrec :: Int -> ExtraArrayValues -> ShowS
$cshowsPrec :: Int -> ExtraArrayValues -> ShowS
Show, ExtraArrayValues -> ExtraArrayValues -> Bool
(ExtraArrayValues -> ExtraArrayValues -> Bool)
-> (ExtraArrayValues -> ExtraArrayValues -> Bool)
-> Eq ExtraArrayValues
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExtraArrayValues -> ExtraArrayValues -> Bool
$c/= :: ExtraArrayValues -> ExtraArrayValues -> Bool
== :: ExtraArrayValues -> ExtraArrayValues -> Bool
$c== :: ExtraArrayValues -> ExtraArrayValues -> Bool
Eq)

instance Aeson.ToJSON ExtraArrayValues where
  toJSON :: ExtraArrayValues -> Value
toJSON MkExtraArrayValues {[PathElem]
Array
values :: Array
path :: [PathElem]
$sel:values:MkExtraArrayValues :: ExtraArrayValues -> Array
$sel:path:MkExtraArrayValues :: ExtraArrayValues -> [PathElem]
..} =
    [Pair] -> Value
Aeson.object
      [ Key
"path" Key -> [PathElem] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [PathElem]
path
      , Key
"values" Key -> Array -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Array
values
      ]

data ExtraObjectValues = MkExtraObjectValues
  { ExtraObjectValues -> [PathElem]
path :: Path
  , ExtraObjectValues -> HashMap Text Value
values :: HashMap Text Aeson.Value
  } deriving (Int -> ExtraObjectValues -> ShowS
[ExtraObjectValues] -> ShowS
ExtraObjectValues -> String
(Int -> ExtraObjectValues -> ShowS)
-> (ExtraObjectValues -> String)
-> ([ExtraObjectValues] -> ShowS)
-> Show ExtraObjectValues
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExtraObjectValues] -> ShowS
$cshowList :: [ExtraObjectValues] -> ShowS
show :: ExtraObjectValues -> String
$cshow :: ExtraObjectValues -> String
showsPrec :: Int -> ExtraObjectValues -> ShowS
$cshowsPrec :: Int -> ExtraObjectValues -> ShowS
Show, ExtraObjectValues -> ExtraObjectValues -> Bool
(ExtraObjectValues -> ExtraObjectValues -> Bool)
-> (ExtraObjectValues -> ExtraObjectValues -> Bool)
-> Eq ExtraObjectValues
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExtraObjectValues -> ExtraObjectValues -> Bool
$c/= :: ExtraObjectValues -> ExtraObjectValues -> Bool
== :: ExtraObjectValues -> ExtraObjectValues -> Bool
$c== :: ExtraObjectValues -> ExtraObjectValues -> Bool
Eq)

instance Aeson.ToJSON ExtraObjectValues where
  toJSON :: ExtraObjectValues -> Value
toJSON MkExtraObjectValues {[PathElem]
HashMap Text Value
values :: HashMap Text Value
path :: [PathElem]
$sel:values:MkExtraObjectValues :: ExtraObjectValues -> HashMap Text Value
$sel:path:MkExtraObjectValues :: ExtraObjectValues -> [PathElem]
..} =
    [Pair] -> Value
Aeson.object
      [ Key
"path" Key -> [PathElem] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [PathElem]
path
      , Key
"values" Key -> HashMap Text Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HashMap Text Value
values
      ]

type Path = [PathElem]

data PathElem
  = Key Text
  | Idx Int
    deriving (Int -> PathElem -> ShowS
[PathElem] -> ShowS
PathElem -> String
(Int -> PathElem -> ShowS)
-> (PathElem -> String) -> ([PathElem] -> ShowS) -> Show PathElem
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PathElem] -> ShowS
$cshowList :: [PathElem] -> ShowS
show :: PathElem -> String
$cshow :: PathElem -> String
showsPrec :: Int -> PathElem -> ShowS
$cshowsPrec :: Int -> PathElem -> ShowS
Show, PathElem -> PathElem -> Bool
(PathElem -> PathElem -> Bool)
-> (PathElem -> PathElem -> Bool) -> Eq PathElem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PathElem -> PathElem -> Bool
$c/= :: PathElem -> PathElem -> Bool
== :: PathElem -> PathElem -> Bool
$c== :: PathElem -> PathElem -> Bool
Eq)

instance Aeson.ToJSON PathElem where
  toJSON :: PathElem -> Value
toJSON = \case
    Key Text
k ->
      Text -> Value
Aeson.String Text
k
    Idx Int
i ->
      Scientific -> Value
Aeson.Number (Int -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)

instance IsString PathElem where
  fromString :: String -> PathElem
fromString =
    Text -> PathElem
Key (Text -> PathElem) -> (String -> Text) -> String -> PathElem
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString

imapMaybe :: (Int -> a -> Maybe b) -> [a] -> [b]
imapMaybe :: (Int -> a -> Maybe b) -> [a] -> [b]
imapMaybe Int -> a -> Maybe b
f =
  ((Int, a) -> Maybe b) -> [(Int, a)] -> [b]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Int -> a -> Maybe b) -> (Int, a) -> Maybe b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> a -> Maybe b
f) ([(Int, a)] -> [b]) -> ([a] -> [(Int, a)]) -> [a] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..]