@@ -1,13 +1,3 @@
1−{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, GeneralizedNewtypeDeriving,
2− IncoherentInstances, OverlappingInstances, OverloadedStrings, Rank2Types,
3− ViewPatterns, FlexibleContexts, UndecidableInstances,
4− ScopedTypeVariables, PatternGuards #-}
7−#ifdef DEFAULT_SIGNATURES
8−{-# LANGUAGE DefaultSignatures #-}
12-- Module: Data.Aeson.Types
2-- Module: Data.Aeson.Types
13-- Copyright: (c) 2011 MailRank, Inc.
3-- Copyright: (c) 2011 MailRank, Inc.
@@ -44,1092 +34,6 @@ module Data.Aeson.Types
47− -- * Generic toJSON and fromJSON
52−import Control.Applicative
39+import Data.Aeson.Types.Internal
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(..))
59−import Data.Hashable (Hashable(..))
60−import Data.Int (Int8, Int16, Int32, Int64)
61−import Data.IntSet (IntSet)
62−import Data.List (foldl')
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
95−-- | The result of running a 'Parser'.
96−data Result a = Error String
98− deriving (Eq, Show, Typeable)
100−instance (NFData a) => NFData (Result a) where
101− rnf (Success a) = rnf a
102− rnf (Error err) = rnf err
104−instance Functor Result where
105− fmap f (Success a) = Success (f a)
106− fmap _ (Error err) = Error err
109−instance Monad Result where
111− {-# INLINE return #-}
112− Success a >>= k = k a
113− Error err >>= _ = Error err
114− {-# INLINE (>>=) #-}
116−instance Applicative Result where
120− {-# INLINE (<*>) #-}
122−instance MonadPlus Result where
123− mzero = fail "mzero"
124− {-# INLINE mzero #-}
125− mplus a@(Success _) _ = a
127− {-# INLINE mplus #-}
129−instance Alternative Result where
131− {-# INLINE empty #-}
133− {-# INLINE (<|>) #-}
135−instance Monoid (Result a) where
136− mempty = fail "mempty"
137− {-# INLINE mempty #-}
139− {-# INLINE mappend #-}
141−-- | Failure continuation.
142−type Failure f r = String -> f r
143−-- | Success continuation.
144−type Success a f r = a -> f r
146−-- | A continuation-based parser type.
147−newtype Parser a = Parser {
148− runParser :: forall f r.
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
163−instance Functor Parser where
164− fmap f m = Parser $ \kf ks -> let ks' a = ks (f a)
165− in runParser m kf ks'
168−instance Applicative Parser where
172− {-# INLINE (<*>) #-}
174−instance Alternative Parser where
175− empty = fail "empty"
176− {-# INLINE empty #-}
178− {-# INLINE (<|>) #-}
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 #-}
187−instance Monoid (Parser a) where
188− mempty = fail "mempty"
189− {-# INLINE mempty #-}
191− {-# INLINE mappend #-}
193−apP :: Parser (a -> b) -> Parser a -> Parser b
200−-- | A JSON \"object\" (key\/value map).
201−type Object = Map Text Value
203−-- | A JSON \"array\" (sequence).
204−type Array = Vector Value
206−-- | A JSON value represented as a Haskell value.
207−data Value = Object Object
213− deriving (Eq, Show, Typeable, Data)
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
223−instance IsString Value where
224− fromString = String . pack
225− {-# INLINE fromString #-}
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
235−-- | The empty array.
237−emptyArray = Array V.empty
239−-- | The empty object.
241−emptyObject = Object M.empty
243−-- | A key\/value pair for an 'Object'.
244−type Pair = (Text, Value)
246−-- | Construct a 'Pair' from a key and a value.
247−(.=) :: ToJSON a => Text -> a -> Pair
248−name .= value = (name, toJSON value)
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 #-}
257−parse :: (a -> Parser b) -> a -> Result b
258−parse m v = runParser (m v) Error Success
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 #-}
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 #-}
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.
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
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.
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
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 #-}
303−-- | A type that can be converted to JSON.
305−-- An example type and instance:
307−-- @data Coord { x :: Double, y :: Double }
309−-- instance ToJSON Coord where
310−-- toJSON (Coord x y) = 'object' [\"x\" '.=' x, \"y\" '.=' y]
313−-- This example assumes the OverloadedStrings language option is enabled.
315− toJSON :: a -> Value
317−#ifdef DEFAULT_SIGNATURES
318− default toJSON :: Data a => a -> Value
319− toJSON = genericToJSON
322−-- | A type that can be converted from JSON, with the possibility of
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.
329−-- An example type and instance:
331−-- @data Coord { x :: Double, y :: Double }
333−-- instance FromJSON Coord where
334−-- parseJSON ('Object' v) = Coord '<$>'
335−-- v '.:' \"x\" '<*>'
338−-- \-- A non-'Object' value is of the wrong type, so use 'mzero' to fail.
339−-- parseJSON _ = 'mzero'
342−-- This example assumes the OverloadedStrings language option is enabled.
343−class FromJSON a where
344− parseJSON :: Value -> Parser a
346−#ifdef DEFAULT_SIGNATURES
347− default parseJSON :: Data a => Value -> Parser a
348− parseJSON = genericParseJSON
351−instance (ToJSON a) => ToJSON (Maybe a) where
352− toJSON (Just a) = toJSON a
353− toJSON Nothing = Null
354− {-# INLINE toJSON #-}
356−instance (FromJSON a) => FromJSON (Maybe a) where
357− parseJSON Null = pure Nothing
358− parseJSON a = Just <$> parseJSON a
359− {-# INLINE parseJSON #-}
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 #-}
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
371− {-# INLINE parseJSON #-}
377−instance ToJSON Bool where
379− {-# INLINE toJSON #-}
381−instance FromJSON Bool where
382− parseJSON (Bool b) = pure b
383− parseJSON v = typeMismatch "Bool" v
384− {-# INLINE parseJSON #-}
386−instance ToJSON () where
387− toJSON _ = emptyArray
388− {-# INLINE toJSON #-}
390−instance FromJSON () where
391− parseJSON (Array v) | V.null v = pure ()
392− parseJSON v = typeMismatch "()" v
393− {-# INLINE parseJSON #-}
395−instance ToJSON [Char] where
396− toJSON = String . T.pack
397− {-# INLINE toJSON #-}
399−instance FromJSON [Char] where
400− parseJSON (String t) = pure (T.unpack t)
401− parseJSON v = typeMismatch "String" v
402− {-# INLINE parseJSON #-}
404−instance ToJSON Char where
405− toJSON = String . T.singleton
406− {-# INLINE toJSON #-}
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 #-}
414−instance ToJSON Double where
416− {-# INLINE toJSON #-}
418−instance FromJSON Double where
419− parseJSON (Number n) = case n of
421− I i -> pure (fromIntegral i)
422− parseJSON Null = pure (0/0)
423− parseJSON v = typeMismatch "Double" v
424− {-# INLINE parseJSON #-}
426−instance ToJSON Number where
428− {-# INLINE toJSON #-}
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 #-}
436−instance ToJSON Float where
437− toJSON = Number . realToFrac
438− {-# INLINE toJSON #-}
440−instance FromJSON Float where
441− parseJSON (Number n) = pure $ case n of
443− I i -> fromIntegral i
444− parseJSON Null = pure (0/0)
445− parseJSON v = typeMismatch "Float" v
446− {-# INLINE parseJSON #-}
448−instance ToJSON (Ratio Integer) where
449− toJSON = Number . fromRational
450− {-# INLINE toJSON #-}
452−instance FromJSON (Ratio Integer) where
453− parseJSON (Number n) = pure $ case n of
455− I i -> fromIntegral i
456− parseJSON v = typeMismatch "Ratio Integer" v
457− {-# INLINE parseJSON #-}
459−instance ToJSON Int where
460− toJSON = Number . fromIntegral
461− {-# INLINE toJSON #-}
463−instance FromJSON Int where
464− parseJSON = parseIntegral
465− {-# INLINE parseJSON #-}
467−parseIntegral :: Integral a => Value -> Parser a
468−parseIntegral (Number n) = pure (floor n)
469−parseIntegral v = typeMismatch "Integral" v
470−{-# INLINE parseIntegral #-}
472−instance ToJSON Integer where
473− toJSON = Number . fromIntegral
474− {-# INLINE toJSON #-}
476−instance FromJSON Integer where
477− parseJSON = parseIntegral
478− {-# INLINE parseJSON #-}
480−instance ToJSON Int8 where
481− toJSON = Number . fromIntegral
482− {-# INLINE toJSON #-}
484−instance FromJSON Int8 where
485− parseJSON = parseIntegral
486− {-# INLINE parseJSON #-}
488−instance ToJSON Int16 where
489− toJSON = Number . fromIntegral
490− {-# INLINE toJSON #-}
492−instance FromJSON Int16 where
493− parseJSON = parseIntegral
494− {-# INLINE parseJSON #-}
496−instance ToJSON Int32 where
497− toJSON = Number . fromIntegral
498− {-# INLINE toJSON #-}
500−instance FromJSON Int32 where
501− parseJSON = parseIntegral
502− {-# INLINE parseJSON #-}
504−instance ToJSON Int64 where
505− toJSON = Number . fromIntegral
506− {-# INLINE toJSON #-}
508−instance FromJSON Int64 where
509− parseJSON = parseIntegral
510− {-# INLINE parseJSON #-}
512−instance ToJSON Word where
513− toJSON = Number . fromIntegral
514− {-# INLINE toJSON #-}
516−instance FromJSON Word where
517− parseJSON = parseIntegral
518− {-# INLINE parseJSON #-}
520−instance ToJSON Word8 where
521− toJSON = Number . fromIntegral
522− {-# INLINE toJSON #-}
524−instance FromJSON Word8 where
525− parseJSON = parseIntegral
526− {-# INLINE parseJSON #-}
528−instance ToJSON Word16 where
529− toJSON = Number . fromIntegral
530− {-# INLINE toJSON #-}
532−instance FromJSON Word16 where
533− parseJSON = parseIntegral
534− {-# INLINE parseJSON #-}
536−instance ToJSON Word32 where
537− toJSON = Number . fromIntegral
538− {-# INLINE toJSON #-}
540−instance FromJSON Word32 where
541− parseJSON = parseIntegral
542− {-# INLINE parseJSON #-}
544−instance ToJSON Word64 where
545− toJSON = Number . fromIntegral
546− {-# INLINE toJSON #-}
548−instance FromJSON Word64 where
549− parseJSON = parseIntegral
550− {-# INLINE parseJSON #-}
552−instance ToJSON Text where
554− {-# INLINE toJSON #-}
556−instance FromJSON Text where
557− parseJSON (String t) = pure t
558− parseJSON v = typeMismatch "Text" v
559− {-# INLINE parseJSON #-}
561−instance ToJSON LT.Text where
562− toJSON = String . LT.toStrict
563− {-# INLINE toJSON #-}
565−instance FromJSON LT.Text where
566− parseJSON (String t) = pure (LT.fromStrict t)
567− parseJSON v = typeMismatch "Lazy Text" v
568− {-# INLINE parseJSON #-}
570−instance ToJSON B.ByteString where
571− toJSON = String . decode
572− {-# INLINE toJSON #-}
574−instance FromJSON B.ByteString where
575− parseJSON (String t) = pure . encodeUtf8 $ t
576− parseJSON v = typeMismatch "ByteString" v
577− {-# INLINE parseJSON #-}
579−instance ToJSON LB.ByteString where
580− toJSON = toJSON . strict
581− {-# INLINE toJSON #-}
583−instance FromJSON LB.ByteString where
584− parseJSON (String t) = pure . lazy $ t
585− parseJSON v = typeMismatch "Lazy ByteString" v
586− {-# INLINE parseJSON #-}
588−instance (ToJSON a) => ToJSON [a] where
589− toJSON = Array . V.fromList . map toJSON
590− {-# INLINE toJSON #-}
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 #-}
597−instance (ToJSON a) => ToJSON (Vector a) where
598− toJSON = Array . V.map toJSON
599− {-# INLINE toJSON #-}
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 #-}
606−vectorToJSON :: (VG.Vector v a, ToJSON a) => v a -> Value
607−vectorToJSON = Array . V.map toJSON . V.convert
608−{-# INLINE vectorToJSON #-}
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 #-}
615−instance (Storable a, ToJSON a) => ToJSON (VS.Vector a) where
616− toJSON = vectorToJSON
618−instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where
619− parseJSON = vectorParseJSON "Data.Vector.Storable.Vector a"
621−instance (VP.Prim a, ToJSON a) => ToJSON (VP.Vector a) where
622− toJSON = vectorToJSON
624−instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where
625− parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector a"
627−instance (VG.Vector VU.Vector a, ToJSON a) => ToJSON (VU.Vector a) where
628− toJSON = vectorToJSON
630−instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where
631− parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"
633−instance (ToJSON a) => ToJSON (Set.Set a) where
634− toJSON = toJSON . Set.toList
635− {-# INLINE toJSON #-}
637−instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
638− parseJSON = fmap Set.fromList . parseJSON
639− {-# INLINE parseJSON #-}
641−instance (ToJSON a) => ToJSON (HashSet.HashSet a) where
642− toJSON = toJSON . HashSet.toList
643− {-# INLINE toJSON #-}
645−instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
646− parseJSON = fmap HashSet.fromList . parseJSON
647− {-# INLINE parseJSON #-}
649−instance ToJSON IntSet.IntSet where
650− toJSON = toJSON . IntSet.toList
651− {-# INLINE toJSON #-}
653−instance FromJSON IntSet.IntSet where
654− parseJSON = fmap IntSet.fromList . parseJSON
655− {-# INLINE parseJSON #-}
657−instance ToJSON a => ToJSON (IntMap.IntMap a) where
658− toJSON = toJSON . IntMap.toList
659− {-# INLINE toJSON #-}
661−instance FromJSON a => FromJSON (IntMap.IntMap a) where
662− parseJSON = fmap IntMap.fromList . parseJSON
663− {-# INLINE parseJSON #-}
665−instance (ToJSON v) => ToJSON (M.Map Text v) where
666− toJSON = Object . M.map toJSON
667− {-# INLINE toJSON #-}
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
674−instance (ToJSON v) => ToJSON (M.Map LT.Text v) where
675− toJSON = Object . transformMap LT.toStrict toJSON
677−instance (FromJSON v) => FromJSON (M.Map LT.Text v) where
678− parseJSON = fmap (M.mapKeysMonotonic LT.fromStrict) . parseJSON
680−instance (ToJSON v) => ToJSON (M.Map String v) where
681− toJSON = Object . transformMap pack toJSON
683−instance (FromJSON v) => FromJSON (M.Map String v) where
684− parseJSON = fmap (M.mapKeysMonotonic unpack) . parseJSON
686−instance (ToJSON v) => ToJSON (M.Map B.ByteString v) where
687− toJSON = Object . transformMap decode toJSON
689−instance (FromJSON v) => FromJSON (M.Map B.ByteString v) where
690− parseJSON = fmap (M.mapKeysMonotonic encodeUtf8) . parseJSON
692−instance (ToJSON v) => ToJSON (M.Map LB.ByteString v) where
693− toJSON = Object . transformMap strict toJSON
695−instance (FromJSON v) => FromJSON (M.Map LB.ByteString v) where
696− parseJSON = fmap (M.mapKeysMonotonic lazy) . parseJSON
698−instance (ToJSON v) => ToJSON (H.HashMap Text v) where
699− toJSON = Object . hashMap id toJSON
700− {-# INLINE toJSON #-}
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
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) :)) []
710−instance (FromJSON v) => FromJSON (H.HashMap LT.Text v) where
711− parseJSON = fmap (mapHash LT.fromStrict) . parseJSON
713−instance (ToJSON v) => ToJSON (H.HashMap String v) where
714− toJSON = Object . hashMap pack toJSON
716−instance (FromJSON v) => FromJSON (H.HashMap String v) where
717− parseJSON = fmap (mapHash unpack) . parseJSON
719−instance (ToJSON v) => ToJSON (H.HashMap B.ByteString v) where
720− toJSON = Object . hashMap decode toJSON
722−instance (FromJSON v) => FromJSON (H.HashMap B.ByteString v) where
723− parseJSON = fmap (mapHash encodeUtf8) . parseJSON
725−instance (ToJSON v) => ToJSON (H.HashMap LB.ByteString v) where
726− toJSON = Object . hashMap strict toJSON
728−instance (FromJSON v) => FromJSON (H.HashMap LB.ByteString v) where
729− parseJSON = fmap (mapHash lazy) . parseJSON
731−instance ToJSON Value where
733− {-# INLINE toJSON #-}
735−instance FromJSON Value where
736− parseJSON a = pure a
737− {-# INLINE parseJSON #-}
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:
743−-- > /Date(1302547608878)/
745−-- The number represents milliseconds since the Unix epoch.
746−newtype DotNetTime = DotNetTime {
747− fromDotNetTime :: UTCTime
748− } deriving (Eq, Ord, Read, Show, Typeable, FormatTime)
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 #-}
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 #-}
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 #-}
772−instance FromJSON UTCTime where
773− parseJSON (String t) =
774− case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of
776− _ -> fail "could not parse ISO-8601 date"
777− parseJSON v = typeMismatch "UTCTime" v
778− {-# INLINE parseJSON #-}
780−instance (ToJSON a, ToJSON b) => ToJSON (a,b) where
781− toJSON (a,b) = toJSON [toJSON a, toJSON b]
782− {-# INLINE toJSON #-}
784−instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
785− parseJSON (Array ab) =
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 #-}
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 #-}
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 #-}
806−instance ToJSON a => ToJSON (Dual a) where
807− toJSON = toJSON . getDual
808− {-# INLINE toJSON #-}
810−instance FromJSON a => FromJSON (Dual a) where
811− parseJSON = fmap Dual . parseJSON
812− {-# INLINE parseJSON #-}
814−instance ToJSON a => ToJSON (First a) where
815− toJSON = toJSON . getFirst
816− {-# INLINE toJSON #-}
818−instance FromJSON a => FromJSON (First a) where
819− parseJSON = fmap First . parseJSON
820− {-# INLINE parseJSON #-}
822−instance ToJSON a => ToJSON (Last a) where
823− toJSON = toJSON . getLast
824− {-# INLINE toJSON #-}
826−instance FromJSON a => FromJSON (Last a) where
827− parseJSON = fmap Last . parseJSON
828− {-# INLINE parseJSON #-}
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.
834−typeMismatch expected actual =
835− fail $ "when expecting a " ++ expected ++ ", encountered " ++ name ++
838− name = case actual of
839− Object _ -> "Object"
841− String _ -> "String"
842− Number _ -> "Number"
847−--------------------------------------------------------------------------------
848−-- Generic toJSON and fromJSON
850−type T a = a -> Value
852−genericToJSON :: (Data a) => a -> Value
853−genericToJSON = toJSON_generic
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)
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
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
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
916−toJSON_generic :: (Data a) => a -> Value
917−toJSON_generic = generic
919− -- Generic encoding of an algebraic data type.
921− case dataTypeRep (dataTypeOf a) of
922− -- No constructor, so it must be an error value. Code
923− -- it anyway as 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
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)]
943− constrString = pack . showConstr
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
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
955−genericFromJSON :: (Data a) => Value -> Result a
956−genericFromJSON = parse genericParseJSON
960−genericParseJSON :: (Data a) => Value -> Parser a
961−genericParseJSON j = parseJSON_generic j
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 ())
995− value :: (FromJSON a) => Parser a
997− list :: (Data a) => Parser [a]
998− list = V.toList <$> genericParseJSON j
999− vector :: (Data a) => Parser (V.Vector a)
1001− Array js -> V.mapM genericParseJSON js
1003− mapAny :: forall e f. (Data e, Data f) => Parser (Map f e)
1005− | tyrep `elem` stringyTypes = res
1006− | otherwise = myFail
1007− where res = case j of
1008− Object js -> M.mapKeysMonotonic trans <$> T.mapM genericParseJSON js
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)
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
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
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]
1038−parseJSON_generic :: (Data a) => Value -> Parser a
1039−parseJSON_generic j = generic
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
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"
1057− maybe (modFail "genericParseJSON" $ "unknown constructor: " ++ s ++ " " ++
1059− return $ readConstr t s
1061− decodeArgs c0 = go (numConstrArgs (resType generic) c0) c0
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)
1075− fromJSObject = map (first unpack) . M.toList
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
1082− [] -> lift $ modFail "construct" "empty list"
1083− (j':js') -> do put js'; lift $ genericParseJSON j'
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
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
1096− resType :: MonadPlus m => m a -> a
1097− resType _ = modError "genericParseJSON" "resType"
1099−modFail :: (Monad m) => String -> String -> m a
1100−modFail func err = fail $ "Data.Aeson.Types." ++ func ++ ": " ++ err
1102−modError :: String -> String -> a
1103−modError func err = error $ "Data.Aeson.Types." ++ func ++ ": " ++ err
1108−-- Type extension for binary type constructors.
1110−-- | Flexible type extension
1111−ext2' :: (Data a, Typeable2 t)
1113− -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
1115−ext2' def ext = maybe def id (dataCast2 ext)
1117−-- | Type extension of queries for type constructors
1118−ext2Q' :: (Data d, Typeable2 t)
1120− -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
1122−ext2Q' def ext = unQ ((Q def) `ext2'` (Q ext))
1124−-- | Type extension of readers for type constructors
1125−ext2R' :: (Monad m, Data d, Typeable2 t)
1127− -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))
1129−ext2R' def ext = unR ((R def) `ext2'` (R ext))
1131−-- | The type constructor for queries
1132−newtype Q q x = Q { unQ :: x -> q }
1134−-- | The type constructor for readers
1135−newtype R m x = R { unR :: m x }