aeson-quick (empty) → 0.1.1
raw patch · 6 files changed
+510/−0 lines, 6 filesdep +aesondep +aeson-quickdep +attoparsecsetup-changed
Dependencies added: aeson, aeson-quick, attoparsec, base, bytestring, criterion, deepseq, microlens, tasty, tasty-hunit, text, unordered-containers, vector
Files
- Data/Aeson/Quick.hs +184/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- aeson-quick.cabal +60/−0
- test/Benchmark.hs +72/−0
- test/Test.hs +162/−0
+ Data/Aeson/Quick.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}++module Data.Aeson.Quick+ (+ -- $use+ -- $examples+ 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) = "," ++ T.unpack k ++ (if o then "?" else "")+ ++ (if s == Val then "" else ":" ++ show s)+ ++-- | Parse a structure, can fail+parseStructure :: T.Text -> Either String Structure+parseStructure = parseOnly structure+ where+ structure = object' <|> array+ object' = Obj <$> ("{" *> sepBy1 lookups (char ',') <* "}")+ array = Arr <$> ("[" *> structure <* "]")+ lookups = (,,) <$> (takeWhile1 isKeyChar)+ <*> ("?" *> pure True <|> pure False)+ <*> (":" *> structure <|> pure Val)+ isKeyChar = isAlphaNum -- TODO+++{- |+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:++>>> "{key}" .? value :: Maybe Foo++Extract list of objects:++>>> "[{key}]" .? value :: Maybe [Foo]++Extract with optional key:++>>> "{key,opt?}" .? value :: Maybe (Foo, Maybe Bar)+-}+(.?) :: FromJSON a => Value -> Structure -> Maybe a+(.?) = AT.parseMaybe . flip extract+{-# INLINE (.?) #-}++-- TODO: Appropriate infixes?++{- |+The (very!) unsafe version of '.?'. This can fail very easily, do not depend on this in your program. Will probably be removed.+-}+(.!) :: 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 value = value '.?' "{name,age,hobbies:[{name}]}"+-- @+--
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2011, Scott Sadler.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ aeson-quick.cabal view
@@ -0,0 +1,60 @@+Name: aeson-quick+Version: 0.1.1+Build-Type: Simple+Cabal-Version: >= 1.10+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-2017 Scott Sadler+Stability: Experimental+Tested-With: GHC == 7.8.4, GHC == 7.10.2, GHC == 8.0.1+++Library+ Exposed-modules: Data.Aeson.Quick+ hs-source-dirs: .+ Build-Depends: base >= 4 && <= 4.9.0.0+ , aeson >= 0.8 && < 0.12+ , attoparsec >= 0.12 && < 0.14+ , deepseq >= 1.3 && < 1.5+ , text >= 1.2 && < 1.3+ , unordered-containers >= 0.2.5 && < 0.3+ , vector >= 0.10 && < 0.12+ 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 && <= 4.9.0.0+ , bytestring >= 0.10.5 && < 0.11+ , aeson >= 0.8 && < 0.12+ , microlens >= 0.4 && < 0.5+ , text >= 1.2 && < 1.3+ , attoparsec >= 0.12 && < 0.14+ , tasty >= 0.10 && < 0.12+ , tasty-hunit >= 0.9 && < 0.10+ 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 && <= 4.9.0.0+ , aeson >= 0.8 && < 0.12+ , bytestring >= 0.10 && < 0.11+ , criterion >= 0.1 && < 1.2+ , text >= 1.2 && < 1.3+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/libscott/aeson-quick
+ test/Benchmark.hs view
@@ -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 "aqGetSimple" $ nf getSimple jsonSimple+ , bench "aesonGetSimple" $ nf aesonGetSimple jsonSimple+ , bench "aqGetComplex" $ nf getComplex jsonComplex+ , bench "aesonGetComplex" $ nf aesonGetComplex jsonComplex+ , bench "aqSetSimple" $ nf setSimple simple+ , bench "aesonSetSimple" $ nf aesonSetSimple simple+ , bench "aqSetComplex" $ nf setComplex 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++ getSimple, aesonGetSimple :: Value -> Integer+ getSimple = check (.? "{a}")+ aesonGetSimple = check $ parseMaybe $ withObject "" (.: "a")+ + getComplex, aesonGetComplex :: Value -> [(Text,Float,[Text],[Text])]+ getComplex = 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]+ setSimple, aesonSetSimple :: Value -> Bool+ setSimple 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}]}"+ setComplex, aesonSetComplex :: Value -> Bool+ setComplex 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
+ test/Test.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++import Control.Applicative++import Data.Aeson.Quick+import Data.ByteString.Lazy (ByteString)+import Data.Either++import Lens.Micro++import Test.Tasty+import Test.Tasty.HUnit+++main :: IO ()+main = defaultMain $ testGroup "Tests" + [ oneKey+ , multipleKeys+ , deepKey+ , keyInArray+ , complex+ , optionalKey+ , nonExistentKey+ , asLens+ , parseInvalid+ , showStructure+ ]+++oneKey :: TestTree+oneKey = testGroup "oneKey"+ [ testCase "get" $+ val .! "{a}" @?= one++ , testCase "set" $+ "{a}" .% Null `jt` "{\"a\":null}"+ ]+ where val = d "{\"a\":1}"+++multipleKeys :: TestTree+multipleKeys = testGroup "multipleKeys"+ [ testCase "get" $+ multiple .! "{a,b}" @?= (one,two)++ , testCase "set" $+ build "{a,b}" multiple (two,[one,one]) `jt` "{\"a\":2,\"b\":[1,1]}"+ ]+ where multiple = d "{\"a\":1,\"b\":2}"+++deepKey :: TestTree+deepKey = testGroup "deepKey"+ [ testCase "get" $+ multilevel .! "{a:{b}}" @?= Just one++ , testCase "set" $+ build "{a:{b}}" multilevel two `jt` "{\"a\":{\"b\":2}}"+ ]+ where multilevel = d "{\"a\":{\"b\":1}}"+++keyInArray :: TestTree+keyInArray = testGroup "keyInArray"+ [ testCase "get" $+ many .! "[{a}]" @?= [one,two]++ , testCase "set" $+ build "[{a}]" many [True,False] `jt` "[{\"a\":true},{\"a\":false}]"+ ]+ where many = d "[{\"a\":1},{\"a\":2}]"+++complex :: TestTree+complex = testGroup "complex"+ [ testCase "get" $+ val .! "{a,b:[{a}]}" @?= (one,[[two,one]])+ , testCase "set" $+ build "{a,b:[{a}]}" val (two,[[one]]) `jt` "{\"a\":2,\"b\":[{\"a\":[1]}]}"+ ]+ where val = d "{\"a\":1,\"b\":[{\"a\":[2,1]}]}"+++optionalKey :: TestTree+optionalKey = testGroup "optionalKey"+ [ testCase "get" $+ val .! "{a?,b?}" @?= (Just one, Nothing :: Maybe Int)+ ]+ where val = d "{\"a\":1}"+++nonExistentKey :: TestTree+nonExistentKey = testGroup "nonExistentKey"+ [ testCase "get" $+ val .? "{b}" @?= (Nothing :: Maybe Int)+ + , testCase "set" $+ build "{a}" (d "{}") Null `jt` "{\"a\":null}"++ , testCase "setDeep" $+ "{a:[{b}]}" .% Null `jt` "{\"a\":[{\"b\":null}]}"++ , testCase "setDeepArray" $+ "[{a}]" .% [one,two] `jt` "[{\"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}]}" + ]+ where val = d "{\"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 ()++ , 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)+++parseInvalid :: TestTree+parseInvalid = testGroup "parseInvalid"+ [ testCase "noKey" $+ isLeft (parseStructure "{a,{b}}") @?= True+ ]+++showStructure :: TestTree+showStructure = testGroup "showStructure"+ [ testCase "all" $+ show ("[{a:[{b?,c}]}]"::Structure) @?= "[{a:[{b?,c}]}]"+ ]+++one, two :: Int+one = 1 +two = 2+++jt :: Value -> ByteString -> IO ()+jt v b = encode v @?= b+++d :: ByteString -> Value+d s = case decode s of+ Just v -> v+ Nothing -> error $ "Coult not decode JSON: " ++ show s+