aeson-quick 0.1.3 → 0.2.0

raw patch · 9 files changed

+658/−382 lines, 9 filesdep +QuickCheckdep +tasty-quickcheckdep +template-haskelldep −ghc-primdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, tasty-quickcheck, template-haskell

Dependencies removed: ghc-prim

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• ChangeLog.md +13/−0
• Data/Aeson/Quick.hs +0/−206
• README.md +74/−0
• aeson-quick.cabal +86/−55
• bench/Benchmark.hs +72/−0
• src/Data/Aeson/Quick.hs +287/−0
• src/Data/Aeson/Quick/Internal.hs +17/−0
• test/Benchmark.hs +0/−72
• test/Test.hs +109/−49

@@ -0,0 +1,13 @@+# Changelog for aeson-quick++## 0.2.0++* Support Aeson gte 2.0.0.0 as well as lte 1.5.6.0+* QuasiQuoter for structure: [quick|...|]+* QuasiQuoter for json literal: [jsonlit|...|]+* Tests with QuickCheck+* new README.md+* Rename Structure to Quick+* New, better defined build function+* Array bounds for deconstruction+

@@ -1,206 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveGeneric #-}--module Data.Aeson.Quick-    (-    -- $use-      module Ae-    , (.?)-    , (.!)-    , extract-    , (.%)-    , build-    , Structure(..)-    , parseStructure-    ) where---import Control.Applicative-import Control.Monad-import Control.DeepSeq--import Data.Aeson as Ae-import qualified Data.Aeson.Types as AT-import Data.Attoparsec.Text hiding (parse)-import Data.Char-import qualified Data.HashMap.Strict as H-import Data.Monoid-import Data.String-import qualified Data.Text as T-import qualified Data.Vector as V--import GHC.Generics (Generic)--data Structure = Obj [(T.Text, Bool, Structure)]-               | Arr Structure-               | Val- deriving (Eq, Ord, Generic)--instance NFData Structure--instance IsString Structure where-  fromString s =-    let e = error $ "Invalid structure: " ++ s-     in either (\_ -> e) id $ parseStructure $ T.pack s---instance Show Structure where-  show (Val) = "Val"-  show (Arr s) = "[" ++ show s ++ "]"-  show (Obj xs) = "{" ++ drop 1 (concatMap go xs) ++ "}"-    where go (k,o,s) = "," ++ showKey (T.unpack k) ++ (if o then "?" else "")-                           ++ (if s == Val then "" else ":" ++ show s)-          showKey "" = ""-          showKey (':':xs) = "\\:" ++ showKey xs-          showKey (',':xs) = "\\," ++ showKey xs-          showKey (c:xs) = c : showKey xs-    ---- | Parse a structure, can fail-parseStructure :: T.Text -> Either String Structure-parseStructure = parseOnly structure-  where-    structure :: Parser Structure-    structure = object' <|> array <|> val--    object' :: Parser Structure-    object' = Obj <$> ("{" *> sepBy1 lookups (char ',') <* "}")--    array :: Parser Structure-    array = Arr <$> ("[" *> structure <* "]")--    val :: Parser Structure-    val = "." >> pure Val--    lookups :: Parser (T.Text, Bool, Structure)-    lookups = (,,) <$> (quotedKey <|> plainKey)-                   <*> ("?" *> pure True <|> pure False)-                   <*> (":" *> structure <|> pure Val)--    quotedKey :: Parser T.Text-    quotedKey = "\"" *> scan False testChar <* "\""--    testChar :: Bool -> Char -> Maybe Bool-    testChar False '"'  = Nothing-    testChar False '\\' = Just True-    testChar _ _        = Just False--    plainKey :: Parser T.Text-    plainKey = takeWhile1 (notInClass "\",:{}?")---{- |-Extracts instances of 'FromJSON' from a 'Value'--This is a wrapper around 'extract' which does the actual work.--Examples assume 'FromJSON' Foo and 'FromJSON' Bar.--Extract key from object:-->>> value .? "{key}" :: Maybe Foo--Extract list of objects:-->>> value .? "[{key}]" :: Maybe [Foo]--Extract with optional key:-->>> value .? "{key,opt?}" :: Maybe (Foo, Maybe Bar)--}-(.?) :: FromJSON a => Value -> Structure -> Maybe a-(.?) = AT.parseMaybe . flip extract-{-# INLINE (.?) #-}---- TODO: Appropriate infixes?--{- |-Unsafe version of '.?'. Returns 'error' on failure.--}-(.!) :: FromJSON a => Value -> Structure -> a-(.!) v s = either err id $ AT.parseEither (extract s) v-  where err msg = error $ show s ++ ": " ++ msg ++ " in " ++ show v-{-# INLINE (.!) #-}---{- |-The 'Parser' that executes a 'Structure' against a 'Value' to return an instance of 'FromJSON'.--}-extract :: FromJSON a => Structure -> Value -> AT.Parser a-extract structure = go structure >=> parseJSON-  where-    go (Obj [s])  = withObject "" (flip look s)-    go (Obj sx)   = withObject "" (forM sx . look) >=> pure . toJSON-    go (Arr s)    = withArray  "" (V.mapM $ go s)   >=> pure . Array-    go Val        = pure-    look v (k,False,Val) = v .: k-    look v (k,False,s)   = v .:  k >>= go s-    look v (k,True,s)    = v .:? k >>= maybe (pure Null) (go s)---{- |-Turns data into JSON objects. --This is a wrapper around 'build' which does the actual work.--Build a simple Value:-->>> encode $ "{a}" .% True-{\"a\": True}--Build a complex Value:-->>> encode $ "[{a}]" '.%' [True, False]-"[{\"a\":true},{\"a\":false}]"--}-(.%) :: ToJSON a => Structure -> a -> Value-(.%) s = build s Null-{-# INLINE (.%) #-}---{- |-Executes a 'Structure' against provided data to update a 'Value'.--Note: /Still has undefined behaviours/, not at all stable.--}-build :: ToJSON a => Structure -> Value -> a -> Value-build structure val = go structure val . toJSON-  where-    go (Val)      _          r         = r-    go (Arr s)    (Array v)  (Array r) = Array $ V.zipWith (go s) v r -    go (Arr s)    Null       (Array r) = Array $ V.map (go s Null) r-    go (Arr s)    Null       r         = toJSON [go s Null r]-    go (Obj [ks]) (Object v) r         = Object $ update v ks r-    go (Obj keys) Null       r         = go (Obj keys) (Object mempty) r-    go (Obj ks)   (Object v) (Array r) = Object $-      let maps = zip ks (V.toList r)-       in foldl (\v' (s,r') -> update v' s r') v maps-    go (Obj keys) (Object v) r         = r-    go a b c = error $ show (a,b,c) -- TODO-    update v (k,_,s) r =-      let startVal = go s (H.lookupDefault Null k v) r-       in H.insert k startVal v----- $use------ aeson-quick is a library for terse marshalling of data to and from aeson's--- 'Value'.------ It works on the observation that by turning objects into tuples inside--- the 'Value', the type system can be employed to do more of the work.------ For example, given the JSON:------ > { "name": "bob"--- > , "age": 29--- > , "hobbies": [{"name": "tennis"}, {"name": "cooking"}]--- > }------ You can write: ------ @--- extractHobbyist :: 'Value' -> 'Maybe' ('String', 'Int', ['String'])--- extractHobbyist = ('.?' "{name,age,hobbies:[{name}]}")--- @---

@@ -0,0 +1,74 @@+# aeson-quick++[![hackage](https://img.shields.io/hackage/v/aeson-quick.svg)](https://hackage.haskell.org/package/aeson-quick) [![ci](https://github.com/ssadler/aeson-quick/actions/workflows/haskell.yml/badge.svg)](https://github.com/ssadler/aeson-quick/tree/0.2.0)++`aeson-quick` is a small DSL on top of [aeson](https://hackage.haskell.org/package/aeson) for casual and concise JSON construction and deconstruction.++In essence, it allows you to remove the Objects in a json `Value` using a simple key lookup syntax, so that the `FromJSON` typeclass can do the rest of the work, and it can go the other way, too.++`aeson-quick` structures can be defined using the `fromString` instance, or using the QuasiQuoter `quick` for compile time validation, ie: `[quick|{foo}|]`.++## Syntax++## Transformations++| Operation                       | Json Value                      | Quick expression     | Haskell type     |+|---------------------------------|---------------------------------|----------------------|------------------|+| Parse any value                 | ``*``                           | ``.``                | ``a``            |+| Key lookup                      | ``{"foo": *}``                  | ``{foo}``            | ``a``            |+| Optional key                    | ``{}``                          | ``{foo?}``           | ``Maybe a``      |+| Multiple keys                   | ``{"foo": *, "bar": *}``        | ``{foo,bar}``        | ``(a, b)``       |+| Nested object                   | ``{"foo": {"bar": *}}``         | ``{foo:{bar}}``      | ``b``            |+| Complex object                  | ``[{"foo": *, "bar": [*, *]}]``     | ``[{a,b:[.]}]``      | ``[(a, [c])]``   |+| Array                           | ``[*, *]``                      | ``[.]``              | ``[a]``          |+| Array lookup (deconstruct only) | ``[*, *]``                      | ``[.]1``             | ``a``            |+| Array range (deconstruct only)  | ``[*, *]``                      | ``[.]1-``            | ``[a]``          |++## Examples:++#### Deconstruction:++```Haskell+> let value = [jsonlit|{"foo": true, "bar": [0, 1], "baz": [{"foo": true}, {}, {"foo": false}]}|]++> value .! "{foo}" :: Bool+True++> value .! "{foo, bar}" :: (Bool, [Int])+(True, [0, 1])++> value .! "{baz:[{foo?}]}" :: [Maybe Bool]+[Just True, Nothing, Just False]++-- value is [1,2,3]+> value .! "[.]1" :: Int+2+> value .! "[.]1-" :: [Int]+[2,3]+> value .! "[.]0-2" :: [Int]+[1,2]+> value .! "[.]4" :: Maybe Int+Nothing+```++#### Construction:++```Haskell++> "." .% True+true++> "{foo}" .% True+{"foo": true}++> "[{foo}]" .% [1,2,3]+[{"foo":1},{"foo":2},{"foo":3}]++> "{foo:[{bar?}]}" .% [Just 1, Nothing]+{"foo":[{"bar":1},{}]}+```+++## Performance++Performance is extremely similar to using Aeson functions directly. See Writeup.md for more details.

@@ -1,63 +1,94 @@-Name:              aeson-quick-Version:           0.1.3-Build-Type:        Simple-Cabal-Version:     >= 1.16-License:           BSD3-License-File:      LICENSE-Author:            Scott Sadler-Maintainer:        Scott Sadler <scott@scottsadler.de>-Homepage:          https://github.com/libscott/aeson-quick-Category:          Text, Web, JSON-Synopsis:          Quick JSON extractions with Aeson-Description:       DSL on top of Aeson. This library is /experimental/.-Copyright:         (c) 2014-2018 Scott Sadler-Stability:         Experimental-Tested-With:       GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.1+cabal-version: 1.12 +-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack -Library-  Exposed-modules:    Data.Aeson.Quick-  hs-source-dirs:     .-  Build-Depends:      base                  >= 4      && <= 5-                    , aeson-                    , attoparsec-                    , deepseq-                    , text-                    , unordered-containers-                    , vector-  if impl(ghc < 7.5)-    Build-Depends:    ghc-prim              >= 0.2+name:           aeson-quick+version:        0.2.0+synopsis:       Quick JSON extractions with Aeson+description:    Small DSL on top of Aeson for casual and concise JSON construction and deconstruction.+category:       JSON+homepage:       https://github.com/ssadler/aeson-quick#readme+bug-reports:    https://github.com/ssadler/aeson-quick/issues+author:         Scott Sadler+maintainer:     scott@scottsadler.de+copyright:      2022 Scott Sadler+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    LICENSE+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/ssadler/aeson-quick++library+  exposed-modules:+      Data.Aeson.Quick+      Data.Aeson.Quick.Internal+  other-modules:+      Paths_aeson_quick+  hs-source-dirs:+      src+  build-depends:+      aeson+    , attoparsec+    , base >=4.7 && <5+    , deepseq+    , template-haskell+    , text+    , unordered-containers+    , vector   default-language: Haskell2010  test-suite aeson-quick-test-  type:               exitcode-stdio-1.0-  hs-source-dirs:     test-  main-is:            Test.hs-  build-depends:      aeson-quick-                    , base                  >= 4      && <= 5-                    , bytestring-                    , aeson-                    , microlens-                    , text-                    , attoparsec-                    , tasty-                    , tasty-hunit+  type: exitcode-stdio-1.0+  main-is: Test.hs+  other-modules:+      Paths_aeson_quick+  hs-source-dirs:+      test+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      QuickCheck+    , aeson+    , aeson-quick+    , attoparsec+    , base >=4.7 && <5+    , bytestring+    , deepseq+    , microlens+    , tasty+    , tasty-hunit+    , tasty-quickcheck+    , template-haskell+    , text+    , unordered-containers+    , vector   default-language: Haskell2010 -benchmark benchmark-  type:               exitcode-stdio-1.0-  main-is:            Benchmark.hs-  hs-source-dirs:     test-  ghc-options:        -Wall -rtsopts -threaded -with-rtsopts=-N-  build-depends:      aeson-quick-                    , base                  >= 4      && <= 5-                    , aeson-                    , bytestring-                    , criterion-                    , text+benchmark criterion-benchmarks+  type: exitcode-stdio-1.0+  main-is: Benchmark.hs+  other-modules:+      Paths_aeson_quick+  hs-source-dirs:+      bench+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      aeson+    , aeson-quick+    , attoparsec+    , base >=4.7 && <5+    , bytestring+    , criterion+    , deepseq+    , template-haskell+    , text+    , unordered-containers+    , vector   default-language: Haskell2010---source-repository head-  type:     git-  location: https://github.com/libscott/aeson-quick

@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Applicative+import Control.Monad++import Criterion.Main++import Data.Aeson.Quick+import Data.Aeson.Types (parseMaybe)+import qualified Data.ByteString.Lazy as BL+import Data.Text (Text)++import System.IO.Unsafe++main :: IO ()+main = defaultMain+  -- TODO: Refactor such that "bench" also tests+  [ bench "quickGetSimple"     $ nf quickGetSimple jsonSimple+  , bench "aesonGetSimple"     $ nf aesonGetSimple jsonSimple+  , bench "quickGetComplex"    $ nf quickGetComplex jsonComplex+  , bench "aesonGetComplex"    $ nf aesonGetComplex jsonComplex+  , bench "quickSetSimple"     $ nf quickSetSimple simple+  , bench "aesonSetSimple"     $ nf aesonSetSimple simple+  , bench "quickSetComplex"    $ nf quickSetComplex complex+  , bench "aesonSetComplex"    $ nf aesonSetComplex complex+  , bench "parseSimple"        $ nf parseQuick "{a}"+  , bench "parseComplex"       $ nf parseQuick "{a,b:[{c,d:[{e,f}]}]}"+ ]+  where+    jsonSimple = d "{\"a\":2,\"b\":[1,1]}" :: Value+    jsonComplex = d $ unsafePerformIO $ BL.readFile "bench/complex.json"++    check :: (Value -> Maybe a) -> Value -> a+    check f = maybe (error "Nothing") id . f++    quickGetSimple, aesonGetSimple :: Value -> Integer+    quickGetSimple = check (.? "{a}")+    aesonGetSimple = check $ parseMaybe $ withObject "" (.: "a")+    +    quickGetComplex, aesonGetComplex :: Value -> [(Text,Float,[Text],[Text])]+    quickGetComplex = check (.! "[{id,ppu,batters:{batter:[{id}]},topping:[{id}]}]")+    aesonGetComplex = check $ parseMaybe $ parseJSON >=> mapM (\o ->+      (,,,) <$> o .: "id" <*> o .: "ppu" <*> batters o <*> toppings o)+      where+        batters = (.:"batters") >=> withObject "" (.:"batter")+                                >=> mapM (withObject "" (.:"id"))+        toppings = (.:"topping") >=> mapM (withObject "" (.:"id"))+    +    simple = object ["a" .= Number 1]+    quickSetSimple, aesonSetSimple :: Value -> Bool+    quickSetSimple r = r `must` ("{a}" .% (1::Int))+    aesonSetSimple r = r `must` object ["a" .= (1::Int)]++    Just complex = decode "{\"a\":1,\"b\":[{\"a\":1},{\"a\":2},{\"a\":3}]}"+    quickSetComplex, aesonSetComplex :: Value -> Bool+    quickSetComplex r =+      let vals = ((1,[1,2,3])::(Int,[Int]))+       in r `must` ("{a,b:[{a}]}" .% vals)+    aesonSetComplex r =+      let inner = [object ["a" .= n] | n <- [1,2,3::Int]]+       in r `must` object ["a" .= (1::Int), "b" .= inner]+++must :: Eq a => a -> a -> Bool+must a b = if a == b then True else error "False"++d :: BL.ByteString -> Value+d s = case decode s of+           Just v -> v+           Nothing -> error $ "Coult not decode JSON: " ++ show s

@@ -0,0 +1,287 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Aeson.Quick+    (+    -- $use+      module Ae+    , (.?)+    , (.!)+    , extract+    , (.%)+    , build+    , Quick(..)+    , parseQuick+    , quick+    , jsonlit+    ) where++import Debug.Trace++import Control.Applicative+import Control.Monad+import Control.DeepSeq++import Data.Aeson as Ae+import qualified Data.Aeson.Types as AT+import Data.Attoparsec.Text hiding (parse)+import Data.Char+import Data.Maybe (catMaybes)+import Data.Monoid hiding (All)+import Data.String+import qualified Data.Text as T+import qualified Data.Vector as V+import GHC.Generics (Generic)++import qualified Language.Haskell.TH.Syntax as TH+import Language.Haskell.TH.Quote++import Data.Aeson.Quick.Internal++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as Key++type KeyType = Key.Key++keyToString :: KeyType -> String+keyToString = Key.toString++textToKey :: T.Text -> KeyType+textToKey = Key.fromText++#else++type KeyType = T.Text++keyToString :: KeyType -> String+keyToString = T.unpack++textToKey :: T.Text -> KeyType+textToKey = id++#endif++data Quick =+    Obj [(KeyType, Bool, Quick)]+  | Arr Quick Bounds+  | Val+  deriving (Eq, Ord, Generic)++instance NFData Quick++instance IsString Quick where+  fromString s =+    let e = error $ "Invalid structure: " ++ s+     in either (\_ -> e) id $ parseQuick $ T.pack s+++instance Show Quick where+  show (Val) = "."+  show (Arr s b) = "[" ++ show s ++ "]" ++ showBound b where+    showBound (All) = ""+    showBound (Single i) = show i+    showBound (Range a mb) = show a ++ "-" ++ maybe "" show mb+  show (Obj xs) = "{" ++ drop 1 (concatMap go xs) ++ "}" where+    go (k,o,s) = "," ++ showKey (keyToString k) ++ (if o then "?" else "")+                     ++ (if s == Val then "" else ":" ++ show s)+    showKey "" = ""+    showKey (':':xs) = "\\:" ++ showKey xs+    showKey (',':xs) = "\\," ++ showKey xs+    showKey (c:xs) = c : showKey xs+++-- | Parse a structure, can fail+parseQuick :: T.Text -> Either String Quick+parseQuick = parseOnly (structure <* endOfInput)+  where+    structure :: Parser Quick+    structure = object' <|> array <|> val++    object' :: Parser Quick+    object' = Obj <$> ("{" *> sepBy lookups (char ',') <* "}")++    array :: Parser Quick+    array = Arr <$> ("[" *> structure <* "]") <*> (arrayBounds <|> pure All)++    arrayBounds = do+      i <- decimal+      let rangeTo = (Just <$> decimal) <|> pure Nothing+      ("-" >> Range i <$> rangeTo) <|>+        pure (Single i)++    val :: Parser Quick+    val = "." >> pure Val++    lookups :: Parser (KeyType, Bool, Quick)+    lookups = (,,) <$> (textToKey <$> (quotedKey <|> plainKey))+                   <*> ("?" *> pure True <|> pure False)+                   <*> (":" *> structure <|> pure Val)++    quotedKey :: Parser T.Text+    quotedKey = "\"" *> scan False testChar <* "\""++    testChar :: Bool -> Char -> Maybe Bool+    testChar False '"'  = Nothing+    testChar False '\\' = Just True+    testChar _ _        = Just False++    plainKey :: Parser T.Text+    plainKey = takeWhile1 (notInClass "\",:{}?")+++{- |+Extracts instances of 'FromJSON' from a 'Value'++This is a wrapper around 'extract' which does the actual work.++Examples assume 'FromJSON' Foo and 'FromJSON' Bar.++Extract key from object:++>>> value .? "{key}" :: Maybe Foo++Extract list of objects:++>>> value .? "[{key}]" :: Maybe [Foo]++Extract with optional key:++>>> value .? "{key,opt?}" :: Maybe (Foo, Maybe Bar)+-}+(.?) :: FromJSON a => Value -> Quick -> Maybe a+(.?) = AT.parseMaybe . flip extract+{-# INLINE (.?) #-}++-- TODO: Appropriate infixes?++{- |+Unsafe version of '.?'. Returns 'error' on failure.+-}+(.!) :: FromJSON a => Value -> Quick -> a+(.!) v s = either err id $ AT.parseEither (extract s) v+  where err msg = error $ show s ++ ": " ++ msg ++ " in " ++ show v+{-# INLINE (.!) #-}+++{- |+The 'Parser' that executes a 'Quick' against a 'Value' to return an instance of 'FromJSON'.+-}+extract :: FromJSON a => Quick -> Value -> AT.Parser a+extract structure = go structure >=> parseJSON+  where+    -- The go function translates the Value into a Value that can then be+    -- further parsed automatically into the return type `a`+    go (Obj [s])  = withObject "" (flip look s)+    go (Obj sx)   = withObject "" (forM sx . look) >=> pure . toJSON+    go (Arr s b)  = withArray  "" (pure . V.map (go s)) >=> bound b+    go Val        = pure+    look v (k,False,Val) = v .: k+    look v (k,False,s)   = v .: k >>= go s+    look v (k,True,s)    = v .:? k >>= maybe (pure Null) (go s)++    bound All v = Array <$> sequence v+    bound (Single i) v =+      case v V.!? i of+        Nothing -> pure Null+        Just a -> a+    bound (Range a mb) v =+      bound All $ V.drop a $ maybe v (\b -> V.take b v) mb+++{- |+Turns data into JSON objects. ++This is a wrapper around 'build' which does the actual work.++Build a simple Value:++>>> encode $ "{a}" .% True+{\"a\": True}++Build a complex Value:++>>> encode $ "[{a}]" '.%' [True, False]+"[{\"a\":true},{\"a\":false}]"+-}+(.%) :: ToJSON a => Quick -> a -> Value+(.%) s a = either error id $ build s a+{-# INLINE (.%) #-}+++{- |+Executes a 'Quick' against provided data to update a 'Value'.+-}+build :: ToJSON a => Quick -> a -> Either String Value+build structure a = go structure $ toJSON a where+  go (Val)       v           = pure v+  go (Arr s All) (Array r)   = Array <$> V.mapM (go s) r+  -- The reason that one element is wrapped in an array is that+  -- tuples should always be provided for objects, but a tuple of one+  -- is not wrapped.+  go (Arr s _)   _           = Left "Cannot index an array during construction"+  go (Obj [k])   v           = object <$> items (zip [k] [v])+  go (Obj xs)    (Array v)   =+    if length xs /= V.length v+       then Left "Object / tuple length mismatch"+       else object <$> items (zip xs $ V.toList v)+  go _          _            = Left "Expected an array"++  items [] = pure []+  items (((k, o, s), val):xs) = do+      if o && val == Null+         then items xs+         else go s val >>= \h -> (k .= h:) <$> items xs+++{- |+QuasiQuoter for a structure, provides compile time checking ie:++>>> val .! [quick|{foo,bar}|]+-}+quick :: QuasiQuoter+quick = QuasiQuoter+  { quotePat = error "quick quasi quoter cannot be used as a pattern"+  , quoteDec = error "quick quasi quoter cannot be used as a declaration"+  , quoteType = error "quick quasi quoter cannot be used as a type"+  , quoteExp = \s ->+      let q = fromString s :: Quick+       in q `seq` [|fromString s|]+  }++jsonlit :: QuasiQuoter+jsonlit = QuasiQuoter+  { quotePat = error "quick quasi quoter cannot be used as a pattern"+  , quoteDec = error "quick quasi quoter cannot be used as a declaration"+  , quoteType = error "quick quasi quoter cannot be used as a type"+  , quoteExp = \s ->+      let bs = fromString s+          r = either error id $ eitherDecode bs :: Value+       in r `seq` [|r|]+  }++++-- $use+--+-- aeson-quick is a library for terse marshalling of data to and from aeson's+-- 'Value'.+--+-- It works on the observation that by turning objects into tuples inside+-- the 'Value', the type system can be employed to do more of the work.+--+-- For example, given the JSON:+--+-- > { "name": "bob"+-- > , "age": 29+-- > , "hobbies": [{"name": "tennis"}, {"name": "cooking"}]+-- > }+--+-- You can write: +--+-- @+-- extractHobbyist :: 'Value' -> 'Maybe' ('String', 'Int', ['String'])+-- extractHobbyist = ('.?' "{name,age,hobbies:[{name}]}")+-- @+--

@@ -0,0 +1,17 @@+{-# LANGUAGE DeriveGeneric #-}++module Data.Aeson.Quick.Internal where++import Control.DeepSeq+import GHC.Generics (Generic)+++data Bounds =+    All+  | Single Int+  | Range Int (Maybe Int)+  deriving (Eq, Ord, Generic, Show)++instance NFData Bounds++

@@ -1,72 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Main where--import Control.Applicative-import Control.Monad--import Criterion.Main--import Data.Aeson.Quick-import Data.Aeson.Types (parseMaybe)-import qualified Data.ByteString.Lazy as BL-import Data.Text (Text)--import System.IO.Unsafe--main :: IO ()-main = defaultMain-  -- TODO: Refactor such that "bench" also tests-  [ bench "quickGetSimple"     $ nf quickGetSimple jsonSimple-  , bench "aesonGetSimple"     $ nf aesonGetSimple jsonSimple-  , bench "quickGetComplex"    $ nf quickGetComplex jsonComplex-  , bench "aesonGetComplex"    $ nf aesonGetComplex jsonComplex-  , bench "quickSetSimple"     $ nf quickSetSimple simple-  , bench "aesonSetSimple"     $ nf aesonSetSimple simple-  , bench "quickSetComplex"    $ nf quickSetComplex complex-  , bench "aesonSetComplex"    $ nf aesonSetComplex complex-  , bench "parseSimple"        $ nf parseStructure "{a}"-  , bench "parseComplex"       $ nf parseStructure "{a,b:[{c,d:[{e,f}]}]}"- ]-  where-    jsonSimple = d "{\"a\":2,\"b\":[1,1]}" :: Value-    jsonComplex = d $ unsafePerformIO $ BL.readFile "test/complex.json"--    check :: (Value -> Maybe a) -> Value -> a-    check f = maybe (error "Nothing") id . f--    quickGetSimple, aesonGetSimple :: Value -> Integer-    quickGetSimple = check (.? "{a}")-    aesonGetSimple = check $ parseMaybe $ withObject "" (.: "a")-    -    quickGetComplex, aesonGetComplex :: Value -> [(Text,Float,[Text],[Text])]-    quickGetComplex = check (.! "[{id,ppu,batters:{batter:[{id}]},topping:[{id}]}]")-    aesonGetComplex = check $ parseMaybe $ parseJSON >=> mapM (\o ->-      (,,,) <$> o .: "id" <*> o .: "ppu" <*> batters o <*> toppings o)-      where-        batters = (.:"batters") >=> withObject "" (.:"batter")-                                >=> mapM (withObject "" (.:"id"))-        toppings = (.:"topping") >=> mapM (withObject "" (.:"id"))-    -    simple = object ["a" .= Number 1]-    quickSetSimple, aesonSetSimple :: Value -> Bool-    quickSetSimple r = r `must` build "{a}" Null (1::Int) -    aesonSetSimple r = r `must` object ["a" .= (1::Int)]--    Just complex = decode "{\"a\":1,\"b\":[{\"a\":1},{\"a\":2},{\"a\":3}]}"-    quickSetComplex, aesonSetComplex :: Value -> Bool-    quickSetComplex r =-      let vals = ((1,[1,2,3])::(Int,[Int]))-       in r `must` build "{a,b:[{a}]}" Null vals-    aesonSetComplex r =-      let inner = [object ["a" .= n] | n <- [1,2,3::Int]]-       in r `must` object ["a" .= (1::Int), "b" .= inner]---must :: Eq a => a -> a -> Bool-must a b = if a == b then True else error "False"--d :: BL.ByteString -> Value-d s = case decode s of-           Just v -> v-           Nothing -> error $ "Coult not decode JSON: " ++ show s

@@ -1,17 +1,26 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE BlockArguments #-}  import Control.Applicative+import Control.Monad  import Data.Aeson.Quick-import Data.ByteString.Lazy (ByteString)+import Data.Aeson.Quick.Internal+import Data.String  import Lens.Micro +import Test.QuickCheck import Test.Tasty import Test.Tasty.HUnit+import Test.Tasty.QuickCheck +import Debug.Trace + main :: IO () main = defaultMain $ testGroup "Tests"    [ oneKey@@ -21,10 +30,11 @@   , complex   , optionalKey   , nonExistentKey-  , asLens   , parseInvalid-  , showStructure+  , showQuick   , quotedKey+  , quasi+  , props   ]  @@ -34,9 +44,9 @@       val .! "{a}" @?= one    , testCase "set" $-      "{a}" .% Null `jt` "{\"a\":null}"+      "{a}" .% Null @?= [jsonlit|{"a":null}|]   ]-  where val = d "{\"a\":1}"+  where val = [jsonlit|{"a":1}|]   multipleKeys :: TestTree@@ -45,9 +55,9 @@       multiple .! "{a,b}" @?= (one,two)    , testCase "set" $-      build "{a,b}" multiple (two,[one,one]) `jt` "{\"a\":2,\"b\":[1,1]}"+      (.%) "{a,b}" (two,[one,one]) @?= [jsonlit|{"a":2,"b":[1,1]}|]   ]-  where multiple = d "{\"a\":1,\"b\":2}"+  where multiple = [jsonlit|{"a":1,"b":2}|]   deepKey :: TestTree@@ -56,9 +66,9 @@       multilevel .! "{a:{b}}" @?= Just one    , testCase "set" $-      build "{a:{b}}" multilevel two `jt` "{\"a\":{\"b\":2}}"+      (.%) "{a:{b}}" two @?= [jsonlit|{"a":{"b":2}}|]   ]-  where multilevel = d "{\"a\":{\"b\":1}}"+  where multilevel = [jsonlit|{"a":{"b":1}}|]   keyInArray :: TestTree@@ -67,9 +77,9 @@       many .! "[{a}]" @?= [one,two]    , testCase "set" $-      build "[{a}]" many [True,False] `jt` "[{\"a\":true},{\"a\":false}]"+      (.%) "[{a}]" [True,False] @?= [jsonlit|[{"a":true},{"a":false}]|]   ]-  where many = d "[{\"a\":1},{\"a\":2}]"+  where many = [jsonlit|[{"a":1},{"a":2}]|]   complex :: TestTree@@ -77,9 +87,9 @@   [ testCase "get" $       val .! "{a,b:[{a}]}" @?= (one,[[two,one]])   , testCase "set" $-      build "{a,b:[{a}]}" val (two,[[one]]) `jt` "{\"a\":2,\"b\":[{\"a\":[1]}]}"+      (.%) "{a,b:[{a}]}" (two,[[one]]) @?= [jsonlit|{"a":2,"b":[{"a":[1]}]}|]   ]-  where val = d "{\"a\":1,\"b\":[{\"a\":[2,1]}]}"+  where val = [jsonlit|{"a":1,"b":[{"a":[2,1]}]}|]   optionalKey :: TestTree@@ -87,7 +97,7 @@   [ testCase "get" $       val .! "{a?,b?}" @?= (Just one, Nothing :: Maybe Int)   ]-  where val = d "{\"a\":1}"+  where val = [jsonlit|{"a":1}|]   nonExistentKey :: TestTree@@ -96,53 +106,60 @@       val .? "{b}" @?= (Nothing :: Maybe Int)      , testCase "set" $-      build "{a}" (d "{}") Null `jt` "{\"a\":null}"+      (.%) "{a}" Null @?= [jsonlit|{"a":null}|]    , testCase "setDeep" $-      "{a:[{b}]}" .% Null `jt` "{\"a\":[{\"b\":null}]}"+      "{a:[{b}]}" .% [Null] @?= [jsonlit|{"a":[{"b":null}]}|]    , testCase "setDeepArray" $-      "[{a}]" .% [one,two] `jt` "[{\"a\":1},{\"a\":2}]"+      "[{a}]" .% [one,two] @?= [jsonlit|[{"a":1},{"a":2}]|]    , testCase "setDeepMany" $       let v = (1,[(10,11)]) :: (Int,[(Int,Int)])        in "{my,complex:[{data,structure}]}" .% v-            @?= d "{\"my\":1,\"complex\":[{\"data\":10,\"structure\":11}]}" +            @?= [jsonlit|{"my":1,"complex":[{"data":10,"structure":11}]}|]++  , testCase "inArray" do+      [jsonlit|[{"foo": 1}, {}, {"foo": 2}]|] .! "[{foo?}]" @?= [Just 1, Nothing, Just (2::Int)]   ]-  where val = d "{\"a\":1}"+  where val = [jsonlit|{"a":1}|]  -asLens :: TestTree-asLens = testGroup "asLens"-  [ testCase "get" $-      let l = queLens "{a,b}" :: Lens' Value (Int,Int)-       in val ^. l . _2 @?= two--  , testCase "getDoesNotExist" $-      -- doesn't work, make a Traversal?-      --d "{}" ^? queLens "{a}" @?= (Nothing :: Maybe (Int,Int))-      putStr "SKIPPED " >> pure ()+-- For now, Quick cannot be used as a lens+-- in order to update objects.+-- Perhaps revisit the old "build" function one day. -  , testCase "set" $-      (val & (queLens "{a,b}") .~ (two,one)) `jt` "{\"a\":2,\"b\":1}"-  ]-  where-    val = d "{\"a\":1,\"b\":2}"-    queLens :: (FromJSON a, ToJSON a) => Structure -> Lens' Value a-    queLens s = lens (.!s) (build s)+--asLens :: TestTree+--asLens = testGroup "asLens"+--  [ testCase "get" $+--      let l = queLens "{a,b}" :: Lens' Value (Int,Int)+--       in val ^. l . _2 @?= two+--+--  --, testCase "getDoesNotExist" $+--  --    -- doesn't work, make a Traversal?+--  --    --d "{}" ^? queLens "{a}" @?= (Nothing :: Maybe (Int,Int))+--  --    putStr "SKIPPED " >> pure ()+--+--  , testCase "set" $+--      (val & (queLens "{a,b}") .~ (two,one)) @?= [jsonlit|{"a":2,"b":1}"+--  ]+--  where+--    val = d "{"a":1,"b":2}"+--    queLens :: (FromJSON a, ToJSON a) => Quick -> Lens' Value a+--    queLens s = lens (.!s) ((.%) s)   parseInvalid :: TestTree parseInvalid = testGroup "parseInvalid"   [ testCase "noKey" $-      isLeft (parseStructure "{a,{b}}") @?= True+      isLeft (parseQuick "{a,{b}}") @?= True   ]  -showStructure :: TestTree-showStructure = testGroup "showStructure"+showQuick :: TestTree+showQuick = testGroup "showQuick"   [ testCase "all" $-      show ("[{a:[{b?,c}]}]"::Structure) @?= "[{a:[{b?,c}]}]"+      show ("[{a:[{b?,c}]}]"::Quick) @?= "[{a:[{b?,c}]}]"   ]  quotedKey :: TestTree@@ -151,20 +168,63 @@     ("{\"_:,}\"?}") @?= Obj [("_:,}", True, Val)]   ] +quasi :: TestTree+quasi = testGroup "quasi-quoter"+  [ testCase "quasi" do+      [quick|.|] @?= Val+      [quick|{a:[.]0}|] @?= "{a:[.]0}"+  ] -one, two :: Int-one = 1 -two = 2 +instance Arbitrary Bounds where+  arbitrary = do+    r <- arbitrary+    case r of+      LT -> pure All+      EQ -> Single <$> choose (0, 100)+      GT -> Range <$> choose (0, 100) <*> (fmap abs <$> arbitrary) -jt :: Value -> ByteString -> IO ()-jt v b = encode v @?= b +instance Arbitrary Quick where+  arbitrary = sized arbQuick where+    arbKey = do+      i <- choose (1, 10)+      s <- replicateM i (elements ['a'..'z'])+      pure $ fromString s -d :: ByteString -> Value-d s = case decode s of-           Just v -> v-           Nothing -> error $ "Coult not decode JSON: " ++ show s+    arbItem x = (,,) <$> arbKey <*> arbitrary <*> arbQuick x++    arbQuick 0 = pure Val+    arbQuick x+      | even x = Arr <$> arbQuick (quot x 2) <*> arbitrary+      | otherwise = do+          i <- choose (0, 3)+          Obj <$> replicateM i (arbItem (quot x 2))++    ++props :: TestTree+props = testGroup "props"+  [+    testProperty "isomorphic parse" $+      \q -> fromString (show (q::Quick)) == q++  , testProperty "isomorphic show" $+      \q -> let s = show (q::Quick) in s == show (fromString s :: Quick)++  , testProperty "iso01" $+      \x -> let q = "[{a,b?}]" in (q .% x) .! q == (x :: [(Int, Maybe Int)])++  , testProperty "iso02" $+      \x -> let q = "[{a:[{d}],b}]" in (q .% x) .! q == (x :: [([Int], Int)])+  ]+++++one, two :: Int+one = 1 +two = 2   isLeft :: Either a b -> Bool