packages feed

aeson-extra 0.3.0.1 → 0.3.1.0

raw patch · 12 files changed

+676/−283 lines, 12 filesdep +recursion-schemesdep +thesedep +transformers

Dependencies added: recursion-schemes, these, transformers

Files

CHANGELOG.md view
@@ -1,3 +1,9 @@+# 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`
aeson-extra.cabal view
@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack  name:           aeson-extra-version:        0.3.0.1+version:        0.3.1.0 synopsis:       Extra goodies for aeson description:    Package provides extra funcitonality on top of @aeson@ and @aeson-compat@ category:       Web@@ -31,14 +31,15 @@   ghc-options: -Wall   build-depends:       base                     >=4.6  && <4.9-    , base-compat              >=0.6.0   && <0.10     , aeson                    >=0.7.0.6 && <0.11     , aeson-compat             >=0.3.0.0 && <0.4+    , base-compat              >=0.6.0   && <0.10     , bytestring               >=0.10 && <0.11     , containers               >=0.5  && <0.6     , exceptions               >=0.8  && <0.9     , hashable                 >=1.2  && <1.3     , parsec                   >=3.1.9 && <3.2+    , recursion-schemes        >=4.1.2 && <4.2     , scientific               >=0.3  && <0.4     , template-haskell         >=2.8  && <2.11     , text                     >=1.2  && <1.3@@ -46,8 +47,21 @@     , time-parsers             >=0.1.0.0 && <0.2     , unordered-containers     >=0.2  && <0.3     , vector                   >=0.10 && <0.12+    , transformers             >=0.3  && <0.6   exposed-modules:       Data.Aeson.Extra+      Data.Aeson.Extra.CollapsedList+      Data.Aeson.Extra.Foldable+      Data.Aeson.Extra.Map+      Data.Aeson.Extra.Merge+      Data.Aeson.Extra.Time+      Data.Aeson.Extra.TH++  if impl(ghc >= 7.8)+    exposed-modules:+      Data.Aeson.Extra.SingObject+      Data.Aeson.Extra.SymTag+   default-language: Haskell2010  test-suite aeson-extra-test@@ -58,9 +72,9 @@   ghc-options: -Wall   build-depends:       base                     >=4.6  && <4.9-    , base-compat              >=0.6.0   && <0.10     , aeson                    >=0.7.0.6 && <0.11     , aeson-compat             >=0.3.0.0 && <0.4+    , base-compat              >=0.6.0   && <0.10     , bytestring               >=0.10 && <0.11     , containers               >=0.5  && <0.6     , exceptions               >=0.8  && <0.9@@ -69,6 +83,7 @@     , scientific               >=0.3  && <0.4     , template-haskell         >=2.8  && <2.11     , text                     >=1.2  && <1.3+    , these                    >=0.6.2.0 && <0.7     , time                     >=1.4.2 && <1.7     , time-parsers             >=0.1.0.0 && <0.2     , unordered-containers     >=0.2  && <0.3
src/Data/Aeson/Extra.hs view
@@ -1,18 +1,8 @@-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE DataKinds              #-}-{-# LANGUAGE DeriveDataTypeable     #-}-{-# LANGUAGE DeriveFoldable         #-}-{-# LANGUAGE DeriveFunctor          #-}-{-# LANGUAGE DeriveTraversable      #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE KindSignatures         #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE UndecidableInstances   #-}+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Data.Aeson.Extra--- Copyright   :  (C) 2015 Oleg Grenrus+-- Copyright   :  (C) 2015-2016 Oleg Grenrus -- License     :  BSD3 -- Maintainer  :  Oleg Grenrus <oleg.grenrus@iki.fi> --@@ -42,6 +32,15 @@   -- * UTCTime   U(..),   Z(..),+  -- * Algebra+  ValueF(..),+  ObjectF,+  ArrayF,+  -- * Merge+  merge,+  -- * Template Haskell+  mkValue,+  mkValue',   -- * Re-exports   module Data.Aeson.Compat,   ) where@@ -49,31 +48,21 @@ import Prelude        () import Prelude.Compat -import Control.Applicative (Alternative(..)) import Data.Aeson.Compat-import Data.Aeson.Types    hiding ((.:?))-import Data.Hashable       (Hashable)-import Data.Monoid-import Data.Text           (Text)-import Data.Time           (UTCTime, ZonedTime)  import qualified Data.ByteString      as BS import qualified Data.ByteString.Lazy as LBS-import qualified Data.Foldable        as Foldable-import qualified Data.HashMap.Strict  as H-import qualified Data.Map             as Map-import qualified Data.Text            as T-import qualified Data.Text.Lazy       as TL-import qualified Data.Text.Read       as T -#if MIN_VERSION_base(4,7,0)-import Data.Proxy-import GHC.TypeLits-#endif+import Data.Aeson.Extra.CollapsedList+import Data.Aeson.Extra.Foldable+import Data.Aeson.Extra.Map+import Data.Aeson.Extra.Merge+import Data.Aeson.Extra.Time+import Data.Aeson.Extra.TH -#if !MIN_VERSION_aeson (0,10,0)-import qualified Text.Parsec       as Parsec-import qualified Data.Time.Parsers as TimeParsers+#if MIN_VERSION_base(4,7,0)+import Data.Aeson.Extra.SingObject+import Data.Aeson.Extra.SymTag #endif  -- | Like 'encode', but produces strict 'BS.ByteString'.@@ -81,247 +70,3 @@ -- /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 . run TimeParsers.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 . run TimeParsers.zonedTime)-#endif--#if !MIN_VERSION_aeson (0,10,0)--- | Run a 'parsers' parser as an aeson parser.-run :: Parsec.Parsec Text () a -> Text -> Parser a-run p t = case Parsec.parse (p <* Parsec.eof) "" t of-            Left err -> fail $ "could not parse date: " ++ show err-            Right r  -> return r-#endif
+ src/Data/Aeson/Extra/CollapsedList.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE CPP                #-}+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable     #-}+{-# LANGUAGE DeriveFunctor      #-}+{-# LANGUAGE DeriveTraversable  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Aeson.Extra.CollapsedList+-- Copyright   :  (C) 2015-2016 Oleg Grenrus+-- License     :  BSD3+-- Maintainer  :  Oleg Grenrus <oleg.grenrus@iki.fi>+--+module Data.Aeson.Extra.CollapsedList (+    CollapsedList(..),+    getCollapsedList,+    parseCollapsedList,+    )where++import Prelude        ()+import Prelude.Compat++import Control.Applicative (Alternative(..))+import Data.Aeson.Compat+import Data.Aeson.Types    hiding ((.:?))+import Data.Text           (Text)++#if __GLASGOW_HASKELL__ >= 708+import Data.Typeable       (Typeable)+#endif++import qualified Data.Foldable        as Foldable+import qualified Data.HashMap.Strict  as H++#if MIN_VERSION_aeson(0,10,0)+import qualified Data.Text as T+#endif++-- | Collapsed list, singleton is represented as the value itself in JSON encoding.+--+-- > λ > decode "null" :: Maybe (CollapsedList [Int] Int)+-- > Just (CollapsedList [])+-- > λ > decode "42" :: Maybe (CollapsedList [Int] Int)+-- > Just (CollapsedList [42])+-- > λ > decode "[1, 2, 3]" :: Maybe (CollapsedList [Int] Int)+-- > Just (CollapsedList [1,2,3])+--+-- > λ > encode (CollapsedList ([] :: [Int]))+-- > "null"+-- > λ > encode (CollapsedList ([42] :: [Int]))+-- > "42"+-- > λ > encode (CollapsedList ([1, 2, 3] :: [Int]))+-- > "[1,2,3]"+--+-- Documentation rely on @f@ 'Alternative' instance behaving like lists'.+newtype CollapsedList f a = CollapsedList (f a)+  deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable+#if __GLASGOW_HASKELL__ >= 708+           , Typeable+#endif+           )++getCollapsedList :: CollapsedList f a -> f a+getCollapsedList (CollapsedList l) = l++instance (FromJSON a, FromJSON (f a), Alternative f) => FromJSON (CollapsedList f a) where+  parseJSON Null         = pure (CollapsedList Control.Applicative.empty)+  parseJSON v@(Array _)  = CollapsedList <$> parseJSON v+  parseJSON v            = CollapsedList . pure <$> parseJSON v++instance (ToJSON a, ToJSON (f a), Foldable f) => ToJSON (CollapsedList f a) where+#if MIN_VERSION_aeson (0,10,0)+  toEncoding (CollapsedList l) =+    case Foldable.toList l of+      []   -> toEncoding Null+      [x]  -> toEncoding x+      _    -> toEncoding l+#endif+  toJSON (CollapsedList l) =+    case Foldable.toList l of+      []   -> toJSON Null+      [x]  -> toJSON x+      _    -> toJSON l++-- | Parses possibly collapsed array value from the object's field.+--+-- > λ > newtype V = V [Int] deriving (Show)+-- > λ > instance FromJSON V where parseJSON = withObject "V" $ \obj -> V <$> parseCollapsedList obj "value"+-- > λ > decode "{}" :: Maybe V+-- > Just (V [])+-- > λ > decode "{\"value\": null}" :: Maybe V+-- > Just (V [])+-- > λ > decode "{\"value\": 42}" :: Maybe V+-- > Just (V [42])+-- > λ > decode "{\"value\": [1, 2, 3, 4]}" :: Maybe V+-- > Just (V [1,2,3,4])+parseCollapsedList :: (FromJSON a, FromJSON (f a), Alternative f) => Object -> Text -> Parser (f a)+parseCollapsedList obj key =+  case H.lookup key obj of+    Nothing   -> pure Control.Applicative.empty+#if MIN_VERSION_aeson(0,10,0)+    Just v    -> modifyFailure addKeyName $ (getCollapsedList <$> parseJSON v) -- <?> Key key+  where+    addKeyName = (mappend ("failed to parse field " `mappend` T.unpack key `mappend`": "))+#else+    Just v    -> getCollapsedList <$> parseJSON v+#endif
+ src/Data/Aeson/Extra/Foldable.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, TypeFamilies, DeriveFoldable, DeriveTraversable #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Aeson.Extra.Foldable+-- Copyright   :  (C) 2015-2016 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.Foldable (+    ValueF(..),+    ObjectF,+    ArrayF,+    ) where++import Prelude        ()+import Prelude.Compat++import Data.Aeson.Compat+import Data.Functor.Foldable+import Data.HashMap.Strict (HashMap)+import Data.Data (Data)+import Data.Text (Text)+import Data.Scientific (Scientific)+import Data.Typeable (Typeable)+import Data.Vector (Vector)++import qualified Data.Functor.Foldable as F++-- | 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 F.Foldable Value where+    project (Object o) = ObjectF o+    project (Array a)  = ArrayF a+    project (String s) = StringF s+    project (Number n) = NumberF n+    project (Bool b)   = BoolF b+    project Null       = NullF++instance F.Unfoldable Value where+    embed (ObjectF o) = Object o+    embed (ArrayF a)  = Array a+    embed (StringF s) = String s+    embed (NumberF n) = Number n+    embed (BoolF b)   = Bool b+    embed NullF       = Null
+ src/Data/Aeson/Extra/Map.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE DeriveDataTypeable     #-}+{-# LANGUAGE DeriveFoldable         #-}+{-# LANGUAGE DeriveFunctor          #-}+{-# LANGUAGE DeriveTraversable      #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE UndecidableInstances   #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Aeson.Extra.Map+-- Copyright   :  (C) 2015-2016 Oleg Grenrus+-- License     :  BSD3+-- Maintainer  :  Oleg Grenrus <oleg.grenrus@iki.fi>+--+-- More or less useful newtypes for writing 'FromJSON' & 'ToJSON' instances+module Data.Aeson.Extra.Map (+  M(..),+  FromJSONKey(..),+  parseIntegralJSONKey,+  FromJSONMap(..),+  ToJSONKey(..),+  ToJSONMap(..),+  ) where++import Prelude        ()+import Prelude.Compat++import Data.Aeson.Compat+import Data.Aeson.Types  hiding ((.:?))+import Data.Hashable     (Hashable)+import Data.Monoid       ((<>))+import Data.Text         (Text)+import Data.Typeable     (Typeable)++import qualified Data.HashMap.Strict as H+import qualified Data.Map            as Map+import qualified Data.Text           as T+import qualified Data.Text.Lazy      as TL+import qualified Data.Text.Read      as T++-- | A wrapper type to parse arbitrary maps+--+-- > λ > decode "{\"1\": 1, \"2\": 2}" :: Maybe (M (H.HashMap Int Int))+-- > Just (M {getMap = fromList [(1,1),(2,2)]})+newtype M a = M { getMap :: a }+  deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable, Typeable)++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)
+ src/Data/Aeson/Extra/Merge.hs view
@@ -0,0 +1,53 @@+{-# 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,+	ValueF(..),+	ObjectF,+	ArrayF,+	) where++import Prelude        ()+import Prelude.Compat++import Data.Aeson.Compat+import Data.Aeson.Extra.Foldable+import Data.Functor.Foldable (project, embed)++-- | Generic merge.+--+-- For example <https://lodash.com/docs#merge>:+--+-- @+-- lodashMerge :: Value -> Value -> Value+-- lodashMerge x y = merge lodashMergeAlg x y+-- +-- lodashMergeAlg :: (a -> a -> a) -> ValueF a -> ValueF a -> ValueF a+-- lodashMergeAlg r a' b' = case (a', b') of+--     (ObjectF a, ObjectF b) -> ObjectF $ alignWith f a b+--     (ArrayF a,  ArrayF b)  -> ArrayF $ alignWith f a b+--     (_,         b)         -> b+--   where f (These x y) = r x y+--         f (This x)    = x+--         f (That x)    = x+-- @+--+-- /Since: aeson-extra-0.3.1.0/+merge :: (forall a. (a -> a -> a) -> ValueF a -> ValueF a -> ValueF a)+       -> Value -> Value -> Value+merge f a b = embed $ f (merge f) (project a) (project b)++-- | Generic merge, in arbitrary context.+--+-- /Since: aeson-extra-0.3.1.0/+mergeA :: Functor f+      => (forall a. (a -> a -> f a) -> ValueF a -> ValueF a -> f (ValueF a))+      -> Value -> Value -> f Value+mergeA f a b = embed <$> f (mergeA f) (project a) (project b)
+ src/Data/Aeson/Extra/SingObject.hs view
@@ -0,0 +1,62 @@+{-# 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 Data.Aeson.Compat+import Data.Monoid       ((<>))+import Data.Proxy+import Data.Typeable     (Typeable)+import GHC.TypeLits++import qualified Data.Text            as T++-- | 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, 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)
+ src/Data/Aeson/Extra/SymTag.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# 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.SymTag (+    SymTag(..),+    ) where++import Prelude        ()+import Prelude.Compat++import Data.Aeson.Compat+import Data.Aeson.Types  hiding ((.:?))+import Data.Proxy+import GHC.TypeLits++import qualified Data.Text as T++-- | Singleton string encoded and decoded as ifself.+--+-- > λ> encode (SymTag :: SymTag "foobar")+-- > "\"foobar\""+--+-- > decode "\"foobar\"" :: Maybe (SymTag "foobar")+-- > Just SymTag+--+-- > decode "\"foobar\"" :: Maybe (SymTag "barfoo")+-- > Nothing+--+-- /Available with: base >=4.7/+data SymTag (s :: Symbol) = SymTag+  deriving (Eq, Ord, Show, Read, Enum, Bounded)++instance KnownSymbol s => FromJSON (SymTag s) where+  parseJSON (String t)+    | T.unpack t == symbolVal (Proxy :: Proxy s) = pure SymTag+  parseJSON v = typeMismatch ("SymTag " ++ show (symbolVal (Proxy :: Proxy s))) v++instance KnownSymbol s => ToJSON (SymTag s) where+#if MIN_VERSION_aeson (0,10,0)+  toEncoding _ = toEncoding (symbolVal (Proxy :: Proxy s))+#endif+  toJSON _ = toJSON (symbolVal (Proxy :: Proxy s))
+ src/Data/Aeson/Extra/TH.hs view
@@ -0,0 +1,65 @@+{-# 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+module Data.Aeson.Extra.TH (+    mkValue,+    mkValue',+    ) where++import Control.Arrow (first)+import Data.Aeson.Compat+import Data.Scientific (scientific, coefficient, base10Exponent)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (Lift(..))++import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Vector as V+import qualified Data.HashMap.Strict as HM++-- | 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++-- | From 'aeson-extra'+--+-- /Since: aeson-extra-0.3.1.0/+instance Lift Value where+    lift Null = [| Null |]+    lift (Bool b) = [| Bool b |]+    lift (Number n) = [| Number (scientific c e) |]+      where+        c = coefficient n+        e = base10Exponent n+    lift (String t) = [| String (T.pack s) |]+      where s = T.unpack t+    lift (Array a) = [| Array (V.fromList a') |]+      where a' = V.toList a+    lift (Object o) = [| Object (HM.fromList . map (first T.pack) $ o') |]+      where o' = map (first T.unpack) . HM.toList $ o
+ src/Data/Aeson/Extra/Time.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Aeson.Extra.Time+-- Copyright   :  (C) 2015-2016 Oleg Grenrus+-- License     :  BSD3+-- Maintainer  :  Oleg Grenrus <oleg.grenrus@iki.fi>+--+-- Time tools+module Data.Aeson.Extra.Time (+    U(..),+    Z(..),+    )where++import Prelude        ()+import Prelude.Compat++import Data.Aeson.Compat+import Data.Aeson.Types  hiding ((.:?))+import Data.Text         (Text)+import Data.Time         (UTCTime, ZonedTime)+import Data.Typeable     (Typeable)++#if !MIN_VERSION_aeson (0,10,0)+import qualified Data.Time.Parsers as TimeParsers+import qualified Text.Parsec       as Parsec+#endif++-- | A type to parse 'UTCTime'+--+-- 'FromJSON' instance accepts for example:+--+-- @+-- 2015-09-07T08:16:40.807Z+-- 2015-09-07 11:16:40.807 +03:00+-- @+--+-- Latter format is accepted by @aeson@ staring from version @0.10.0.0@.+--+-- See <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, Typeable)++instance ToJSON U where+  toJSON = toJSON . getU+#if MIN_VERSION_aeson (0,10,0)+  toEncoding = toEncoding . getU+#endif++instance FromJSON U where+#if MIN_VERSION_aeson (0,10,0)+  parseJSON = fmap U . parseJSON+#else+  parseJSON = withText "UTCTime" (fmap U . run TimeParsers.utcTime)+#endif++-- | A type to parse 'ZonedTime'+--+-- /Since: aeson-extra-0.2.2.0/+newtype Z = Z { getZ :: ZonedTime }+  deriving (Show, Read, Typeable)++instance ToJSON Z where+  toJSON = toJSON . getZ+#if MIN_VERSION_aeson (0,10,0)+  toEncoding = toEncoding . getZ+#endif++instance FromJSON Z where+#if MIN_VERSION_aeson (0,10,0)+  parseJSON = fmap Z . parseJSON+#else+  parseJSON = withText "ZonedTime" (fmap Z . run TimeParsers.zonedTime)+#endif++#if !MIN_VERSION_aeson (0,10,0)+-- | Run a 'parsers' parser as an aeson parser.+run :: Parsec.Parsec Text () a -> Text -> Parser a+run p t = case Parsec.parse (p <* Parsec.eof) "" t of+            Left err -> fail $ "could not parse date: " ++ show err+            Right r  -> return r+#endif
test/Tests.hs view
@@ -9,7 +9,8 @@ import           Control.Applicative #endif -import qualified Data.HashMap.Lazy as H++ import           Data.Map (Map) import           Data.Maybe (isJust) import           Data.String (fromString)@@ -19,7 +20,11 @@ import           Test.Tasty import           Test.Tasty.HUnit import           Test.Tasty.QuickCheck+import Data.These (These (..))+import Data.Align (alignWith) +import qualified Data.HashMap.Lazy as H+ #if MIN_VERSION_base(4,7,0) import           Data.Proxy #endif@@ -42,6 +47,7 @@   , utctimeTests   , zonedtimeTests   , timeTHTests+  , mergeTests     ]  ------------------------------------------------------------------------------@@ -208,14 +214,37 @@   , "2015-09-07 05:16:40.807 -03:00"   ] ---------------------------------------------------------------------------------- Time Template Haskell-------------------------------------------------------------------------------- timeTHTests :: TestTree timeTHTests =     testCase "time TH example" $ assertBool "should be equal" $ lhs == rhs       where lhs = UTCTime (ModifiedJulianDay 56789) 123.456             rhs = $(mkUTCTime "2014-05-12 00:02:03.456000Z") +------------------------------------------------------------------------------+-- Merge tests+------------------------------------------------------------------------------++lodashMerge :: Value -> Value -> Value+lodashMerge x y = merge lodashMergeAlg x y++lodashMergeAlg :: (a -> a -> a) -> ValueF a -> ValueF a -> ValueF a+lodashMergeAlg r a' b' = case (a', b') of+    (ObjectF a, ObjectF b) -> ObjectF $ alignWith f a b+    (ArrayF a,  ArrayF b)  -> ArrayF $ alignWith f a b+    (_,         b)         -> b+  where f (These x y) = r x y+        f (This x)    = x+        f (That x)    = x     +mergeTests :: TestTree+mergeTests = testGroup "Lodash merge examples" $ map f examples+  where+    f (x, y, z) = testCase "-" $ assertBool "should be equal" $ lodashMerge x y == z+    examples =+      [ (,,) $(mkValue "[1, 2, 3]") $(mkValue "[4, 5, 6, 7, 8]") $(mkValue "[4, 5, 6, 7, 8]")+      , (,,) $(mkValue' "{'a': 1}") $(mkValue' "{'b': 2}") $(mkValue' "{'a': 1, 'b': 2}")+      , (,,)+        $(mkValue' "{ 'data': [{ 'user': 'barney' }, { 'user': 'fred' }] }")+        $(mkValue' "{ 'data': [{ 'age': 36 }, { 'age': 40 }] }")+        $(mkValue' "{ 'data': [{ 'user': 'barney', 'age': 36 }, { 'user': 'fred', 'age': 40 }] }")+      ]