module Data.Aeson.Types
(
Value(..)
, Array
, emptyArray
, Pair
, Object
, emptyObject
, DotNetTime(..)
, typeMismatch
, Parser
, Result(..)
, FromJSON(..)
, fromJSON
, parse
, ToJSON(..)
, (.=)
, (.:)
, (.:?)
, object
) where
import Control.Applicative
import Control.DeepSeq (NFData(..))
import Control.Monad (MonadPlus(..))
import Data.Aeson.Functions
import Data.Attoparsec.Char8 (Number(..))
import Data.Data (Data)
import Data.Int (Int8, Int16, Int32, Int64)
import Data.Map (Map)
import Data.Monoid (Dual(..), First(..), Last(..))
import Data.Monoid (Monoid(..))
import Data.Ratio (Ratio)
import Data.String (IsString(..))
import Data.Text (Text, pack, unpack)
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Clock (UTCTime)
import Data.Time.Format (FormatTime, formatTime, parseTime)
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.HashMap.Strict as H
import qualified Data.IntSet as IntSet
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
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 -> fail $ "key " ++ show key ++ " not present"
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 v = typeMismatch "Bool" v
instance ToJSON () where
toJSON _ = emptyArray
instance FromJSON () where
parseJSON (Array v) | V.null v = pure ()
parseJSON v = typeMismatch "()" v
instance ToJSON [Char] where
toJSON = String . T.pack
instance FromJSON [Char] where
parseJSON (String t) = pure (T.unpack t)
parseJSON v = typeMismatch "String" v
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 v = typeMismatch "Char" v
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 v = typeMismatch "Double" v
instance ToJSON Number where
toJSON = Number
instance FromJSON Number where
parseJSON (Number n) = pure n
parseJSON v = typeMismatch "Number" v
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 v = typeMismatch "Float" v
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 v = typeMismatch "Ratio Integer" v
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 v = typeMismatch "Integral" v
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 v = typeMismatch "Text" v
instance ToJSON LT.Text where
toJSON = String . LT.toStrict
instance FromJSON LT.Text where
parseJSON (String t) = pure (LT.fromStrict t)
parseJSON v = typeMismatch "Lazy Text" v
instance ToJSON B.ByteString where
toJSON = String . decode
instance FromJSON B.ByteString where
parseJSON (String t) = pure . encodeUtf8 $ t
parseJSON v = typeMismatch "ByteString" v
instance ToJSON LB.ByteString where
toJSON = toJSON . strict
instance FromJSON LB.ByteString where
parseJSON (String t) = pure . lazy $ t
parseJSON v = typeMismatch "Lazy ByteString" v
instance (ToJSON a) => ToJSON [a] where
toJSON = Array . V.fromList . map toJSON
instance (FromJSON a) => FromJSON [a] where
parseJSON (Array a) = mapM parseJSON (V.toList a)
parseJSON v = typeMismatch "[a]" v
instance (ToJSON a) => ToJSON (Vector a) where
toJSON = Array . V.map toJSON
instance (FromJSON a) => FromJSON (Vector a) where
parseJSON (Array a) = V.mapM parseJSON a
parseJSON v = typeMismatch "Vector a" v
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 <$> mapM go (M.toAscList o)
where go (k,v) = ((,) k) <$> parseJSON v
parseJSON v = typeMismatch "Map Text a" v
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 v) => ToJSON (M.Map B.ByteString v) where
toJSON = Object . transformMap decode toJSON
instance (FromJSON v) => FromJSON (M.Map B.ByteString v) where
parseJSON = fmap (M.mapKeysMonotonic encodeUtf8) . parseJSON
instance (ToJSON v) => ToJSON (M.Map LB.ByteString v) where
toJSON = Object . transformMap strict toJSON
instance (FromJSON v) => FromJSON (M.Map LB.ByteString v) where
parseJSON = fmap (M.mapKeysMonotonic lazy) . parseJSON
instance (ToJSON v) => ToJSON (H.HashMap Text v) where
toJSON = Object . hashMap id toJSON
instance (FromJSON v) => FromJSON (H.HashMap Text v) where
parseJSON (Object o) = H.fromList <$> mapM go (M.toList o)
where go (k,v) = ((,) k) <$> parseJSON v
parseJSON v = typeMismatch "HashMap Text a" v
instance (ToJSON v) => ToJSON (H.HashMap LT.Text v) where
toJSON = Object . M.fromList . H.foldrWithKey (\k v -> ((LT.toStrict k,toJSON v) :)) []
instance (FromJSON v) => FromJSON (H.HashMap LT.Text v) where
parseJSON = fmap (mapHash LT.fromStrict) . parseJSON
instance (ToJSON v) => ToJSON (H.HashMap String v) where
toJSON = Object . hashMap pack toJSON
instance (FromJSON v) => FromJSON (H.HashMap String v) where
parseJSON = fmap (mapHash unpack) . parseJSON
instance (ToJSON v) => ToJSON (H.HashMap B.ByteString v) where
toJSON = Object . hashMap decode toJSON
instance (FromJSON v) => FromJSON (H.HashMap B.ByteString v) where
parseJSON = fmap (mapHash encodeUtf8) . parseJSON
instance (ToJSON v) => ToJSON (H.HashMap LB.ByteString v) where
toJSON = Object . hashMap strict toJSON
instance (FromJSON v) => FromJSON (H.HashMap LB.ByteString v) where
parseJSON = fmap (mapHash lazy) . parseJSON
instance ToJSON Value where
toJSON a = a
instance FromJSON Value where
parseJSON a = pure a
newtype DotNetTime = DotNetTime {
fromDotNetTime :: 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)
_ -> fail "could not parse .NET time"
parseJSON v = typeMismatch "DotNetTime" v
instance ToJSON UTCTime where
toJSON t = String (pack (take 23 str ++ "Z"))
where str = formatTime defaultTimeLocale "%FT%T%Q" t
instance FromJSON UTCTime where
parseJSON (String t) =
case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of
Just d -> pure d
_ -> fail "could not parse ISO-8601 date"
parseJSON v = typeMismatch "UTCTime" v
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
_ -> fail $ "cannot unpack array of length " ++
show (V.length ab) ++ " into a pair"
parseJSON v = typeMismatch "(a,b)" v
instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where
toJSON (a,b,c) = toJSON [toJSON a, toJSON b, toJSON c]
instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where
parseJSON (Array abc) =
case V.toList abc of
[a,b,c] -> (,,) <$> parseJSON a <*> parseJSON b <*> parseJSON c
_ -> fail $ "cannot unpack array of length " ++
show (V.length abc) ++ " into a 3-tuple"
parseJSON v = typeMismatch "(a,b,c)" v
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
typeMismatch :: String
-> Value
-> Parser a
typeMismatch expected actual =
fail $ "when expecting a " ++ expected ++ ", encountered " ++ name ++
" instead"
where
name = case actual of
Object _ -> "Object"
Array _ -> "Array"
String _ -> "String"
Number _ -> "Number"
Bool _ -> "Boolean"
Null -> "Null"