module Data.Aeson.Types
(
Value(..)
, Array
, emptyArray
, Pair
, Object
, emptyObject
, DotNetTime(..)
, Parser
, Result(..)
, FromJSON(..)
, fromJSON
, parse
, ToJSON(..)
, (.=)
, (.:)
, (.:?)
, object
) where
import Control.Applicative
import Control.Monad (MonadPlus(..))
import Data.Monoid (Monoid(..))
import Control.DeepSeq (NFData(..))
import Data.Data (Data)
import Data.Int (Int8, Int16, Int32, Int64)
import qualified Data.IntSet as IntSet
import Data.Map (Map)
import Data.Monoid (Dual(..), First(..), Last(..))
import Data.Ratio (Ratio)
import Data.String (IsString(..))
import Data.Text (Text, pack, unpack)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Time.Clock (UTCTime)
import Data.Time.Format (FormatTime, formatTime, parseTime)
import Data.Attoparsec.Char8 (Number(..))
import Data.Typeable (Typeable)
import Data.Vector (Vector)
import Data.Word (Word, Word8, Word16, Word32, Word64)
import System.Locale (defaultTimeLocale)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import qualified Data.Map as M
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.Vector as V
import Data.Aeson.Functions
data Result a = Error String
| Success a
deriving (Eq, Show, Typeable)
type Failure r = String -> Result r
type Success a r = a -> Result r
newtype Parser a = Parser {
runParser :: forall r.
Failure r
-> Success a r
-> Result r
}
instance Monad Parser where
m >>= g = Parser $ \kf ks -> let ks' a = runParser (g a) kf ks
in runParser m kf ks'
return a = Parser $ \_kf ks -> ks a
fail msg = Parser $ \kf _ks -> kf msg
instance Functor Parser where
fmap f m = Parser $ \kf ks -> let ks' a = ks (f a)
in runParser m kf ks'
instance Applicative Parser where
pure = return
(<*>) = apP
instance Alternative Parser where
empty = fail "empty"
(<|>) = mplus
instance MonadPlus Parser where
mzero = fail "mzero"
mplus a b = Parser $ \kf ks -> let kf' _ = runParser b kf ks
in runParser a kf' ks
instance Monoid (Parser a) where
mempty = fail "mempty"
mappend = mplus
apP :: Parser (a -> b) -> Parser a -> Parser b
apP d e = do
b <- d
a <- e
return (b a)
type Object = Map Text Value
type Array = Vector Value
data Value = Object Object
| Array Array
| String Text
| Number Number
| Bool !Bool
| Null
deriving (Eq, Show, Typeable, Data)
instance NFData Value where
rnf (Object o) = rnf o
rnf (Array a) = V.foldl' (\x y -> rnf y `seq` x) () a
rnf (String s) = rnf s
rnf (Number n) = case n of I i -> rnf i; D d -> rnf d
rnf (Bool b) = rnf b
rnf Null = ()
instance IsString Value where
fromString = String . pack
emptyArray :: Value
emptyArray = Array V.empty
emptyObject :: Value
emptyObject = Object M.empty
type Pair = (Text, Value)
(.=) :: ToJSON a => Text -> a -> Pair
name .= value = (name, toJSON value)
fromJSON :: (FromJSON a) => Value -> Result a
fromJSON = parse parseJSON
parse :: (a -> Parser b) -> a -> Result b
parse m v = runParser (m v) Error Success
(.:) :: (FromJSON a) => Object -> Text -> Parser a
obj .: key = case M.lookup key obj of
Nothing -> empty
Just v -> parseJSON v
(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
obj .:? key = case M.lookup key obj of
Nothing -> pure Nothing
Just v -> parseJSON v
object :: [Pair] -> Value
object = Object . M.fromList
class ToJSON a where
toJSON :: a -> Value
class FromJSON a where
parseJSON :: Value -> Parser a
instance (ToJSON a) => ToJSON (Maybe a) where
toJSON (Just a) = toJSON a
toJSON Nothing = Null
instance (FromJSON a) => FromJSON (Maybe a) where
parseJSON Null = pure Nothing
parseJSON a = Just <$> parseJSON a
instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where
toJSON (Left a) = toJSON a
toJSON (Right b) = toJSON b
instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
parseJSON a = Left <$> parseJSON a <|> Right <$> parseJSON a
instance ToJSON Bool where
toJSON = Bool
instance FromJSON Bool where
parseJSON (Bool b) = pure b
parseJSON _ = empty
instance ToJSON () where
toJSON _ = emptyArray
instance FromJSON () where
parseJSON (Array v) | V.null v = pure ()
parseJSON _ = empty
instance ToJSON [Char] where
toJSON = String . T.pack
instance FromJSON [Char] where
parseJSON (String t) = pure (T.unpack t)
parseJSON _ = empty
instance ToJSON Char where
toJSON = String . T.singleton
instance FromJSON Char where
parseJSON (String t)
| T.compareLength t 1 == EQ = pure (T.head t)
parseJSON _ = empty
instance ToJSON Double where
toJSON = Number . D
instance FromJSON Double where
parseJSON (Number n) = case n of
D d -> pure d
I i -> pure (fromIntegral i)
parseJSON _ = empty
instance ToJSON Number where
toJSON = Number
instance FromJSON Number where
parseJSON (Number n) = pure n
parseJSON _ = empty
instance ToJSON Float where
toJSON = Number . fromRational . toRational
instance FromJSON Float where
parseJSON (Number n) = case n of
D d -> pure . fromRational . toRational $ d
I i -> pure (fromIntegral i)
parseJSON _ = empty
instance ToJSON (Ratio Integer) where
toJSON = Number . fromRational
instance FromJSON (Ratio Integer) where
parseJSON (Number n) = case n of
D d -> pure . toRational $ d
I i -> pure (fromIntegral i)
parseJSON _ = empty
instance ToJSON Int where
toJSON = Number . fromIntegral
instance FromJSON Int where
parseJSON = parseIntegral
parseIntegral :: Integral a => Value -> Parser a
parseIntegral (Number n) = pure (floor n)
parseIntegral _ = empty
instance ToJSON Integer where
toJSON = Number . fromIntegral
instance FromJSON Integer where
parseJSON = parseIntegral
instance ToJSON Int8 where
toJSON = Number . fromIntegral
instance FromJSON Int8 where
parseJSON = parseIntegral
instance ToJSON Int16 where
toJSON = Number . fromIntegral
instance FromJSON Int16 where
parseJSON = parseIntegral
instance ToJSON Int32 where
toJSON = Number . fromIntegral
instance FromJSON Int32 where
parseJSON = parseIntegral
instance ToJSON Int64 where
toJSON = Number . fromIntegral
instance FromJSON Int64 where
parseJSON = parseIntegral
instance ToJSON Word where
toJSON = Number . fromIntegral
instance FromJSON Word where
parseJSON = parseIntegral
instance ToJSON Word8 where
toJSON = Number . fromIntegral
instance FromJSON Word8 where
parseJSON = parseIntegral
instance ToJSON Word16 where
toJSON = Number . fromIntegral
instance FromJSON Word16 where
parseJSON = parseIntegral
instance ToJSON Word32 where
toJSON = Number . fromIntegral
instance FromJSON Word32 where
parseJSON = parseIntegral
instance ToJSON Word64 where
toJSON = Number . fromIntegral
instance FromJSON Word64 where
parseJSON = parseIntegral
instance ToJSON Text where
toJSON = String
instance FromJSON Text where
parseJSON (String t) = pure t
parseJSON _ = empty
instance ToJSON LT.Text where
toJSON = String . LT.toStrict
instance FromJSON LT.Text where
parseJSON (String t) = pure (LT.fromStrict t)
parseJSON _ = empty
instance ToJSON B.ByteString where
toJSON = String . decodeUtf8
instance FromJSON B.ByteString where
parseJSON (String t) = pure . encodeUtf8 $ t
parseJSON _ = empty
instance ToJSON LB.ByteString where
toJSON = toJSON . B.concat . LB.toChunks
instance FromJSON LB.ByteString where
parseJSON (String t) = pure . LB.fromChunks . (:[]) . encodeUtf8 $ t
parseJSON _ = empty
instance (ToJSON a) => ToJSON [a] where
toJSON = Array . V.fromList . map toJSON
instance (FromJSON a) => FromJSON [a] where
parseJSON (Array a) = mapA parseJSON (V.toList a)
parseJSON _ = empty
instance (ToJSON a) => ToJSON (Vector a) where
toJSON = Array . V.map toJSON
instance (FromJSON a) => FromJSON (Vector a) where
parseJSON (Array a) = V.fromList <$> mapA parseJSON (V.toList a)
parseJSON _ = empty
instance (ToJSON a) => ToJSON (Set.Set a) where
toJSON = toJSON . Set.toList
instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
parseJSON = fmap Set.fromList . parseJSON
instance ToJSON IntSet.IntSet where
toJSON = toJSON . IntSet.toList
instance FromJSON IntSet.IntSet where
parseJSON = fmap IntSet.fromList . parseJSON
instance (ToJSON v) => ToJSON (M.Map Text v) where
toJSON = Object . M.map toJSON
instance (FromJSON v) => FromJSON (M.Map Text v) where
parseJSON (Object o) = M.fromAscList <$> go (M.toAscList o)
where
go ((k,v):kvs) = ((:) . (,) k) <$> parseJSON v <*> go kvs
go _ = pure []
parseJSON _ = empty
instance (ToJSON v) => ToJSON (M.Map LT.Text v) where
toJSON = Object . transformMap LT.toStrict toJSON
instance (FromJSON v) => FromJSON (M.Map LT.Text v) where
parseJSON = fmap (M.mapKeysMonotonic LT.fromStrict) . parseJSON
instance (ToJSON v) => ToJSON (M.Map String v) where
toJSON = Object . transformMap pack toJSON
instance (FromJSON v) => FromJSON (M.Map String v) where
parseJSON = fmap (M.mapKeysMonotonic unpack) . parseJSON
instance ToJSON Value where
toJSON a = a
instance FromJSON Value where
parseJSON a = pure a
newtype DotNetTime = DotNetTime UTCTime
deriving (Eq, Ord, Read, Show, Typeable, FormatTime)
instance ToJSON DotNetTime where
toJSON (DotNetTime t) =
String (pack (formatTime defaultTimeLocale "/Date(%s)/" t))
instance FromJSON DotNetTime where
parseJSON (String t) =
case parseTime defaultTimeLocale "/Date(%s)/" (unpack t) of
Just d -> pure (DotNetTime d)
_ -> empty
parseJSON _ = empty
instance ToJSON UTCTime where
toJSON t = String (pack (formatTime defaultTimeLocale "%FT%X%QZ" t))
instance FromJSON UTCTime where
parseJSON (String t) =
case parseTime defaultTimeLocale "%FT%X%QZ" (unpack t) of
Just d -> pure d
_ -> empty
parseJSON _ = empty
instance (ToJSON a, ToJSON b) => ToJSON (a,b) where
toJSON (a,b) = toJSON [toJSON a, toJSON b]
instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
parseJSON (Array ab) = case V.toList ab of
[a,b] -> (,) <$> parseJSON a <*> parseJSON b
_ -> empty
parseJSON _ = empty
instance ToJSON a => ToJSON (Dual a) where
toJSON = toJSON . getDual
instance FromJSON a => FromJSON (Dual a) where
parseJSON = fmap Dual . parseJSON
instance ToJSON a => ToJSON (First a) where
toJSON = toJSON . getFirst
instance FromJSON a => FromJSON (First a) where
parseJSON = fmap First . parseJSON
instance ToJSON a => ToJSON (Last a) where
toJSON = toJSON . getLast
instance FromJSON a => FromJSON (Last a) where
parseJSON = fmap Last . parseJSON
mapA :: (Alternative m) => (t -> m a) -> [t] -> m [a]
mapA f = go
where
go (a:as) = (:) <$> f a <*> go as
go _ = pure []