diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,8 +2,9 @@ [![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) - -The package motivation is twofold: +[![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) -- 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) diff --git a/aeson-extra.cabal b/aeson-extra.cabal --- a/aeson-extra.cabal +++ b/aeson-extra.cabal @@ -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 -maintainer: Oleg Grenrus -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 +maintainer: Oleg Grenrus +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 diff --git a/src/Data/Aeson/Compat.hs b/src/Data/Aeson/Compat.hs deleted file mode 100644 --- a/src/Data/Aeson/Compat.hs +++ /dev/null @@ -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 --- --- 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 diff --git a/src/Data/Aeson/Extra.hs b/src/Data/Aeson/Extra.hs --- a/src/Data/Aeson/Extra.hs +++ b/src/Data/Aeson/Extra.hs @@ -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 -- -- 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 --- --- /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 diff --git a/src/Data/Aeson/Extra/CollapsedList.hs b/src/Data/Aeson/Extra/CollapsedList.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Extra/CollapsedList.hs @@ -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 +-- +-- 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`": ")) diff --git a/src/Data/Aeson/Extra/Foldable.hs b/src/Data/Aeson/Extra/Foldable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Extra/Foldable.hs @@ -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 diff --git a/src/Data/Aeson/Extra/Merge.hs b/src/Data/Aeson/Extra/Merge.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Extra/Merge.hs @@ -0,0 +1,60 @@ +{-# 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, + 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 : +-- +-- /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 diff --git a/src/Data/Aeson/Extra/Recursive.hs b/src/Data/Aeson/Extra/Recursive.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Extra/Recursive.hs @@ -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 +-- +-- 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 diff --git a/src/Data/Aeson/Extra/SingObject.hs b/src/Data/Aeson/Extra/SingObject.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Extra/SingObject.hs @@ -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 +-- +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 diff --git a/src/Data/Aeson/Extra/Stream.hs b/src/Data/Aeson/Extra/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Extra/Stream.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Aeson.Extra.Stream +-- Copyright : (C) 2015-2016 Oleg Grenrus +-- License : BSD3 +-- Maintainer : Oleg Grenrus +-- +module Data.Aeson.Extra.Stream ( + streamDecode, +) where + +import Prelude () +import Prelude.Compat + +import Control.Applicative (many, (<|>)) +import Data.Aeson (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') diff --git a/src/Data/Aeson/Extra/SymTag.hs b/src/Data/Aeson/Extra/SymTag.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Extra/SymTag.hs @@ -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 +-- +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 = () diff --git a/src/Data/Aeson/Extra/TH.hs b/src/Data/Aeson/Extra/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Extra/TH.hs @@ -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 +-- +-- 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 diff --git a/src/Data/Aeson/Extra/Time.hs b/src/Data/Aeson/Extra/Time.hs deleted file mode 100644 --- a/src/Data/Aeson/Extra/Time.hs +++ /dev/null @@ -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 --- 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 "" diff --git a/src/Data/Time/TH.hs b/src/Data/Time/TH.hs deleted file mode 100644 --- a/src/Data/Time/TH.hs +++ /dev/null @@ -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 diff --git a/test/Orphans.hs b/test/Orphans.hs --- a/test/Orphans.hs +++ b/test/Orphans.hs @@ -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 diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -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 }] }") + ]