{-# LANGUAGE CPP #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Aeson.Match.QQ.Internal.Match
  ( match
  , Error(..)
  , Mismatch(..)
  , MissingPathElem(..)
  , ExtraArrayValues(..)
  , ExtraObjectValues(..)
  , Path(..)
  , PathElem(..)
  ) where

import           Control.Applicative (liftA2)
import           Control.Monad (unless)
import           Data.Aeson ((.=))
import qualified Data.Aeson as Aeson
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as Aeson (toHashMapText)
#endif
import           Data.Bool (bool)
import qualified Data.ByteString.Lazy.Char8 as ByteString.Lazy
import qualified Data.CaseInsensitive as CI
import           Data.Either.Validation
  ( Validation(..)
  , eitherToValidation
  , validationToEither
  )
import           Data.Foldable (for_, toList)
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.List as List
import           Data.List.NonEmpty (NonEmpty)
import           Data.Maybe (mapMaybe)
import qualified Data.Set as Set
import           Data.String (IsString(..))
import           Data.Text (Text)
import qualified Data.Text as Text
import           Data.Vector (Vector)
import qualified Data.Vector as Vector
import           GHC.Exts (IsList)
import           Prelude hiding (any, null)
import qualified Text.PrettyPrint as PP
  ( Doc
  , vcat
  , hsep
  , brackets
  , text
  , char
  , int
  )
import qualified Text.PrettyPrint.HughesPJClass as PP (Pretty(..))

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


-- | Test if a matcher matches a 'Aeson.Value'.
match
  :: Value Aeson.Value
     -- ^ A matcher
  -> Aeson.Value
     -- ^ A 'Value' from aeson
  -> Either (NonEmpty Error) (HashMap Text Aeson.Value)
     -- ^ Either a non-empty list of errors, or a mapping
     -- from _holes to their values.
match :: Value Value
-> Value -> Either (NonEmpty Error) (HashMap Text Value)
match Value Value
matcher0 Value
given0 =
  forall e a. Validation e a -> Either e a
validationToEither ([PathElem]
-> Value Value
-> Value
-> Validation (NonEmpty Error) (HashMap Text Value)
go [] Value Value
matcher0 Value
given0)
 where
  go :: [PathElem]
-> Value Value
-> Value
-> Validation (NonEmpty Error) (HashMap Text Value)
go [PathElem]
path Value Value
matcher Value
given = do
    let mismatched :: Validation (NonEmpty Error) a
mismatched = forall a.
[PathElem] -> Value Value -> Value -> Validation (NonEmpty Error) a
mismatch [PathElem]
path Value Value
matcher Value
given
        mistyped :: Validation (NonEmpty Error) a
mistyped = forall a.
[PathElem] -> Value Value -> Value -> Validation (NonEmpty Error) a
mistype [PathElem]
path Value Value
matcher Value
given
    case (Value Value
matcher, Value
given) of
      (Any Maybe TypeSig
holeTypeO Maybe Text
nameO, Value
val) -> do
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe TypeSig
holeTypeO forall a b. (a -> b) -> a -> b
$ \TypeSig
holeType ->
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TypeSig -> Value -> Bool
holeTypeMatch TypeSig
holeType Value
val)
            forall {a}. Validation (NonEmpty Error) a
mistyped
        pure (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (\Text
name -> 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) ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
      (Value Value
Null, Value
_) -> do
        forall {a}. Validation (NonEmpty Error) a
mistyped
        pure forall a. Monoid a => a
mempty
      (Bool Bool
b, Aeson.Bool Bool
b') -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
b forall a. Eq a => a -> a -> Bool
== Bool
b') forall {a}. Validation (NonEmpty Error) a
mismatched
        pure forall a. Monoid a => a
mempty
      (Bool Bool
_, Value
_) -> do
        forall {a}. Validation (NonEmpty Error) a
mistyped
        pure forall a. Monoid a => a
mempty
      (Number Scientific
n, Aeson.Number Scientific
n') -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Scientific
n forall a. Eq a => a -> a -> Bool
== Scientific
n') forall {a}. Validation (NonEmpty Error) a
mismatched
        pure forall a. Monoid a => a
mempty
      (Number Scientific
_, Value
_) -> do
        forall {a}. Validation (NonEmpty Error) a
mistyped
        pure forall a. Monoid a => a
mempty
      (String Text
str, Aeson.String Text
str') -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Text
str forall a. Eq a => a -> a -> Bool
== Text
str') forall {a}. Validation (NonEmpty Error) a
mismatched
        pure forall a. Monoid a => a
mempty
      (String Text
_, Value
_) -> do
        forall {a}. Validation (NonEmpty Error) a
mistyped
        pure forall a. Monoid a => a
mempty
      (StringCI CI Text
str, Aeson.String Text
str') -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CI Text
str forall a. Eq a => a -> a -> Bool
== forall s. FoldCase s => s -> CI s
CI.mk Text
str') forall {a}. Validation (NonEmpty Error) a
mismatched
        pure forall a. Monoid a => a
mempty
      (StringCI CI Text
_, Value
_) -> do
        forall {a}. Validation (NonEmpty Error) a
mistyped
        pure 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 =
            forall a b. (Int -> a -> b -> b) -> b -> Vector a -> b
Vector.ifoldr (\Int
i t
v f (HashMap k v)
a -> forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 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)) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty)
          extraValues :: Array
extraValues =
            forall a. Int -> Vector a -> Vector a
Vector.drop (forall a. Vector a -> Int
Vector.length Vector (Value Value)
knownValues) Array
arr
        in
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
            (Bool
extendable Bool -> Bool -> Bool
|| forall a. Vector a -> Bool
Vector.null Array
extraValues)
            (forall a. [PathElem] -> Array -> Validation (NonEmpty Error) a
extraArrayValues [PathElem]
path Array
extraValues) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
          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 -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. [PathElem] -> PathElem -> Validation (NonEmpty Error) a
missingPathElem [PathElem]
path (Int -> PathElem
Idx Int
i)) ([PathElem]
-> Value Value
-> Value
-> Validation (NonEmpty Error) (HashMap Text Value)
go (Int -> PathElem
Idx Int
i forall a. a -> [a] -> [a]
: [PathElem]
path) Value Value
v) (Array
arr forall a. Vector a -> Int -> Maybe a
Vector.!? Int
i))
            Vector (Value Value)
knownValues
      (Array Box (Vector (Value Value))
_, Value
_) -> do
        forall {a}. Validation (NonEmpty Error) a
mistyped
        pure forall a. Monoid a => a
mempty
      (ArrayUO Box (Vector (Value Value))
box, Aeson.Array Array
arr) ->
        Validation (NonEmpty Error) (HashMap Text Value)
-> [PathElem]
-> Box (Vector (Value Value))
-> Array
-> Validation (NonEmpty Error) (HashMap Text Value)
matchArrayUO forall {a}. Validation (NonEmpty Error) a
mismatched [PathElem]
path Box (Vector (Value Value))
box Array
arr
      (ArrayUO Box (Vector (Value Value))
_, Value
_) -> do
        forall {a}. Validation (NonEmpty Error) a
mistyped
        pure 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}
#if MIN_VERSION_aeson(2,0,0)
        , Aeson.Object (forall v. KeyMap v -> HashMap Text v
Aeson.toHashMapText -> HashMap Text Value
o)
#else
        , Aeson.Object o
#endif

        ) ->
        let fold :: (t -> t -> f (HashMap k v)) -> HashMap t t -> f (HashMap k v)
fold t -> t -> f (HashMap k v)
f =
              forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HashMap.foldrWithKey (\t
k t
v f (HashMap k v)
a -> forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 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)) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty)
            extraValues :: HashMap Text Value
extraValues =
              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
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
            (Bool
extendable Bool -> Bool -> Bool
|| forall k v. HashMap k v -> Bool
HashMap.null HashMap Text Value
extraValues)
            (forall a.
[PathElem] -> HashMap Text Value -> Validation (NonEmpty Error) a
extraObjectValues [PathElem]
path HashMap Text Value
extraValues) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
          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 -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. [PathElem] -> PathElem -> Validation (NonEmpty Error) a
missingPathElem [PathElem]
path (Text -> PathElem
Key Text
k)) ([PathElem]
-> Value Value
-> Value
-> Validation (NonEmpty Error) (HashMap Text Value)
go (Text -> PathElem
Key Text
k forall a. a -> [a] -> [a]
: [PathElem]
path) Value Value
v) (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
        forall {a}. Validation (NonEmpty Error) a
mistyped
        pure forall a. Monoid a => a
mempty
      (Ext Value
val, Value
val') ->
        [PathElem]
-> Value Value
-> Value
-> Validation (NonEmpty Error) (HashMap Text Value)
go [PathElem]
path (forall ext. Value -> Value ext
embed Value
val) Value
val'

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
StringCIT} , Aeson.String {}) -> Bool
True
    (TypeSig {type_ :: TypeSig -> Type
type_ = Type
ArrayT} , Aeson.Array {}) -> Bool
True
    (TypeSig {type_ :: TypeSig -> Type
type_ = Type
ArrayUOT} , Aeson.Array {}) -> Bool
True
    (TypeSig {type_ :: TypeSig -> Type
type_ = Type
ObjectT} , Aeson.Object {}) -> Bool
True
    (TypeSig
_, Value
_) -> Bool
False

matchArrayUO
  :: Validation (NonEmpty Error) (HashMap Text Aeson.Value)
  -> [PathElem]
  -> Box (Vector (Value Aeson.Value))
  -> Vector Aeson.Value
  -> Validation (NonEmpty Error) (HashMap Text Aeson.Value)
matchArrayUO :: Validation (NonEmpty Error) (HashMap Text Value)
-> [PathElem]
-> Box (Vector (Value Value))
-> Array
-> Validation (NonEmpty Error) (HashMap Text Value)
matchArrayUO Validation (NonEmpty Error) (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 = forall a b. (a -> b) -> [a] -> [b]
map ([Value] -> Value Value -> [(Int, HashMap Text Value)]
collectMatchingIndices (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
xs)) (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 Error) (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.
      | forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, HashMap Text Value)]
ivs forall a. Ord a => a -> a -> Bool
< forall (t :: * -> *) a. Foldable t => t a -> Int
length Vector (Value Value)
knownValues ->
        Validation (NonEmpty Error) (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.
      | forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, HashMap Text Value)]
ivs forall a. Ord a => a -> a -> Bool
< 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 = forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Int, HashMap Text Value)]
ivs)
            extraValues :: Array
extraValues = forall a. (Int -> a -> Bool) -> Vector a -> Vector a
Vector.ifilter (\Int
i Value
_ -> Bool -> Bool
not (Int
i forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
is)) Array
xs
        forall a. [PathElem] -> Array -> Validation (NonEmpty Error) a
extraArrayValues [PathElem]
path Array
extraValues
      | Bool
otherwise ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap 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 =
    forall a b. (Int -> a -> Maybe b) -> [a] -> [b]
imapMaybe 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 -> Either (NonEmpty Error) (HashMap Text Value)
match Value Value
knownValue Value
x of
        Left NonEmpty Error
_ ->
          forall a. Maybe a
Nothing
        Right HashMap Text Value
vs ->
          forall a. a -> Maybe a
Just (a
i, HashMap Text Value
vs)
  allIndicesAssignments :: [[(Int, HashMap Text Value)]] -> [[(Int, HashMap Text Value)]]
allIndicesAssignments = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map I -> (Int, HashMap Text Value)
unI) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[I]] -> [[I]]
cleanUp forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Int -> [[(Int, HashMap Text Value)]] -> [[I]]
go 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
      forall a. a -> a -> Bool -> a
bool (forall a b. (a -> b) -> [a] -> [b]
map ((Int, HashMap Text Value) -> I
I (Int
i, HashMap Text Value
vs) forall a. a -> [a] -> [a]
:) (Set Int -> [[(Int, HashMap Text Value)]] -> [[I]]
go (forall a. Ord a => a -> Set a -> Set a
Set.insert Int
i Set Int
known) [[(Int, HashMap Text Value)]]
iss)) [] (Int
i forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
known)
    cleanUp :: [[I]] -> [[I]]
cleanUp =
      forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. Set a -> [a]
Set.toAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 forall a. Ord a => a -> a -> Ordering
`compare` Int
b

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

mistype
  :: [PathElem]
  -> Value Aeson.Value
  -> Aeson.Value
  -> Validation (NonEmpty Error) a
mistype :: forall a.
[PathElem] -> Value Value -> Value -> Validation (NonEmpty Error) a
mistype ([PathElem] -> Path
Path forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse -> Path
path) Value Value
matcher Value
given =
  forall e a. e -> Validation (NonEmpty e) a
throwE (Mismatch -> Error
Mistype MkMismatch {Value
Value Value
Path
given :: Value
matcher :: Value Value
path :: Path
$sel:given:MkMismatch :: Value
$sel:matcher:MkMismatch :: Value Value
$sel:path:MkMismatch :: Path
..})

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

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

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

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

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

instance PP.Pretty Error where
  pPrint :: Error -> Doc
pPrint = \case
    Mismatch Mismatch
err ->
      [Doc] -> Doc
PP.vcat
        [ Doc
"  error: value does not match"
        , forall a. Pretty a => a -> Doc
PP.pPrint Mismatch
err
        ]
    Mistype Mismatch
err ->
      [Doc] -> Doc
PP.vcat
        [ Doc
"  error: type of value does not match"
        , forall a. Pretty a => a -> Doc
PP.pPrint Mismatch
err
        ]
    MissingPathElem MissingPathElem
err ->
      [Doc] -> Doc
PP.vcat
        [ Doc
"  error: missing key or index"
        , forall a. Pretty a => a -> Doc
PP.pPrint MissingPathElem
err
        ]
    ExtraArrayValues ExtraArrayValues
err ->
      [Doc] -> Doc
PP.vcat
        [ Doc
"  error: extra array values"
        , forall a. Pretty a => a -> Doc
PP.pPrint ExtraArrayValues
err
        ]
    ExtraObjectValues ExtraObjectValues
err ->
      [Doc] -> Doc
PP.vcat
        [ Doc
"  error: extra object values"
        , forall a. Pretty a => a -> Doc
PP.pPrint ExtraObjectValues
err
        ]

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

data Mismatch = MkMismatch
  { Mismatch -> Path
path    :: Path
  , Mismatch -> Value Value
matcher :: Value Aeson.Value
  , Mismatch -> Value
given   :: Aeson.Value
  } deriving (Int -> Mismatch -> ShowS
[Mismatch] -> ShowS
Mismatch -> String
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
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 {Value
Value Value
Path
given :: Value
matcher :: Value Value
path :: Path
$sel:given:MkMismatch :: Mismatch -> Value
$sel:matcher:MkMismatch :: Mismatch -> Value Value
$sel:path:MkMismatch :: Mismatch -> Path
..} =
    [Pair] -> Value
Aeson.object
      [ Key
"path" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Path
path
      , Key
"matcher" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value Value
matcher
      , Key
"given" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
given
      ]

instance PP.Pretty Mismatch where
  pPrint :: Mismatch -> Doc
pPrint MkMismatch {Value
Value Value
Path
given :: Value
matcher :: Value Value
path :: Path
$sel:given:MkMismatch :: Mismatch -> Value
$sel:matcher:MkMismatch :: Mismatch -> Value Value
$sel:path:MkMismatch :: Mismatch -> Path
..} =
    [Doc] -> Doc
PP.vcat
      [ [Doc] -> Doc
PP.hsep [Doc
"   path:", forall a. Pretty a => a -> Doc
PP.pPrint Path
path]
      , [Doc] -> Doc
PP.hsep [Doc
"matcher:", forall a. ToJSON a => a -> Doc
ppJson Value Value
matcher]
      , [Doc] -> Doc
PP.hsep [Doc
"  given:", forall a. ToJSON a => a -> Doc
ppJson Value
given]
      ]

data MissingPathElem = MkMissingPathElem
  { MissingPathElem -> Path
path    :: Path
  , MissingPathElem -> PathElem
missing :: PathElem
  } deriving (Int -> MissingPathElem -> ShowS
[MissingPathElem] -> ShowS
MissingPathElem -> String
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
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
Path
missing :: PathElem
path :: Path
$sel:missing:MkMissingPathElem :: MissingPathElem -> PathElem
$sel:path:MkMissingPathElem :: MissingPathElem -> Path
..} =
    [Pair] -> Value
Aeson.object
      [ Key
"path" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Path
path
      , Key
"missing" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= PathElem
missing
      ]

instance PP.Pretty MissingPathElem where
  pPrint :: MissingPathElem -> Doc
pPrint (MkMissingPathElem {PathElem
Path
missing :: PathElem
path :: Path
$sel:missing:MkMissingPathElem :: MissingPathElem -> PathElem
$sel:path:MkMissingPathElem :: MissingPathElem -> Path
..}) =
    [Doc] -> Doc
PP.vcat
      [ [Doc] -> Doc
PP.hsep [Doc
"   path:", forall a. Pretty a => a -> Doc
PP.pPrint Path
path]
      , [Doc] -> Doc
PP.hsep [Doc
"missing:", forall a. Pretty a => a -> Doc
PP.pPrint PathElem
missing]
      ]

data ExtraArrayValues = MkExtraArrayValues
  { ExtraArrayValues -> Path
path   :: Path
  , ExtraArrayValues -> Array
values :: Vector Aeson.Value
  } deriving (Int -> ExtraArrayValues -> ShowS
[ExtraArrayValues] -> ShowS
ExtraArrayValues -> String
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
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 {Array
Path
values :: Array
path :: Path
$sel:values:MkExtraArrayValues :: ExtraArrayValues -> Array
$sel:path:MkExtraArrayValues :: ExtraArrayValues -> Path
..} =
    [Pair] -> Value
Aeson.object
      [ Key
"path" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Path
path
      , Key
"values" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Array
values
      ]

instance PP.Pretty ExtraArrayValues where
  pPrint :: ExtraArrayValues -> Doc
pPrint MkExtraArrayValues {Array
Path
values :: Array
path :: Path
$sel:values:MkExtraArrayValues :: ExtraArrayValues -> Array
$sel:path:MkExtraArrayValues :: ExtraArrayValues -> Path
..} =
    [Doc] -> Doc
PP.vcat
      [ [Doc] -> Doc
PP.hsep [Doc
"   path:", forall a. Pretty a => a -> Doc
PP.pPrint Path
path]
      , [Doc] -> Doc
PP.hsep
          [ Doc
" values:"
          , [Doc] -> Doc
PP.vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. ToJSON a => a -> Doc
ppJson (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Array
values))
          ]
      ]

data ExtraObjectValues = MkExtraObjectValues
  { ExtraObjectValues -> Path
path   :: Path
  , ExtraObjectValues -> HashMap Text Value
values :: HashMap Text Aeson.Value
  } deriving (Int -> ExtraObjectValues -> ShowS
[ExtraObjectValues] -> ShowS
ExtraObjectValues -> String
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
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 {HashMap Text Value
Path
values :: HashMap Text Value
path :: Path
$sel:values:MkExtraObjectValues :: ExtraObjectValues -> HashMap Text Value
$sel:path:MkExtraObjectValues :: ExtraObjectValues -> Path
..} =
    [Pair] -> Value
Aeson.object
      [ Key
"path" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Path
path
      , Key
"values" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HashMap Text Value
values
      ]

instance PP.Pretty ExtraObjectValues where
  pPrint :: ExtraObjectValues -> Doc
pPrint MkExtraObjectValues {HashMap Text Value
Path
values :: HashMap Text Value
path :: Path
$sel:values:MkExtraObjectValues :: ExtraObjectValues -> HashMap Text Value
$sel:path:MkExtraObjectValues :: ExtraObjectValues -> Path
..} =
    [Doc] -> Doc
PP.vcat
      [ [Doc] -> Doc
PP.hsep [Doc
"   path:", forall a. Pretty a => a -> Doc
PP.pPrint Path
path]
      , [Doc] -> Doc
PP.hsep
          [ Doc
" values:"
          , [Doc] -> Doc
PP.vcat ((forall a b. (a -> b) -> [a] -> [b]
map forall {a}. ToJSON a => (Text, a) -> Doc
prettyKV forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. HashMap k v -> [(k, v)]
HashMap.toList) HashMap Text Value
values)
          ]
      ]
   where
    prettyKV :: (Text, a) -> Doc
prettyKV (Text
k, a
v) =
      [Doc] -> Doc
PP.vcat
        [ [Doc] -> Doc
PP.hsep [Doc
"  key:", forall a. Pretty a => a -> Doc
PP.pPrint (Text -> PathElem
Key Text
k)]
        , [Doc] -> Doc
PP.hsep [Doc
"value:", forall a. ToJSON a => a -> Doc
ppJson a
v]
        ]

newtype Path = Path { Path -> [PathElem]
unPath :: [PathElem] }
    deriving (Int -> Path -> ShowS
[Path] -> ShowS
Path -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Path] -> ShowS
$cshowList :: [Path] -> ShowS
show :: Path -> String
$cshow :: Path -> String
showsPrec :: Int -> Path -> ShowS
$cshowsPrec :: Int -> Path -> ShowS
Show, Path -> Path -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Path -> Path -> Bool
$c/= :: Path -> Path -> Bool
== :: Path -> Path -> Bool
$c== :: Path -> Path -> Bool
Eq, Int -> [Item Path] -> Path
[Item Path] -> Path
Path -> [Item Path]
forall l.
([Item l] -> l)
-> (Int -> [Item l] -> l) -> (l -> [Item l]) -> IsList l
toList :: Path -> [Item Path]
$ctoList :: Path -> [Item Path]
fromListN :: Int -> [Item Path] -> Path
$cfromListN :: Int -> [Item Path] -> Path
fromList :: [Item Path] -> Path
$cfromList :: [Item Path] -> Path
IsList, [Path] -> Encoding
[Path] -> Value
Path -> Encoding
Path -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Path] -> Encoding
$ctoEncodingList :: [Path] -> Encoding
toJSONList :: [Path] -> Value
$ctoJSONList :: [Path] -> Value
toEncoding :: Path -> Encoding
$ctoEncoding :: Path -> Encoding
toJSON :: Path -> Value
$ctoJSON :: Path -> Value
Aeson.ToJSON)

instance PP.Pretty Path where
  pPrint :: Path -> Doc
pPrint =
    forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall a. Pretty a => a -> Doc
PP.pPrint forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path -> [PathElem]
unPath

data PathElem
  = Key Text
  | Idx Int
    deriving (Int -> PathElem -> ShowS
[PathElem] -> ShowS
PathElem -> String
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
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 IsString PathElem where
  fromString :: String -> PathElem
fromString =
    Text -> PathElem
Key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString

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 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)

instance PP.Pretty PathElem where
  pPrint :: PathElem -> Doc
pPrint = \case
    Key Text
k ->
      Char -> Doc
PP.char Char
'.' forall a. Semigroup a => a -> a -> a
<> String -> Doc
PP.text (Text -> String
Text.unpack Text
k)
    Idx Int
i ->
      Doc -> Doc
PP.brackets (Int -> Doc
PP.int Int
i)

ppJson :: Aeson.ToJSON a => a -> PP.Doc
ppJson :: forall a. ToJSON a => a -> Doc
ppJson =
  String -> Doc
PP.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
ByteString.Lazy.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
Aeson.encode

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