aeson-extra 0.2.3.0 → 0.5.1.3
raw patch · 17 files changed
Files
- CHANGELOG.md +69/−0
- README.md +5/−4
- aeson-extra.cabal +77/−69
- src/Data/Aeson/Compat.hs +0/−194
- src/Data/Aeson/Extra.hs +41/−299
- src/Data/Aeson/Extra/CollapsedList.hs +145/−0
- src/Data/Aeson/Extra/Foldable.hs +5/−0
- src/Data/Aeson/Extra/Merge.hs +60/−0
- src/Data/Aeson/Extra/Recursive.hs +98/−0
- src/Data/Aeson/Extra/SingObject.hs +114/−0
- src/Data/Aeson/Extra/Stream.hs +64/−0
- src/Data/Aeson/Extra/SymTag.hs +55/−0
- src/Data/Aeson/Extra/TH.hs +45/−0
- src/Data/Aeson/Extra/Time.hs +0/−159
- src/Data/Time/TH.hs +0/−25
- test/Orphans.hs +2/−0
- test/Tests.hs +65/−100
CHANGELOG.md view
@@ -1,3 +1,72 @@+# 0.5.1.3 (2023-07-09)++- Support `aeson-2.2.0.0`++# 0.5.1.1 (2022-06-15)++- Support `aeson-2.1.0.0`+- Drop unused package dependencies++# 0.5.1 (2021-09-10)++- Support `aeson-2.0.0.0`++# 0.5 (2021-03-22)++- Trim lower bounds+- Remove `Data.Aeson.Extra.Map` (use recent `aeson`).+- Remove `Data.Aeson.Time` (use recent `aeson`)++# 0.4.1.3 (2019-10-21)++- support semialign-1.1+- drop spurious dependency from test-suite++# 0.4.1.2 (2019-06-02)++- these-1 support++# 0.4.1.1 (2018-04-11)++- base-compat-0.10 support++# 0.4.1.0 (2017-07-24)++- GHC-8.2 support+- add `NFData SingObject` and `NFData SymTag` instances+- add `lodashMerge`+- rename `Foldable` to `Recursive` (the old module is still there).++# 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`
README.md view
@@ -2,8 +2,9 @@ [](https://travis-ci.org/phadej/aeson-extra) [](http://hackage.haskell.org/package/aeson-extra)--The package motivation is twofold:+[](http://stackage.org/lts-3/package/aeson-extra)+[](http://stackage.org/nightly/package/aeson-extra) -- provide compatibility layer for [`aeson`](http://hackage.haskell.org/package/aeson)-- provide extra combinators+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.cabal view
@@ -1,85 +1,93 @@--- This file has been generated from package.yaml by hpack version 0.8.0.------ see: https://github.com/sol/hpack+cabal-version: >=1.10+name: aeson-extra+version: 0.5.1.3+synopsis: Extra goodies for aeson+description:+ Package provides extra functionality on top of @aeson@ and @aeson-compat@ -name: aeson-extra-version: 0.2.3.0-synopsis: Extra goodies for aeson-description: The package motivation is twofold:- .- * provide compatibility layer for @aeson@- .- * provide extra combinators-category: Web-homepage: https://github.com/phadej/aeson-extra#readme-bug-reports: https://github.com/phadej/aeson-extra/issues-author: Oleg Grenrus <oleg.grenrus@iki.fi>-maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>-license: BSD3-license-file: LICENSE-tested-with: GHC==7.6.3, GHC==7.8.4, GHC==7.10.2-build-type: Simple-cabal-version: >= 1.10+category: Data, Aeson+homepage: https://github.com/phadej/aeson-extra#readme+bug-reports: https://github.com/phadej/aeson-extra/issues+author: Oleg Grenrus <oleg.grenrus@iki.fi>+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>+license: BSD3+license-file: LICENSE+tested-with:+ GHC ==7.8.4+ || ==7.10.3+ || ==8.0.2+ || ==8.2.2+ || ==8.4.4+ || ==8.6.5+ || ==8.8.4+ || ==8.10.7+ || ==9.0.2+ || ==9.2.8+ || ==9.4.5+ || ==9.6.2 +build-type: Simple extra-source-files:- CHANGELOG.md- README.md+ CHANGELOG.md+ README.md source-repository head- type: git+ type: git location: https://github.com/phadej/aeson-extra library- hs-source-dirs:- src- ghc-options: -Wall+ hs-source-dirs: src+ ghc-options: -Wall build-depends:- base >=4.6 && <4.9- , aeson >=0.7.0.6 && <0.11- , attoparsec >=0.12 && <0.14- , bytestring >=0.10 && <0.11- , containers >=0.5 && <0.6- , exceptions >=0.8 && <0.9- , hashable >=1.2 && <1.3- , scientific >=0.3 && <0.4- , template-haskell >=2.8 && <2.11- , text >=1.2 && <1.3- , time >=1.4.2 && <1.6- , unordered-containers >=0.2 && <0.3- , vector >=0.10 && <0.12+ aeson >=1.5.4.1 && <1.6 || >=2.0 && <2.3+ , attoparsec >=0.11.3.4 && <0.15+ , attoparsec-aeson >=2.1.0.0 && <2.3+ , base >=4.7 && <4.19+ , base-compat-batteries >=0.11.2 && <0.14+ , bytestring >=0.10 && <0.12+ , deepseq >=1.3 && <1.5+ , recursion-schemes >=4.1.2 && <5.3+ , scientific >=0.3 && <0.4+ , semialign >=1 && <1.4+ , template-haskell >=2.8 && <2.21+ , text >=1.2 && <1.3 || >=2.0 && <2.1+ , these >=1 && <1.3+ , unordered-containers >=0.2 && <0.3+ , vector >=0.10 && <0.14++ -- if !impl(ghc >=8.2)+ -- build-depends: bifunctors >=5.5.2 && <5.7+ exposed-modules:- Data.Aeson.Compat- Data.Aeson.Extra- Data.Time.TH- other-modules:- Data.Aeson.Extra.Time+ Data.Aeson.Extra+ Data.Aeson.Extra.CollapsedList+ Data.Aeson.Extra.Foldable+ Data.Aeson.Extra.Merge+ Data.Aeson.Extra.Recursive+ Data.Aeson.Extra.SingObject+ Data.Aeson.Extra.Stream+ Data.Aeson.Extra.SymTag+ 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+ type: exitcode-stdio-1.0+ main-is: Tests.hs+ hs-source-dirs: test+ ghc-options: -Wall build-depends:- base >=4.6 && <4.9- , aeson >=0.7.0.6 && <0.11- , attoparsec >=0.12 && <0.14- , bytestring >=0.10 && <0.11- , containers >=0.5 && <0.6- , exceptions >=0.8 && <0.9- , hashable >=1.2 && <1.3- , scientific >=0.3 && <0.4- , template-haskell >=2.8 && <2.11- , text >=1.2 && <1.3- , time >=1.4.2 && <1.6- , unordered-containers >=0.2 && <0.3- , vector >=0.10 && <0.12+ aeson , aeson-extra- , 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+ , base+ , base-compat-batteries+ , containers+ , quickcheck-instances >=0.3 && <0.4+ , tasty >=0.10 && <1.5+ , tasty-hunit >=0.9 && <0.11+ , tasty-quickcheck >=0.8 && <0.11+ , unordered-containers+ , vector++ other-modules: Orphans default-language: Haskell2010
− src/Data/Aeson/Compat.hs
@@ -1,194 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--------------------------------------------------------------------------------- |--- Module : Data.Aeson.Compat--- Copyright : (C) 2015 Oleg Grenrus--- License : BSD3--- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi>------ Compatibility notices------ * 'decode' etc. work as in @aeson >=0.9@--- * but it is generalised to work in any 'MonadThrow' (that is extra)--- * '.:?' works as in @aeson <0.10@--- * '.:!' works as '.:?' in @aeson ==0.10@-module Data.Aeson.Compat (- -- * Generic decoding functions- decode,- decode',- decodeStrict,- decodeStrict',- AesonException(..),- -- * Either decoding functions- eitherDecode, eitherDecode', eitherDecodeStrict, eitherDecodeStrict',- -- * Operators- (.:?), (.:!),- -- * Re-exports- -- | Original 'Data.Aeson..:?' operator is not re-exported- module Data.Aeson,- ) where--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif--#if MIN_VERSION_aeson(0,10,0)-import Data.Monoid-#endif--import Data.Aeson hiding- ((.:?), decode, decode', decodeStrict, decodeStrict'-#if !MIN_VERSION_aeson (0,9,0)- , eitherDecode, eitherDecode', eitherDecodeStrict, eitherDecodeStrict'-#endif- )--#if !MIN_VERSION_aeson (0,9,0)-import Data.Aeson.Parser (value, value')-import qualified Data.Attoparsec.ByteString as A-import qualified Data.Attoparsec.ByteString.Char8 as A (skipSpace)-import qualified Data.Attoparsec.Lazy as L-#endif--import Control.Monad.Catch-import Data.Aeson.Types hiding ((.:?))-import Data.ByteString as B-import Data.ByteString.Lazy as L-import qualified Data.HashMap.Strict as H-import Data.Text as T-import Data.Typeable (Typeable)--#if !MIN_VERSION_aeson(0,10,0)-import Data.Time (Day, LocalTime)-import qualified Data.Aeson.Extra.Time as ExtraTime-#endif---- | Exception thrown by 'decode' - family of functions in this module.-newtype AesonException = AesonException String- deriving (Show, Typeable)--instance Exception AesonException--eitherAesonExc :: (MonadThrow m) => Either String a -> m a-eitherAesonExc (Left err) = throwM (AesonException err)-eitherAesonExc (Right x) = return x---- | Like original 'Data.Aeson.decode' but in arbitrary 'MonadThrow'.------ Parse a top-level JSON value, i.e. also strings, numbers etc.-decode :: (FromJSON a, MonadThrow m) => L.ByteString -> m a-decode = eitherAesonExc . eitherDecode---- | Like original 'Data.Aeson.decode'' but in arbitrary 'MonadThrow'.-decode' :: (FromJSON a, MonadThrow m) => L.ByteString -> m a-decode' = eitherAesonExc . eitherDecode'---- | Like original 'Data.Aeson.decodeStrict' but in arbitrary 'MonadThrow'.-decodeStrict :: (FromJSON a, MonadThrow m) => B.ByteString -> m a-decodeStrict = eitherAesonExc . eitherDecodeStrict---- | Like original 'Data.Aeson.decodeStrict'' but in arbitrary 'MonadThrow'.-decodeStrict' :: (FromJSON a, MonadThrow m) => B.ByteString -> m a-decodeStrict' = eitherAesonExc . eitherDecodeStrict'---- | Retrieve the value associated with the given key of an 'Object'.--- The result is 'Nothing' if the key is not present, or 'empty' if--- the value cannot be converted to the desired type.------ This accessor is most useful if the key and value can be absent--- from an object without affecting its validity. If the key and--- value are mandatory, use '.:' instead.------ This operator is consistent in 'aeson >=0.8 && <0.11'-(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)-obj .:? key = case H.lookup key obj of- Nothing -> pure Nothing- Just v ->-#if MIN_VERSION_aeson(0,10,0)- modifyFailure addKeyName $ parseJSON v -- <?> Key key- where- addKeyName = (("failed to parse field " <> T.unpack key <> ": ") <>)-#else- parseJSON v-#endif-{-# INLINE (.:?) #-}---- | Like '.:?', but the resulting parser will fail,--- if the key is present but is 'Null'.-(.:!) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)-obj .:! key = case H.lookup key obj of- Nothing -> pure Nothing- Just v ->-#if MIN_VERSION_aeson(0,10,0)- modifyFailure addKeyName $ Just <$> parseJSON v -- <?> Key key- where- addKeyName = (("failed to parse field " <> T.unpack key <> ": ") <>)-#else- Just <$> parseJSON v-#endif-{-# INLINE (.:!) #-}--#if !MIN_VERSION_aeson(0,9,0)--- From Parser.Internal---- | Parse a top-level JSON value followed by optional whitespace and--- end-of-input. See also: 'json'.-jsonEOF :: A.Parser Value-jsonEOF = value <* A.skipSpace <* A.endOfInput---- | Parse a top-level JSON value followed by optional whitespace and--- end-of-input. See also: 'json''.-jsonEOF' :: A.Parser Value-jsonEOF' = value' <* A.skipSpace <* A.endOfInput---- | Like 'decode' but returns an error message when decoding fails.-eitherDecode :: (FromJSON a) => L.ByteString -> Either String a-eitherDecode = eitherDecodeWith jsonEOF fromJSON-{-# INLINE eitherDecode #-}---- | Like 'decodeStrict' but returns an error message when decoding fails.-eitherDecodeStrict :: (FromJSON a) => B.ByteString -> Either String a-eitherDecodeStrict = eitherDecodeStrictWith jsonEOF fromJSON-{-# INLINE eitherDecodeStrict #-}---- | Like 'decode'' but returns an error message when decoding fails.-eitherDecode' :: (FromJSON a) => L.ByteString -> Either String a-eitherDecode' = eitherDecodeWith jsonEOF' fromJSON-{-# INLINE eitherDecode' #-}---- | Like 'decodeStrict'' but returns an error message when decoding fails.-eitherDecodeStrict' :: (FromJSON a) => B.ByteString -> Either String a-eitherDecodeStrict' = eitherDecodeStrictWith jsonEOF' fromJSON-{-# INLINE eitherDecodeStrict' #-}--eitherDecodeWith :: L.Parser Value -> (Value -> Result a) -> L.ByteString- -> Either String a-eitherDecodeWith p to s =- case L.parse p s of- L.Done _ v -> case to v of- Success a -> Right a- Error msg -> Left msg- L.Fail _ _ msg -> Left msg-{-# INLINE eitherDecodeWith #-}--eitherDecodeStrictWith :: A.Parser Value -> (Value -> Result a) -> B.ByteString- -> Either String a-eitherDecodeStrictWith p to s =- case either Error to (A.parseOnly p s) of- Success a -> Right a- Error msg -> Left msg-{-# INLINE eitherDecodeStrictWith #-}--#endif--#if !MIN_VERSION_aeson(0,10,0)--- | /Since: aeson-extra-0.2.2.0/-instance FromJSON Day where- parseJSON = withText "Day" (ExtraTime.run ExtraTime.day)---- | /Since: aeson-extra-0.2.2.0/-instance FromJSON LocalTime where- parseJSON = withText "LocalTime" (ExtraTime.run ExtraTime.localTime)-#endif
src/Data/Aeson/Extra.hs view
@@ -1,316 +1,58 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Aeson.Extra--- Copyright : (C) 2015 Oleg Grenrus+-- Copyright : (C) 2015-2016 Oleg Grenrus -- License : BSD3 -- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi> -- -- 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(..),- -- * Re-exports- module Data.Aeson.Compat,- ) where+ -- * Strict encoding+ encodeStrict,+ -- * Symbol tag+ SymTag(..),+ -- * Singleton object+ SingObject(..),+ mkSingObject,+ getSingObject,+ -- * CollapsedList+ CollapsedList(..),+ getCollapsedList,+ parseCollapsedList,+ -- * Algebra+ ValueF(..),+ ObjectF,+ ArrayF,+ -- * Merge+ merge,+ lodashMerge,+ -- * Stream+ streamDecode,+ -- * Template Haskell+ mkValue,+ mkValue',+) where -#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable)-import Data.Traversable (Traversable, traverse)-#endif+import Prelude ()+import Prelude.Compat -import Control.Applicative-import Data.Monoid-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as LBS-import Data.Aeson.Compat-import Data.Aeson.Types hiding ((.:?))-import qualified Data.Foldable as Foldable-import qualified Data.HashMap.Strict as H-import Data.Hashable (Hashable)-import qualified Data.Map as Map-import Data.Text as T-import qualified Data.Text.Lazy as TL-import Data.Time (UTCTime, ZonedTime)-import qualified Data.Text.Read as T+import Data.Aeson -#if MIN_VERSION_base(4,7,0)-import Data.Proxy-import GHC.TypeLits-#endif+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS -#if !MIN_VERSION_aeson (0,10,0)-import qualified Data.Aeson.Extra.Time as ExtraTime-#endif+import Data.Aeson.Extra.CollapsedList+import Data.Aeson.Extra.Merge+import Data.Aeson.Extra.Recursive ()+import Data.Aeson.Extra.SingObject+import Data.Aeson.Extra.Stream+import Data.Aeson.Extra.SymTag+import Data.Aeson.Extra.TH -- | Like 'encode', but produces strict 'BS.ByteString'.+--+-- /Since: 0.2.3.0/ encodeStrict :: ToJSON a => a -> BS.ByteString encodeStrict = LBS.toStrict . encode---- | 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)--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)--#if MIN_VERSION_base(4,7,0)--- | 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))----- | 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)--mkSingObject :: Proxy s -> a -> SingObject s a-mkSingObject _ = SingObject--getSingObject :: Proxy s -> SingObject s a -> a-getSingObject _ (SingObject x) = x--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----- | 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)--getCollapsedList :: CollapsedList f a -> f a-getCollapsedList (CollapsedList l) = l--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 = (("failed to parse field " <> T.unpack key <> ": ") <>)-#else- Just v -> getCollapsedList <$> parseJSON v-#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 <https://github.com/bos/aeson/blob/4667ef1029a373cf4510f7deca147c357c6d8947/Data/Aeson/Parser/Time.hs#L150>------ /Since: aeson-extra-0.2.2.0/-newtype U = U { getU :: UTCTime }- deriving (Eq, Ord, Show, Read)--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 . ExtraTime.run ExtraTime.utcTime)-#endif---- | A type to parse 'ZonedTime'------ /Since: aeson-extra-0.2.2.0/-newtype Z = Z { getZ :: ZonedTime }- deriving (Show, Read)--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 . ExtraTime.run ExtraTime.zonedTime)-#endif
+ src/Data/Aeson/Extra/CollapsedList.hs view
@@ -0,0 +1,145 @@+{-# 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 <oleg.grenrus@iki.fi>+--+-- 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.Types hiding ((.:?))+import Data.Text (Text)++#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable (Typeable)+#endif++import qualified Data.Foldable as Foldable+import qualified Data.Text as T++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KM+#else+import qualified Data.HashMap.Strict as KM+#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++instance (FromJSON1 f, Alternative f) => FromJSON1 (CollapsedList f) where+#if MIN_VERSION_aeson(2,2,0)+ liftParseJSON o p _ v = CollapsedList <$> case v of+ Null -> pure Control.Applicative.empty+ Array _ -> liftParseJSON o p (listParser p) v+ x -> pure <$> p x+#else+ liftParseJSON p _ v = CollapsedList <$> case v of+ Null -> pure Control.Applicative.empty+ Array _ -> liftParseJSON p (listParser p) v+ x -> pure <$> p x+#endif++instance (ToJSON1 f, Foldable f) => ToJSON1 (CollapsedList f) where+#if MIN_VERSION_aeson(2,2,0)+ liftToEncoding o to _ (CollapsedList l) = case l' of+ [] -> toEncoding Null+ [x] -> to x+ _ -> liftToEncoding o to (listEncoding to) l+ where+ l' = Foldable.toList l++ liftToJSON o to _ (CollapsedList l) = case l' of+ [] -> toJSON Null+ [x] -> to x+ _ -> liftToJSON o to (listValue to) l+ where+ l' = Foldable.toList l+#else+ 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+#endif++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 KM.lookup key obj of+ Nothing -> pure Control.Applicative.empty+ Just v -> modifyFailure addKeyName $ (getCollapsedList <$> parseJSON v) -- <?> Key key+ where+#if MIN_VERSION_aeson(2,0,0)+ key = Key.fromText key'+#else+ key = key'+#endif+ addKeyName = (mappend ("failed to parse field " `mappend` T.unpack key' `mappend`": "))
+ src/Data/Aeson/Extra/Foldable.hs view
@@ -0,0 +1,5 @@+module Data.Aeson.Extra.Foldable+ {-# DEPRECATED "Use Data.Aeson.Extra.Recursive module" #-}+ (module Data.Aeson.Extra.Recursive) where++import Data.Aeson.Extra.Recursive
+ src/Data/Aeson/Extra/Merge.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE RankNTypes #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Aeson.Extra.Merge+-- Copyright : (C) 2015-2016 Oleg Grenrus+-- License : BSD3+-- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi>+--+module Data.Aeson.Extra.Merge (+ merge,+ mergeA,+ lodashMerge,+ ValueF(..),+ ObjectF,+ ArrayF,+ ) where++import Prelude ()+import Prelude.Compat++import Data.Aeson+import Data.Aeson.Extra.Recursive+import Data.Align (alignWith)+import Data.Functor.Foldable (embed, project)+import Data.These (These (..))++-- | Generic merge.+--+-- For example see 'lodashMerge'.+--+-- /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)++-- | Example of using 'merge'. see <https://lodash.com/docs#merge>:+--+-- /Note:/ not tested against JavaScript lodash, so may disagree in the results.+--+-- @since 0.4.1.0+lodashMerge :: Value -> Value -> Value+lodashMerge = merge alg+ where+ alg :: (a -> a -> a) -> ValueF a -> ValueF a -> ValueF a+ alg 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
+ src/Data/Aeson/Extra/Recursive.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Aeson.Extra.Recursive+-- Copyright : (C) 2015-2017 Oleg Grenrus+-- License : BSD3+-- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi>+--+-- 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.Recursive (+ ValueF(..),+ ObjectF,+ ArrayF,+ ) where++import Prelude ()+import Prelude.Compat++import Data.Aeson+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++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as KM+#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+#if MIN_VERSION_aeson(2,0,0)+ project (Object o) = ObjectF (KM.toHashMapText o)+#else+ project (Object o) = ObjectF o+#endif+ 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+#if MIN_VERSION_aeson(2,0,0)+ embed (ObjectF o) = Object (KM.fromHashMapText o)+#else+ embed (ObjectF o) = Object o+#endif+ embed (ArrayF a) = Array a+ embed (StringF s) = String s+ embed (NumberF n) = Number n+ embed (BoolF b) = Bool b+ embed NullF = Null
+ src/Data/Aeson/Extra/SingObject.hs view
@@ -0,0 +1,114 @@+{-# 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 <oleg.grenrus@iki.fi>+--+module Data.Aeson.Extra.SingObject (+ SingObject(..),+ mkSingObject,+ getSingObject,+ ) where++import Prelude ()+import Prelude.Compat++import Control.DeepSeq (NFData (..))+import Data.Aeson+import Data.Aeson.Encoding (pair)+import Data.Proxy (Proxy (..))+import Data.String (fromString)+import Data.Typeable (Typeable)+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)++import qualified Data.Text as T++#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KM+#else+import qualified Data.HashMap.Strict as KM+#endif++#if MIN_VERSION_aeson(2,2,0)+import Data.Aeson.Types (JSONPathElement (Key))+#else+import Data.Aeson.Internal (JSONPathElement (Key))+#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++instance KnownSymbol s => FromJSON1 (SingObject s) where+#if MIN_VERSION_aeson(2,2,0)+ liftParseJSON _ p _ = withObject ("SingObject "<> show key) $ \obj ->+ case KM.lookup key obj of+ Nothing -> fail $ "key " ++ show key ++ " not present"+ Just v -> SingObject <$> p v <?> Key key+ where+ key = fromString $ symbolVal (Proxy :: Proxy s)+#else+ liftParseJSON p _ = withObject ("SingObject "<> show key) $ \obj ->+ case KM.lookup key obj of+ Nothing -> fail $ "key " ++ show key ++ " not present"+ Just v -> SingObject <$> p v <?> Key key+ where+ key = fromString $ symbolVal (Proxy :: Proxy s)+#endif++instance KnownSymbol s => ToJSON1 (SingObject s) where+#if MIN_VERSION_aeson(2,2,0)+ liftToJSON _ to _ (SingObject x) =+ object [ key .= to x]+ where+ key = fromString $ symbolVal (Proxy :: Proxy s)+ liftToEncoding _ to _ (SingObject x) =+ pairs $ pair key $ to x+ where+ key = fromString $ symbolVal (Proxy :: Proxy s)+#else+ liftToJSON to _ (SingObject x) =+ object [ key .= to x]+ where+ key = fromString $ symbolVal (Proxy :: Proxy s)+ liftToEncoding to _ (SingObject x) =+ pairs $ pair key $ to x+ where+ key = fromString $ symbolVal (Proxy :: Proxy s)+#endif++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++-- | @since 0.4.1.0+instance NFData a => NFData (SingObject s a) where+ rnf (SingObject x) = rnf x
+ src/Data/Aeson/Extra/Stream.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE ScopedTypeVariables #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Aeson.Extra.Stream+-- Copyright : (C) 2015-2016 Oleg Grenrus+-- License : BSD3+-- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi>+--+module Data.Aeson.Extra.Stream (+ streamDecode,+) where++import Prelude ()+import Prelude.Compat++import Control.Applicative (many, (<|>))+import Data.Aeson (FromJSON, Result (..), Value, fromJSON)+import Data.Aeson.Parser (value)++import qualified Data.Attoparsec.ByteString.Char8 as A8+import qualified Data.Attoparsec.ByteString.Lazy as A+import qualified Data.ByteString.Lazy as LBS++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')
+ src/Data/Aeson/Extra/SymTag.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Aeson.Extra.SymTag+-- Copyright : (C) 2015-2018 Oleg Grenrus+-- License : BSD3+-- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi>+--+module Data.Aeson.Extra.SymTag (+ SymTag(..),+ ) where++import Prelude ()+import Prelude.Compat++import Control.DeepSeq (NFData (..))+import Data.Aeson+import Data.Aeson.Types hiding ((.:?))+import Data.Proxy (Proxy (..))+import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)++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))++-- | @since 0.4.1.0+instance NFData (SymTag s) where+ rnf SymTag = ()
+ src/Data/Aeson/Extra/TH.hs view
@@ -0,0 +1,45 @@+{-# 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 <oleg.grenrus@iki.fi>+--+-- 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 Language.Haskell.TH++import qualified Data.Text as T+import qualified Data.Text.Encoding as TE++import Data.Aeson++-- | 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
− src/Data/Aeson/Extra/Time.hs
@@ -1,159 +0,0 @@-{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}---- |--- Module: Data.Aeson.Extra.Time (Data.Aeson.Parser.Time)--- Copyright: (c) 2015 Bryan O'Sullivan--- License: Apache--- Maintainer: Bryan O'Sullivan <bos@serpentine.com>--- Stability: experimental--- Portability: portable------ Parsers for parsing dates and times.--module Data.Aeson.Extra.Time- (- run- , day- , localTime- , timeOfDay- , timeZone- , utcTime- , zonedTime- ) where--import Control.Monad (when, void)-import Data.Attoparsec.Text as A-import Data.Bits ((.&.))-import Data.Char (isDigit, ord)-import Data.Fixed (Pico)-import Data.Int (Int64)-import Data.Maybe (fromMaybe)-import Data.Text (Text)-import Data.Time.Calendar (Day, fromGregorianValid)-import Data.Time.Clock (UTCTime(..))-import qualified Data.Aeson.Types as Aeson-import qualified Data.Text as T-import qualified Data.Time.LocalTime as Local--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>), (<*), (*>))-#endif---- from Data.Aeson.Internal.Time-import Unsafe.Coerce (unsafeCoerce)--toPico :: Integer -> Pico-toPico = unsafeCoerce---- | Run an attoparsec parser as an aeson parser.-run :: Parser a -> Text -> Aeson.Parser a-run p t = case A.parseOnly (p <* endOfInput) t of- Left err -> fail $ "could not parse date: " ++ err- Right r -> return r---- | Parse a date of the form @YYYY-MM-DD@.-day :: Parser Day-day = do- y <- decimal <* char '-'- m <- twoDigits <* char '-'- d <- twoDigits- maybe (fail "invalid date") return (fromGregorianValid y m d)---- | Parse a two-digit integer (e.g. day of month, hour).-twoDigits :: Parser Int-twoDigits = do- a <- digit- b <- digit- let c2d c = ord c .&. 15- return $! c2d a * 10 + c2d b---- | Parse a time of the form @HH:MM:SS[.SSS]@.-timeOfDay :: Parser Local.TimeOfDay-timeOfDay = do- h <- twoDigits <* char ':'- m <- twoDigits <* char ':'- s <- seconds- if h < 24 && m < 60 && s < 61- then return (Local.TimeOfDay h m s)- else fail "invalid time"--data T = T {-# UNPACK #-} !Int {-# UNPACK #-} !Int64---- | Parse a count of seconds, with the integer part being two digits--- long.-seconds :: Parser Pico-seconds = do- real <- twoDigits- mc <- peekChar- case mc of- Just '.' -> do- t <- anyChar *> takeWhile1 isDigit- return $! parsePicos real t- _ -> return $! fromIntegral real- where- parsePicos a0 t = toPico (fromIntegral (t' * 10^n))- where T n t' = T.foldl' step (T 12 (fromIntegral a0)) t- step ma@(T m a) c- | m <= 0 = ma- | otherwise = T (m-1) (10 * a + fromIntegral (ord c) .&. 15)---- | Parse a time zone, and return 'Nothing' if the offset from UTC is--- zero. (This makes some speedups possible.)-timeZone :: Parser (Maybe Local.TimeZone)-timeZone = do- let maybeSkip c = do ch <- peekChar'; when (ch == c) (void anyChar)- maybeSkip ' '- ch <- satisfy $ \c -> c == 'Z' || c == '+' || c == '-'- if ch == 'Z'- then return Nothing- else do- h <- twoDigits- mm <- peekChar- m <- case mm of- Just ':' -> anyChar *> twoDigits- Just d | isDigit d -> twoDigits- _ -> return 0- let off | ch == '-' = negate off0- | otherwise = off0- off0 = h * 60 + m- case undefined of- _ | off == 0 ->- return Nothing- | off < -720 || off > 840 || m > 59 ->- fail "invalid time zone offset"- | otherwise ->- let !tz = Local.minutesToTimeZone off- in return (Just tz)---- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@.--- The space may be replaced with a @T@. The number of seconds may be--- followed by a fractional component.-localTime :: Parser Local.LocalTime-localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay- where daySep = satisfy (\c -> c == 'T' || c == ' ')---- | Behaves as 'zonedTime', but converts any time zone offset into a--- UTC time.-utcTime :: Parser UTCTime-utcTime = do- lt@(Local.LocalTime d t) <- localTime- mtz <- timeZone- case mtz of- Nothing -> let !tt = Local.timeOfDayToTime t- in return (UTCTime d tt)- Just tz -> return $! Local.localTimeToUTC tz lt---- | Parse a date with time zone info. Acceptable formats:------ @YYYY-MM-DD HH:MM:SS Z@------ The first space may instead be a @T@, and the second space is--- optional. The @Z@ represents UTC. The @Z@ may be replaced with a--- time zone offset of the form @+0000@ or @-08:00@, where the first--- two digits are hours, the @:@ is optional and the second two digits--- (also optional) are minutes.-zonedTime :: Parser Local.ZonedTime-zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)--utc :: Local.TimeZone-utc = Local.TimeZone 0 False ""
− src/Data/Time/TH.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--- | Template Haskell extras for `Data.Time`.------ This module is in a wrong place, but it reuses the same parser as aeson parser.-module Data.Time.TH (mkUTCTime) where--import Control.Applicative ((<*))-import Data.Time (UTCTime(..), Day(..))-import qualified Data.Text as T-import qualified Data.Attoparsec.Text as A-import Language.Haskell.TH-import Data.Aeson.Extra.Time (utcTime)---- | Make a 'UTCTime'. Accepts the same strings as aeson `UTCTime` parser accepts.------ > t :: UTCTime--- > t = $(mkUTCTime "2014-05-12 00:02:03.456000Z")-mkUTCTime :: String -> Q Exp-mkUTCTime s =- case A.parseOnly (utcTime <* A.endOfInput) (T.pack s) of- Left err -> fail $ "could not parse UTCTime: " ++ err- Right (UTCTime (ModifiedJulianDay d) dt) ->- [| UTCTime (ModifiedJulianDay $(d')) $(dt') :: UTCTime |]- where d' = return $ LitE $ integerL d- dt' = return $ LitE $ rationalL $ toRational dt
test/Orphans.hs view
@@ -6,9 +6,11 @@ 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
test/Tests.hs view
@@ -1,47 +1,36 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-} module Main (main) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative-#endif--import qualified Data.HashMap.Lazy as H-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 Prelude ()+import Prelude.Compat -#if MIN_VERSION_base(4,7,0)-import Data.Proxy-#endif+import Data.Aeson+import Data.Aeson.Extra -import Data.Aeson.Extra-import Data.Time.TH+import Data.Maybe (isJust)+import Data.Proxy+import Data.Vector (Vector)+import Test.QuickCheck.Instances ()+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck -import Orphans ()+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 ] ------------------------------------------------------------------------------@@ -57,26 +46,6 @@ 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 ------------------------------------------------------------------------------ @@ -108,8 +77,6 @@ in prop ] -#endif- ------------------------------------------------------------------------------ -- parseCollapsedList ------------------------------------------------------------------------------@@ -137,6 +104,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 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 (.:!) ------------------------------------------------------------------------------@@ -169,53 +169,18 @@ 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"- ]----------------------------------------------------------------------------------- Time Template Haskell+-- Merge tests ------------------------------------------------------------------------------ -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")-- +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 }] }")+ ]