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