diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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 + diff --git a/Data/Aeson/Quick.hs b/Data/Aeson/Quick.hs deleted file mode 100644 --- a/Data/Aeson/Quick.hs +++ /dev/null @@ -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}]}") --- @ --- diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/aeson-quick.cabal b/aeson-quick.cabal --- a/aeson-quick.cabal +++ b/aeson-quick.cabal @@ -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 -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 diff --git a/bench/Benchmark.hs b/bench/Benchmark.hs new file mode 100644 --- /dev/null +++ b/bench/Benchmark.hs @@ -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 diff --git a/src/Data/Aeson/Quick.hs b/src/Data/Aeson/Quick.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Quick.hs @@ -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}]}") +-- @ +-- diff --git a/src/Data/Aeson/Quick/Internal.hs b/src/Data/Aeson/Quick/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Quick/Internal.hs @@ -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 + + diff --git a/test/Benchmark.hs b/test/Benchmark.hs deleted file mode 100644 --- a/test/Benchmark.hs +++ /dev/null @@ -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 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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