@@ -1,4 +1,4 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
1+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances #-}
22
33-- Module: Data.Aeson.Types
44-- Copyright: (c) 2011 MailRank, Inc.
@@ -14,7 +14,10 @@ module Data.Aeson.Types
1414 -- * Core JSON types
1515 Value(..)
1616 , Array
17+ , emptyArray
18+ , Pair
1719 , Object
20+ , emptyObject
1821 -- * Type conversion
1922 , FromJSON(..)
2023 , ToJSON(..)
@@ -25,23 +28,32 @@ module Data.Aeson.Types
2528 , object
2629 ) where
2730
31+import Control.Arrow ((***))
2832import Control.Applicative
2933import Control.DeepSeq (NFData(..))
34+-- import Data.Data (Data)
35+import Data.Hashable (Hashable)
3036import Data.HashMap (HashMap)
31−import qualified Data.ByteString as B
32−import qualified Data.ByteString.Lazy as LB
33−import Data.Text.Encoding (decodeUtf8, encodeUtf8)
37+import Data.Monoid (Dual(..), First(..), Last(..))
3438import Data.Text (Text, pack, unpack)
35−import qualified Data.Text.Lazy as LT
39+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
3640import Data.Time.Clock (UTCTime)
3741import Data.Time.Format (formatTime, parseTime)
3842import Data.Typeable (Typeable)
3943import Data.Vector (Vector)
4044import System.Locale (defaultTimeLocale)
41−import qualified Data.HashMap as M
45+import qualified Data.HashMap as HM
46+import qualified Data.Map as M
47+import qualified Data.ByteString as B
48+import qualified Data.ByteString.Lazy as LB
49+import qualified Data.Set as Set
50+import qualified Data.Text.Lazy as LT
4251import qualified Data.Vector as V
4352
53+-- | A JSON \"object\" (key\/value map).
4454type Object = HashMap Text Value
55+
56+-- | A JSON \"array\" (sequence).
4557type Array = Vector Value
4658
4759-- | A JSON value represented as a Haskell value.
@@ -61,9 +73,24 @@ instance NFData Value where
6173 rnf (Bool b) = rnf b
6274 rnf Null = ()
6375
64−-- | Construct an 'Object' from a key and a value.
65−(.=) :: ToJSON a => Text -> a -> Object
66−name .= value = M.singleton name (toJSON value)
76+-- | The empty array.
77+emptyArray :: Value
78+emptyArray = Array V.empty
79+
80+-- | The empty object.
81+emptyObject :: Value
82+emptyObject = Object HM.empty
83+
84+-- | A key\/value pair for an 'Object'.
85+newtype Pair = Pair { unPair :: (Text, Value) }
86+ deriving (Eq, Typeable)
87+
88+instance Show Pair where
89+ show = show . unPair
90+
91+-- | Construct a 'Pair' from a key and a value.
92+(.=) :: ToJSON a => Text -> a -> Pair
93+name .= value = Pair (name, toJSON value)
6794{-# INLINE (.=) #-}
6895
6996-- | Retrieve the value associated with the given key of an 'Object'.
@@ -73,8 +100,8 @@ name .= value = M.singleton name (toJSON value)
73100-- This accessor is appropriate if the key and value /must/ be present
74101-- in an object for it to be valid. If the key and value are
75102-- optional, use '(.:?)' instead.
76−(.:) :: (Alternative f, FromJSON a) => Object -> Text -> f a
77−obj .: key = case M.lookup key obj of
103+(.:) :: (Alternative m, FromJSON a) => Object -> Text -> m a
104+obj .: key = case HM.lookup key obj of
78105 Nothing -> empty
79106 Just v -> fromJSON v
80107{-# INLINE (.:) #-}
@@ -86,16 +113,16 @@ obj .: key = case M.lookup key obj of
86113-- This accessor is most useful if the key and value can be absent
87114-- from an object without affecting its validity. If the key and
88115-- value are mandatory, use '(.:?)' instead.
89−(.:?) :: (Alternative f, FromJSON a) => Object -> Text -> f (Maybe a)
90−obj .:? key = case M.lookup key obj of
116+(.:?) :: (Alternative m, FromJSON a) => Object -> Text -> m (Maybe a)
117+obj .:? key = case HM.lookup key obj of
91118 Nothing -> pure Nothing
92119 Just v -> fromJSON v
93120{-# INLINE (.:?) #-}
94121
95−-- | Create a 'Value' from a list of 'Object's. If duplicate
122+-- | Create a 'Value' from a list of 'Pair's. If duplicate
96123-- keys arise, earlier keys and their associated values win.
97−object :: [Object] -> Value
98−object = Object . M.fromList . concat . map M.toList
124+object :: [Pair] -> Value
125+object = Object . HM.fromList . map unPair
99126{-# INLINE object #-}
100127
101128-- | A type that can be converted to JSON.
@@ -113,7 +140,7 @@ class ToJSON a where
113140-- | A type that can be converted from JSON, with the possibility of
114141-- failure.
115142--
116−-- When writing an instance, use 'empty' to make a conversion fail,
143+-- When writing an instance, use 'mzero' to make a conversion fail,
117144-- e.g. if an 'Object' is missing a required key, or the value is of
118145-- the wrong type.
119146--
@@ -126,11 +153,11 @@ class ToJSON a where
126153-- v '.:' \"x\" '<*>'
127154-- v '.:' \"y\"
128155--
129−-- \-- A non-'Object' value is of the wrong type, so use 'empty' to fail.
130−-- fromJSON _ = 'empty'
156+-- \-- A non-'Object' value is of the wrong type, so use 'mzero' to fail.
157+-- fromJSON _ = 'mzero'
131158-- @
132159class FromJSON a where
133− fromJSON :: Alternative f => Value -> f a
160+ fromJSON :: Alternative m => Value -> m a
134161
135162instance (ToJSON a) => ToJSON (Maybe a) where
136163 toJSON (Just a) = toJSON a
@@ -223,12 +250,6 @@ instance FromJSON LB.ByteString where
223250 fromJSON _ = empty
224251 {-# INLINE fromJSON #-}
225252
226−mapA :: (Applicative f) => (t -> f a) -> [t] -> f [a]
227−mapA f = go
228− where
229− go (a:as) = (:) <$> f a <*> go as
230− go [] = pure []
231−
232253instance (ToJSON a) => ToJSON [a] where
233254 toJSON = Array . V.fromList . map toJSON
234255 {-# INLINE toJSON #-}
@@ -247,6 +268,37 @@ instance (FromJSON a) => FromJSON (Vector a) where
247268 fromJSON _ = empty
248269 {-# INLINE fromJSON #-}
249270
271+instance (ToJSON a) => ToJSON (Set.Set a) where
272+ toJSON = toJSON . Set.toList
273+ {-# INLINE toJSON #-}
274+
275+instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
276+ fromJSON = fmap Set.fromList . fromJSON
277+ {-# INLINE fromJSON #-}
278+
279+instance (ToJSON v) => ToJSON (M.Map Text v) where
280+ toJSON = Object . HM.fromList . M.toList . M.map toJSON
281+ {-# INLINE toJSON #-}
282+
283+instance (FromJSON v) => FromJSON (M.Map Text v) where
284+ fromJSON (Object o) = M.fromList <$> go (HM.toList o)
285+ where
286+ go ((k,v):kvs) = ((:) . (,) k) <$> fromJSON v <*> go kvs
287+ go _ = pure []
288+ fromJSON _ = empty
289+
290+instance (ToJSON v) => ToJSON (M.Map LT.Text v) where
291+ toJSON = Object . transformMap LT.toStrict toJSON
292+
293+instance (FromJSON v) => FromJSON (M.Map LT.Text v) where
294+ fromJSON = fmap (M.mapKeysMonotonic LT.fromStrict) . fromJSON
295+
296+instance (ToJSON v) => ToJSON (M.Map String v) where
297+ toJSON = Object . transformMap pack toJSON
298+
299+instance (FromJSON v) => FromJSON (M.Map String v) where
300+ fromJSON = fmap (M.mapKeysMonotonic unpack) . fromJSON
301+
250302instance ToJSON Value where
251303 toJSON a = a
252304 {-# INLINE toJSON #-}
@@ -280,12 +332,38 @@ instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
280332 fromJSON _ = empty
281333 {-# INLINE fromJSON #-}
282334
335+instance ToJSON a => ToJSON (Dual a) where
336+ toJSON = toJSON . getDual
337+ {-# INLINE toJSON #-}
283338
339+instance FromJSON a => FromJSON (Dual a) where
340+ fromJSON = fmap Dual . fromJSON
341+ {-# INLINE fromJSON #-}
284342
343+instance ToJSON a => ToJSON (First a) where
344+ toJSON = toJSON . getFirst
345+ {-# INLINE toJSON #-}
285346
347+instance FromJSON a => FromJSON (First a) where
348+ fromJSON = fmap First . fromJSON
349+ {-# INLINE fromJSON #-}
286350
351+instance ToJSON a => ToJSON (Last a) where
352+ toJSON = toJSON . getLast
353+ {-# INLINE toJSON #-}
287354
355+instance FromJSON a => FromJSON (Last a) where
356+ fromJSON = fmap Last . fromJSON
357+ {-# INLINE fromJSON #-}
288358
359+-- | Transform one map into another. The ordering of keys must be
360+-- preserved.
361+transformMap :: (Ord k1, Hashable k2, Ord k2) => (k1 -> k2) -> (v1 -> v2)
362+ -> M.Map k1 v1 -> HM.HashMap k2 v2
363+transformMap fk fv = HM.fromList . map (fk *** fv) . M.toList
289364
290−
291−
365+mapA :: (Alternative m) => (t -> m a) -> [t] -> m [a]
366+mapA f = go
367+ where
368+ go (a:as) = (:) <$> f a <*> go as
369+ go _ = pure []