diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# 0.3.2.0 + +- Add `Data.Aeson.Extra.Stream` with `streamDecode` + # 0.3.1.1 (2016-02-09) - Support aeson-0.11 diff --git a/aeson-extra.cabal b/aeson-extra.cabal --- a/aeson-extra.cabal +++ b/aeson-extra.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: aeson-extra -version: 0.3.1.1 +version: 0.3.2.0 synopsis: Extra goodies for aeson description: Package provides extra funcitonality on top of @aeson@ and @aeson-compat@ category: Web @@ -33,6 +33,7 @@ base >=4.6 && <4.10 , aeson >=0.7.0.6 && <0.12 , aeson-compat >=0.3.0.0 && <0.4 + , attoparsec >=0.11.3.4 && <0.14 , base-compat >=0.6.0 && <0.10 , bytestring >=0.10 && <0.11 , containers >=0.5 && <0.6 @@ -54,6 +55,7 @@ Data.Aeson.Extra.Foldable Data.Aeson.Extra.Map Data.Aeson.Extra.Merge + Data.Aeson.Extra.Stream Data.Aeson.Extra.Time Data.Aeson.Extra.TH @@ -83,7 +85,7 @@ , scientific >=0.3 && <0.4 , template-haskell >=2.8 && <2.11 , text >=1.2 && <1.3 - , these >=0.6.2.0 && <0.7 + , these >=0.6.2.0 && <0.8 , time >=1.4.2 && <1.7 , time-parsers >=0.1.0.0 && <0.2 , unordered-containers >=0.2 && <0.3 diff --git a/src/Data/Aeson/Extra.hs b/src/Data/Aeson/Extra.hs --- a/src/Data/Aeson/Extra.hs +++ b/src/Data/Aeson/Extra.hs @@ -38,6 +38,8 @@ ArrayF, -- * Merge merge, + -- * Stream + streamDecode, -- * Template Haskell mkValue, mkValue', @@ -57,6 +59,7 @@ import Data.Aeson.Extra.Foldable import Data.Aeson.Extra.Map import Data.Aeson.Extra.Merge +import Data.Aeson.Extra.Stream import Data.Aeson.Extra.Time import Data.Aeson.Extra.TH diff --git a/src/Data/Aeson/Extra/Merge.hs b/src/Data/Aeson/Extra/Merge.hs --- a/src/Data/Aeson/Extra/Merge.hs +++ b/src/Data/Aeson/Extra/Merge.hs @@ -7,12 +7,12 @@ -- Maintainer : Oleg Grenrus -- module Data.Aeson.Extra.Merge ( - merge, - mergeA, - ValueF(..), - ObjectF, - ArrayF, - ) where + merge, + mergeA, + ValueF(..), + ObjectF, + ArrayF, + ) where import Prelude () import Prelude.Compat diff --git a/src/Data/Aeson/Extra/Stream.hs b/src/Data/Aeson/Extra/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Extra/Stream.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Aeson.Extra.Stream +-- Copyright : (C) 2015-2016 Oleg Grenrus +-- License : BSD3 +-- Maintainer : Oleg Grenrus +-- +module Data.Aeson.Extra.Stream ( + streamDecode, + ) where + +import Prelude () +import Prelude.Compat + +import Control.Applicative ((<|>), many) +import Data.Aeson.Compat (FromJSON, Result (..), Value, fromJSON) +import Data.Aeson.Parser (value) + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Attoparsec.ByteString.Char8 as A8 +import qualified Data.Attoparsec.ByteString.Lazy as A + +streamParse :: LBS.ByteString -> ([Value], Maybe String) +streamParse = start + where + start bs = case A.parse (lexemeChar '[') bs of + A.Done bs' _ -> first bs' + A.Fail _ _ err -> ([], Just err) + first bs = case A.parse (lexemeChar ']') bs of + A.Done _ _ -> ([], Nothing) + A.Fail _ _ _ -> go bs + go bs = case A.parse valueEnd bs of + A.Done _ (r, False) -> ([r], Nothing) + A.Done bs' (r, True) -> case go bs' of + ~(rs, end) -> (r:rs, end) + A.Fail _ _ err -> ([], Just err) + valueEnd = do + v <- value + c <- True <$ lexemeChar ',' <|> False <$ lexemeChar ']' + return (v, c) + lexemeChar c = many A8.space *> A8.char c <* many A8.space + +-- | Lazyly parse 'LBS.ByteString' with top-level JSON array. +-- +-- /Note:/ inspecting result's second field will force the list! +-- +-- @ +-- let ~(values, err) = 'streamDecode' bs +-- traverse_ processValue values +-- maybe (pure ()) printError err +-- @ +-- +-- @since 0.3.2.0 +streamDecode :: forall a. FromJSON a => LBS.ByteString -> ([a], Maybe String) +streamDecode bs = go values + where + (values, err) = streamParse bs + go :: [Value] -> ([a], Maybe String) + go [] = ([], err) + go (v:vs) = case fromJSON v of + Error err' -> ([], Just err') + Success x -> case go vs of + ~(xs, err') -> (x:xs, err') diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -47,7 +47,8 @@ , utctimeTests , zonedtimeTests , timeTHTests - , mergeTests + , mergeTests + , streamTests ] ------------------------------------------------------------------------------ @@ -143,6 +144,39 @@ in prop ] +------------------------------------------------------------------------------- +-- Stream +------------------------------------------------------------------------------- + +streamTests :: TestTree +streamTests = testGroup "stream" + [ streamDecodeTests + ] + where + streamDecodeTests = testGroup "decode" $ + map (uncurry validTestCase) valids ++ + [ testCase "ws: empty" $ streamDecode " [ ] " @?= ([] :: [Int], Nothing) + , testCase "ws: singleton" $ streamDecode " [ 1 ]" @?= ([1] :: [Int], Nothing) + , testCase "ws: many" $ streamDecode " [ 1 , 2, 3 ] " @?= ([1,2,3] :: [Int], Nothing) + -- Errors: + , testCase "error begin" $ streamDecode' "," @?= ([] :: [Int], True) + , testCase "parses first" $ streamDecode' "[1,2,3[" @?= ([1,2] :: [Int], True) + , testCase "error begin" $ streamDecode' "[1,2,'a']" @?= ([1,2] :: [Int], True) + ] + + validTestCase name value = + testCase ("valid " ++ name) $ streamDecode (encode value) @?= (value, Nothing) + + streamDecode' = fmap isJust . streamDecode + + valids :: [(String, [Int])] + valids = + [ (,) "empty" [] + , (,) "singleton" [1] + , (,) "many" [1..200] + ] + + ------------------------------------------------------------------------------ -- Comparison (.:?) and (.:!) ------------------------------------------------------------------------------ @@ -235,7 +269,7 @@ where f (These x y) = r x y f (This x) = x f (That x) = x - + mergeTests :: TestTree mergeTests = testGroup "Lodash merge examples" $ map f examples where