@@ -4,15 +4,6 @@
44 ScopedTypeVariables, PatternGuards #-}
55
66{-# LANGUAGE CPP #-}
7−#ifdef GENERICS
8−{-# LANGUAGE DefaultSignatures
9− , TypeOperators
10− , EmptyDataDecls
11− , KindSignatures
12− , MultiParamTypeClasses
13− , FunctionalDependencies
14− #-}
15−#endif
167
178-- |
189-- Module: Data.Aeson.Types.Internal
@@ -33,67 +24,31 @@ module Data.Aeson.Types.Internal
3324 , Pair
3425 , Object
3526 , emptyObject
36− -- * Convenience types and functions
37− , DotNetTime(..)
38− , typeMismatch
3927 -- * Type conversion
4028 , Parser
4129 , Result(..)
42− , FromJSON(..)
43− , fromJSON
4430 , parse
4531 , parseEither
4632 , parseMaybe
47− , ToJSON(..)
4833 -- * Constructors and accessors
49− , (.=)
50− , (.:)
51− , (.:?)
5234 , object
5335 ) where
5436
5537import Control.Applicative
5638import Control.DeepSeq (NFData(..))
5739import Control.Monad.State.Strict
58−import Data.Aeson.Functions
5940import Data.Attoparsec.Char8 (Number(..))
6041import Data.Data (Data)
6142import Data.Hashable (Hashable(..))
62−import Data.Int (Int8, Int16, Int32, Int64)
6343import Data.List (foldl')
6444import Data.Map (Map)
65−import Data.Monoid (Dual(..), First(..), Last(..))
6645import Data.Monoid (Monoid(..))
67−import Data.Ratio (Ratio)
6846import Data.String (IsString(..))
69−import Data.Text.Encoding (encodeUtf8)
70−import Data.Text (Text, pack, unpack)
71−import Data.Time.Clock (UTCTime)
72−import Data.Time.Format (FormatTime, formatTime, parseTime)
47+import Data.Text (Text, pack)
7348import Data.Typeable (Typeable)
74−import Data.Vector (Vector, (!?))
75−import Data.Word (Word, Word8, Word16, Word32, Word64)
76−import Foreign.Storable (Storable)
77−import System.Locale (defaultTimeLocale)
78−import qualified Data.ByteString as B
79−import qualified Data.ByteString.Lazy as LB
80−import qualified Data.HashMap.Strict as H
81−import qualified Data.HashSet as HashSet
82−import qualified Data.IntSet as IntSet
83−import qualified Data.IntMap as IntMap
49+import Data.Vector (Vector)
8450import qualified Data.Map as M
85−import qualified Data.Set as Set
86−import qualified Data.Text as T
87−import qualified Data.Text.Lazy as LT
8851import 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−#ifdef GENERICS
95−import GHC.Generics
96−#endif
9752
9853-- | The result of running a 'Parser'.
9954data Result a = Error String
@@ -258,19 +213,6 @@ isEmptyArray _ = False
258213emptyObject :: Value
259214emptyObject = Object M.empty
260215
261−-- | A key\/value pair for an 'Object'.
262−type Pair = (Text, Value)
263−
264−-- | Construct a 'Pair' from a key and a value.
265−(.=) :: ToJSON a => Text -> a -> Pair
266−name .= value = (name, toJSON value)
267−{-# INLINE (.=) #-}
268−
269−-- | Convert a value from JSON, failing if the types do not match.
270−fromJSON :: (FromJSON a) => Value -> Result a
271−fromJSON = parse parseJSON
272−{-# INLINE fromJSON #-}
273−
274216-- | Run a 'Parser'.
275217parse :: (a -> Parser b) -> a -> Result b
276218parse m v = runParser (m v) Error Success
@@ -284,871 +226,13 @@ parseMaybe m v = runParser (m v) (const Nothing) Just
284226-- | Run a 'Parser' with an 'Either' result type.
285227parseEither :: (a -> Parser b) -> a -> Either String b
286228parseEither m v = runParser (m v) Left Right
287−{-# INLINE parseEither #-}
288−
289−-- | Retrieve the value associated with the given key of an 'Object'.
290−-- The result is 'empty' if the key is not present or the value cannot
291−-- be converted to the desired type.
292−--
293−-- This accessor is appropriate if the key and value /must/ be present
294−-- in an object for it to be valid. If the key and value are
295−-- optional, use '(.:?)' instead.
296−(.:) :: (FromJSON a) => Object -> Text -> Parser a
297−obj .: key = case M.lookup key obj of
298− Nothing -> fail $ "key " ++ show key ++ " not present"
299− Just v -> parseJSON v
300−{-# INLINE (.:) #-}
301229
302−-- | Retrieve the value associated with the given key of an 'Object'.
303−-- The result is 'Nothing' if the key is not present, or 'empty' if
304−-- the value cannot be converted to the desired type.
305−--
306−-- This accessor is most useful if the key and value can be absent
307−-- from an object without affecting its validity. If the key and
308−-- value are mandatory, use '(.:)' instead.
309−(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
310−obj .:? key = case M.lookup key obj of
311− Nothing -> pure Nothing
312− Just v -> parseJSON v
313−{-# INLINE (.:?) #-}
230+-- | A key\/value pair for an 'Object'.
231+type Pair = (Text, Value)
314232
233+{-# INLINE parseEither #-}
315234-- | Create a 'Value' from a list of name\/value 'Pair's. If duplicate
316235-- keys arise, earlier keys and their associated values win.
317236object :: [Pair] -> Value
318237object = Object . M.fromList
319238{-# INLINE object #-}
320−
321−-- | A type that can be converted to JSON.
322−--
323−-- An example type and instance:
324−--
325−-- @{-\# LANGUAGE OverloadedStrings #-}
326−--
327−-- data Coord { x :: Double, y :: Double }
328−--
329−-- instance ToJSON Coord where
330−-- toJSON (Coord x y) = 'object' [\"x\" '.=' x, \"y\" '.=' y]
331−-- @
332−--
333−-- Note the use of the @OverloadedStrings@ language extension which enables
334−-- 'Text' values to be written as string literals.
335−--
336−-- Instead of manually writing your 'ToJSON' instance, there are three options
337−-- to do it automatically:
338−--
339−-- * 'Data.Aeson.TH' provides template-haskell functions which will derive an
340−-- instance at compile-time. The generated instance is optimized for your type
341−-- so will probably be more efficient than the following two options:
342−--
343−-- * 'Data.Aeson.Generic' provides a generic @toJSON@ function that accepts any
344−-- type which is an instance of 'Data'.
345−--
346−-- * If your compiler has support for the @DeriveGeneric@ and
347−-- @DefaultSignatures@ language extensions, @toJSON@ will have a default generic
348−-- implementation.
349−--
350−-- To use the latter option, simply add a @deriving 'Generic'@ clause to your
351−-- datatype and declare a @ToJSON@ instance for your datatype without giving a
352−-- definition for @toJSON@.
353−--
354−-- For example the previous example can be simplified to just:
355−--
356−-- @{-\# LANGUAGE DeriveGeneric \#-}
357−--
358−-- import GHC.Generics
359−--
360−-- data Coord { x :: Double, y :: Double } deriving Generic
361−--
362−-- instance ToJSON Coord
363−-- @
364−class ToJSON a where
365− toJSON :: a -> Value
366−
367−#ifdef GENERICS
368− default toJSON :: (Generic a, GToJSON (Rep a)) => a -> Value
369− toJSON = gToJSON . from
370−#endif
371−
372−-- | A type that can be converted from JSON, with the possibility of
373−-- failure.
374−--
375−-- When writing an instance, use 'mzero' or 'fail' to make a
376−-- conversion fail, e.g. if an 'Object' is missing a required key, or
377−-- the value is of the wrong type.
378−--
379−-- An example type and instance:
380−--
381−-- @{-\# LANGUAGE OverloadedStrings #-}
382−--
383−-- data Coord { x :: Double, y :: Double }
384−--
385−-- instance FromJSON Coord where
386−-- parseJSON ('Object' v) = Coord '<$>'
387−-- v '.:' \"x\" '<*>'
388−-- v '.:' \"y\"
389−--
390−-- \-- A non-'Object' value is of the wrong type, so use 'mzero' to fail.
391−-- parseJSON _ = 'mzero'
392−-- @
393−--
394−-- Note the use of the @OverloadedStrings@ language extension which enables
395−-- 'Text' values to be written as string literals.
396−--
397−-- Instead of manually writing your 'FromJSON' instance, there are three options
398−-- to do it automatically:
399−--
400−-- * 'Data.Aeson.TH' provides template-haskell functions which will derive an
401−-- instance at compile-time. The generated instance is optimized for your type
402−-- so will probably be more efficient than the following two options:
403−--
404−-- * 'Data.Aeson.Generic' provides a generic @fromJSON@ function that parses to
405−-- any type which is an instance of 'Data'.
406−--
407−-- * If your compiler has support for the @DeriveGeneric@ and
408−-- @DefaultSignatures@ language extensions, @parseJSON@ will have a default
409−-- generic implementation.
410−--
411−-- To use this, simply add a @deriving 'Generic'@ clause to your datatype and
412−-- declare a @FromJSON@ instance for your datatype without giving a definition
413−-- for @parseJSON@.
414−--
415−-- For example the previous example can be simplified to just:
416−--
417−-- @{-\# LANGUAGE DeriveGeneric \#-}
418−--
419−-- import GHC.Generics
420−--
421−-- data Coord { x :: Double, y :: Double } deriving Generic
422−--
423−-- instance FromJSON Coord
424−-- @
425−class FromJSON a where
426− parseJSON :: Value -> Parser a
427−
428−#ifdef GENERICS
429− default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a
430− parseJSON = fmap to . gParseJSON
431−#endif
432−
433−instance (ToJSON a) => ToJSON (Maybe a) where
434− toJSON (Just a) = toJSON a
435− toJSON Nothing = Null
436− {-# INLINE toJSON #-}
437−
438−instance (FromJSON a) => FromJSON (Maybe a) where
439− parseJSON Null = pure Nothing
440− parseJSON a = Just <$> parseJSON a
441− {-# INLINE parseJSON #-}
442−
443−instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where
444− toJSON (Left a) = object [left .= a]
445− toJSON (Right b) = object [right .= b]
446− {-# INLINE toJSON #-}
447−
448−instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
449− parseJSON (Object (M.toList -> [(key, value)]))
450− | key == left = Left <$> parseJSON value
451− | key == right = Right <$> parseJSON value
452− parseJSON _ = mzero
453− {-# INLINE parseJSON #-}
454−
455−left, right :: Text
456−left = "Left"
457−right = "Right"
458−
459−instance ToJSON Bool where
460− toJSON = Bool
461− {-# INLINE toJSON #-}
462−
463−instance FromJSON Bool where
464− parseJSON (Bool b) = pure b
465− parseJSON v = typeMismatch "Bool" v
466− {-# INLINE parseJSON #-}
467−
468−instance ToJSON () where
469− toJSON _ = emptyArray
470− {-# INLINE toJSON #-}
471−
472−instance FromJSON () where
473− parseJSON (Array v) | V.null v = pure ()
474− parseJSON v = typeMismatch "()" v
475− {-# INLINE parseJSON #-}
476−
477−instance ToJSON [Char] where
478− toJSON = String . T.pack
479− {-# INLINE toJSON #-}
480−
481−instance FromJSON [Char] where
482− parseJSON (String t) = pure (T.unpack t)
483− parseJSON v = typeMismatch "String" v
484− {-# INLINE parseJSON #-}
485−
486−instance ToJSON Char where
487− toJSON = String . T.singleton
488− {-# INLINE toJSON #-}
489−
490−instance FromJSON Char where
491− parseJSON (String t)
492− | T.compareLength t 1 == EQ = pure (T.head t)
493− parseJSON v = typeMismatch "Char" v
494− {-# INLINE parseJSON #-}
495−
496−instance ToJSON Double where
497− toJSON = Number . D
498− {-# INLINE toJSON #-}
499−
500−instance FromJSON Double where
501− parseJSON (Number n) = case n of
502− D d -> pure d
503− I i -> pure (fromIntegral i)
504− parseJSON Null = pure (0/0)
505− parseJSON v = typeMismatch "Double" v
506− {-# INLINE parseJSON #-}
507−
508−instance ToJSON Number where
509− toJSON = Number
510− {-# INLINE toJSON #-}
511−
512−instance FromJSON Number where
513− parseJSON (Number n) = pure n
514− parseJSON Null = pure (D (0/0))
515− parseJSON v = typeMismatch "Number" v
516− {-# INLINE parseJSON #-}
517−
518−instance ToJSON Float where
519− toJSON = Number . realToFrac
520− {-# INLINE toJSON #-}
521−
522−instance FromJSON Float where
523− parseJSON (Number n) = pure $ case n of
524− D d -> realToFrac d
525− I i -> fromIntegral i
526− parseJSON Null = pure (0/0)
527− parseJSON v = typeMismatch "Float" v
528− {-# INLINE parseJSON #-}
529−
530−instance ToJSON (Ratio Integer) where
531− toJSON = Number . fromRational
532− {-# INLINE toJSON #-}
533−
534−instance FromJSON (Ratio Integer) where
535− parseJSON (Number n) = pure $ case n of
536− D d -> toRational d
537− I i -> fromIntegral i
538− parseJSON v = typeMismatch "Ratio Integer" v
539− {-# INLINE parseJSON #-}
540−
541−instance ToJSON Int where
542− toJSON = Number . fromIntegral
543− {-# INLINE toJSON #-}
544−
545−instance FromJSON Int where
546− parseJSON = parseIntegral
547− {-# INLINE parseJSON #-}
548−
549−parseIntegral :: Integral a => Value -> Parser a
550−parseIntegral (Number n) = pure (floor n)
551−parseIntegral v = typeMismatch "Integral" v
552−{-# INLINE parseIntegral #-}
553−
554−instance ToJSON Integer where
555− toJSON = Number . fromIntegral
556− {-# INLINE toJSON #-}
557−
558−instance FromJSON Integer where
559− parseJSON = parseIntegral
560− {-# INLINE parseJSON #-}
561−
562−instance ToJSON Int8 where
563− toJSON = Number . fromIntegral
564− {-# INLINE toJSON #-}
565−
566−instance FromJSON Int8 where
567− parseJSON = parseIntegral
568− {-# INLINE parseJSON #-}
569−
570−instance ToJSON Int16 where
571− toJSON = Number . fromIntegral
572− {-# INLINE toJSON #-}
573−
574−instance FromJSON Int16 where
575− parseJSON = parseIntegral
576− {-# INLINE parseJSON #-}
577−
578−instance ToJSON Int32 where
579− toJSON = Number . fromIntegral
580− {-# INLINE toJSON #-}
581−
582−instance FromJSON Int32 where
583− parseJSON = parseIntegral
584− {-# INLINE parseJSON #-}
585−
586−instance ToJSON Int64 where
587− toJSON = Number . fromIntegral
588− {-# INLINE toJSON #-}
589−
590−instance FromJSON Int64 where
591− parseJSON = parseIntegral
592− {-# INLINE parseJSON #-}
593−
594−instance ToJSON Word where
595− toJSON = Number . fromIntegral
596− {-# INLINE toJSON #-}
597−
598−instance FromJSON Word where
599− parseJSON = parseIntegral
600− {-# INLINE parseJSON #-}
601−
602−instance ToJSON Word8 where
603− toJSON = Number . fromIntegral
604− {-# INLINE toJSON #-}
605−
606−instance FromJSON Word8 where
607− parseJSON = parseIntegral
608− {-# INLINE parseJSON #-}
609−
610−instance ToJSON Word16 where
611− toJSON = Number . fromIntegral
612− {-# INLINE toJSON #-}
613−
614−instance FromJSON Word16 where
615− parseJSON = parseIntegral
616− {-# INLINE parseJSON #-}
617−
618−instance ToJSON Word32 where
619− toJSON = Number . fromIntegral
620− {-# INLINE toJSON #-}
621−
622−instance FromJSON Word32 where
623− parseJSON = parseIntegral
624− {-# INLINE parseJSON #-}
625−
626−instance ToJSON Word64 where
627− toJSON = Number . fromIntegral
628− {-# INLINE toJSON #-}
629−
630−instance FromJSON Word64 where
631− parseJSON = parseIntegral
632− {-# INLINE parseJSON #-}
633−
634−instance ToJSON Text where
635− toJSON = String
636− {-# INLINE toJSON #-}
637−
638−instance FromJSON Text where
639− parseJSON (String t) = pure t
640− parseJSON v = typeMismatch "Text" v
641− {-# INLINE parseJSON #-}
642−
643−instance ToJSON LT.Text where
644− toJSON = String . LT.toStrict
645− {-# INLINE toJSON #-}
646−
647−instance FromJSON LT.Text where
648− parseJSON (String t) = pure (LT.fromStrict t)
649− parseJSON v = typeMismatch "Lazy Text" v
650− {-# INLINE parseJSON #-}
651−
652−instance ToJSON B.ByteString where
653− toJSON = String . decode
654− {-# INLINE toJSON #-}
655−
656−instance FromJSON B.ByteString where
657− parseJSON (String t) = pure . encodeUtf8 $ t
658− parseJSON v = typeMismatch "ByteString" v
659− {-# INLINE parseJSON #-}
660−
661−instance ToJSON LB.ByteString where
662− toJSON = toJSON . strict
663− {-# INLINE toJSON #-}
664−
665−instance FromJSON LB.ByteString where
666− parseJSON (String t) = pure . lazy $ t
667− parseJSON v = typeMismatch "Lazy ByteString" v
668− {-# INLINE parseJSON #-}
669−
670−instance (ToJSON a) => ToJSON [a] where
671− toJSON = Array . V.fromList . map toJSON
672− {-# INLINE toJSON #-}
673−
674−instance (FromJSON a) => FromJSON [a] where
675− parseJSON (Array a) = mapM parseJSON (V.toList a)
676− parseJSON v = typeMismatch "[a]" v
677− {-# INLINE parseJSON #-}
678−
679−instance (ToJSON a) => ToJSON (Vector a) where
680− toJSON = Array . V.map toJSON
681− {-# INLINE toJSON #-}
682−
683−instance (FromJSON a) => FromJSON (Vector a) where
684− parseJSON (Array a) = V.mapM parseJSON a
685− parseJSON v = typeMismatch "Vector a" v
686− {-# INLINE parseJSON #-}
687−
688−vectorToJSON :: (VG.Vector v a, ToJSON a) => v a -> Value
689−vectorToJSON = Array . V.map toJSON . V.convert
690−{-# INLINE vectorToJSON #-}
691−
692−vectorParseJSON :: (FromJSON a, VG.Vector w a) => String -> Value -> Parser (w a)
693−vectorParseJSON _ (Array a) = V.convert <$> V.mapM parseJSON a
694−vectorParseJSON s v = typeMismatch s v
695−{-# INLINE vectorParseJSON #-}
696−
697−instance (Storable a, ToJSON a) => ToJSON (VS.Vector a) where
698− toJSON = vectorToJSON
699−
700−instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where
701− parseJSON = vectorParseJSON "Data.Vector.Storable.Vector a"
702−
703−instance (VP.Prim a, ToJSON a) => ToJSON (VP.Vector a) where
704− toJSON = vectorToJSON
705−
706−instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where
707− parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector a"
708−
709−instance (VG.Vector VU.Vector a, ToJSON a) => ToJSON (VU.Vector a) where
710− toJSON = vectorToJSON
711−
712−instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where
713− parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"
714−
715−instance (ToJSON a) => ToJSON (Set.Set a) where
716− toJSON = toJSON . Set.toList
717− {-# INLINE toJSON #-}
718−
719−instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
720− parseJSON = fmap Set.fromList . parseJSON
721− {-# INLINE parseJSON #-}
722−
723−instance (ToJSON a) => ToJSON (HashSet.HashSet a) where
724− toJSON = toJSON . HashSet.toList
725− {-# INLINE toJSON #-}
726−
727−instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
728− parseJSON = fmap HashSet.fromList . parseJSON
729− {-# INLINE parseJSON #-}
730−
731−instance ToJSON IntSet.IntSet where
732− toJSON = toJSON . IntSet.toList
733− {-# INLINE toJSON #-}
734−
735−instance FromJSON IntSet.IntSet where
736− parseJSON = fmap IntSet.fromList . parseJSON
737− {-# INLINE parseJSON #-}
738−
739−instance ToJSON a => ToJSON (IntMap.IntMap a) where
740− toJSON = toJSON . IntMap.toList
741− {-# INLINE toJSON #-}
742−
743−instance FromJSON a => FromJSON (IntMap.IntMap a) where
744− parseJSON = fmap IntMap.fromList . parseJSON
745− {-# INLINE parseJSON #-}
746−
747−instance (ToJSON v) => ToJSON (M.Map Text v) where
748− toJSON = Object . M.map toJSON
749− {-# INLINE toJSON #-}
750−
751−instance (FromJSON v) => FromJSON (M.Map Text v) where
752− parseJSON (Object o) = M.fromAscList <$> mapM go (M.toAscList o)
753− where go (k,v) = ((,) k) <$> parseJSON v
754− parseJSON v = typeMismatch "Map Text a" v
755−
756−instance (ToJSON v) => ToJSON (M.Map LT.Text v) where
757− toJSON = Object . transformMap LT.toStrict toJSON
758−
759−instance (FromJSON v) => FromJSON (M.Map LT.Text v) where
760− parseJSON = fmap (M.mapKeysMonotonic LT.fromStrict) . parseJSON
761−
762−instance (ToJSON v) => ToJSON (M.Map String v) where
763− toJSON = Object . transformMap pack toJSON
764−
765−instance (FromJSON v) => FromJSON (M.Map String v) where
766− parseJSON = fmap (M.mapKeysMonotonic unpack) . parseJSON
767−
768−instance (ToJSON v) => ToJSON (M.Map B.ByteString v) where
769− toJSON = Object . transformMap decode toJSON
770−
771−instance (FromJSON v) => FromJSON (M.Map B.ByteString v) where
772− parseJSON = fmap (M.mapKeysMonotonic encodeUtf8) . parseJSON
773−
774−instance (ToJSON v) => ToJSON (M.Map LB.ByteString v) where
775− toJSON = Object . transformMap strict toJSON
776−
777−instance (FromJSON v) => FromJSON (M.Map LB.ByteString v) where
778− parseJSON = fmap (M.mapKeysMonotonic lazy) . parseJSON
779−
780−instance (ToJSON v) => ToJSON (H.HashMap Text v) where
781− toJSON = Object . hashMap id toJSON
782− {-# INLINE toJSON #-}
783−
784−instance (FromJSON v) => FromJSON (H.HashMap Text v) where
785− parseJSON (Object o) = H.fromList <$> mapM go (M.toList o)
786− where go (k,v) = ((,) k) <$> parseJSON v
787− parseJSON v = typeMismatch "HashMap Text a" v
788−
789−instance (ToJSON v) => ToJSON (H.HashMap LT.Text v) where
790− toJSON = Object . M.fromList . H.foldrWithKey (\k v -> ((LT.toStrict k,toJSON v) :)) []
791−
792−instance (FromJSON v) => FromJSON (H.HashMap LT.Text v) where
793− parseJSON = fmap (mapHash LT.fromStrict) . parseJSON
794−
795−instance (ToJSON v) => ToJSON (H.HashMap String v) where
796− toJSON = Object . hashMap pack toJSON
797−
798−instance (FromJSON v) => FromJSON (H.HashMap String v) where
799− parseJSON = fmap (mapHash unpack) . parseJSON
800−
801−instance (ToJSON v) => ToJSON (H.HashMap B.ByteString v) where
802− toJSON = Object . hashMap decode toJSON
803−
804−instance (FromJSON v) => FromJSON (H.HashMap B.ByteString v) where
805− parseJSON = fmap (mapHash encodeUtf8) . parseJSON
806−
807−instance (ToJSON v) => ToJSON (H.HashMap LB.ByteString v) where
808− toJSON = Object . hashMap strict toJSON
809−
810−instance (FromJSON v) => FromJSON (H.HashMap LB.ByteString v) where
811− parseJSON = fmap (mapHash lazy) . parseJSON
812−
813−instance ToJSON Value where
814− toJSON a = a
815− {-# INLINE toJSON #-}
816−
817−instance FromJSON Value where
818− parseJSON a = pure a
819− {-# INLINE parseJSON #-}
820−
821−-- | A newtype wrapper for 'UTCTime' that uses the same non-standard
822−-- serialization format as Microsoft .NET, whose @System.DateTime@
823−-- type is by default serialized to JSON as in the following example:
824−--
825−-- > /Date(1302547608878)/
826−--
827−-- The number represents milliseconds since the Unix epoch.
828−newtype DotNetTime = DotNetTime {
829− fromDotNetTime :: UTCTime
830− } deriving (Eq, Ord, Read, Show, Typeable, FormatTime)
831−
832−instance ToJSON DotNetTime where
833− toJSON (DotNetTime t) =
834− String (pack (secs ++ msecs ++ ")/"))
835− where secs = formatTime defaultTimeLocale "/Date(%s" t
836− msecs = take 3 $ formatTime defaultTimeLocale "%q" t
837− {-# INLINE toJSON #-}
838−
839−instance FromJSON DotNetTime where
840− parseJSON (String t) =
841− case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
842− Just d -> pure (DotNetTime d)
843− _ -> fail "could not parse .NET time"
844− where (s,m) = T.splitAt (T.length t - 5) t
845− t' = T.concat [s,".",m]
846− parseJSON v = typeMismatch "DotNetTime" v
847− {-# INLINE parseJSON #-}
848−
849−instance ToJSON UTCTime where
850− toJSON t = String (pack (take 23 str ++ "Z"))
851− where str = formatTime defaultTimeLocale "%FT%T%Q" t
852− {-# INLINE toJSON #-}
853−
854−instance FromJSON UTCTime where
855− parseJSON (String t) =
856− case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of
857− Just d -> pure d
858− _ -> fail "could not parse ISO-8601 date"
859− parseJSON v = typeMismatch "UTCTime" v
860− {-# INLINE parseJSON #-}
861−
862−instance (ToJSON a, ToJSON b) => ToJSON (a,b) where
863− toJSON (a,b) = toJSON [toJSON a, toJSON b]
864− {-# INLINE toJSON #-}
865−
866−instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
867− parseJSON (Array ab) =
868− case V.toList ab of
869− [a,b] -> (,) <$> parseJSON a <*> parseJSON b
870− _ -> fail $ "cannot unpack array of length " ++
871− show (V.length ab) ++ " into a pair"
872− parseJSON v = typeMismatch "(a,b)" v
873− {-# INLINE parseJSON #-}
874−
875−instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where
876− toJSON (a,b,c) = toJSON [toJSON a, toJSON b, toJSON c]
877− {-# INLINE toJSON #-}
878−
879−instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where
880− parseJSON (Array abc) =
881− case V.toList abc of
882− [a,b,c] -> (,,) <$> parseJSON a <*> parseJSON b <*> parseJSON c
883− _ -> fail $ "cannot unpack array of length " ++
884− show (V.length abc) ++ " into a 3-tuple"
885− parseJSON v = typeMismatch "(a,b,c)" v
886− {-# INLINE parseJSON #-}
887−
888−instance ToJSON a => ToJSON (Dual a) where
889− toJSON = toJSON . getDual
890− {-# INLINE toJSON #-}
891−
892−instance FromJSON a => FromJSON (Dual a) where
893− parseJSON = fmap Dual . parseJSON
894− {-# INLINE parseJSON #-}
895−
896−instance ToJSON a => ToJSON (First a) where
897− toJSON = toJSON . getFirst
898− {-# INLINE toJSON #-}
899−
900−instance FromJSON a => FromJSON (First a) where
901− parseJSON = fmap First . parseJSON
902− {-# INLINE parseJSON #-}
903−
904−instance ToJSON a => ToJSON (Last a) where
905− toJSON = toJSON . getLast
906− {-# INLINE toJSON #-}
907−
908−instance FromJSON a => FromJSON (Last a) where
909− parseJSON = fmap Last . parseJSON
910− {-# INLINE parseJSON #-}
911−
912−-- | Fail parsing due to a type mismatch, with a descriptive message.
913−typeMismatch :: String -- ^ The name of the type you are trying to parse.
914− -> Value -- ^ The actual value encountered.
915− -> Parser a
916−typeMismatch expected actual =
917− fail $ "when expecting a " ++ expected ++ ", encountered " ++ name ++
918− " instead"
919− where
920− name = case actual of
921− Object _ -> "Object"
922− Array _ -> "Array"
923− String _ -> "String"
924− Number _ -> "Number"
925− Bool _ -> "Boolean"
926− Null -> "Null"
927−
928−#ifdef GENERICS
929−--------------------------------------------------------------------------------
930−-- Generic toJSON
931−
932−class GToJSON f where
933− gToJSON :: f a -> Value
934−
935−instance (GToJSON a) => GToJSON (M1 i c a) where
936− gToJSON = gToJSON . unM1
937− {-# INLINE gToJSON #-}
938−
939−instance (ToJSON a) => GToJSON (K1 i a) where
940− gToJSON = toJSON . unK1
941− {-# INLINE gToJSON #-}
942−
943−instance GToJSON U1 where
944− gToJSON _ = emptyArray
945− {-# INLINE gToJSON #-}
946−
947−instance (ConsToJSON a) => GToJSON (C1 c a) where
948− gToJSON = consToJSON . unM1
949− {-# INLINE gToJSON #-}
950−
951−instance (GProductToValues a, GProductToValues b) => GToJSON (a :*: b) where
952− gToJSON = toJSON . toList . gProductToValues
953− {-# INLINE gToJSON #-}
954−
955−instance (GObject a, GObject b) => GToJSON (a :+: b) where
956− gToJSON (L1 x) = Object $ gObject x
957− gToJSON (R1 x) = Object $ gObject x
958− {-# INLINE gToJSON #-}
959−
960−--------------------------------------------------------------------------------
961−
962−class ConsToJSON f where consToJSON :: f a -> Value
963−class ConsToJSON' b f where consToJSON' :: Tagged b (f a -> Value)
964−
965−instance (IsRecord f b, ConsToJSON' b f) => ConsToJSON f where
966− consToJSON = unTagged (consToJSON' :: Tagged b (f a -> Value))
967− {-# INLINE consToJSON #-}
968−
969−instance (GRecordToPairs f) => ConsToJSON' True f where
970− consToJSON' = Tagged (object . toList . gRecordToPairs)
971− {-# INLINE consToJSON' #-}
972−
973−instance GToJSON f => ConsToJSON' False f where
974− consToJSON' = Tagged gToJSON
975− {-# INLINE consToJSON' #-}
976−
977−--------------------------------------------------------------------------------
978−
979−class GRecordToPairs f where
980− gRecordToPairs :: f a -> DList Pair
981−
982−instance (GRecordToPairs a, GRecordToPairs b) => GRecordToPairs (a :*: b) where
983− gRecordToPairs (a :*: b) = gRecordToPairs a `append` gRecordToPairs b
984− {-# INLINE gRecordToPairs #-}
985−
986−instance (Selector s, GToJSON a) => GRecordToPairs (S1 s a) where
987− gRecordToPairs m1 = singleton (pack (selName m1), gToJSON (unM1 m1))
988− {-# INLINE gRecordToPairs #-}
989−
990−--------------------------------------------------------------------------------
991−
992−class GProductToValues f where
993− gProductToValues :: f a -> DList Value
994−
995−instance (GProductToValues a, GProductToValues b) => GProductToValues (a :*: b) where
996− gProductToValues (a :*: b) = gProductToValues a `append` gProductToValues b
997− {-# INLINE gProductToValues #-}
998−
999−instance (GToJSON a) => GProductToValues a where
1000− gProductToValues = singleton . gToJSON
1001− {-# INLINE gProductToValues #-}
1002−
1003−--------------------------------------------------------------------------------
1004−
1005−class GObject f where
1006− gObject :: f a -> Object
1007−
1008−instance (GObject a, GObject b) => GObject (a :+: b) where
1009− gObject (L1 x) = gObject x
1010− gObject (R1 x) = gObject x
1011− {-# INLINE gObject #-}
1012−
1013−instance (Constructor c, GToJSON a, ConsToJSON a) => GObject (C1 c a) where
1014− gObject m1 = M.singleton (pack (conName m1)) (gToJSON m1)
1015− {-# INLINE gObject #-}
1016−
1017−--------------------------------------------------------------------------------
1018−-- Generic parseJSON
1019−
1020−class GFromJSON f where
1021− gParseJSON :: Value -> Parser (f a)
1022−
1023−instance (GFromJSON a) => GFromJSON (M1 i c a) where
1024− gParseJSON = fmap M1 . gParseJSON
1025− {-# INLINE gParseJSON #-}
1026−
1027−instance (FromJSON a) => GFromJSON (K1 i a) where
1028− gParseJSON = fmap K1 . parseJSON
1029− {-# INLINE gParseJSON #-}
1030−
1031−instance GFromJSON U1 where
1032− gParseJSON v
1033− | isEmptyArray v = pure U1
1034− | otherwise = typeMismatch "unit constructor (U1)" v
1035− {-# INLINE gParseJSON #-}
1036−
1037−instance (ConsFromJSON a) => GFromJSON (C1 c a) where
1038− gParseJSON = fmap M1 . consParseJSON
1039− {-# INLINE gParseJSON #-}
1040−
1041−instance (GFromProduct a, GFromProduct b) => GFromJSON (a :*: b) where
1042− gParseJSON (Array arr) = gParseProduct arr
1043− gParseJSON v = typeMismatch "product (:*:)" v
1044− {-# INLINE gParseJSON #-}
1045−
1046−instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where
1047− gParseJSON (Object (M.toList -> [keyVal])) = gParseSum keyVal
1048− gParseJSON v = typeMismatch "sum (:+:)" v
1049− {-# INLINE gParseJSON #-}
1050−
1051−--------------------------------------------------------------------------------
1052−
1053−class ConsFromJSON f where consParseJSON :: Value -> Parser (f a)
1054−class ConsFromJSON' b f where consParseJSON' :: Tagged b (Value -> Parser (f a))
1055−
1056−instance (IsRecord f b, ConsFromJSON' b f) => ConsFromJSON f where
1057− consParseJSON = unTagged (consParseJSON' :: Tagged b (Value -> Parser (f a)))
1058− {-# INLINE consParseJSON #-}
1059−
1060−instance (GFromRecord f) => ConsFromJSON' True f where
1061− consParseJSON' = Tagged parseRecord
1062− where
1063− parseRecord (Object obj) = gParseRecord obj
1064− parseRecord v = typeMismatch "record (:*:)" v
1065− {-# INLINE consParseJSON' #-}
1066−
1067−instance (GFromJSON f) => ConsFromJSON' False f where
1068− consParseJSON' = Tagged gParseJSON
1069− {-# INLINE consParseJSON' #-}
1070−
1071−--------------------------------------------------------------------------------
1072−
1073−class GFromRecord f where
1074− gParseRecord :: Object -> Parser (f a)
1075−
1076−instance (GFromRecord a, GFromRecord b) => GFromRecord (a :*: b) where
1077− gParseRecord obj = (:*:) <$> gParseRecord obj <*> gParseRecord obj
1078− {-# INLINE gParseRecord #-}
1079−
1080−instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
1081− gParseRecord obj = case M.lookup (T.pack key) obj of
1082− Nothing -> notFound key
1083− Just v -> gParseJSON v
1084− where
1085− key = selName (undefined :: t s a p)
1086− {-# INLINE gParseRecord #-}
1087−
1088−--------------------------------------------------------------------------------
1089−
1090−class GFromProduct f where
1091− gParseProduct :: Array -> Parser (f a)
1092−
1093−instance (GFromProduct a, GFromProduct b) => GFromProduct (a :*: b) where
1094− gParseProduct arr = (:*:) <$> gParseProduct arrL <*> gParseProduct arrR
1095− where
1096− (arrL, arrR) = V.splitAt (V.length arr `div` 2) arr
1097− {-# INLINE gParseProduct #-}
1098−
1099−instance (GFromJSON a) => GFromProduct a where
1100− gParseProduct ((!? 0) -> Just v) = gParseJSON v
1101− gParseProduct _ = fail "Array to small"
1102− {-# INLINE gParseProduct #-}
1103−
1104−--------------------------------------------------------------------------------
1105−
1106−class GFromSum f where
1107− gParseSum :: Pair -> Parser (f a)
1108−
1109−instance (GFromSum a, GFromSum b) => GFromSum (a :+: b) where
1110− gParseSum keyVal = (L1 <$> gParseSum keyVal) <|> (R1 <$> gParseSum keyVal)
1111− {-# INLINE gParseSum #-}
1112−
1113−instance (Constructor c, GFromJSON a, ConsFromJSON a) => GFromSum (C1 c a) where
1114− gParseSum (key, value)
1115− | key == pack (conName (undefined :: t c a p)) = gParseJSON value
1116− | otherwise = notFound $ unpack key
1117− {-# INLINE gParseSum #-}
1118−
1119−notFound :: String -> Parser a
1120−notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
1121−
1122−--------------------------------------------------------------------------------
1123−
1124−newtype Tagged s b = Tagged {unTagged :: b}
1125−
1126−data True
1127−data False
1128−
1129−class IsRecord (f :: * -> *) b | f -> b
1130−
1131−instance (IsRecord f b) => IsRecord (f :*: g) b
1132−instance IsRecord (M1 S NoSelector f) False
1133−instance (IsRecord f b) => IsRecord (M1 S c f) b
1134−instance IsRecord (K1 i c) True
1135−instance IsRecord U1 False
1136−
1137−--------------------------------------------------------------------------------
1138−
1139−type DList a = [a] -> [a]
1140−
1141−toList :: DList a -> [a]
1142−toList = ($ [])
1143−{-# INLINE toList #-}
1144−
1145−singleton :: a -> DList a
1146−singleton = (:)
1147−{-# INLINE singleton #-}
1148−
1149−append :: DList a -> DList a -> DList a
1150−append = (.)
1151−{-# INLINE append #-}
1152−
1153−--------------------------------------------------------------------------------
1154−#endif