aeson-match-qq 1.6.1 → 1.7.0

raw patch · 10 files changed

+807/−180 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.markdown +12/−0
• aeson-match-qq.cabal +5/−2
• src/Aeson/Match/QQ.hs +6/−2
• src/Aeson/Match/QQ/Internal/AesonUtils.hs +124/−0
• src/Aeson/Match/QQ/Internal/Match.hs +98/−32
• src/Aeson/Match/QQ/Internal/Parse.hs +103/−73
• src/Aeson/Match/QQ/Internal/PrettyPrint.hs +178/−0
• src/Aeson/Match/QQ/Internal/Value.hs +68/−61
• test/Aeson/Match/QQ/Internal/PrettyPrintSpec.hs +156/−0
• test/Aeson/Match/QQSpec.hs +57/−10

@@ -1,3 +1,15 @@+1.7.0+====++  * Removed some of conditional compilation, by no longer pretending that+  we provide `liftTyped` for `Matcher`.++  * Fixed yet another embarrassing parser bug (https://github.com/supki/aeson-match-qq/pull/33)++  * Implemented `[...]` and `{...}` as shortcuts to `_ : array` and `_ : object` respectively (https://github.com/supki/aeson-match-qq/pull/34)++  * Some work has been done on making match failures output understandable error messages (https://github.com/supki/aeson-match-qq/pull/37, https://github.com/supki/aeson-match-qq/pull/38, https://github.com/supki/aeson-match-qq/pull/39)+ 1.6.1 ===== 

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.7.+-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack  name:           aeson-match-qq-version:        1.6.1+version:        1.7.0 synopsis:       Declarative JSON matchers. description:    See README.markdown category:       Web@@ -27,8 +27,10 @@ library   exposed-modules:       Aeson.Match.QQ+      Aeson.Match.QQ.Internal.AesonUtils       Aeson.Match.QQ.Internal.Match       Aeson.Match.QQ.Internal.Parse+      Aeson.Match.QQ.Internal.PrettyPrint       Aeson.Match.QQ.Internal.Value   other-modules:       Paths_aeson_match_qq@@ -56,6 +58,7 @@   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:+      Aeson.Match.QQ.Internal.PrettyPrintSpec       Aeson.Match.QQSpec       Paths_aeson_match_qq   hs-source-dirs:

@@ -3,6 +3,7 @@   , qq    , Error(..)+  , TypeMismatch(..)   , Mismatch(..)   , MissingPathElem(..)   , ExtraArrayValues(..)@@ -17,18 +18,20 @@   , Type(..)   , Path(..)   , PathElem(..)++  , parse   ) where  import           Data.String (IsString(..)) import qualified Data.Text.Encoding as Text import           Language.Haskell.TH.Quote (QuasiQuoter(..))-import           Language.Haskell.TH.Syntax (Lift(..)) import qualified Text.PrettyPrint as PP (render) import qualified Text.PrettyPrint.HughesPJClass as PP (Pretty(..))  import           Aeson.Match.QQ.Internal.Match   ( match   , Error(..)+  , TypeMismatch(..)   , Mismatch(..)   , MissingPathElem(..)   , ExtraArrayValues(..)@@ -44,6 +47,7 @@   , Object   , HoleSig(..)   , Type(..)+  , quote   )  @@ -55,7 +59,7 @@         Left err ->           error ("Aeson.Match.QQ.qq: " ++ err)         Right val ->-          lift val+          quote val   , quotePat =       \_ -> error "Aeson.Match.QQ.qq: no quotePat"   , quoteType =

@@ -0,0 +1,124 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+module Aeson.Match.QQ.Internal.AesonUtils+  ( toJSONE+  , pp+  ) where++import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Encoding.Internal as Aeson (encodingToLazyByteString)+import qualified Data.Aeson.KeyMap as Aeson.KeyMap+import           Data.Bool (bool)+import           Data.Foldable (toList)+import qualified Data.List as List+import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import           Data.Int (Int64)+import           Data.Scientific (Scientific, floatingOrInteger)+import           Data.String (fromString)+import           Data.Text (Text)+import           Data.Vector (Vector)+import           Text.PrettyPrint ((<+>))+import qualified Text.PrettyPrint as PP+++-- | This is a round-about way to produce a 'Aeson.Value' from a 'ToJSON' instance.+-- it is written this way to avoid calling 'Aeson.toJSON' which might be undefined+-- for some datatypes that only implement 'toEncoding'.+--+-- It is defined in a separate module due to the TH stage restrictions as we need+-- to 'lift' 'toJSONE' eventually.+toJSONE :: Aeson.ToJSON x => x -> Aeson.Value+toJSONE x =+  let+    ~(Just val) = conv x+    -- ^ the pattern is irrefutable because we assume that it is always possible+    -- to recover a Value from an Encoding generated by Aeson.toEncoding+  in+    val+ where+  conv =+    Aeson.decode . Aeson.encodingToLazyByteString . Aeson.toEncoding++-- | A super-basic re-implementation of aeson-pretty. This function attains 2 goals:+--+--   - we avoid another dependency+--   - it uses the same prettyprinter everything else uses, and thus+--   it is easily integrated.+pp :: Aeson.Value -> PP.Doc+pp = \case+  Aeson.Null ->+    rNull+  Aeson.Bool b ->+    rBool b+  Aeson.Number n ->+    rNumber n+  Aeson.String str ->+    rString str+  Aeson.Array xs ->+    rArray xs+  Aeson.Object o ->+    rObject (Aeson.KeyMap.toHashMapText o)+ where+  rNull :: PP.Doc+  rNull =+    "null"++  rBool :: Bool -> PP.Doc+  rBool =+    bool "false" "true"++  rNumber :: Scientific -> PP.Doc+  rNumber =+    fromString . either (show @Double) (show @Int64) . floatingOrInteger++  rString :: Text -> PP.Doc+  rString =+    fromString . show++  rArray :: Vector Aeson.Value -> PP.Doc+  rArray values =+    case toList values of+      [] ->+        "[]"+      x : xs ->+        PP.vcat $+          ["[" <+> pp x] <>+          map (\x' -> "," <+> pp x') xs <>+          ["]"]++  rObject :: HashMap Text Aeson.Value -> PP.Doc+  rObject values =+    case List.sortOn fst (HashMap.toList values) of+      [] ->+        "{}"+      kv : kvs ->+        PP.vcat $+          ["{" <+> rKeyValue kv] <>+          map (\kv' -> "," <+> rKeyValue kv') kvs <>+          ["}"]+   where+    rKeyValue (key, value) =+      if simpleValue value then+        (rString key <> ":") <+> pp value+      else+        PP.vcat+          [ rString key <> ":"+          , pp value+          ]++  simpleValue :: Aeson.Value -> Bool+  simpleValue = \case+    Aeson.Null {} ->+      True+    Aeson.Bool {} ->+      True+    Aeson.Number {} ->+      True+    Aeson.String {} ->+      True+    Aeson.Array {} ->+      False+    Aeson.Object {} ->+      False

@@ -11,6 +11,7 @@ module Aeson.Match.QQ.Internal.Match   ( match   , Error(..)+  , TypeMismatch(..)   , Mismatch(..)   , MissingPathElem(..)   , ExtraArrayValues(..)@@ -27,7 +28,6 @@ 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(..)@@ -38,7 +38,7 @@ 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.List.NonEmpty (NonEmpty, nonEmpty) import           Data.Maybe (mapMaybe) import qualified Data.Set as Set import           Data.String (IsString(..))@@ -49,8 +49,7 @@ import           GHC.Exts (IsList) import           Prelude hiding (any, null) import qualified Text.PrettyPrint as PP-  ( Doc-  , vcat+  ( vcat   , hsep   , brackets   , text@@ -59,6 +58,8 @@   ) import qualified Text.PrettyPrint.HughesPJClass as PP (Pretty(..)) +import qualified Aeson.Match.QQ.Internal.AesonUtils as AesonUtils (pp)+import qualified Aeson.Match.QQ.Internal.PrettyPrint as Matcher (pp) import           Aeson.Match.QQ.Internal.Value   ( Matcher(..)   , Box(..)@@ -79,42 +80,45 @@   validationToEither (go [] matcher0 given0)  where   go path matcher given = do-    let mismatched = mismatch path matcher given-        mistyped = mistype path matcher given+    let+      mismatched =+        mismatch path matcher given+      mistyped expected =+        mistype path expected matcher given     case (matcher, given) of       (Hole holeTypeO nameO, val) -> do         for_ holeTypeO $ \holeType ->-          unless (holeTypeMatch holeType val)-            mistyped+          unless (holeTypeMatch holeType val) $+            mistyped (type_ holeType)         pure (maybe mempty (\name -> HashMap.singleton name val) nameO)       (Null, Aeson.Null) ->         pure mempty       (Null, _) -> do-        mistyped+        mismatched         pure mempty       (Bool b, Aeson.Bool b') -> do         unless (b == b') mismatched         pure mempty       (Bool _, _) -> do-        mistyped+        mistyped BoolT         pure mempty       (Number n, Aeson.Number n') -> do         unless (n == n') mismatched         pure mempty       (Number _, _) -> do-        mistyped+        mistyped NumberT         pure mempty       (String str, Aeson.String str') -> do         unless (str == str') mismatched         pure mempty       (String _, _) -> do-        mistyped+        mistyped StringT         pure mempty       (StringCI str, Aeson.String str') -> do         unless (str == CI.mk str') mismatched         pure mempty       (StringCI _, _) -> do-        mistyped+        mistyped StringCIT         pure mempty       (Array Box {values, extra}, Aeson.Array arr) ->         let@@ -130,12 +134,12 @@             (\i v -> maybe (missingPathElem path (Idx i)) (go (Idx i : path) v) (arr Vector.!? i))             values       (Array _, _) -> do-        mistyped+        mistyped ArrayT         pure mempty       (ArrayUO box, Aeson.Array arr) ->         matchArrayUO mismatched path box arr       (ArrayUO _, _) -> do-        mistyped+        mistyped ArrayUOT         pure mempty       ( Object Box {values, extra} #if MIN_VERSION_aeson(2,0,0)@@ -157,7 +161,7 @@             (\k v -> maybe (missingPathElem path (Key k)) (go (Key k : path) v) (HashMap.lookup k o))             values       (Object _, _) -> do-        mistyped+        mistyped ObjectT         pure mempty       (Ext val, val') ->         go path (embed val) val'@@ -243,11 +247,12 @@  mistype   :: [PathElem]+  -> Type   -> Matcher Aeson.Value   -> Aeson.Value   -> Validation (NonEmpty Error) a-mistype (Path . reverse -> path) matcher given =-  throwE (Mistype MkMismatch {..})+mistype (Path . reverse -> path) expected matcher given =+  throwE (Mistype MkTypeMismatch {..})  missingPathElem   :: [PathElem]@@ -278,7 +283,7 @@ data Error   = Mismatch Mismatch     -- ^ The type of the value is correct, but the value itself is wrong-  | Mistype Mismatch+  | Mistype TypeMismatch     -- ^ The type of the value is wrong   | MissingPathElem MissingPathElem     -- ^ The request path is missing in the value@@ -297,7 +302,7 @@         ]     Mistype err ->       PP.vcat-        [ "  error: type of value does not match"+        [ "   error: type of value does not match"         , PP.pPrint err         ]     MissingPathElem err ->@@ -340,8 +345,73 @@         , "value" .= v         ] --- | A generic error that covers cases where either the type of the value--- is wrong, or the value itself does not match.+-- | This error type covers the case where the type of the value does not match.+data TypeMismatch = MkTypeMismatch+  { path     :: Path+  , expected :: Type+  , matcher  :: Matcher Aeson.Value+  , given    :: Aeson.Value+  } deriving (Show, Eq)++instance Aeson.ToJSON TypeMismatch where+  toJSON MkTypeMismatch {..} =+    Aeson.object+      [ "path" .= path+      , "expected" .= expected+      , "actual" .= typeJOf given+      , "matcher" .= matcher+      , "given" .= given+      ]++instance PP.Pretty TypeMismatch where+  pPrint MkTypeMismatch {..} =+    PP.vcat+      [ PP.hsep ["expected:", PP.pPrint expected]+      , PP.hsep ["  actual:", PP.pPrint (typeJOf given)]+      , PP.hsep ["    path:", PP.pPrint path]+      , PP.hsep [" matcher:", Matcher.pp matcher]+      , PP.hsep ["   given:", AesonUtils.pp given]+      ]++-- | JSON value type.+data TypeJ+  = NullTJ+  | BoolTJ+  | NumberTJ+  | StringTJ+  | ArrayTJ+  | ObjectTJ+    deriving (Show, Eq)++instance Aeson.ToJSON TypeJ where+  toJSON =+    Aeson.toJSON . \case+      NullTJ -> "null" :: Text+      BoolTJ -> "bool"+      NumberTJ -> "number"+      StringTJ -> "string"+      ArrayTJ -> "array"+      ObjectTJ -> "object"++instance PP.Pretty TypeJ where+  pPrint = \case+    NullTJ {} -> "null"+    BoolTJ {} -> "bool"+    NumberTJ {} -> "number"+    StringTJ {} -> "string"+    ArrayTJ {} -> "array"+    ObjectTJ {} -> "object"++typeJOf :: Aeson.Value -> TypeJ+typeJOf = \case+  Aeson.Null -> NullTJ+  Aeson.Bool {} -> BoolTJ+  Aeson.Number {} -> NumberTJ+  Aeson.String {} -> StringTJ+  Aeson.Array {} -> ArrayTJ+  Aeson.Object {} -> ObjectTJ++-- | This error type covers the case where the type matches but the value does not. data Mismatch = MkMismatch   { path    :: Path   , matcher :: Matcher Aeson.Value@@ -360,11 +430,11 @@   pPrint MkMismatch {..} =     PP.vcat       [ PP.hsep ["   path:", PP.pPrint path]-      , PP.hsep ["matcher:", ppJson matcher]-      , PP.hsep ["  given:", ppJson given]+      , PP.hsep ["matcher:", Matcher.pp matcher]+      , PP.hsep ["  given:", AesonUtils.pp given]       ] --- | This error covers the case where the requested path simply does not exist+-- | This error type covers the case where the requested path simply does not exist -- in a 'Aeson.Value'. data MissingPathElem = MkMissingPathElem   { path    :: Path@@ -405,7 +475,7 @@       [ PP.hsep ["   path:", PP.pPrint path]       , PP.hsep           [ " values:"-          , PP.vcat (map ppJson (toList values))+          , PP.vcat (map AesonUtils.pp (toList values))           ]       ] @@ -436,7 +506,7 @@     prettyKV (k, v) =       PP.vcat         [ PP.hsep ["  key:", PP.pPrint (Key k)]-        , PP.hsep ["value:", ppJson v]+        , PP.hsep ["value:", AesonUtils.pp v]         ]  -- | A path is a list of path elements.@@ -445,7 +515,7 @@  instance PP.Pretty Path where   pPrint =-    foldMap PP.pPrint . unPath+    maybe "." (foldMap PP.pPrint) . nonEmpty . unPath  -- | A path element is either a key lookup in an object, or an index lookup in an array. data PathElem@@ -470,10 +540,6 @@       PP.char '.' <> PP.text (Text.unpack k)     Idx i ->       PP.brackets (PP.int i)--ppJson :: Aeson.ToJSON a => a -> PP.Doc-ppJson =-  PP.text . ByteString.Lazy.unpack . Aeson.encode  imapMaybe :: (Int -> a -> Maybe b) -> [a] -> [b] imapMaybe f =

@@ -1,6 +1,8 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-} module Aeson.Match.QQ.Internal.Parse   ( parse   ) where@@ -33,47 +35,74 @@   )  +-- | An 'attoparsec' parser for a 'Matcher'.+--+-- /Note:/ consumes spaces before and after the matcher. parse :: ByteString -> Either String (Matcher Exp) parse =-  Atto.parseOnly value+  Atto.parseOnly (value <* eof)  value :: Atto.Parser (Matcher Exp) value = do-  spaces-  b <- Atto.peekWord8'-  case b of-    HoleP ->-      any-    NP ->-      null-    FP ->-      false-    TP ->-      true-    DoubleQuoteP ->-      string-    OpenSquareBracketP ->-      array-    OpenParenP ->-      arrayUO <|> stringCI-    OpenCurlyBracketP ->-      object-    HashP ->-      haskellExp-    _ | startOfNumber b ->-        number-      | otherwise ->-        fail ("a value cannot start with " ++ show b)+  val <- between spaces spaces $ do+    b <- Atto.peekWord8'+    case b of+      HoleP ->+        any+      NP ->+        null+      FP ->+        false+      TP ->+        true+      DoubleQuoteP ->+        string+      OpenSquareBracketP ->+        array+      OpenParenP ->+        arrayUO <|> stringCI+      OpenCurlyBracketP ->+        object+      HashP ->+        haskellExp+      _ | startOfNumber b ->+          number+        | otherwise ->+          fail ("a value cannot start with " ++ show b)+  pure (optimize val)  where   startOfNumber b =     b >= ZeroP && b <= NineP || b == MinusP+  between a b p =+    a *> p <* b +optimize :: Matcher Exp -> Matcher Exp+optimize = \case+  -- [...] -> _ : array+  Array Box {extra = True, values = (Vector.null -> True)} ->+    Hole (Just (HoleSig ArrayT False)) Nothing+  -- this optimization is probably never going to be used,+  -- but I'll include it for completeness:+  -- (unordered) [...] -> _ : unordered-array+  ArrayUO Box {extra = True, values = (Vector.null -> True)} ->+    Hole (Just (HoleSig ArrayUOT False)) Nothing+  -- {...} -> _ : object+  Object Box {extra = True, values = (HashMap.null -> True)} ->+    Hole (Just (HoleSig ObjectT False)) Nothing+  val ->+    val+ any :: Atto.Parser (Matcher Exp) any = do   _ <- Atto.word8 HoleP   name <- fmap Just key <|> pure Nothing   spaces-  expectedType <- optional holeSig+  b <- optional Atto.peekWord8'+  expectedType <- case b of+    Just ColonP ->+      fmap Just holeSig+    _ ->+      pure Nothing   pure (Hole expectedType name)  null :: Atto.Parser (Matcher Exp)@@ -115,31 +144,30 @@       loop [] 0  where   loop acc !n = do-    val <- value     spaces-    b <- Atto.satisfy (\w -> w == CommaP || w == CloseSquareBracketP) Atto.<?> "',' or ']'"+    b <- Atto.peekWord8'     case b of-      CommaP -> do-        spaces-        b' <- Atto.peekWord8'-        case b' of-          DotP -> do-            rest-            spaces-            _ <- Atto.word8 CloseSquareBracketP-            pure $ Array Box-              { values = Vector.fromListN (n + 1) (reverse (val : acc))-              , extra = True-              }-          _ ->-            loop (val : acc) (n + 1)-      CloseSquareBracketP ->-        pure $ Array Box-          { values = Vector.fromListN (n + 1) (reverse (val : acc))-          , extra = False-          }-      _ ->-        error "impossible"+      DotP -> do+       rest+       spaces+       _ <- Atto.word8 CloseSquareBracketP+       pure $ Array Box+         { values = Vector.fromListN (n + 1) (reverse acc)+         , extra = True+         }+      _ -> do+       val <- value+       sep <- Atto.satisfy (\w -> w == CommaP || w == CloseSquareBracketP) Atto.<?> "',' or ']'"+       case sep of+         CommaP ->+           loop (val : acc) (n + 1)+         CloseSquareBracketP ->+           pure $ Array Box+             { values = Vector.fromListN (n + 1) (reverse (val : acc))+             , extra = False+             }+         _ ->+           error "impossible"  arrayUO :: Atto.Parser (Matcher Exp) arrayUO = do@@ -161,35 +189,33 @@       loop []  where   loop acc = do-    k <- key     spaces-    _ <- Atto.word8 ColonP-    spaces-    val <- value-    spaces-    b <- Atto.satisfy (\b -> b == CommaP || b == CloseCurlyBracketP) Atto.<?> "',' or '}'"+    b <- Atto.peekWord8'     case b of-      CommaP -> do+      DotP -> do+        rest         spaces-        b' <- Atto.peekWord8'-        case b' of-          DotP -> do-            rest-            spaces-            _ <- Atto.word8 CloseCurlyBracketP+        _ <- Atto.word8 CloseCurlyBracketP+        pure $ Object Box+          { values = HashMap.fromList acc+          , extra = True+          }+      _ -> do+        k <- key+        spaces+        _ <- Atto.word8 ColonP+        val <- value+        sep <- Atto.satisfy (\w -> w == CommaP || w == CloseCurlyBracketP) Atto.<?> "',' or '}'"+        case sep of+          CommaP ->+            loop ((k, val) : acc)+          CloseCurlyBracketP ->             pure $ Object Box               { values = HashMap.fromList ((k, val) : acc)-              , extra = True+              , extra = False               }           _ ->-            loop ((k, val) : acc)-      CloseCurlyBracketP ->-        pure $ Object Box-          { values = HashMap.fromList ((k, val) : acc)-          , extra = False-          }-      _ ->-        error "impossible"+            error "impossible"  key :: Atto.Parser Text key =@@ -230,12 +256,16 @@     , p "array" ArrayT     , p "unordered-array" ArrayUOT     , p "object" ObjectT-    ]+    ] Atto.<?> "unknown type in hole signature"  where   p name typeName = do     _ <- Atto.string name     q <- optional (Atto.word8 QuestionMarkP)     pure (HoleSig typeName (isJust q))++eof :: Atto.Parser ()+eof =+  Atto.endOfInput Atto.<?> "trailing garbage after a Matcher value"  -- This function has been stolen from aeson. -- ref: https://hackage.haskell.org/package/aeson-1.4.6.0/docs/src/Data.Aeson.Parser.Internal.html#skipSpace

@@ -0,0 +1,178 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+module Aeson.Match.QQ.Internal.PrettyPrint+  ( pp+  ) where++import qualified Data.Aeson as Aeson+import           Data.Bool (bool)+import qualified Data.ByteString.Lazy as ByteString.Lazy+import           Data.CaseInsensitive (CI)+import qualified Data.CaseInsensitive as CI+import qualified Data.Char as Char+import           Data.Foldable (toList)+import           Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import           Data.Int (Int64)+import qualified Data.List as List+import           Data.Scientific (Scientific, floatingOrInteger)+import           Data.String (fromString)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import           Data.Text (Text)+import           Data.Vector (Vector)+import           Text.PrettyPrint ((<+>))+import qualified Text.PrettyPrint as PP++import           Aeson.Match.QQ.Internal.Value+  ( Matcher(..)+  , HoleSig(..)+  , Type(..)+  , Box(..)+  )+++pp :: Matcher Aeson.Value -> PP.Doc+pp value =+  PP.vcat+    [ "[qq|"+    , PP.nest 2 (rValue value)+    , "|]"+    ]++rValue :: Matcher Aeson.Value -> PP.Doc+rValue = \case+  Hole sig name ->+    rHole sig name+  Null ->+    rNull+  Bool b ->+    rBool b+  Number n ->+    rNumber n+  String str ->+    rString str+  StringCI str ->+    rStringCI str+  Array xs ->+    rArray xs+  ArrayUO xs ->+    rArrayUO xs+  Object o ->+    rObject o+  Ext ext ->+    rExt ext++rHole :: Maybe HoleSig -> Maybe Text -> PP.Doc+rHole sig name =+  ("_" <> maybe PP.empty rName name) <+> maybe PP.empty rSig sig++rName :: Text -> PP.Doc+rName name =+  PP.text (bool (Text.unpack name) (show name) (hasSpaces name))+ where+  hasSpaces =+    Text.any Char.isSpace++rSig :: HoleSig -> PP.Doc+rSig HoleSig {type_, nullable} =+  (":" <+> rType type_) <> bool PP.empty "?" nullable+ where+  rType = \case+    BoolT -> "bool"+    NumberT -> "number"+    StringT -> "string"+    StringCIT -> "ci-string"+    ArrayT -> "array"+    ArrayUOT -> "unordered-array"+    ObjectT -> "object"++rNull :: PP.Doc+rNull =+  "null"++rBool :: Bool -> PP.Doc+rBool =+  bool "false" "true"++rNumber :: Scientific -> PP.Doc+rNumber =+  fromString . either (show @Double) (show @Int64) . floatingOrInteger++rString :: Text -> PP.Doc+rString =+  fromString . show++rStringCI :: CI Text -> PP.Doc+rStringCI str =+  PP.vcat+    [ "(ci)"+    , rString (CI.original str)+    ]++rArray :: Box (Vector (Matcher Aeson.Value)) -> PP.Doc+rArray Box {values, extra} =+  case toList values of+    [] ->+      "[]"+    x : xs ->+      PP.vcat $+        ["[" <+> rValue x] <>+        map (\x' -> "," <+> rValue x') xs <>+        [bool PP.empty ", ..." extra, "]"]++rArrayUO :: Box (Vector (Matcher Aeson.Value)) -> PP.Doc+rArrayUO box =+  PP.vcat+    [ "(unordered)"+    , rArray box+    ]++rExt :: Aeson.Value -> PP.Doc+rExt =+  fromString . Text.unpack . Text.decodeUtf8 . ByteString.Lazy.toStrict . Aeson.encode++rObject :: Box (HashMap Text (Matcher Aeson.Value)) -> PP.Doc+rObject Box {values, extra} =+  case List.sortOn fst (HashMap.toList values) of+    [] ->+      "{}"+    kv : kvs ->+      PP.vcat $+        ["{" <+> rKeyValue kv] <>+        map (\kv' -> "," <+> rKeyValue kv') kvs <>+        [bool PP.empty ", ..." extra, "}"]+ where+  rKeyValue (key, value) =+    if simpleValue value then+      (rName key <> ":") <+> rValue value+    else+      PP.vcat+        [ rName key <> ":"+        , rValue value+        ]++simpleValue :: Matcher Aeson.Value -> Bool+simpleValue = \case+  Hole {} ->+    True+  Null {} ->+    True+  Bool {} ->+    True+  Number {} ->+    True+  String {} ->+    True+  StringCI {} ->+    True+  Array {} ->+    False+  ArrayUO {} ->+    False+  Object {} ->+    False+  Ext {} ->+    True

@@ -17,6 +17,7 @@   , HoleSig(..)   , Type(..)   , embed+  , quote   ) where  import           Data.Aeson ((.=))@@ -24,29 +25,23 @@ #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.KeyMap as Aeson (toHashMapText) #endif-import qualified Data.Aeson.Encoding.Internal as Aeson (encodingToLazyByteString) import           Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import           Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import           Data.Scientific (Scientific)-import           Data.String (fromString) import           Data.Text (Text) import qualified Data.Text as Text import           Data.Vector (Vector) import qualified Data.Vector as Vector-import           Language.Haskell.TH (Exp(..), Lit(..))-import           Language.Haskell.TH.Syntax-  ( Lift(..)-#if MIN_VERSION_template_haskell(2,17,0)-  , unsafeCodeCoerce-#else-  , unsafeTExpCoerce-#endif-  )+import           Language.Haskell.TH (Q, Exp(..), Lit(..))+import           Language.Haskell.TH.Syntax (Lift(..)) import           Prelude hiding (any, null)+import qualified Text.PrettyPrint.HughesPJClass as PP (Pretty(..)) +import           Aeson.Match.QQ.Internal.AesonUtils (toJSONE) + -- | A value constructed using 'qq' that attempts to match -- a JSON document. data Matcher ext@@ -133,55 +128,57 @@  type Object ext = Box (HashMap Text (Matcher ext)) --- | Convert `'Matcher' 'Exp'` to `'Matcher' 'Aeson.Value'`. This uses a roundabout way to get--- `Aeson.Value` from `ToJSON.toEncoding` to avoid calling `Aeson.toJSON` which may be--- undefined for some datatypes.-instance ext ~ Exp => Lift (Matcher ext) where-  lift = \case-    Hole type_ name ->-      [| Hole type_ $(pure (maybe (ConE 'Nothing) (AppE (ConE 'Just) . AppE (VarE 'fromString) . LitE . textL) name)) :: Matcher Aeson.Value |]-    Null ->-      [| Null :: Matcher Aeson.Value |]-    Bool b ->-      [| Bool b :: Matcher Aeson.Value |]-    Number n ->-      [| Number (fromRational $(pure (LitE (RationalL (toRational n))))) :: Matcher Aeson.Value |]-    String str ->-      [| String (fromString $(pure (LitE (textL str)))) :: Matcher Aeson.Value |]-    StringCI str ->-      [| StringCI (fromString $(pure (LitE (textL (CI.original str))))) :: Matcher Aeson.Value |]-    Array Box {values, extra} -> [|-        Array Box-          { values =-              Vector.fromList $(fmap (ListE . Vector.toList) (traverse lift values))-          , extra-          } :: Matcher Aeson.Value-      |]-    ArrayUO Box {values, extra} -> [|-        ArrayUO Box-          { values =-              Vector.fromList $(fmap (ListE . Vector.toList) (traverse lift values))-          , extra-          } :: Matcher Aeson.Value-      |]-    Object Box {values, extra} -> [|-        Object Box-          { values =-              HashMap.fromList $(fmap (ListE . map (\(k, v) -> TupE [Just (LitE (textL k)), Just v]) . HashMap.toList) (traverse lift values))-          , extra-          } :: Matcher Aeson.Value-      |]-    Ext ext ->-      [| Ext (let ~(Just val) = Aeson.decode (Aeson.encodingToLazyByteString (Aeson.toEncoding $(pure ext))) in val) :: Matcher Aeson.Value |]-   where-    textL =-      StringL . Text.unpack-  liftTyped =-#if MIN_VERSION_template_haskell(2,17,0)-    unsafeCodeCoerce . lift-#else-    unsafeTExpCoerce . lift-#endif+-- | It may be tempting to make this the 'Lift' instance for 'Matcher', but I don't+-- think it would be correct. We can get a lot from re-using 'Lift' machinery: namely,+-- we can cpmpletely bypass manual 'Exp' construction. But, fundamentally, 'Lift' is+-- for "serializing" Haskell values and it is not what we are attempting here.+quote :: Matcher Exp -> Q Exp+quote = \case+  Hole type_ name ->+    [| Hole type_ name :: Matcher Aeson.Value |]+  Null ->+    [| Null :: Matcher Aeson.Value |]+  Bool b ->+    [| Bool b :: Matcher Aeson.Value |]+  Number n ->+    [| Number n :: Matcher Aeson.Value |]+  String str ->+    [| String str :: Matcher Aeson.Value |]+  StringCI ci -> let+      original = CI.original ci+    in+      [| StringCI (CI.mk original) :: Matcher Aeson.Value |]+  Array Box {values, extra} -> do+    let+      quoted =+        fmap ListE (traverse quote (Vector.toList values))+    [| Array Box+         { values = Vector.fromList $quoted+         , extra+         } :: Matcher Aeson.Value |]+  ArrayUO Box {values, extra} -> do+    let+      quoted =+        fmap ListE (traverse quote (Vector.toList values))+    [| ArrayUO Box+         { values = Vector.fromList $quoted+         , extra+         } :: Matcher Aeson.Value |]+  Object Box {values, extra} -> do+    let+      quoted =+        fmap toExp (traverse (traverse quote) (HashMap.toList values))+      toExp =+        ListE . map (\(k, v) -> tup2 (LitE (StringL (Text.unpack k)), v))+      tup2 (a, b) =+        TupE [Just a, Just b]+    [| Object Box+         { values = HashMap.fromList $quoted+         , extra+         } :: Matcher Aeson.Value |]+  -- | This is fundamentally type-unsafe as long as we try to splice `Exp` in.+  Ext ext ->+    [| Ext (toJSONE $(pure ext)) :: Matcher Aeson.Value |]  -- | _hole type signature data HoleSig = HoleSig@@ -222,8 +219,18 @@       StringT {} -> "string"       StringCIT {} -> "ci-string"       ArrayT {} -> "array"-      ArrayUOT {} -> "array-unordered"+      ArrayUOT {} -> "unordered-array"       ObjectT {} -> "object"++instance PP.Pretty Type where+  pPrint = \case+    BoolT {} -> "bool"+    NumberT {} -> "number"+    StringT {} -> "string"+    StringCIT {} -> "ci-string"+    ArrayT {} -> "array"+    ArrayUOT {} -> "unordered-array"+    ObjectT {} -> "object"  embed :: Aeson.Value -> Matcher ext embed = \case

@@ -0,0 +1,156 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+module Aeson.Match.QQ.Internal.PrettyPrintSpec (spec) where++import           Test.Hspec++import           Aeson.Match.QQ (qq)+import           Aeson.Match.QQ.Internal.PrettyPrint (pp)+++spec :: Spec+spec = do+  it "holes" $ do+    pp [qq| _ |] `shouldBe`+      "[qq|\n\+      \  _\n\+      \|]"+    pp [qq| _hole |] `shouldBe`+      "[qq|\n\+      \  _hole\n\+      \|]"+    pp [qq| _"fancy hole" |] `shouldBe`+      "[qq|\n\+      \  _\"fancy hole\"\n\+      \|]"+    pp [qq| _typed-hole : number |] `shouldBe`+      "[qq|\n\+      \  _typed-hole : number\n\+      \|]"++  it "basic values" $ do+    pp [qq| null |] `shouldBe`+      "[qq|\n\+      \  null\n\+      \|]"++    pp [qq| false |] `shouldBe`+      "[qq|\n\+      \  false\n\+      \|]"+    pp [qq| true |] `shouldBe`+      "[qq|\n\+      \  true\n\+      \|]"++    pp [qq| 4 |] `shouldBe`+      "[qq|\n\+      \  4\n\+      \|]"+    pp [qq| 7.42 |] `shouldBe`+      "[qq|\n\+      \  7.42\n\+      \|]"++    pp [qq| "" |] `shouldBe`+      "[qq|\n\+      \  \"\"\n\+      \|]"+    pp [qq| "foo" |] `shouldBe`+      "[qq|\n\+      \  \"foo\"\n\+      \|]"++    pp [qq| (ci) "" |] `shouldBe`+      "[qq|\n\+      \  (ci)\n\+      \  \"\"\n\+      \|]"+    pp [qq| (ci) "foo" |] `shouldBe`+      "[qq|\n\+      \  (ci)\n\+      \  \"foo\"\n\+      \|]"++  it "arrays" $ do+    pp [qq| [] |] `shouldBe`+      "[qq|\n\+      \  []\n\+      \|]"+    pp [qq| [1,2,3] |] `shouldBe`+      "[qq|\n\+      \  [ 1\n\+      \  , 2\n\+      \  , 3\n\+      \  ]\n\+      \|]"+    pp [qq| [1, ...] |] `shouldBe`+      "[qq|\n\+      \  [ 1\n\+      \  , ...\n\+      \  ]\n\+      \|]"+    pp [qq| [1, {qux: 42, quux: 0, ...}, 3] |] `shouldBe`+      "[qq|\n\+      \  [ 1\n\+      \  , { quux: 0\n\+      \    , qux: 42\n\+      \    , ...\n\+      \    }\n\+      \  , 3\n\+      \  ]\n\+      \|]"++    pp [qq| (unordered) [] |] `shouldBe`+      "[qq|\n\+      \  (unordered)\n\+      \  []\n\+      \|]"+    pp [qq| (unordered) [1,2,3] |] `shouldBe`+      "[qq|\n\+      \  (unordered)\n\+      \  [ 1\n\+      \  , 2\n\+      \  , 3\n\+      \  ]\n\+      \|]"++  it "objects" $ do+    pp [qq| {} |] `shouldBe`+      "[qq|\n\+      \  {}\n\+      \|]"+    pp [qq| {foo: 4, bar: 7} |] `shouldBe`+      "[qq|\n\+      \  { bar: 7\n\+      \  , foo: 4\n\+      \  }\n\+      \|]"+    pp [qq| {foo: 4, ...} |] `shouldBe`+      "[qq|\n\+      \  { foo: 4\n\+      \  , ...\n\+      \  }\n\+      \|]"+    pp [qq| {foo: 4, bar: {qux: 42, quux: 0, ...}, baz: 7} |] `shouldBe`+      "[qq|\n\+      \  { bar:\n\+      \    { quux: 0\n\+      \    , qux: 42\n\+      \    , ...\n\+      \    }\n\+      \  , baz: 7\n\+      \  , foo: 4\n\+      \  }\n\+      \|]"++    let+      spliced = 7 :: Int+    pp [qq| {foo: #{spliced}} |] `shouldBe`+      "[qq|\n\+      \  { foo: 7\n\+      \  }\n\+      \|]"

@@ -7,7 +7,7 @@  import qualified Data.Aeson as Aeson import           Data.Aeson.QQ (aesonQQ)-import           Data.List.NonEmpty (NonEmpty)+import           Data.List.NonEmpty (NonEmpty(..)) import qualified Data.HashMap.Strict as HashMap import           Test.Hspec @@ -145,6 +145,7 @@         match [qq| (unordered) [{foo: _hole}, ...] |] [aesonQQ| [{foo: 2}, 1] |] `shouldBe`           pure (HashMap.singleton "hole" [aesonQQ| 2 |]) +  describe "repro" $ do     -- https://github.com/supki/aeson-match-qq/issues/7     it "#7" $ do       match [qq| {foo: _} |] [aesonQQ| {} |] `shouldBe`@@ -173,6 +174,12 @@             , extra = False             }) +    -- https://github.com/supki/aeson-match-qq/issues/12+    it "#12" $ do+      [qq| [ ... ] |] `shouldBe` [qq| _ : array |]+      [qq| (unordered) [ ... ] |] `shouldBe` [qq| _ : unordered-array |]+      [qq| { ... } |] `shouldBe` [qq| _ : object |]+     -- https://github.com/supki/aeson-match-qq/issues/13     it "#13" $       [qq| "Слава Україні" |] `shouldMatch` [aesonQQ| "Слава Україні" |]@@ -188,26 +195,59 @@           })       -- string !~ number       match [qq| "foo" |] [aesonQQ| 4 |] `shouldBe`-        throwE (Mistype MkMismatch+        throwE (Mistype MkTypeMismatch           { path = []+          , expected = StringT           , matcher = String "foo"           , given = Aeson.Number 4           })       -- string !~ null       match [qq| "foo" |] [aesonQQ| null |] `shouldBe`-        throwE (Mistype MkMismatch+        throwE (Mistype MkTypeMismatch           { path = []+          , expected = StringT           , matcher = String "foo"           , given = Aeson.Null           })       -- null !~ number       match [qq| null |] [aesonQQ| 4 |] `shouldBe`-        throwE (Mistype MkMismatch+        throwE (Mismatch MkMismatch           { path = []           , matcher = Null           , given = Aeson.Number 4           }) +    -- https://github.com/supki/aeson-match-qq/issues/28+    it "#28" $ do+      let+        Left (err :| _) =+          match [qq| [{foo: 4, bar: 7}] |] [aesonQQ| {foo: 4, bar: 7}|]+      prettyError err `shouldBe`+          "   error: type of value does not match\n\+          \expected: array\n\+          \  actual: object\n\+          \    path: .\n\+          \ matcher: [qq|\n\+          \            [ { bar: 7\n\+          \              , foo: 4\n\+          \              }\n\+          \            ]\n\+          \          |]\n\+          \   given: { \"bar\": 7\n\+          \          , \"foo\": 4\n\+          \          }"++    -- https://github.com/supki/aeson-match-qq/issues/29+    it "#29" $ do+      parse "_ : not-a-known-type" `shouldBe`+        Left "unknown type in hole signature: Failed reading: empty"++    -- https://github.com/supki/aeson-match-qq/issues/32+    it "#32" $ do+      parse "null some garbage" `shouldBe`+        Left "trailing garbage after a Matcher value: endOfInput"++  describe "pretty-printing" $     it "pretty" $ do       prettyError (Mismatch MkMismatch         { path = [Key "foo", Idx 0, Key "bar"]@@ -216,17 +256,24 @@         }) `shouldBe`           "  error: value does not match\n\           \   path: .foo[0].bar\n\-          \matcher: {\"value\":\"foo\",\"type\":\"string\"}\n\+          \matcher: [qq|\n\+          \           \"foo\"\n\+          \         |]\n\           \  given: \"bar\""-      prettyError (Mistype MkMismatch+      prettyError (Mistype MkTypeMismatch         { path = [Key "foo", Idx 0, Key "bar"]+        , expected = StringT         , matcher = String "foo"         , given = Aeson.Number 4         }) `shouldBe`-          "  error: type of value does not match\n\-          \   path: .foo[0].bar\n\-          \matcher: {\"value\":\"foo\",\"type\":\"string\"}\n\-          \  given: 4"+          "   error: type of value does not match\n\+          \expected: string\n\+          \  actual: number\n\+          \    path: .foo[0].bar\n\+          \ matcher: [qq|\n\+          \            \"foo\"\n\+          \          |]\n\+          \   given: 4"       prettyError (MissingPathElem MkMissingPathElem         { path = [Key "foo", Idx 0, Key "bar"]         , missing = Idx 1