@@ -1,4 +1,4 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
1+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances #-}
22
33-- Module: Data.Aeson.Types
44-- Copyright: (c) 2011 MailRank, Inc.
@@ -15,6 +15,7 @@ module Data.Aeson.Types
1515 Value(..)
1616 , Array
1717 , emptyArray
18+ , Pair
1819 , Object
1920 , emptyObject
2021 -- * Type conversion
@@ -27,7 +28,8 @@ module Data.Aeson.Types
2728 , object
2829 ) where
2930
30−import Control.Applicative
31+import Control.Monad (MonadPlus(..), ap, liftM)
32+import Control.Arrow ((***))
3133import Control.DeepSeq (NFData(..))
3234import Data.Map (Map)
3335import qualified Data.ByteString as B
@@ -38,12 +40,14 @@ import qualified Data.Text.Lazy as LT
3840import Data.Time.Clock (UTCTime)
3941import Data.Time.Format (formatTime, parseTime)
4042import Data.Typeable (Typeable)
43+import Data.Data (Data)
4144import Data.Vector (Vector)
4245import System.Locale (defaultTimeLocale)
4346import qualified Data.Map as M
47+import qualified Data.Set as Set
4448import qualified Data.Vector as V
4549
46−-- | A JSON \"object\" (key/value map).
50+-- | A JSON \"object\" (key\/value map).
4751type Object = Map Text Value
4852
4953-- | A JSON \"array\" (sequence).
@@ -56,7 +60,7 @@ data Value = Object Object
5660 | Number Double
5761 | Bool !Bool
5862 | Null
59− deriving (Eq, Show, Typeable)
63+ deriving (Eq, Show, Typeable, Data)
6064
6165instance NFData Value where
6266 rnf (Object o) = rnf o
@@ -74,9 +78,16 @@ emptyArray = Array V.empty
7478emptyObject :: Value
7579emptyObject = Object M.empty
7680
77−-- | Construct an 'Object' from a key and a value.
78−(.=) :: ToJSON a => Text -> a -> Object
79−name .= value = M.singleton name (toJSON value)
81+-- | A key\/value pair for an 'Object'.
82+newtype Pair = Pair { unPair :: (Text, Value) }
83+ deriving (Eq, Typeable)
84+
85+instance Show Pair where
86+ show = show . unPair
87+
88+-- | Construct a 'Pair' from a key and a value.
89+(.=) :: ToJSON a => Text -> a -> Pair
90+name .= value = Pair (name, toJSON value)
8091{-# INLINE (.=) #-}
8192
8293-- | Retrieve the value associated with the given key of an 'Object'.
@@ -86,9 +97,9 @@ name .= value = M.singleton name (toJSON value)
8697-- This accessor is appropriate if the key and value /must/ be present
8798-- in an object for it to be valid. If the key and value are
8899-- optional, use '(.:?)' instead.
89−(.:) :: (Alternative f, FromJSON a) => Object -> Text -> f a
100+(.:) :: (MonadPlus m, FromJSON a) => Object -> Text -> m a
90101obj .: key = case M.lookup key obj of
91− Nothing -> empty
102+ Nothing -> mzero
92103 Just v -> fromJSON v
93104{-# INLINE (.:) #-}
94105
@@ -99,16 +110,16 @@ obj .: key = case M.lookup key obj of
99110-- This accessor is most useful if the key and value can be absent
100111-- from an object without affecting its validity. If the key and
101112-- value are mandatory, use '(.:?)' instead.
102−(.:?) :: (Alternative f, FromJSON a) => Object -> Text -> f (Maybe a)
113+(.:?) :: (MonadPlus m, FromJSON a) => Object -> Text -> m (Maybe a)
103114obj .:? key = case M.lookup key obj of
104− Nothing -> pure Nothing
115+ Nothing -> return Nothing
105116 Just v -> fromJSON v
106117{-# INLINE (.:?) #-}
107118
108−-- | Create a 'Value' from a list of 'Object's. If duplicate
119+-- | Create a 'Value' from a list of 'Pair's. If duplicate
109120-- keys arise, earlier keys and their associated values win.
110−object :: [Object] -> Value
111−object = Object . M.unions
121+object :: [Pair] -> Value
122+object = Object . M.fromList . map unPair
112123{-# INLINE object #-}
113124
114125-- | A type that can be converted to JSON.
@@ -126,7 +137,7 @@ class ToJSON a where
126137-- | A type that can be converted from JSON, with the possibility of
127138-- failure.
128139--
129−-- When writing an instance, use 'empty' to make a conversion fail,
140+-- When writing an instance, use 'mzero' to make a conversion fail,
130141-- e.g. if an 'Object' is missing a required key, or the value is of
131142-- the wrong type.
132143--
@@ -135,15 +146,15 @@ class ToJSON a where
135146-- @data Coord { x :: Double, y :: Double }
136147--
137148-- instance FromJSON Coord where
138−-- fromJSON ('Object' v) = Coord '<$>'
139−-- v '.:' \"x\" '<*>'
149+-- fromJSON ('Object' v) = Coord `'liftM'`
150+-- v '.:' \"x\" `'ap'`
140151-- v '.:' \"y\"
141152--
142−-- \-- A non-'Object' value is of the wrong type, so use 'empty' to fail.
143−-- fromJSON _ = 'empty'
153+-- \-- A non-'Object' value is of the wrong type, so use 'mzero' to fail.
154+-- fromJSON _ = 'mzero'
144155-- @
145156class FromJSON a where
146− fromJSON :: Alternative f => Value -> f a
157+ fromJSON :: MonadPlus m => Value -> m a
147158
148159instance (ToJSON a) => ToJSON (Maybe a) where
149160 toJSON (Just a) = toJSON a
@@ -151,7 +162,7 @@ instance (ToJSON a) => ToJSON (Maybe a) where
151162 {-# INLINE toJSON #-}
152163
153164instance (FromJSON a) => FromJSON (Maybe a) where
154− fromJSON Null = pure Nothing
165+ fromJSON Null = return Nothing
155166 fromJSON a = Just <$> fromJSON a
156167 {-# INLINE fromJSON #-}
157168
@@ -169,7 +180,7 @@ instance ToJSON Bool where
169180 {-# INLINE toJSON #-}
170181
171182instance FromJSON Bool where
172− fromJSON (Bool b) = pure b
183+ fromJSON (Bool b) = return b
173184 fromJSON _ = empty
174185 {-# INLINE fromJSON #-}
175186
@@ -178,7 +189,7 @@ instance ToJSON Double where
178189 {-# INLINE toJSON #-}
179190
180191instance FromJSON Double where
181− fromJSON (Number n) = pure n
192+ fromJSON (Number n) = return n
182193 fromJSON _ = empty
183194 {-# INLINE fromJSON #-}
184195
@@ -187,7 +198,7 @@ instance ToJSON Int where
187198 {-# INLINE toJSON #-}
188199
189200instance FromJSON Int where
190− fromJSON (Number n) = pure (floor n)
201+ fromJSON (Number n) = return (floor n)
191202 fromJSON _ = empty
192203 {-# INLINE fromJSON #-}
193204
@@ -196,7 +207,7 @@ instance ToJSON Integer where
196207 {-# INLINE toJSON #-}
197208
198209instance FromJSON Integer where
199− fromJSON (Number n) = pure (floor n)
210+ fromJSON (Number n) = return (floor n)
200211 fromJSON _ = empty
201212 {-# INLINE fromJSON #-}
202213
@@ -205,7 +216,7 @@ instance ToJSON Text where
205216 {-# INLINE toJSON #-}
206217
207218instance FromJSON Text where
208− fromJSON (String t) = pure t
219+ fromJSON (String t) = return t
209220 fromJSON _ = empty
210221 {-# INLINE fromJSON #-}
211222
@@ -214,7 +225,7 @@ instance ToJSON LT.Text where
214225 {-# INLINE toJSON #-}
215226
216227instance FromJSON LT.Text where
217− fromJSON (String t) = pure (LT.fromStrict t)
228+ fromJSON (String t) = return (LT.fromStrict t)
218229 fromJSON _ = empty
219230 {-# INLINE fromJSON #-}
220231
@@ -223,7 +234,7 @@ instance ToJSON B.ByteString where
223234 {-# INLINE toJSON #-}
224235
225236instance FromJSON B.ByteString where
226− fromJSON (String t) = pure . encodeUtf8 $ t
237+ fromJSON (String t) = return . encodeUtf8 $ t
227238 fromJSON _ = empty
228239 {-# INLINE fromJSON #-}
229240
@@ -232,16 +243,10 @@ instance ToJSON LB.ByteString where
232243 {-# INLINE toJSON #-}
233244
234245instance FromJSON LB.ByteString where
235− fromJSON (String t) = pure . LB.fromChunks . (:[]) . encodeUtf8 $ t
246+ fromJSON (String t) = return . LB.fromChunks . (:[]) . encodeUtf8 $ t
236247 fromJSON _ = empty
237248 {-# INLINE fromJSON #-}
238249
239−mapA :: (Applicative f) => (t -> f a) -> [t] -> f [a]
240−mapA f = go
241− where
242− go (a:as) = (:) <$> f a <*> go as
243− go [] = pure []
244−
245250instance (ToJSON a) => ToJSON [a] where
246251 toJSON = Array . V.fromList . map toJSON
247252 {-# INLINE toJSON #-}
@@ -260,12 +265,44 @@ instance (FromJSON a) => FromJSON (Vector a) where
260265 fromJSON _ = empty
261266 {-# INLINE fromJSON #-}
262267
268+instance (ToJSON a) => ToJSON (Set.Set a) where
269+ toJSON = toJSON . Set.toList
270+ {-# INLINE toJSON #-}
271+
272+instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
273+ fromJSON = liftM Set.fromList . fromJSON
274+ {-# INLINE fromJSON #-}
275+
276+instance (ToJSON v) => ToJSON (M.Map Text v) where
277+ toJSON = Object . M.map toJSON
278+ {-# INLINE toJSON #-}
279+
280+instance (FromJSON v) => FromJSON (M.Map Text v) where
281+ fromJSON (Object o) = go [] (M.toAscList o)
282+ where
283+ go acc ((k,v):kvs) = do v' <- fromJSON v
284+ go ((k,v'):acc) kvs
285+ go acc _ = return (M.fromAscList (reverse acc))
286+ fromJSON _ = empty
287+
288+instance (ToJSON v) => ToJSON (M.Map LT.Text v) where
289+ toJSON = Object . transformMap LT.toStrict toJSON
290+
291+instance (FromJSON v) => FromJSON (M.Map LT.Text v) where
292+ fromJSON = liftM (M.mapKeysMonotonic LT.fromStrict) . fromJSON
293+
294+instance (ToJSON v) => ToJSON (M.Map String v) where
295+ toJSON = Object . transformMap pack toJSON
296+
297+instance (FromJSON v) => FromJSON (M.Map String v) where
298+ fromJSON = liftM (M.mapKeysMonotonic unpack) . fromJSON
299+
263300instance ToJSON Value where
264301 toJSON a = a
265302 {-# INLINE toJSON #-}
266303
267304instance FromJSON Value where
268− fromJSON a = pure a
305+ fromJSON a = return a
269306 {-# INLINE fromJSON #-}
270307
271308-- We happen to use the same JSON formatting for a UTCTime as .NET
@@ -277,7 +314,7 @@ instance ToJSON UTCTime where
277314instance FromJSON UTCTime where
278315 fromJSON (String t) =
279316 case parseTime defaultTimeLocale "/Date(%s)/" (unpack t) of
280− Just d -> pure d
317+ Just d -> return d
281318 _ -> empty
282319 fromJSON _ = empty
283320 {-# INLINE fromJSON #-}
@@ -293,12 +330,37 @@ instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
293330 fromJSON _ = empty
294331 {-# INLINE fromJSON #-}
295332
333+-- | Transform one map into another. The ordering of keys must be
334+-- preserved.
335+transformMap :: (Ord k1, Ord k2) => (k1 -> k2) -> (v1 -> v2)
336+ -> M.Map k1 v1 -> M.Map k2 v2
337+transformMap fk fv = M.fromAscList . map (fk *** fv) . M.toAscList
296338
297−
298−
299−
300−
301−
302−
303−
304−
339+mapA :: (MonadPlus m) => (t -> m a) -> [t] -> m [a]
340+mapA f = go []
341+ where
342+ go acc (a:as) = do
343+ v <- f a
344+ go (v:acc) as
345+ go acc _ = return (reverse acc)
346+
347+-- Applicative-style notation.
348+
349+(<$>) :: (Monad m) => (a1 -> r) -> m a1 -> m r
350+(<$>) = liftM
351+{-# INLINE (<$>) #-}
352+infixl 4 <$>
353+
354+(<*>) :: (Monad m) => m (a -> b) -> m a -> m b
355+(<*>) = ap
356+{-# INLINE (<*>) #-}
357+infixl 4 <*>
358+
359+(<|>) :: (MonadPlus m) => m a -> m a -> m a
360+(<|>) = mplus
361+{-# INLINE (<|>) #-}
362+infixl 3 <|>
363+
364+empty :: (MonadPlus m) => m a
365+empty = mzero
366+{-# INLINE empty #-}