{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Aeson.Extra (
encodeStrict,
M(..),
FromJSONKey(..),
parseIntegralJSONKey,
FromJSONMap(..),
ToJSONKey(..),
ToJSONMap(..),
#if MIN_VERSION_base(4,7,0)
SymTag(..),
SingObject(..),
mkSingObject,
getSingObject,
#endif
CollapsedList(..),
getCollapsedList,
parseCollapsedList,
U(..),
Z(..),
module Data.Aeson.Compat,
) where
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
#if !MIN_VERSION_aeson (0,10,0)
import qualified Text.Parsec as Parsec
import qualified Data.Time.Parsers as TimeParsers
#endif
encodeStrict :: ToJSON a => a -> BS.ByteString
encodeStrict = LBS.toStrict . encode
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)
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))
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
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
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)
where
addKeyName = (("failed to parse field " <> T.unpack key <> ": ") <>)
#else
Just v -> getCollapsedList <$> parseJSON v
#endif
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
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 :: 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