@@ -1,18 +1,10 @@
1−{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, GeneralizedNewtypeDeriving,
2− IncoherentInstances, OverlappingInstances, OverloadedStrings, Rank2Types,
3− ViewPatterns, FlexibleContexts, UndecidableInstances,
4− ScopedTypeVariables, PatternGuards #-}
5−
61{-# LANGUAGE CPP #-}
7−#ifdef DEFAULT_SIGNATURES
8−{-# LANGUAGE DefaultSignatures #-}
9−#endif
102
113-- |
124-- Module: Data.Aeson.Types
135-- Copyright: (c) 2011 MailRank, Inc.
146-- License: Apache
15−-- Maintainer: Bryan O'Sullivan <bos@mailrank.com>
7+-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>
168-- Stability: experimental
179-- Portability: portable
1810--
@@ -43,1084 +35,13 @@ module Data.Aeson.Types
4335 , (.=)
4436 , (.:)
4537 , (.:?)
38+ , (.:/)
4639 , object
47− -- * Generic toJSON and fromJSON
48− , genericToJSON
49− , genericFromJSON
5040 ) where
5141
52−import Control.Applicative
53−import Control.Arrow (first)
54−import Control.Monad.State.Strict
55−import Control.DeepSeq (NFData(..))
56−import Data.Aeson.Functions
57−import Data.Attoparsec.Char8 (Number(..))
58−import Data.Generics
59−import Data.Hashable (Hashable(..))
60−import Data.Int (Int8, Int16, Int32, Int64)
61−import Data.IntSet (IntSet)
62−import Data.List (foldl')
63−import Data.Map (Map)
64−import Data.Maybe (fromJust)
65−import Data.Monoid (Dual(..), First(..), Last(..))
66−import Data.Monoid (Monoid(..))
67−import Data.Ratio (Ratio)
68−import Data.String (IsString(..))
69−import Data.Text (Text, pack, unpack)
70−import Data.Text.Encoding (encodeUtf8)
71−import Data.Time.Clock (UTCTime)
72−import Data.Time.Format (FormatTime, formatTime, parseTime)
73−import Data.Vector (Vector)
74−import Data.Word (Word, Word8, Word16, Word32, Word64)
75−import Foreign.Storable (Storable)
76−import System.Locale (defaultTimeLocale)
77−import qualified Data.ByteString as B
78−import qualified Data.ByteString.Lazy as LB
79−import qualified Data.HashMap.Strict as H
80−import qualified Data.HashSet as HashSet
81−import qualified Data.IntSet as IntSet
82−import qualified Data.Map as M
83−import qualified Data.Set as Set
84−import qualified Data.Text as T
85−import qualified Data.Text.Lazy as LT
86−import qualified Data.Traversable as T
87−import qualified Data.Vector as V
88−import qualified Data.Vector.Storable as VS
89−import qualified Data.Vector.Primitive as VP
90−import qualified Data.Vector.Unboxed as VU
91−import qualified Data.Vector.Generic as VG
92−
93−
94−-- | The result of running a 'Parser'.
95−data Result a = Error String
96− | Success a
97− deriving (Eq, Show, Typeable)
98−
99−instance (NFData a) => NFData (Result a) where
100− rnf (Success a) = rnf a
101− rnf (Error err) = rnf err
102−
103−instance Functor Result where
104− fmap f (Success a) = Success (f a)
105− fmap _ (Error err) = Error err
106− {-# INLINE fmap #-}
107−
108−instance Monad Result where
109− return = Success
110− {-# INLINE return #-}
111− Success a >>= k = k a
112− Error err >>= _ = Error err
113− {-# INLINE (>>=) #-}
114−
115−instance Applicative Result where
116− pure = return
117− {-# INLINE pure #-}
118− (<*>) = ap
119− {-# INLINE (<*>) #-}
120−
121−instance MonadPlus Result where
122− mzero = fail "mzero"
123− {-# INLINE mzero #-}
124− mplus a@(Success _) _ = a
125− mplus _ b = b
126− {-# INLINE mplus #-}
127−
128−instance Alternative Result where
129− empty = mzero
130− {-# INLINE empty #-}
131− (<|>) = mplus
132− {-# INLINE (<|>) #-}
133−
134−instance Monoid (Result a) where
135− mempty = fail "mempty"
136− {-# INLINE mempty #-}
137− mappend = mplus
138− {-# INLINE mappend #-}
139−
140−-- | Failure continuation.
141−type Failure f r = String -> f r
142−-- | Success continuation.
143−type Success a f r = a -> f r
144−
145−-- | A continuation-based parser type.
146−newtype Parser a = Parser {
147− runParser :: forall f r.
148− Failure f r
149− -> Success a f r
150− -> f r
151− }
152−
153−instance Monad Parser where
154− m >>= g = Parser $ \kf ks -> let ks' a = runParser (g a) kf ks
155− in runParser m kf ks'
156− {-# INLINE (>>=) #-}
157− return a = Parser $ \_kf ks -> ks a
158− {-# INLINE return #-}
159− fail msg = Parser $ \kf _ks -> kf msg
160− {-# INLINE fail #-}
161−
162−instance Functor Parser where
163− fmap f m = Parser $ \kf ks -> let ks' a = ks (f a)
164− in runParser m kf ks'
165− {-# INLINE fmap #-}
166−
167−instance Applicative Parser where
168− pure = return
169− {-# INLINE pure #-}
170− (<*>) = apP
171− {-# INLINE (<*>) #-}
172−
173−instance Alternative Parser where
174− empty = fail "empty"
175− {-# INLINE empty #-}
176− (<|>) = mplus
177− {-# INLINE (<|>) #-}
178−
179−instance MonadPlus Parser where
180− mzero = fail "mzero"
181− {-# INLINE mzero #-}
182− mplus a b = Parser $ \kf ks -> let kf' _ = runParser b kf ks
183− in runParser a kf' ks
184− {-# INLINE mplus #-}
185−
186−instance Monoid (Parser a) where
187− mempty = fail "mempty"
188− {-# INLINE mempty #-}
189− mappend = mplus
190− {-# INLINE mappend #-}
191−
192−apP :: Parser (a -> b) -> Parser a -> Parser b
193−apP d e = do
194− b <- d
195− a <- e
196− return (b a)
197−{-# INLINE apP #-}
198−
199−-- | A JSON \"object\" (key\/value map).
200−type Object = Map Text Value
201−
202−-- | A JSON \"array\" (sequence).
203−type Array = Vector Value
204−
205−-- | A JSON value represented as a Haskell value.
206−data Value = Object Object
207− | Array Array
208− | String Text
209− | Number Number
210− | Bool !Bool
211− | Null
212− deriving (Eq, Show, Typeable, Data)
213−
214−instance NFData Value where
215− rnf (Object o) = rnf o
216− rnf (Array a) = V.foldl' (\x y -> rnf y `seq` x) () a
217− rnf (String s) = rnf s
218− rnf (Number n) = case n of I i -> rnf i; D d -> rnf d
219− rnf (Bool b) = rnf b
220− rnf Null = ()
221−
222−instance IsString Value where
223− fromString = String . pack
224− {-# INLINE fromString #-}
225−
226−instance Hashable Value where
227− hash (Object o) = foldl' hashWithSalt 0 . M.toList $ o
228− hash (Array a) = V.foldl' hashWithSalt 1 a
229− hash (String s) = 2 `hashWithSalt` s
230− hash (Number n) = 3 `hashWithSalt` case n of I i -> hash i; D d -> hash d
231− hash (Bool b) = 4 `hashWithSalt` b
232− hash Null = 5
233−
234−-- | The empty array.
235−emptyArray :: Value
236−emptyArray = Array V.empty
237−
238−-- | The empty object.
239−emptyObject :: Value
240−emptyObject = Object M.empty
241−
242−-- | A key\/value pair for an 'Object'.
243−type Pair = (Text, Value)
244−
245−-- | Construct a 'Pair' from a key and a value.
246−(.=) :: ToJSON a => Text -> a -> Pair
247−name .= value = (name, toJSON value)
248−{-# INLINE (.=) #-}
249−
250−-- | Convert a value from JSON, failing if the types do not match.
251−fromJSON :: (FromJSON a) => Value -> Result a
252−fromJSON = parse parseJSON
253−{-# INLINE fromJSON #-}
254−
255−-- | Run a 'Parser'.
256−parse :: (a -> Parser b) -> a -> Result b
257−parse m v = runParser (m v) Error Success
258−{-# INLINE parse #-}
259−
260−-- | Run a 'Parser' with a 'Maybe' result type.
261−parseMaybe :: (a -> Parser b) -> a -> Maybe b
262−parseMaybe m v = runParser (m v) (const Nothing) Just
263−{-# INLINE parseMaybe #-}
264−
265−-- | Run a 'Parser' with an 'Either' result type.
266−parseEither :: (a -> Parser b) -> a -> Either String b
267−parseEither m v = runParser (m v) Left Right
268−{-# INLINE parseEither #-}
269−
270−-- | Retrieve the value associated with the given key of an 'Object'.
271−-- The result is 'empty' if the key is not present or the value cannot
272−-- be converted to the desired type.
273−--
274−-- This accessor is appropriate if the key and value /must/ be present
275−-- in an object for it to be valid. If the key and value are
276−-- optional, use '(.:?)' instead.
277−(.:) :: (FromJSON a) => Object -> Text -> Parser a
278−obj .: key = case M.lookup key obj of
279− Nothing -> fail $ "key " ++ show key ++ " not present"
280− Just v -> parseJSON v
281−{-# INLINE (.:) #-}
282−
283−-- | Retrieve the value associated with the given key of an 'Object'.
284−-- The result is 'Nothing' if the key is not present, or 'empty' if
285−-- the value cannot be converted to the desired type.
286−--
287−-- This accessor is most useful if the key and value can be absent
288−-- from an object without affecting its validity. If the key and
289−-- value are mandatory, use '(.:)' instead.
290−(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
291−obj .:? key = case M.lookup key obj of
292− Nothing -> pure Nothing
293− Just v -> parseJSON v
294−{-# INLINE (.:?) #-}
295−
296−-- | Create a 'Value' from a list of name\/value 'Pair's. If duplicate
297−-- keys arise, earlier keys and their associated values win.
298−object :: [Pair] -> Value
299−object = Object . M.fromList
300−{-# INLINE object #-}
301−
302−-- | A type that can be converted to JSON.
303−--
304−-- An example type and instance:
305−--
306−-- @data Coord { x :: Double, y :: Double }
307−--
308−-- instance ToJSON Coord where
309−-- toJSON (Coord x y) = 'object' [\"x\" '.=' x, \"y\" '.=' y]
310−-- @
311−--
312−-- This example assumes the OverloadedStrings language option is enabled.
313−class ToJSON a where
314− toJSON :: a -> Value
315−
316−#ifdef DEFAULT_SIGNATURES
317− default toJSON :: Data a => a -> Value
318− toJSON = genericToJSON
319−#endif
320−
321−-- | A type that can be converted from JSON, with the possibility of
322−-- failure.
323−--
324−-- When writing an instance, use 'mzero' or 'fail' to make a
325−-- conversion fail, e.g. if an 'Object' is missing a required key, or
326−-- the value is of the wrong type.
327−--
328−-- An example type and instance:
329−--
330−-- @data Coord { x :: Double, y :: Double }
331−--
332−-- instance FromJSON Coord where
333−-- parseJSON ('Object' v) = Coord '<$>'
334−-- v '.:' \"x\" '<*>'
335−-- v '.:' \"y\"
336−--
337−-- \-- A non-'Object' value is of the wrong type, so use 'mzero' to fail.
338−-- parseJSON _ = 'mzero'
339−-- @
340−--
341−-- This example assumes the OverloadedStrings language option is enabled.
342−class FromJSON a where
343− parseJSON :: Value -> Parser a
42+import Data.Aeson.Types.Class
43+import Data.Aeson.Types.Internal
34444
345−#ifdef DEFAULT_SIGNATURES
346− default parseJSON :: Data a => Value -> Parser a
347− parseJSON = genericParseJSON
45+#ifdef GENERICS
46+import Data.Aeson.Types.Generic ()
34847#endif
349−
350−instance (ToJSON a) => ToJSON (Maybe a) where
351− toJSON (Just a) = toJSON a
352− toJSON Nothing = Null
353− {-# INLINE toJSON #-}
354−
355−instance (FromJSON a) => FromJSON (Maybe a) where
356− parseJSON Null = pure Nothing
357− parseJSON a = Just <$> parseJSON a
358− {-# INLINE parseJSON #-}
359−
360−instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where
361− toJSON (Left a) = object [left .= a]
362− toJSON (Right b) = object [right .= b]
363− {-# INLINE toJSON #-}
364−
365−instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
366− parseJSON (Object (M.toList -> [(key, value)]))
367− | key == left = Left <$> parseJSON value
368− | key == right = Right <$> parseJSON value
369− parseJSON _ = mzero
370− {-# INLINE parseJSON #-}
371−
372−left, right :: Text
373−left = "Left"
374−right = "Right"
375−
376−instance ToJSON Bool where
377− toJSON = Bool
378− {-# INLINE toJSON #-}
379−
380−instance FromJSON Bool where
381− parseJSON (Bool b) = pure b
382− parseJSON v = typeMismatch "Bool" v
383− {-# INLINE parseJSON #-}
384−
385−instance ToJSON () where
386− toJSON _ = emptyArray
387− {-# INLINE toJSON #-}
388−
389−instance FromJSON () where
390− parseJSON (Array v) | V.null v = pure ()
391− parseJSON v = typeMismatch "()" v
392− {-# INLINE parseJSON #-}
393−
394−instance ToJSON [Char] where
395− toJSON = String . T.pack
396− {-# INLINE toJSON #-}
397−
398−instance FromJSON [Char] where
399− parseJSON (String t) = pure (T.unpack t)
400− parseJSON v = typeMismatch "String" v
401− {-# INLINE parseJSON #-}
402−
403−instance ToJSON Char where
404− toJSON = String . T.singleton
405− {-# INLINE toJSON #-}
406−
407−instance FromJSON Char where
408− parseJSON (String t)
409− | T.compareLength t 1 == EQ = pure (T.head t)
410− parseJSON v = typeMismatch "Char" v
411− {-# INLINE parseJSON #-}
412−
413−instance ToJSON Double where
414− toJSON = Number . D
415− {-# INLINE toJSON #-}
416−
417−instance FromJSON Double where
418− parseJSON (Number n) = case n of
419− D d -> pure d
420− I i -> pure (fromIntegral i)
421− parseJSON Null = pure (0/0)
422− parseJSON v = typeMismatch "Double" v
423− {-# INLINE parseJSON #-}
424−
425−instance ToJSON Number where
426− toJSON = Number
427− {-# INLINE toJSON #-}
428−
429−instance FromJSON Number where
430− parseJSON (Number n) = pure n
431− parseJSON Null = pure (D (0/0))
432− parseJSON v = typeMismatch "Number" v
433− {-# INLINE parseJSON #-}
434−
435−instance ToJSON Float where
436− toJSON = Number . realToFrac
437− {-# INLINE toJSON #-}
438−
439−instance FromJSON Float where
440− parseJSON (Number n) = pure $ case n of
441− D d -> realToFrac d
442− I i -> fromIntegral i
443− parseJSON Null = pure (0/0)
444− parseJSON v = typeMismatch "Float" v
445− {-# INLINE parseJSON #-}
446−
447−instance ToJSON (Ratio Integer) where
448− toJSON = Number . fromRational
449− {-# INLINE toJSON #-}
450−
451−instance FromJSON (Ratio Integer) where
452− parseJSON (Number n) = pure $ case n of
453− D d -> toRational d
454− I i -> fromIntegral i
455− parseJSON v = typeMismatch "Ratio Integer" v
456− {-# INLINE parseJSON #-}
457−
458−instance ToJSON Int where
459− toJSON = Number . fromIntegral
460− {-# INLINE toJSON #-}
461−
462−instance FromJSON Int where
463− parseJSON = parseIntegral
464− {-# INLINE parseJSON #-}
465−
466−parseIntegral :: Integral a => Value -> Parser a
467−parseIntegral (Number n) = pure (floor n)
468−parseIntegral v = typeMismatch "Integral" v
469−{-# INLINE parseIntegral #-}
470−
471−instance ToJSON Integer where
472− toJSON = Number . fromIntegral
473− {-# INLINE toJSON #-}
474−
475−instance FromJSON Integer where
476− parseJSON = parseIntegral
477− {-# INLINE parseJSON #-}
478−
479−instance ToJSON Int8 where
480− toJSON = Number . fromIntegral
481− {-# INLINE toJSON #-}
482−
483−instance FromJSON Int8 where
484− parseJSON = parseIntegral
485− {-# INLINE parseJSON #-}
486−
487−instance ToJSON Int16 where
488− toJSON = Number . fromIntegral
489− {-# INLINE toJSON #-}
490−
491−instance FromJSON Int16 where
492− parseJSON = parseIntegral
493− {-# INLINE parseJSON #-}
494−
495−instance ToJSON Int32 where
496− toJSON = Number . fromIntegral
497− {-# INLINE toJSON #-}
498−
499−instance FromJSON Int32 where
500− parseJSON = parseIntegral
501− {-# INLINE parseJSON #-}
502−
503−instance ToJSON Int64 where
504− toJSON = Number . fromIntegral
505− {-# INLINE toJSON #-}
506−
507−instance FromJSON Int64 where
508− parseJSON = parseIntegral
509− {-# INLINE parseJSON #-}
510−
511−instance ToJSON Word where
512− toJSON = Number . fromIntegral
513− {-# INLINE toJSON #-}
514−
515−instance FromJSON Word where
516− parseJSON = parseIntegral
517− {-# INLINE parseJSON #-}
518−
519−instance ToJSON Word8 where
520− toJSON = Number . fromIntegral
521− {-# INLINE toJSON #-}
522−
523−instance FromJSON Word8 where
524− parseJSON = parseIntegral
525− {-# INLINE parseJSON #-}
526−
527−instance ToJSON Word16 where
528− toJSON = Number . fromIntegral
529− {-# INLINE toJSON #-}
530−
531−instance FromJSON Word16 where
532− parseJSON = parseIntegral
533− {-# INLINE parseJSON #-}
534−
535−instance ToJSON Word32 where
536− toJSON = Number . fromIntegral
537− {-# INLINE toJSON #-}
538−
539−instance FromJSON Word32 where
540− parseJSON = parseIntegral
541− {-# INLINE parseJSON #-}
542−
543−instance ToJSON Word64 where
544− toJSON = Number . fromIntegral
545− {-# INLINE toJSON #-}
546−
547−instance FromJSON Word64 where
548− parseJSON = parseIntegral
549− {-# INLINE parseJSON #-}
550−
551−instance ToJSON Text where
552− toJSON = String
553− {-# INLINE toJSON #-}
554−
555−instance FromJSON Text where
556− parseJSON (String t) = pure t
557− parseJSON v = typeMismatch "Text" v
558− {-# INLINE parseJSON #-}
559−
560−instance ToJSON LT.Text where
561− toJSON = String . LT.toStrict
562− {-# INLINE toJSON #-}
563−
564−instance FromJSON LT.Text where
565− parseJSON (String t) = pure (LT.fromStrict t)
566− parseJSON v = typeMismatch "Lazy Text" v
567− {-# INLINE parseJSON #-}
568−
569−instance ToJSON B.ByteString where
570− toJSON = String . decode
571− {-# INLINE toJSON #-}
572−
573−instance FromJSON B.ByteString where
574− parseJSON (String t) = pure . encodeUtf8 $ t
575− parseJSON v = typeMismatch "ByteString" v
576− {-# INLINE parseJSON #-}
577−
578−instance ToJSON LB.ByteString where
579− toJSON = toJSON . strict
580− {-# INLINE toJSON #-}
581−
582−instance FromJSON LB.ByteString where
583− parseJSON (String t) = pure . lazy $ t
584− parseJSON v = typeMismatch "Lazy ByteString" v
585− {-# INLINE parseJSON #-}
586−
587−instance (ToJSON a) => ToJSON [a] where
588− toJSON = Array . V.fromList . map toJSON
589− {-# INLINE toJSON #-}
590−
591−instance (FromJSON a) => FromJSON [a] where
592− parseJSON (Array a) = mapM parseJSON (V.toList a)
593− parseJSON v = typeMismatch "[a]" v
594− {-# INLINE parseJSON #-}
595−
596−instance (ToJSON a) => ToJSON (Vector a) where
597− toJSON = Array . V.map toJSON
598− {-# INLINE toJSON #-}
599−
600−instance (FromJSON a) => FromJSON (Vector a) where
601− parseJSON (Array a) = V.mapM parseJSON a
602− parseJSON v = typeMismatch "Vector a" v
603− {-# INLINE parseJSON #-}
604−
605−vectorToJSON :: (VG.Vector v a, ToJSON a) => v a -> Value
606−vectorToJSON = Array . V.map toJSON . V.convert
607−{-# INLINE vectorToJSON #-}
608−
609−vectorParseJSON :: (FromJSON a, VG.Vector w a) => String -> Value -> Parser (w a)
610−vectorParseJSON _ (Array a) = V.convert <$> V.mapM parseJSON a
611−vectorParseJSON s v = typeMismatch s v
612−{-# INLINE vectorParseJSON #-}
613−
614−instance (Storable a, ToJSON a) => ToJSON (VS.Vector a) where
615− toJSON = vectorToJSON
616−
617−instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where
618− parseJSON = vectorParseJSON "Data.Vector.Storable.Vector a"
619−
620−instance (VP.Prim a, ToJSON a) => ToJSON (VP.Vector a) where
621− toJSON = vectorToJSON
622−
623−instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where
624− parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector a"
625−
626−instance (VG.Vector VU.Vector a, ToJSON a) => ToJSON (VU.Vector a) where
627− toJSON = vectorToJSON
628−
629−instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where
630− parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"
631−
632−instance (ToJSON a) => ToJSON (Set.Set a) where
633− toJSON = toJSON . Set.toList
634− {-# INLINE toJSON #-}
635−
636−instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
637− parseJSON = fmap Set.fromList . parseJSON
638− {-# INLINE parseJSON #-}
639−
640−instance (ToJSON a) => ToJSON (HashSet.HashSet a) where
641− toJSON = toJSON . HashSet.toList
642− {-# INLINE toJSON #-}
643−
644−instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
645− parseJSON = fmap HashSet.fromList . parseJSON
646− {-# INLINE parseJSON #-}
647−
648−instance ToJSON IntSet.IntSet where
649− toJSON = toJSON . IntSet.toList
650− {-# INLINE toJSON #-}
651−
652−instance FromJSON IntSet.IntSet where
653− parseJSON = fmap IntSet.fromList . parseJSON
654− {-# INLINE parseJSON #-}
655−
656−instance (ToJSON v) => ToJSON (M.Map Text v) where
657− toJSON = Object . M.map toJSON
658− {-# INLINE toJSON #-}
659−
660−instance (FromJSON v) => FromJSON (M.Map Text v) where
661− parseJSON (Object o) = M.fromAscList <$> mapM go (M.toAscList o)
662− where go (k,v) = ((,) k) <$> parseJSON v
663− parseJSON v = typeMismatch "Map Text a" v
664−
665−instance (ToJSON v) => ToJSON (M.Map LT.Text v) where
666− toJSON = Object . transformMap LT.toStrict toJSON
667−
668−instance (FromJSON v) => FromJSON (M.Map LT.Text v) where
669− parseJSON = fmap (M.mapKeysMonotonic LT.fromStrict) . parseJSON
670−
671−instance (ToJSON v) => ToJSON (M.Map String v) where
672− toJSON = Object . transformMap pack toJSON
673−
674−instance (FromJSON v) => FromJSON (M.Map String v) where
675− parseJSON = fmap (M.mapKeysMonotonic unpack) . parseJSON
676−
677−instance (ToJSON v) => ToJSON (M.Map B.ByteString v) where
678− toJSON = Object . transformMap decode toJSON
679−
680−instance (FromJSON v) => FromJSON (M.Map B.ByteString v) where
681− parseJSON = fmap (M.mapKeysMonotonic encodeUtf8) . parseJSON
682−
683−instance (ToJSON v) => ToJSON (M.Map LB.ByteString v) where
684− toJSON = Object . transformMap strict toJSON
685−
686−instance (FromJSON v) => FromJSON (M.Map LB.ByteString v) where
687− parseJSON = fmap (M.mapKeysMonotonic lazy) . parseJSON
688−
689−instance (ToJSON v) => ToJSON (H.HashMap Text v) where
690− toJSON = Object . hashMap id toJSON
691− {-# INLINE toJSON #-}
692−
693−instance (FromJSON v) => FromJSON (H.HashMap Text v) where
694− parseJSON (Object o) = H.fromList <$> mapM go (M.toList o)
695− where go (k,v) = ((,) k) <$> parseJSON v
696− parseJSON v = typeMismatch "HashMap Text a" v
697−
698−instance (ToJSON v) => ToJSON (H.HashMap LT.Text v) where
699− toJSON = Object . M.fromList . H.foldrWithKey (\k v -> ((LT.toStrict k,toJSON v) :)) []
700−
701−instance (FromJSON v) => FromJSON (H.HashMap LT.Text v) where
702− parseJSON = fmap (mapHash LT.fromStrict) . parseJSON
703−
704−instance (ToJSON v) => ToJSON (H.HashMap String v) where
705− toJSON = Object . hashMap pack toJSON
706−
707−instance (FromJSON v) => FromJSON (H.HashMap String v) where
708− parseJSON = fmap (mapHash unpack) . parseJSON
709−
710−instance (ToJSON v) => ToJSON (H.HashMap B.ByteString v) where
711− toJSON = Object . hashMap decode toJSON
712−
713−instance (FromJSON v) => FromJSON (H.HashMap B.ByteString v) where
714− parseJSON = fmap (mapHash encodeUtf8) . parseJSON
715−
716−instance (ToJSON v) => ToJSON (H.HashMap LB.ByteString v) where
717− toJSON = Object . hashMap strict toJSON
718−
719−instance (FromJSON v) => FromJSON (H.HashMap LB.ByteString v) where
720− parseJSON = fmap (mapHash lazy) . parseJSON
721−
722−instance ToJSON Value where
723− toJSON a = a
724− {-# INLINE toJSON #-}
725−
726−instance FromJSON Value where
727− parseJSON a = pure a
728− {-# INLINE parseJSON #-}
729−
730−-- | A newtype wrapper for 'UTCTime' that uses the same non-standard
731−-- serialization format as Microsoft .NET, whose @System.DateTime@
732−-- type is by default serialized to JSON as in the following example:
733−--
734−-- > /Date(1302547608878)/
735−--
736−-- The number represents milliseconds since the Unix epoch.
737−newtype DotNetTime = DotNetTime {
738− fromDotNetTime :: UTCTime
739− } deriving (Eq, Ord, Read, Show, Typeable, FormatTime)
740−
741−instance ToJSON DotNetTime where
742− toJSON (DotNetTime t) =
743− String (pack (secs ++ msecs ++ ")/"))
744− where secs = formatTime defaultTimeLocale "/Date(%s" t
745− msecs = take 3 $ formatTime defaultTimeLocale "%q" t
746− {-# INLINE toJSON #-}
747−
748−instance FromJSON DotNetTime where
749− parseJSON (String t) =
750− case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
751− Just d -> pure (DotNetTime d)
752− _ -> fail "could not parse .NET time"
753− where (s,m) = T.splitAt (T.length t - 5) t
754− t' = T.concat [s,".",m]
755− parseJSON v = typeMismatch "DotNetTime" v
756− {-# INLINE parseJSON #-}
757−
758−instance ToJSON UTCTime where
759− toJSON t = String (pack (take 23 str ++ "Z"))
760− where str = formatTime defaultTimeLocale "%FT%T%Q" t
761− {-# INLINE toJSON #-}
762−
763−instance FromJSON UTCTime where
764− parseJSON (String t) =
765− case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of
766− Just d -> pure d
767− _ -> fail "could not parse ISO-8601 date"
768− parseJSON v = typeMismatch "UTCTime" v
769− {-# INLINE parseJSON #-}
770−
771−instance (ToJSON a, ToJSON b) => ToJSON (a,b) where
772− toJSON (a,b) = toJSON [toJSON a, toJSON b]
773− {-# INLINE toJSON #-}
774−
775−instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
776− parseJSON (Array ab) =
777− case V.toList ab of
778− [a,b] -> (,) <$> parseJSON a <*> parseJSON b
779− _ -> fail $ "cannot unpack array of length " ++
780− show (V.length ab) ++ " into a pair"
781− parseJSON v = typeMismatch "(a,b)" v
782− {-# INLINE parseJSON #-}
783−
784−instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where
785− toJSON (a,b,c) = toJSON [toJSON a, toJSON b, toJSON c]
786− {-# INLINE toJSON #-}
787−
788−instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where
789− parseJSON (Array abc) =
790− case V.toList abc of
791− [a,b,c] -> (,,) <$> parseJSON a <*> parseJSON b <*> parseJSON c
792− _ -> fail $ "cannot unpack array of length " ++
793− show (V.length abc) ++ " into a 3-tuple"
794− parseJSON v = typeMismatch "(a,b,c)" v
795− {-# INLINE parseJSON #-}
796−
797−instance ToJSON a => ToJSON (Dual a) where
798− toJSON = toJSON . getDual
799− {-# INLINE toJSON #-}
800−
801−instance FromJSON a => FromJSON (Dual a) where
802− parseJSON = fmap Dual . parseJSON
803− {-# INLINE parseJSON #-}
804−
805−instance ToJSON a => ToJSON (First a) where
806− toJSON = toJSON . getFirst
807− {-# INLINE toJSON #-}
808−
809−instance FromJSON a => FromJSON (First a) where
810− parseJSON = fmap First . parseJSON
811− {-# INLINE parseJSON #-}
812−
813−instance ToJSON a => ToJSON (Last a) where
814− toJSON = toJSON . getLast
815− {-# INLINE toJSON #-}
816−
817−instance FromJSON a => FromJSON (Last a) where
818− parseJSON = fmap Last . parseJSON
819− {-# INLINE parseJSON #-}
820−
821−-- | Fail parsing due to a type mismatch, with a descriptive message.
822−typeMismatch :: String -- ^ The name of the type you are trying to parse.
823− -> Value -- ^ The actual value encountered.
824− -> Parser a
825−typeMismatch expected actual =
826− fail $ "when expecting a " ++ expected ++ ", encountered " ++ name ++
827− " instead"
828− where
829− name = case actual of
830− Object _ -> "Object"
831− Array _ -> "Array"
832− String _ -> "String"
833− Number _ -> "Number"
834− Bool _ -> "Boolean"
835− Null -> "Null"
836−
837−
838−--------------------------------------------------------------------------------
839−-- Generic toJSON and fromJSON
840−
841−type T a = a -> Value
842−
843−genericToJSON :: (Data a) => a -> Value
844−genericToJSON = toJSON_generic
845− `ext1Q` list
846− `ext1Q` vector
847− `ext1Q` set
848− `ext2Q'` mapAny
849− `ext2Q'` hashMapAny
850− -- Use the standard encoding for all base types.
851− `extQ` (toJSON :: T Integer)
852− `extQ` (toJSON :: T Int)
853− `extQ` (toJSON :: T Int8)
854− `extQ` (toJSON :: T Int16)
855− `extQ` (toJSON :: T Int32)
856− `extQ` (toJSON :: T Int64)
857− `extQ` (toJSON :: T Word)
858− `extQ` (toJSON :: T Word8)
859− `extQ` (toJSON :: T Word16)
860− `extQ` (toJSON :: T Word32)
861− `extQ` (toJSON :: T Word64)
862− `extQ` (toJSON :: T Double)
863− `extQ` (toJSON :: T Number)
864− `extQ` (toJSON :: T Float)
865− `extQ` (toJSON :: T Rational)
866− `extQ` (toJSON :: T Char)
867− `extQ` (toJSON :: T Text)
868− `extQ` (toJSON :: T LT.Text)
869− `extQ` (toJSON :: T String)
870− `extQ` (toJSON :: T B.ByteString)
871− `extQ` (toJSON :: T LB.ByteString)
872− `extQ` (toJSON :: T Value)
873− `extQ` (toJSON :: T DotNetTime)
874− `extQ` (toJSON :: T UTCTime)
875− `extQ` (toJSON :: T IntSet)
876− `extQ` (toJSON :: T Bool)
877− `extQ` (toJSON :: T ())
878− --`extQ` (T.toJSON :: T Ordering)
879− where
880− list xs = Array . V.fromList . map genericToJSON $ xs
881− vector v = Array . V.map genericToJSON $ v
882− set s = Array . V.fromList . map genericToJSON . Set.toList $ s
883−
884− mapAny m
885− | tyrep == typeOf T.empty = remap id
886− | tyrep == typeOf LT.empty = remap LT.toStrict
887− | tyrep == typeOf string = remap pack
888− | tyrep == typeOf B.empty = remap decode
889− | tyrep == typeOf LB.empty = remap strict
890− | otherwise = modError "genericToJSON" $
891− "cannot convert map keyed by type " ++ show tyrep
892− where tyrep = typeOf . head . M.keys $ m
893− remap f = Object . transformMap (f . fromJust . cast) genericToJSON $ m
894−
895− hashMapAny m
896− | tyrep == typeOf T.empty = remap id
897− | tyrep == typeOf LT.empty = remap LT.toStrict
898− | tyrep == typeOf string = remap pack
899− | tyrep == typeOf B.empty = remap decode
900− | tyrep == typeOf LB.empty = remap strict
901− | otherwise = modError "genericToJSON" $
902− "cannot convert map keyed by type " ++ show tyrep
903− where tyrep = typeOf . head . H.keys $ m
904− remap f = Object . hashMap (f . fromJust . cast) genericToJSON $ m
905−
906−
907−toJSON_generic :: (Data a) => a -> Value
908−toJSON_generic = generic
909− where
910− -- Generic encoding of an algebraic data type.
911− generic a =
912− case dataTypeRep (dataTypeOf a) of
913− -- No constructor, so it must be an error value. Code
914− -- it anyway as Null.
915− AlgRep [] -> Null
916− -- Elide a single constructor and just code the arguments.
917− AlgRep [c] -> encodeArgs c (gmapQ genericToJSON a)
918− -- For multiple constructors, make an object with a
919− -- field name that is the constructor (except lower
920− -- case) and the data is the arguments encoded.
921− AlgRep _ -> encodeConstr (toConstr a) (gmapQ genericToJSON a)
922− rep -> err (dataTypeOf a) rep
923− where
924− err dt r = modError "genericToJSON" $ "not AlgRep " ++
925− show r ++ "(" ++ show dt ++ ")"
926− -- Encode nullary constructor as a string.
927− -- Encode non-nullary constructors as an object with the constructor
928− -- name as the single field and the arguments as the value.
929− -- Use an array if the are no field names, but elide singleton arrays,
930− -- and use an object if there are field names.
931− encodeConstr c [] = String . constrString $ c
932− encodeConstr c as = object [(constrString c, encodeArgs c as)]
933−
934− constrString = pack . showConstr
935−
936− encodeArgs c = encodeArgs' (constrFields c)
937− encodeArgs' [] [j] = j
938− encodeArgs' [] js = Array . V.fromList $ js
939− encodeArgs' ns js = object $ zip (map mungeField ns) js
940−
941− -- Skip leading '_' in field name so we can use keywords
942− -- etc. as field names.
943− mungeField ('_':cs) = pack cs
944− mungeField cs = pack cs
945−
946−genericFromJSON :: (Data a) => Value -> Result a
947−genericFromJSON = parse genericParseJSON
948−
949−type F a = Parser a
950−
951−genericParseJSON :: (Data a) => Value -> Parser a
952−genericParseJSON j = parseJSON_generic j
953− `ext1R` list
954− `ext1R` vector
955− `ext2R'` mapAny
956− `ext2R'` hashMapAny
957− -- Use the standard encoding for all base types.
958− `extR` (value :: F Integer)
959− `extR` (value :: F Int)
960− `extR` (value :: F Int8)
961− `extR` (value :: F Int16)
962− `extR` (value :: F Int32)
963− `extR` (value :: F Int64)
964− `extR` (value :: F Word)
965− `extR` (value :: F Word8)
966− `extR` (value :: F Word16)
967− `extR` (value :: F Word32)
968− `extR` (value :: F Word64)
969− `extR` (value :: F Double)
970− `extR` (value :: F Number)
971− `extR` (value :: F Float)
972− `extR` (value :: F Rational)
973− `extR` (value :: F Char)
974− `extR` (value :: F Text)
975− `extR` (value :: F LT.Text)
976− `extR` (value :: F String)
977− `extR` (value :: F B.ByteString)
978− `extR` (value :: F LB.ByteString)
979− `extR` (value :: F Value)
980− `extR` (value :: F DotNetTime)
981− `extR` (value :: F UTCTime)
982− `extR` (value :: F IntSet)
983− `extR` (value :: F Bool)
984− `extR` (value :: F ())
985− where
986− value :: (FromJSON a) => Parser a
987− value = parseJSON j
988− list :: (Data a) => Parser [a]
989− list = V.toList <$> genericParseJSON j
990− vector :: (Data a) => Parser (V.Vector a)
991− vector = case j of
992− Array js -> V.mapM genericParseJSON js
993− _ -> myFail
994− mapAny :: forall e f. (Data e, Data f) => Parser (Map f e)
995− mapAny
996− | tyrep `elem` stringyTypes = res
997− | otherwise = myFail
998− where res = case j of
999− Object js -> M.mapKeysMonotonic trans <$> T.mapM genericParseJSON js
1000− _ -> myFail
1001− trans
1002− | tyrep == typeOf T.empty = remap id
1003− | tyrep == typeOf LT.empty = remap LT.fromStrict
1004− | tyrep == typeOf string = remap T.unpack
1005− | tyrep == typeOf B.empty = remap encodeUtf8
1006− | tyrep == typeOf LB.empty = remap lazy
1007− | otherwise = modError "genericParseJSON"
1008− "mapAny -- should never happen"
1009− tyrep = typeOf (undefined :: f)
1010− remap f = fromJust . cast . f
1011− hashMapAny :: forall e f. (Data e, Data f) => Parser (H.HashMap f e)
1012− hashMapAny
1013− | tyrep == typeOf string = process T.unpack
1014− | tyrep == typeOf LT.empty = process LT.fromStrict
1015− | tyrep == typeOf T.empty = process id
1016− | otherwise = myFail
1017− where
1018− process f = maybe myFail return . cast =<< parseWith f
1019− parseWith :: (Eq c, Hashable c) => (Text -> c) -> Parser (H.HashMap c e)
1020− parseWith f = case j of
1021− Object js -> H.fromList . map (first f) . M.toList <$>
1022− T.mapM genericParseJSON js
1023− _ -> myFail
1024− tyrep = typeOf (undefined :: f)
1025− myFail = modFail "genericParseJSON" $ "bad data: " ++ show j
1026− stringyTypes = [typeOf LT.empty, typeOf T.empty, typeOf B.empty,
1027− typeOf LB.empty, typeOf string]
1028−
1029−parseJSON_generic :: (Data a) => Value -> Parser a
1030−parseJSON_generic j = generic
1031− where
1032− typ = dataTypeOf $ resType generic
1033− generic = case dataTypeRep typ of
1034− AlgRep [] -> case j of
1035− Null -> return (modError "genericParseJSON" "empty type")
1036− _ -> modFail "genericParseJSON" "no-constr bad data"
1037− AlgRep [_] -> decodeArgs (indexConstr typ 1) j
1038− AlgRep _ -> do (c, j') <- getConstr typ j; decodeArgs c j'
1039− rep -> modFail "genericParseJSON" $
1040− show rep ++ "(" ++ show typ ++ ")"
1041− getConstr t (Object o) | [(s, j')] <- fromJSObject o = do
1042− c <- readConstr' t s
1043− return (c, j')
1044− getConstr t (String js) = do c <- readConstr' t (unpack js)
1045− return (c, Null) -- handle nullary ctor
1046− getConstr _ _ = modFail "genericParseJSON" "bad constructor encoding"
1047− readConstr' t s =
1048− maybe (modFail "genericParseJSON" $ "unknown constructor: " ++ s ++ " " ++
1049− show t)
1050− return $ readConstr t s
1051−
1052− decodeArgs c0 = go (numConstrArgs (resType generic) c0) c0
1053− (constrFields c0)
1054− where
1055− go 0 c _ Null = construct c [] -- nullary constructor
1056− go 1 c [] jd = construct c [jd] -- unary constructor
1057− go n c [] (Array js)
1058− | n > 1 = construct c (V.toList js) -- no field names
1059− -- FIXME? We could allow reading an array into a constructor
1060− -- with field names.
1061− go _ c fs@(_:_) (Object o) = selectFields o fs >>=
1062− construct c -- field names
1063− go _ c _ jd = modFail "genericParseJSON" $
1064− "bad decodeArgs data " ++ show (c, jd)
1065−
1066− fromJSObject = map (first unpack) . M.toList
1067−
1068− -- Build the value by stepping through the list of subparts.
1069− construct c = evalStateT $ fromConstrM f c
1070− where f :: (Data a) => StateT [Value] Parser a
1071− f = do js <- get
1072− case js of
1073− [] -> lift $ modFail "construct" "empty list"
1074− (j':js') -> do put js'; lift $ genericParseJSON j'
1075−
1076− -- Select the named fields from a JSON object.
1077− selectFields fjs = mapM sel
1078− where sel f = maybe (modFail "genericParseJSON" $ "field does not exist " ++
1079− f) return $ M.lookup (pack f) fjs
1080−
1081− -- Count how many arguments a constructor has. The value x is
1082− -- used to determine what type the constructor returns.
1083− numConstrArgs :: (Data a) => a -> Constr -> Int
1084− numConstrArgs x c = execState (fromConstrM f c `asTypeOf` return x) 0
1085− where f = do modify (+1); return undefined
1086−
1087− resType :: MonadPlus m => m a -> a
1088− resType _ = modError "genericParseJSON" "resType"
1089−
1090−modFail :: (Monad m) => String -> String -> m a
1091−modFail func err = fail $ "Data.Aeson.Types." ++ func ++ ": " ++ err
1092−
1093−modError :: String -> String -> a
1094−modError func err = error $ "Data.Aeson.Types." ++ func ++ ": " ++ err
1095−
1096−string :: String
1097−string = ""
1098−
1099−-- Type extension for binary type constructors.
1100−
1101−-- | Flexible type extension
1102−ext2' :: (Data a, Typeable2 t)
1103− => c a
1104− -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
1105− -> c a
1106−ext2' def ext = maybe def id (dataCast2 ext)
1107−
1108−-- | Type extension of queries for type constructors
1109−ext2Q' :: (Data d, Typeable2 t)
1110− => (d -> q)
1111− -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
1112− -> d -> q
1113−ext2Q' def ext = unQ ((Q def) `ext2'` (Q ext))
1114−
1115−-- | Type extension of readers for type constructors
1116−ext2R' :: (Monad m, Data d, Typeable2 t)
1117− => m d
1118− -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))
1119− -> m d
1120−ext2R' def ext = unR ((R def) `ext2'` (R ext))
1121−
1122−-- | The type constructor for queries
1123−newtype Q q x = Q { unQ :: x -> q }
1124−
1125−-- | The type constructor for readers
1126−newtype R m x = R { unR :: m x }