{-# 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
  ( Matcher(..)
  , Box(..)
  , HoleSig(..)
  , Type(..)
  , embed
  )


-- | Test if a 'Matcher' matches a 'Aeson.Value'.
match
  :: Matcher Aeson.Value
  -> Aeson.Value
  -> Either (NonEmpty Error) (HashMap Text Aeson.Value)
     -- ^ Either a non-empty list of errors, or a mapping
     -- from named _holes to their values.
match :: Matcher Value
-> Value -> Either (NonEmpty Error) (HashMap Text Value)
match Matcher Value
matcher0 Value
given0 =
  forall e a. Validation e a -> Either e a
validationToEither ([PathElem]
-> Matcher Value
-> Value
-> Validation (NonEmpty Error) (HashMap Text Value)
go [] Matcher Value
matcher0 Value
given0)
 where
  go :: [PathElem]
-> Matcher Value
-> Value
-> Validation (NonEmpty Error) (HashMap Text Value)
go [PathElem]
path Matcher Value
matcher Value
given = do
    let mismatched :: Validation (NonEmpty Error) a
mismatched = forall a.
[PathElem]
-> Matcher Value -> Value -> Validation (NonEmpty Error) a
mismatch [PathElem]
path Matcher Value
matcher Value
given
        mistyped :: Validation (NonEmpty Error) a
mistyped = forall a.
[PathElem]
-> Matcher Value -> Value -> Validation (NonEmpty Error) a
mistype [PathElem]
path Matcher Value
matcher Value
given
    case (Matcher Value
matcher, Value
given) of
      (Hole Maybe HoleSig
holeTypeO Maybe Text
nameO, Value
val) -> do
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe HoleSig
holeTypeO forall a b. (a -> b) -> a -> b
$ \HoleSig
holeType ->
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (HoleSig -> Value -> Bool
holeTypeMatch HoleSig
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)
      (Matcher Value
Null, Value
Aeson.Null) ->
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
      (Matcher 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 (Matcher Value)
values :: forall a. Box a -> a
values :: Vector (Matcher Value)
values, Bool
extra :: forall a. Box a -> Bool
extra :: Bool
extra}, 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 (Matcher Value)
values) Array
arr
        in
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
            (Bool
extra 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 Matcher 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]
-> Matcher Value
-> Value
-> Validation (NonEmpty Error) (HashMap Text Value)
go (Int -> PathElem
Idx Int
i forall a. a -> [a] -> [a]
: [PathElem]
path) Matcher Value
v) (Array
arr forall a. Vector a -> Int -> Maybe a
Vector.!? Int
i))
            Vector (Matcher Value)
values
      (Array Box (Vector (Matcher Value))
_, Value
_) -> do
        forall {a}. Validation (NonEmpty Error) a
mistyped
        pure forall a. Monoid a => a
mempty
      (ArrayUO Box (Vector (Matcher Value))
box, Aeson.Array Array
arr) ->
        Validation (NonEmpty Error) (HashMap Text Value)
-> [PathElem]
-> Box (Vector (Matcher Value))
-> Array
-> Validation (NonEmpty Error) (HashMap Text Value)
matchArrayUO forall {a}. Validation (NonEmpty Error) a
mismatched [PathElem]
path Box (Vector (Matcher Value))
box Array
arr
      (ArrayUO Box (Vector (Matcher Value))
_, Value
_) -> do
        forall {a}. Validation (NonEmpty Error) a
mistyped
        pure forall a. Monoid a => a
mempty
      ( Object Box {HashMap Text (Matcher Value)
values :: HashMap Text (Matcher Value)
values :: forall a. Box a -> a
values, Bool
extra :: Bool
extra :: forall a. Box a -> Bool
extra}
#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 (Matcher Value)
values
        in
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
            (Bool
extra 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 Matcher 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]
-> Matcher Value
-> Value
-> Validation (NonEmpty Error) (HashMap Text Value)
go (Text -> PathElem
Key Text
k forall a. a -> [a] -> [a]
: [PathElem]
path) Matcher 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 (Matcher Value)
values
      (Object Box (HashMap Text (Matcher Value))
_, Value
_) -> do
        forall {a}. Validation (NonEmpty Error) a
mistyped
        pure forall a. Monoid a => a
mempty
      (Ext Value
val, Value
val') ->
        [PathElem]
-> Matcher Value
-> Value
-> Validation (NonEmpty Error) (HashMap Text Value)
go [PathElem]
path (forall ext. Value -> Matcher ext
embed Value
val) Value
val'

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

matchArrayUO
  :: Validation (NonEmpty Error) (HashMap Text Aeson.Value)
  -> [PathElem]
  -> Box (Vector (Matcher Aeson.Value))
  -> Vector Aeson.Value
  -> Validation (NonEmpty Error) (HashMap Text Aeson.Value)
matchArrayUO :: Validation (NonEmpty Error) (HashMap Text Value)
-> [PathElem]
-> Box (Vector (Matcher Value))
-> Array
-> Validation (NonEmpty Error) (HashMap Text Value)
matchArrayUO Validation (NonEmpty Error) (HashMap Text Value)
mismatched [PathElem]
path Box {Vector (Matcher Value)
values :: Vector (Matcher Value)
values :: forall a. Box a -> a
values, Bool
extra :: Bool
extra :: forall a. Box a -> Bool
extra} Array
xs = do
  -- Collect possible indices in `xs` for each position in `values`.
  let indices :: [[(Int, HashMap Text Value)]]
indices = forall a b. (a -> b) -> [a] -> [b]
map ([Value] -> Matcher 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 (Matcher Value)
values)
  -- Find all unique valid ways to map each position in `values` 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 `values` 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 (Matcher Value)
values ->
        Validation (NonEmpty Error) (HashMap Text Value)
mismatched
      -- If there are some members of `xs` that aren't matched by
      -- anything in `values`, we check if the 'Matcher' allows for
      -- extra values.
      | 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
extra -> 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] -> Matcher Value -> [(Int, HashMap Text Value)]
collectMatchingIndices [Value]
is Matcher 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 Matcher Value
-> Value -> Either (NonEmpty Error) (HashMap Text Value)
match Matcher 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]
  -> Matcher Aeson.Value
  -> Aeson.Value
  -> Validation (NonEmpty Error) a
mismatch :: forall a.
[PathElem]
-> Matcher 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) Matcher Value
matcher Value
given =
  forall e a. e -> Validation (NonEmpty e) a
throwE (Mismatch -> Error
Mismatch MkMismatch {Value
Matcher Value
Path
$sel:given:MkMismatch :: Value
$sel:matcher:MkMismatch :: Matcher Value
$sel:path:MkMismatch :: Path
given :: Value
matcher :: Matcher Value
path :: Path
..})

mistype
  :: [PathElem]
  -> Matcher Aeson.Value
  -> Aeson.Value
  -> Validation (NonEmpty Error) a
mistype :: forall a.
[PathElem]
-> Matcher 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) Matcher Value
matcher Value
given =
  forall e a. e -> Validation (NonEmpty e) a
throwE (Mismatch -> Error
Mistype MkMismatch {Value
Matcher Value
Path
given :: Value
matcher :: Matcher Value
path :: Path
$sel:given:MkMismatch :: Value
$sel:matcher:MkMismatch :: Matcher 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

-- | Various errors that can happen when a matcher tries to match a 'Aeson.Value'.
data Error
  = Mismatch Mismatch
    -- ^ The type of the value is correct, but the value itself is wrong
  | Mistype Mismatch
    -- ^ The type of the value is wrong
  | MissingPathElem MissingPathElem
    -- ^ The request path is missing in the value
  | ExtraArrayValues ExtraArrayValues
    -- ^ Unexpected extra values in an array
  | ExtraObjectValues ExtraObjectValues
    -- ^ Unexpected extra key-value pairs in an object
    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
        ]

-- | A generic error that covers cases where either the type of the value
-- is wrong, or the value itself does not match.
data Mismatch = MkMismatch
  { Mismatch -> Path
path    :: Path
  , Mismatch -> Matcher Value
matcher :: Matcher 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
Matcher Value
Path
given :: Value
matcher :: Matcher Value
path :: Path
$sel:given:MkMismatch :: Mismatch -> Value
$sel:matcher:MkMismatch :: Mismatch -> Matcher 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
.= Matcher 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
Matcher Value
Path
given :: Value
matcher :: Matcher Value
path :: Path
$sel:given:MkMismatch :: Mismatch -> Value
$sel:matcher:MkMismatch :: Mismatch -> Matcher 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 Matcher Value
matcher]
      , [Doc] -> Doc
PP.hsep [Doc
"  given:", forall a. ToJSON a => a -> Doc
ppJson Value
given]
      ]

-- | This error covers the case where the requested path simply does not exist
-- in a 'Aeson.Value'.
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]
      ]

-- | Unless an permissive matcher is used, any extra values in an array
-- missing in the matcher will trigger this error.
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))
          ]
      ]

-- | Unless an permissive matcher is used, any extra key-value pairs in
-- an object missing in the matcher will trigger this error.
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]
        ]

-- | A path is a list of path elements.
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

-- | A path element is either a key lookup in an object, or an index lookup in an array.
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..]