aeson-extra-0.4.0.0/0000755000000000000000000000000012772162124012271 5ustar0000000000000000aeson-extra-0.4.0.0/aeson-extra.cabal0000644000000000000000000000533012772162124015504 0ustar0000000000000000name: aeson-extra version: 0.4.0.0 synopsis: Extra goodies for aeson description: Package provides extra funcitonality on top of @aeson@ and @aeson-compat@ category: Web homepage: https://github.com/phadej/aeson-extra#readme bug-reports: https://github.com/phadej/aeson-extra/issues author: Oleg Grenrus maintainer: Oleg Grenrus license: BSD3 license-file: LICENSE tested-with: GHC==7.6.3, GHC==7.8.4, GHC==7.10.3, GHC==8.0.1 build-type: Simple cabal-version: >= 1.10 extra-source-files: CHANGELOG.md README.md source-repository head type: git location: https://github.com/phadej/aeson-extra library hs-source-dirs: src ghc-options: -Wall build-depends: base >=4.6 && <4.10 , aeson >=0.7.0.6 && <1.1 , 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 , exceptions >=0.8 && <0.9 , hashable >=1.2 && <1.3 , parsec >=3.1.9 && <3.2 , recursion-schemes >=4.1.2 && <5.1 , scientific >=0.3 && <0.4 , template-haskell >=2.8 && <2.12 , text >=1.2 && <1.3 , time >=1.4.2 && <1.7 , time-parsers >=0.1.0.0 && <0.2 , unordered-containers >=0.2 && <0.3 , vector >=0.10 && <0.12 if impl(ghc >= 7.8) exposed-modules: Data.Aeson.Extra.SingObject Data.Aeson.Extra.SymTag exposed-modules: Data.Aeson.Extra Data.Aeson.Extra.CollapsedList Data.Aeson.Extra.Foldable Data.Aeson.Extra.Map Data.Aeson.Extra.Merge Data.Aeson.Extra.Stream Data.Aeson.Extra.Time Data.Aeson.Extra.TH default-language: Haskell2010 test-suite aeson-extra-test type: exitcode-stdio-1.0 main-is: Tests.hs hs-source-dirs: test ghc-options: -Wall build-depends: base >=4.6 && <4.10 , aeson-extra >=0.4 && <0.5 , containers >=0.5 && <0.6 , 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 , vector >=0.10 && <0.12 , tasty >=0.10 && <0.12 , tasty-hunit >=0.9 && <0.10 , tasty-quickcheck >=0.8 && <0.9 , quickcheck-instances >=0.3 && <0.4 other-modules: Orphans default-language: Haskell2010 aeson-extra-0.4.0.0/CHANGELOG.md0000644000000000000000000000220012772162124014074 0ustar0000000000000000# 0.4.0.0 - `aeson-1` related changes: - `SingObject` and `CollapsedList` changes - deprecated `Map` module # 0.3.2.0 - Add `Data.Aeson.Extra.Stream` with `streamDecode` # 0.3.1.1 (2016-02-09) - Support aeson-0.11 # 0.3.1.0 (2015-12-27) - Add `Data.Aeson.Extra.TH` - Add `Data.Aeson.Extra.Foldable` - Add `Data.Aeson.Extra.Merge` # 0.3.0.1 (2016-01-26) - Support `quickcheck-instances >=0.3.12` # 0.3.0.0 (2015-12-25) - `Data.Time.TH` moved to [`time-parsers`](http://hackage.haskell.org/package/time-parsers) - `Data.Aeson.Compat` moved to [`aeson-compat`](http://hackage.haskell.org/package/aeson-compat) - The modules aren't re-exported, as that would require `Cabal >= 1.21` restriction # 0.2.3.0 (2015-12-08) - `Data.Time.TH` module with `mkUTCTime` - `encodeStrict` in `Data.Aeson.Extra` # 0.2.2.0 (2015-11-10) - `U` and `Z` to parse `UTCTime` and `ZonedTime` compatibly - Orphans `FromJSON` for `Day` and `LocalTime` # 0.2.1.0 (2015-10-05) GHC 7.6 Support - No `SymTag` or `SingObject` support # 0.2.0.0 (2015-09-29) No ListLike - Make `CollapsedList` use typeclasses in `base` # 0.1.0.0 (2015-09-29) Initial release aeson-extra-0.4.0.0/LICENSE0000644000000000000000000000276212772162124013305 0ustar0000000000000000Copyright (c) 2015, Oleg Grenrus All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * 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. * Neither the name of Oleg Grenrus nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT OWNER 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. aeson-extra-0.4.0.0/README.md0000644000000000000000000000123012772162124013544 0ustar0000000000000000# aeson-extra [![Build Status](https://travis-ci.org/phadej/aeson-extra.svg?branch=master)](https://travis-ci.org/phadej/aeson-extra) [![Hackage](https://img.shields.io/hackage/v/aeson-extra.svg)](http://hackage.haskell.org/package/aeson-extra) [![Stackage LTS 3](http://stackage.org/package/aeson-extra/badge/lts-3)](http://stackage.org/lts-3/package/aeson-extra) [![Stackage Nightly](http://stackage.org/package/aeson-extra/badge/nightly)](http://stackage.org/nightly/package/aeson-extra) Package provides extra funcitonality on top of [`aeson`](https://hackage.haskell.org/package/aeson) and [`aeson-compat`](https://hackage.haskell.org/package/aeson-compat) aeson-extra-0.4.0.0/Setup.hs0000644000000000000000000000005612772162124013726 0ustar0000000000000000import Distribution.Simple main = defaultMain aeson-extra-0.4.0.0/src/0000755000000000000000000000000012772162124013060 5ustar0000000000000000aeson-extra-0.4.0.0/src/Data/0000755000000000000000000000000012772162124013731 5ustar0000000000000000aeson-extra-0.4.0.0/src/Data/Aeson/0000755000000000000000000000000012772162124014776 5ustar0000000000000000aeson-extra-0.4.0.0/src/Data/Aeson/Extra.hs0000644000000000000000000000322412772162124016416 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Aeson.Extra -- Copyright : (C) 2015-2016 Oleg Grenrus -- License : BSD3 -- Maintainer : Oleg Grenrus -- -- More or less useful newtypes for writing 'FromJSON' & 'ToJSON' instances module Data.Aeson.Extra ( -- * Strict encoding encodeStrict, -- * Generic maps M(..), FromJSONKey(..), parseIntegralJSONKey, FromJSONMap(..), ToJSONKey(..), ToJSONMap(..), #if MIN_VERSION_base(4,7,0) -- * Symbol tag SymTag(..), -- * Singleton object SingObject(..), mkSingObject, getSingObject, #endif -- * CollapsedList CollapsedList(..), getCollapsedList, parseCollapsedList, -- * UTCTime U(..), Z(..), -- * Algebra ValueF(..), ObjectF, ArrayF, -- * Merge merge, -- * Stream streamDecode, -- * Template Haskell mkValue, mkValue', -- * Re-exports module Data.Aeson.Compat, ) where import Prelude () import Prelude.Compat import Data.Aeson.Compat import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Aeson.Extra.CollapsedList 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 #if MIN_VERSION_base(4,7,0) import Data.Aeson.Extra.SingObject import Data.Aeson.Extra.SymTag #endif -- | Like 'encode', but produces strict 'BS.ByteString'. -- -- /Since: 0.2.3.0/ encodeStrict :: ToJSON a => a -> BS.ByteString encodeStrict = LBS.toStrict . encode aeson-extra-0.4.0.0/src/Data/Aeson/Extra/0000755000000000000000000000000012772162124016061 5ustar0000000000000000aeson-extra-0.4.0.0/src/Data/Aeson/Extra/CollapsedList.hs0000644000000000000000000001300412772162124021155 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Aeson.Extra.CollapsedList -- Copyright : (C) 2015-2016 Oleg Grenrus -- License : BSD3 -- Maintainer : Oleg Grenrus -- -- Note: the contexts of functions are different with @aeson-1@. module Data.Aeson.Extra.CollapsedList ( CollapsedList(..), getCollapsedList, parseCollapsedList, )where import Prelude () import Prelude.Compat import Control.Applicative (Alternative (..)) import Data.Aeson.Compat import Data.Aeson.Types hiding ((.:?)) import Data.Text (Text) #if __GLASGOW_HASKELL__ >= 708 import Data.Typeable (Typeable) #endif import qualified Data.Foldable as Foldable import qualified Data.HashMap.Strict as H #if MIN_VERSION_aeson(0,10,0) import qualified Data.Text as T #endif -- | Collapsed list, singleton is represented as the value itself in JSON encoding. -- -- > λ > decode "null" :: Maybe (CollapsedList [Int] Int) -- > Just (CollapsedList []) -- > λ > decode "42" :: Maybe (CollapsedList [Int] Int) -- > Just (CollapsedList [42]) -- > λ > decode "[1, 2, 3]" :: Maybe (CollapsedList [Int] Int) -- > Just (CollapsedList [1,2,3]) -- -- > λ > encode (CollapsedList ([] :: [Int])) -- > "null" -- > λ > encode (CollapsedList ([42] :: [Int])) -- > "42" -- > λ > encode (CollapsedList ([1, 2, 3] :: [Int])) -- > "[1,2,3]" -- -- Documentation rely on @f@ 'Alternative' instance behaving like lists'. newtype CollapsedList f a = CollapsedList (f a) deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable #if __GLASGOW_HASKELL__ >= 708 , Typeable #endif ) getCollapsedList :: CollapsedList f a -> f a getCollapsedList (CollapsedList l) = l #if MIN_VERSION_aeson(1,0,0) instance (FromJSON1 f, Alternative f) => FromJSON1 (CollapsedList f) where liftParseJSON p _ v = CollapsedList <$> case v of Null -> pure Control.Applicative.empty Array _ -> liftParseJSON p (listParser p) v x -> pure <$> p x instance (ToJSON1 f, Foldable f) => ToJSON1 (CollapsedList f) where liftToEncoding to _ (CollapsedList l) = case l' of [] -> toEncoding Null [x] -> to x _ -> liftToEncoding to (listEncoding to) l where l' = Foldable.toList l liftToJSON to _ (CollapsedList l) = case l' of [] -> toJSON Null [x] -> to x _ -> liftToJSON to (listValue to) l where l' = Foldable.toList l instance (ToJSON1 f, Foldable f, ToJSON a) => ToJSON (CollapsedList f a) where toJSON = toJSON1 toEncoding = toEncoding1 instance (FromJSON1 f, Alternative f, FromJSON a) => FromJSON (CollapsedList f a) where parseJSON = parseJSON1 -- | Parses possibly collapsed array value from the object's field. -- -- > λ > newtype V = V [Int] deriving (Show) -- > λ > instance FromJSON V where parseJSON = withObject "V" $ \obj -> V <$> parseCollapsedList obj "value" -- > λ > decode "{}" :: Maybe V -- > Just (V []) -- > λ > decode "{\"value\": null}" :: Maybe V -- > Just (V []) -- > λ > decode "{\"value\": 42}" :: Maybe V -- > Just (V [42]) -- > λ > decode "{\"value\": [1, 2, 3, 4]}" :: Maybe V -- > Just (V [1,2,3,4]) parseCollapsedList :: (FromJSON a, FromJSON1 f, Alternative f) => Object -> Text -> Parser (f a) parseCollapsedList obj key = case H.lookup key obj of Nothing -> pure Control.Applicative.empty Just v -> modifyFailure addKeyName $ (getCollapsedList <$> parseJSON v) -- Key key where addKeyName = (mappend ("failed to parse field " `mappend` T.unpack key `mappend`": ")) #else instance (FromJSON a, FromJSON (f a), Alternative f) => FromJSON (CollapsedList f a) where parseJSON Null = pure (CollapsedList Control.Applicative.empty) parseJSON v@(Array _) = CollapsedList <$> parseJSON v parseJSON v = CollapsedList . pure <$> parseJSON v instance (ToJSON a, ToJSON (f a), Foldable f) => ToJSON (CollapsedList f a) where #if MIN_VERSION_aeson (0,10,0) toEncoding (CollapsedList l) = case Foldable.toList l of [] -> toEncoding Null [x] -> toEncoding x _ -> toEncoding l #endif toJSON (CollapsedList l) = case Foldable.toList l of [] -> toJSON Null [x] -> toJSON x _ -> toJSON l -- | Parses possibly collapsed array value from the object's field. -- -- > λ > newtype V = V [Int] deriving (Show) -- > λ > instance FromJSON V where parseJSON = withObject "V" $ \obj -> V <$> parseCollapsedList obj "value" -- > λ > decode "{}" :: Maybe V -- > Just (V []) -- > λ > decode "{\"value\": null}" :: Maybe V -- > Just (V []) -- > λ > decode "{\"value\": 42}" :: Maybe V -- > Just (V [42]) -- > λ > decode "{\"value\": [1, 2, 3, 4]}" :: Maybe V -- > Just (V [1,2,3,4]) parseCollapsedList :: (FromJSON a, FromJSON (f a), Alternative f) => Object -> Text -> Parser (f a) parseCollapsedList obj key = case H.lookup key obj of Nothing -> pure Control.Applicative.empty #if MIN_VERSION_aeson(0,10,0) Just v -> modifyFailure addKeyName $ (getCollapsedList <$> parseJSON v) -- Key key where addKeyName = (mappend ("failed to parse field " `mappend` T.unpack key `mappend`": ")) #else Just v -> getCollapsedList <$> parseJSON v #endif #endif aeson-extra-0.4.0.0/src/Data/Aeson/Extra/Foldable.hs0000644000000000000000000000440012772162124020123 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Aeson.Extra.Foldable -- Copyright : (C) 2015-2016 Oleg Grenrus -- License : BSD3 -- Maintainer : Oleg Grenrus -- -- Helps writing recursive algorithms on 'Value', for example: -- -- @ -- stripNulls :: Value -> Value -- stripNulls = 'cata' ('embed' . f) -- where -- f (ObjectF a) = ObjectF $ HM.filter (== Null) a -- f x = x -- @ module Data.Aeson.Extra.Foldable ( ValueF(..), ObjectF, ArrayF, ) where import Prelude () import Prelude.Compat import Data.Aeson.Compat import Data.Data (Data) import Data.Functor.Foldable import Data.HashMap.Strict (HashMap) import Data.Scientific (Scientific) import Data.Text (Text) import Data.Typeable (Typeable) import Data.Vector (Vector) #if !(MIN_VERSION_recursion_schemes(5,0,0)) #define Recursive F.Foldable #define Corecursive F.Unfoldable import qualified Data.Functor.Foldable as F #endif -- | A JSON \"object\" (key\/value map). -- -- /Since: aeson-extra-0.3.1.0/ type ObjectF a = HashMap Text a -- | A JSON \"array\" (sequence). -- -- /Since: aeson-extra-0.3.1.0/ type ArrayF a = Vector a -- | An algebra of 'Value' -- -- /Since: aeson-extra-0.3.1.0/ data ValueF a = ObjectF (ObjectF a) | ArrayF !(ArrayF a) | StringF !Text | NumberF !Scientific | BoolF !Bool | NullF deriving (Eq, Read, Show, Typeable, Data, Functor, Prelude.Compat.Foldable, Traversable) type instance Base Value = ValueF instance Recursive Value where project (Object o) = ObjectF o project (Array a) = ArrayF a project (String s) = StringF s project (Number n) = NumberF n project (Bool b) = BoolF b project Null = NullF instance Corecursive Value where embed (ObjectF o) = Object o embed (ArrayF a) = Array a embed (StringF s) = String s embed (NumberF n) = Number n embed (BoolF b) = Bool b embed NullF = Null aeson-extra-0.4.0.0/src/Data/Aeson/Extra/Map.hs0000644000000000000000000000725412772162124017142 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Aeson.Extra.Map -- Copyright : (C) 2015-2016 Oleg Grenrus -- License : BSD3 -- Maintainer : Oleg Grenrus -- -- More or less useful newtypes for writing 'FromJSON' & 'ToJSON' instances module Data.Aeson.Extra.Map {-# DEPRECATED "Use aeson-1 TOJSONKey etc functionality" #-} ( M(..), FromJSONKey(..), parseIntegralJSONKey, FromJSONMap(..), ToJSONKey(..), ToJSONMap(..), ) where import Prelude () import Prelude.Compat import Data.Aeson.Compat (ToJSON (..), FromJSON (..), Value (..), withObject) import Data.Aeson.Types (Parser) import Data.Hashable (Hashable) import Data.Monoid ((<>)) import Data.Text (Text) import Data.Typeable (Typeable) import qualified Data.HashMap.Strict as H import qualified Data.Map as Map import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Read as T -- | A wrapper type to parse arbitrary maps -- -- > λ > decode "{\"1\": 1, \"2\": 2}" :: Maybe (M (H.HashMap Int Int)) -- > Just (M {getMap = fromList [(1,1),(2,2)]}) newtype M a = M { getMap :: a } deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable, Typeable) {-# DEPRECATED M "Use aeson-1 TOJSONKey etc functionality" #-} class FromJSONKey a where parseJSONKey :: Text -> Parser a instance FromJSONKey Text where parseJSONKey = pure instance FromJSONKey TL.Text where parseJSONKey = pure . TL.fromStrict instance FromJSONKey String where parseJSONKey = pure . T.unpack instance FromJSONKey Int where parseJSONKey = parseIntegralJSONKey instance FromJSONKey Integer where parseJSONKey = parseIntegralJSONKey parseIntegralJSONKey :: Integral a => Text -> Parser a parseIntegralJSONKey t = case (T.signed T.decimal) t of Right (v, left) | T.null left -> pure v | otherwise -> fail $ "Garbage left: " <> T.unpack left Left err -> fail err class FromJSONMap m k v | m -> k v where parseJSONMap :: H.HashMap Text Value -> Parser m instance (Eq k, Hashable k, FromJSONKey k, FromJSON v) => FromJSONMap (H.HashMap k v) k v where parseJSONMap = fmap H.fromList . traverse f . H.toList where f (k, v) = (,) <$> parseJSONKey k <*> parseJSON v instance (Ord k, FromJSONKey k, FromJSON v) => FromJSONMap (Map.Map k v) k v where parseJSONMap = fmap Map.fromList . traverse f . H.toList where f (k, v) = (,) <$> parseJSONKey k <*> parseJSON v instance (FromJSONMap m k v) => FromJSON (M m) where parseJSON v = M <$> withObject "Map" parseJSONMap v class ToJSONKey a where toJSONKey :: a -> Text instance ToJSONKey Text where toJSONKey = id instance ToJSONKey TL.Text where toJSONKey = TL.toStrict instance ToJSONKey String where toJSONKey = T.pack instance ToJSONKey Int where toJSONKey = T.pack . show instance ToJSONKey Integer where toJSONKey = T.pack . show class ToJSONMap m k v | m -> k v where toJSONMap :: m -> H.HashMap Text Value instance (ToJSONKey k, ToJSON v) => ToJSONMap (H.HashMap k v) k v where toJSONMap = H.fromList . fmap f . H.toList where f (k, v) = (toJSONKey k, toJSON v) instance (ToJSONKey k, ToJSON v) => ToJSONMap (Map.Map k v) k v where toJSONMap = H.fromList . fmap f . Map.toList where f (k, v) = (toJSONKey k, toJSON v) instance (ToJSONMap m k v) => ToJSON (M m) where toJSON (M m) = Object (toJSONMap m) aeson-extra-0.4.0.0/src/Data/Aeson/Extra/Merge.hs0000644000000000000000000000300712772162124017454 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Aeson.Extra.Merge -- Copyright : (C) 2015-2016 Oleg Grenrus -- License : BSD3 -- Maintainer : Oleg Grenrus -- module Data.Aeson.Extra.Merge ( merge, mergeA, ValueF(..), ObjectF, ArrayF, ) where import Prelude () import Prelude.Compat import Data.Aeson.Compat import Data.Aeson.Extra.Foldable import Data.Functor.Foldable (project, embed) -- | Generic merge. -- -- For example : -- -- @ -- lodashMerge :: Value -> Value -> Value -- lodashMerge x y = merge lodashMergeAlg x y -- -- lodashMergeAlg :: (a -> a -> a) -> ValueF a -> ValueF a -> ValueF a -- lodashMergeAlg r a' b' = case (a', b') of -- (ObjectF a, ObjectF b) -> ObjectF $ alignWith f a b -- (ArrayF a, ArrayF b) -> ArrayF $ alignWith f a b -- (_, b) -> b -- where f (These x y) = r x y -- f (This x) = x -- f (That x) = x -- @ -- -- /Since: aeson-extra-0.3.1.0/ merge :: (forall a. (a -> a -> a) -> ValueF a -> ValueF a -> ValueF a) -> Value -> Value -> Value merge f a b = embed $ f (merge f) (project a) (project b) -- | Generic merge, in arbitrary context. -- -- /Since: aeson-extra-0.3.1.0/ mergeA :: Functor f => (forall a. (a -> a -> f a) -> ValueF a -> ValueF a -> f (ValueF a)) -> Value -> Value -> f Value mergeA f a b = embed <$> f (mergeA f) (project a) (project b) aeson-extra-0.4.0.0/src/Data/Aeson/Extra/SingObject.hs0000644000000000000000000000577012772162124020455 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Aeson.Extra.SymTag -- Copyright : (C) 2015-2016 Oleg Grenrus -- License : BSD3 -- Maintainer : Oleg Grenrus -- module Data.Aeson.Extra.SingObject ( SingObject(..), mkSingObject, getSingObject, ) where import Prelude () import Prelude.Compat import Data.Aeson.Compat import Data.Monoid ((<>)) import Data.Proxy import Data.Typeable (Typeable) import GHC.TypeLits import qualified Data.Text as T #if MIN_VERSION_aeson(1,0,0) import Data.Aeson.Internal (JSONPathElement (Key), ()) import Data.Aeson.Encoding (pair) import Data.Aeson.Types hiding ((.:?)) import qualified Data.HashMap.Strict as HM #endif -- | Singleton value object -- -- > λ > decode "{\"value\": 42 }" :: Maybe (SingObject "value" Int) -- > Just (SingObject 42) -- -- > λ > encode (SingObject 42 :: SingObject "value" Int) -- > "{\"value\":42}" -- -- /Available with: base >=4.7/ newtype SingObject (s ::Symbol) a = SingObject a deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable, Typeable) mkSingObject :: Proxy s -> a -> SingObject s a mkSingObject _ = SingObject getSingObject :: Proxy s -> SingObject s a -> a getSingObject _ (SingObject x) = x #if MIN_VERSION_aeson(1,0,0) instance KnownSymbol s => FromJSON1 (SingObject s) where liftParseJSON p _ = withObject ("SingObject "<> show key) $ \obj -> case HM.lookup key obj of Nothing -> fail $ "key " ++ show key ++ " not present" Just v -> SingObject <$> p v Key key where key = T.pack $ symbolVal (Proxy :: Proxy s) instance KnownSymbol s => ToJSON1 (SingObject s) where liftToJSON to _ (SingObject x) = object [ key .= to x] where key = T.pack $ symbolVal (Proxy :: Proxy s) liftToEncoding to _ (SingObject x) = pairs $ pair key $ to x where key = T.pack $ symbolVal (Proxy :: Proxy s) instance (KnownSymbol s, FromJSON a) => FromJSON (SingObject s a) where parseJSON = parseJSON1 instance (KnownSymbol s, ToJSON a) => ToJSON (SingObject s a) where toJSON = toJSON1 toEncoding = toEncoding1 #else instance (KnownSymbol s, FromJSON a) => FromJSON (SingObject s a) where parseJSON = withObject ("SingObject "<> show key) $ \obj -> SingObject <$> obj .: T.pack key where key = symbolVal (Proxy :: Proxy s) instance (KnownSymbol s, ToJSON a) => ToJSON (SingObject s a) where #if MIN_VERSION_aeson(0,10,0) toEncoding (SingObject x) = pairs (T.pack key .= x) where key = symbolVal (Proxy :: Proxy s) #endif toJSON (SingObject x) = object [T.pack key .= x] where key = symbolVal (Proxy :: Proxy s) #endif aeson-extra-0.4.0.0/src/Data/Aeson/Extra/Stream.hs0000644000000000000000000000404512772162124017653 0ustar0000000000000000{-# 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') aeson-extra-0.4.0.0/src/Data/Aeson/Extra/SymTag.hs0000644000000000000000000000264012772162124017623 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Aeson.Extra.SymTag -- Copyright : (C) 2015-2016 Oleg Grenrus -- License : BSD3 -- Maintainer : Oleg Grenrus -- module Data.Aeson.Extra.SymTag ( SymTag(..), ) where import Prelude () import Prelude.Compat import Data.Aeson.Compat import Data.Aeson.Types hiding ((.:?)) import Data.Proxy import GHC.TypeLits import qualified Data.Text as T -- | Singleton string encoded and decoded as ifself. -- -- > λ> encode (SymTag :: SymTag "foobar") -- > "\"foobar\"" -- -- > decode "\"foobar\"" :: Maybe (SymTag "foobar") -- > Just SymTag -- -- > decode "\"foobar\"" :: Maybe (SymTag "barfoo") -- > Nothing -- -- /Available with: base >=4.7/ data SymTag (s :: Symbol) = SymTag deriving (Eq, Ord, Show, Read, Enum, Bounded) instance KnownSymbol s => FromJSON (SymTag s) where parseJSON (String t) | T.unpack t == symbolVal (Proxy :: Proxy s) = pure SymTag parseJSON v = typeMismatch ("SymTag " ++ show (symbolVal (Proxy :: Proxy s))) v instance KnownSymbol s => ToJSON (SymTag s) where #if MIN_VERSION_aeson (0,10,0) toEncoding _ = toEncoding (symbolVal (Proxy :: Proxy s)) #endif toJSON _ = toJSON (symbolVal (Proxy :: Proxy s)) aeson-extra-0.4.0.0/src/Data/Aeson/Extra/TH.hs0000644000000000000000000000437412772162124016740 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Aeson.Extra.TH -- Copyright : (C) 2015-2016 Oleg Grenrus -- License : BSD3 -- Maintainer : Oleg Grenrus -- -- In addition to 'mkValue' and 'mkValue'' helpers, -- this module exports 'Lift' 'Value' orphan instance for aeson <0.11 module Data.Aeson.Extra.TH ( mkValue, mkValue', ) where import Data.Aeson.Compat import qualified Data.Text as T import qualified Data.Text.Encoding as TE import Language.Haskell.TH #if !MIN_VERSION_aeson_compat(0,3,5) import Data.Aeson.Types (Parser) #endif #if !MIN_VERSION_aeson(0,11,0) import Control.Arrow (first) import qualified Data.HashMap.Strict as HM import Data.Scientific (base10Exponent, coefficient, scientific) import qualified Data.Vector as V import Language.Haskell.TH.Syntax (Lift (..)) #endif -- | Create a 'Value' from string representation. -- -- This is useful in tests. -- -- /Since: aeson-extra-0.3.1.0/ mkValue :: String -> Q Exp mkValue s = case eitherDecodeStrict' bs :: Either String Value of Left err -> fail $ "mkValue: " ++ err Right v -> [| v |] where bs = TE.encodeUtf8 $ T.pack s -- | Like 'mkValue', but replace single quotes with double quotes before. -- -- > > $(mkValue' "{'a': 2 }") -- > Object (fromList [("a",Number 2.0)]) -- -- /Since: aeson-extra-0.3.1.0/ mkValue' :: String -> Q Exp mkValue' = mkValue . map f where f '\'' = '"' f x = x #if !MIN_VERSION_aeson(0,11,0) -- | From 'aeson-extra' -- -- /Since: aeson-extra-0.3.1.0/ instance Lift Value where lift Null = [| Null |] lift (Bool b) = [| Bool b |] lift (Number n) = [| Number (scientific c e) |] where c = coefficient n e = base10Exponent n lift (String t) = [| String (T.pack s) |] where s = T.unpack t lift (Array a) = [| Array (V.fromList a') |] where a' = V.toList a lift (Object o) = [| Object (HM.fromList . map (first T.pack) $ o') |] where o' = map (first T.unpack) . HM.toList $ o #endif aeson-extra-0.4.0.0/src/Data/Aeson/Extra/Time.hs0000644000000000000000000000436412772162124017322 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Aeson.Extra.Time -- Copyright : (C) 2015-2016 Oleg Grenrus -- License : BSD3 -- Maintainer : Oleg Grenrus -- -- Time tools module Data.Aeson.Extra.Time ( U(..), Z(..), )where import Prelude () import Prelude.Compat import Data.Aeson.Compat import Data.Time (UTCTime, ZonedTime) import Data.Typeable (Typeable) #if !MIN_VERSION_aeson (0,10,0) import Data.Text (Text) #if !MIN_VERSION_aeson_compat(0,3,5) import Data.Aeson.Types (Parser) #endif import qualified Data.Time.Parsers as TimeParsers import qualified Text.Parsec as Parsec #endif -- | A type to parse 'UTCTime' -- -- 'FromJSON' instance accepts for example: -- -- @ -- 2015-09-07T08:16:40.807Z -- 2015-09-07 11:16:40.807 +03:00 -- @ -- -- Latter format is accepted by @aeson@ staring from version @0.10.0.0@. -- -- See -- -- /Since: aeson-extra-0.2.2.0/ newtype U = U { getU :: UTCTime } deriving (Eq, Ord, Show, Read, Typeable) instance ToJSON U where toJSON = toJSON . getU #if MIN_VERSION_aeson (0,10,0) toEncoding = toEncoding . getU #endif instance FromJSON U where #if MIN_VERSION_aeson (0,10,0) parseJSON = fmap U . parseJSON #else parseJSON = withText "UTCTime" (fmap U . run TimeParsers.utcTime) #endif -- | A type to parse 'ZonedTime' -- -- /Since: aeson-extra-0.2.2.0/ newtype Z = Z { getZ :: ZonedTime } deriving (Show, Read, Typeable) instance ToJSON Z where toJSON = toJSON . getZ #if MIN_VERSION_aeson (0,10,0) toEncoding = toEncoding . getZ #endif instance FromJSON Z where #if MIN_VERSION_aeson (0,10,0) parseJSON = fmap Z . parseJSON #else parseJSON = withText "ZonedTime" (fmap Z . run TimeParsers.zonedTime) #endif #if !MIN_VERSION_aeson (0,10,0) -- | Run a 'parsers' parser as an aeson parser. run :: Parsec.Parsec Text () a -> Text -> Parser a run p t = case Parsec.parse (p <* Parsec.eof) "" t of Left err -> fail $ "could not parse date: " ++ show err Right r -> return r #endif aeson-extra-0.4.0.0/test/0000755000000000000000000000000012772162124013250 5ustar0000000000000000aeson-extra-0.4.0.0/test/Orphans.hs0000644000000000000000000000062312772162124015217 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Orphans where #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif #if !MIN_VERSION_quickcheck_instances(0,3,12) import Data.Vector as V import Test.Tasty.QuickCheck instance Arbitrary a => Arbitrary (Vector a) where arbitrary = V.fromList <$> arbitrary shrink = fmap V.fromList . shrink . V.toList #endif aeson-extra-0.4.0.0/test/Tests.hs0000644000000000000000000002436312772162124014716 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} module Main (main) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif import Data.Map (Map) import Data.Maybe (isJust) import Data.String (fromString) import Data.Time (zonedTimeToUTC, UTCTime(..), Day(..)) import Data.Vector (Vector) import Test.QuickCheck.Instances () import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck import Data.These (These (..)) import Data.Align (alignWith) import qualified Data.HashMap.Lazy as H #if MIN_VERSION_base(4,7,0) import Data.Proxy #endif import Data.Aeson.Extra import Data.Time.TH import Orphans () main :: IO () main = defaultMain $ testGroup "Tests" [ dotColonMark , encodeStrictTests , mTests #if MIN_VERSION_base(4,7,0) , symTests , singObjectTests #endif , collapsedListTests , utctimeTests , zonedtimeTests , timeTHTests , mergeTests , streamTests ] ------------------------------------------------------------------------------ -- encodeStrict ------------------------------------------------------------------------------ encodeStrictTests :: TestTree encodeStrictTests = testGroup "encodeStrict" [ testProperty "decodeStrict . encodeStrict" prop ] where prop :: Int -> Property prop i = let lhs = decodeStrict . encodeStrict $ i rhs = Just i in lhs === rhs ------------------------------------------------------------------------------ -- M ------------------------------------------------------------------------------ mTests :: TestTree mTests = testGroup "M" [ testCase "decode" $ let lhs = decode "{\"1\": 1, \"2\": 2}" :: Maybe (M (H.HashMap Int Int)) rhs = Just result in lhs @?= rhs , testProperty "decode . encode" $ let prop :: Map Int Int -> Property prop m = let lhs = fmap getMap . decode . encode . M $ m rhs = Just m in lhs === rhs in prop ] where result = M $ H.fromList [(1,1),(2,2)] #if MIN_VERSION_base(4,7,0) ------------------------------------------------------------------------------ -- SymTag ------------------------------------------------------------------------------ symTests :: TestTree symTests = testGroup "SymTag" [ testCase "encode" $ encode (SymTag :: SymTag "foobar") @?= "\"foobar\"" , testCase "decode success" $ (decode "\"foobar\"" :: Maybe (SymTag "foobar")) @?= Just SymTag , testCase "decode failure" $ (decode "\"foobar\"" :: Maybe (SymTag "barfoo")) @?= Nothing ] ------------------------------------------------------------------------------ -- SingObject ------------------------------------------------------------------------------ -- > λ > decode "{\"value\": 42 }" :: Maybe (SingObject "value" Int) -- > Just (SingObject 42) singObjectTests :: TestTree singObjectTests = testGroup "SingObject" [ testCase "decode success" $ (decode "{\"value\": 42 }" :: Maybe (SingObject "value" Int)) @?= Just (SingObject 42) , testCase "decode failure" $ (decode "{\"value\": 42 }" :: Maybe (SingObject "key" Int)) @?= Nothing , testProperty "decode . encode" $ let prop :: Int -> Property prop n = let rhs = fmap (getSingObject p) . decode . encode . mkSingObject p $ n lhs = Just n in lhs === rhs p :: Proxy "value" p = Proxy in prop ] #endif ------------------------------------------------------------------------------ -- parseCollapsedList ------------------------------------------------------------------------------ newtype V = V [Int] deriving (Show, Eq) instance FromJSON V where parseJSON = withObject "V" $ \obj -> V <$> parseCollapsedList obj "value" collapsedListTests :: TestTree collapsedListTests = testGroup "collapsedList" [ testCase "empty" $ (decode "{}" :: Maybe V) @?= Just (V []) , testCase "null" $ (decode "{\"value\": null}" :: Maybe V) @?= Just (V []) , testCase "singleton" $ (decode "{\"value\": 42}" :: Maybe V) @?= Just (V [42]) , testCase "array" $ (decode "{\"value\": [1, 2, 3, 4]}" :: Maybe V) @?= Just (V [1,2,3,4]) , testProperty "decode . encode" $ let prop :: [Int] -> Property prop l = let rhs = fmap getCollapsedList . decode . encode . CollapsedList $ l lhs = Just l in lhs === rhs in prop , testProperty "Vector decode . encode" $ let prop :: Vector Int -> Property prop l = let rhs = fmap getCollapsedList . decode . encode . CollapsedList $ l lhs = Just l in lhs === rhs 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 v = testCase ("valid " ++ name) $ streamDecode (encode v) @?= (v, Nothing) streamDecode' = fmap isJust . streamDecode valids :: [(String, [Int])] valids = [ (,) "empty" [] , (,) "singleton" [1] , (,) "many" [1..200] ] ------------------------------------------------------------------------------ -- Comparison (.:?) and (.:!) ------------------------------------------------------------------------------ newtype T1 = T1 (Maybe Int) deriving (Eq, Show) newtype T2 = T2 (Maybe Int) deriving (Eq, Show) newtype T3 = T3 (Maybe Int) deriving (Eq, Show) instance FromJSON T1 where parseJSON = fmap T1 . withObject "T1" (.: "value") instance FromJSON T2 where parseJSON = fmap T2 . withObject "T2" (.:? "value") instance FromJSON T3 where parseJSON = fmap T3 . withObject "T3" (.:! "value") dotColonMark :: TestTree dotColonMark = testGroup "Operators" $ fmap t [ assertEqual ".: not-present" Nothing (decode ex1 :: Maybe T1) , assertEqual ".: 42" (Just (T1 (Just 42))) (decode ex2 :: Maybe T1) , assertEqual ".: null" (Just (T1 Nothing)) (decode ex3 :: Maybe T1) , assertEqual ".:? not-present" (Just (T2 (Nothing))) (decode ex1 :: Maybe T2) , assertEqual ".:? 42" (Just (T2 (Just 42))) (decode ex2 :: Maybe T2) , assertEqual ".:? null" (Just (T2 Nothing)) (decode ex3 :: Maybe T2) , assertEqual ".:! not-present" (Just (T3 (Nothing))) (decode ex1 :: Maybe T3) , assertEqual ".:! 42" (Just (T3 (Just 42))) (decode ex2 :: Maybe T3) , assertEqual ".:! null" Nothing (decode ex3 :: Maybe T3) ] where ex1 = "{}" ex2 = "{\"value\": 42 }" ex3 = "{\"value\": null }" t = testCase "-" ------------------------------------------------------------------------------ -- U & Z ------------------------------------------------------------------------------ utctimeTests :: TestTree utctimeTests = testGroup "U" $ [ testCase "base case" $ assertBool "base case" $ isJust simple ] ++ map t timeStrings where simple = decode "\"2015-09-07T08:16:40.807Z\"" :: Maybe U t str = testCase str . assertEqual str simple . decode . fromString $ "\"" ++ str ++ "\"" zonedtimeTests :: TestTree zonedtimeTests = testGroup "Z" $ [ testCase "base case" $ assertBool "base case" $ isJust simple ] ++ map t timeStrings where simple = decode "\"2015-09-07T08:16:40.807Z\"" :: Maybe Z t str = testCase str . assertEqual str (fmap z simple) . fmap z . decode . fromString $ "\"" ++ str ++ "\"" z (Z z') = zonedTimeToUTC z' timeStrings :: [String] timeStrings = [ "2015-09-07T08:16:40.807Z" , "2015-09-07T11:16:40.807+0300" , "2015-09-07 08:16:40.807Z" , "2015-09-07 08:16:40.807 Z" , "2015-09-07 08:16:40.807 +0000" , "2015-09-07 08:16:40.807 +00:00" , "2015-09-07 11:16:40.807 +03:00" , "2015-09-07 05:16:40.807 -03:00" ] timeTHTests :: TestTree timeTHTests = testCase "time TH example" $ assertBool "should be equal" $ lhs == rhs where lhs = UTCTime (ModifiedJulianDay 56789) 123.456 rhs = $(mkUTCTime "2014-05-12 00:02:03.456000Z") ------------------------------------------------------------------------------ -- Merge tests ------------------------------------------------------------------------------ lodashMerge :: Value -> Value -> Value lodashMerge x y = merge lodashMergeAlg x y lodashMergeAlg :: (a -> a -> a) -> ValueF a -> ValueF a -> ValueF a lodashMergeAlg r a' b' = case (a', b') of (ObjectF a, ObjectF b) -> ObjectF $ alignWith f a b (ArrayF a, ArrayF b) -> ArrayF $ alignWith f a b (_, b) -> b 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 f (x, y, z) = testCase "-" $ assertBool "should be equal" $ lodashMerge x y == z examples = [ (,,) $(mkValue "[1, 2, 3]") $(mkValue "[4, 5, 6, 7, 8]") $(mkValue "[4, 5, 6, 7, 8]") , (,,) $(mkValue' "{'a': 1}") $(mkValue' "{'b': 2}") $(mkValue' "{'a': 1, 'b': 2}") , (,,) $(mkValue' "{ 'data': [{ 'user': 'barney' }, { 'user': 'fred' }] }") $(mkValue' "{ 'data': [{ 'age': 36 }, { 'age': 40 }] }") $(mkValue' "{ 'data': [{ 'user': 'barney', 'age': 36 }, { 'user': 'fred', 'age': 40 }] }") ]