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