@@ -1,18 +1,4 @@
1−{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, GeneralizedNewtypeDeriving,
1+{-# LANGUAGE CPP, DeriveDataTypeable, Rank2Types #-}
2− IncoherentInstances, OverlappingInstances, OverloadedStrings, Rank2Types,
3− ViewPatterns, FlexibleContexts, UndecidableInstances,
4− ScopedTypeVariables, PatternGuards #-}
8−{-# LANGUAGE DefaultSignatures
12− , MultiParamTypeClasses
13− , FunctionalDependencies
18-- Module: Data.Aeson.Types.Internal
4-- Module: Data.Aeson.Types.Internal
@@ -33,68 +19,31 @@ module Data.Aeson.Types.Internal
35 , emptyObject
21 , emptyObject
36− -- * Convenience types and functions
39 -- * Type conversion
22 -- * Type conversion
41 , Result(..)
24 , Result(..)
45 , parseEither
26 , parseEither
46 , parseMaybe
27 , parseMaybe
48 -- * Constructors and accessors
28 -- * Constructors and accessors
55import Control.Applicative
32import Control.Applicative
56import Control.DeepSeq (NFData(..))
33import Control.DeepSeq (NFData(..))
57import Control.Monad.State.Strict
34import Control.Monad.State.Strict
58−import Data.Aeson.Functions
59import Data.Attoparsec.Char8 (Number(..))
35import Data.Attoparsec.Char8 (Number(..))
60−import Data.Bits (shiftR)
61import Data.Data (Data)
36import Data.Data (Data)
62import Data.Hashable (Hashable(..))
37import Data.Hashable (Hashable(..))
63−import Data.Int (Int8, Int16, Int32, Int64)
64import Data.List (foldl')
38import Data.List (foldl')
65import Data.Map (Map)
39import Data.Map (Map)
66−import Data.Monoid (Dual(..), First(..), Last(..))
67import Data.Monoid (Monoid(..))
40import Data.Monoid (Monoid(..))
68−import Data.Ratio (Ratio)
69import Data.String (IsString(..))
41import Data.String (IsString(..))
70−import Data.Text.Encoding (encodeUtf8)
42+import Data.Text (Text, pack)
71−import Data.Text (Text, pack, unpack)
72−import Data.Time.Clock (UTCTime)
73−import Data.Time.Format (FormatTime, formatTime, parseTime)
74import Data.Typeable (Typeable)
43import Data.Typeable (Typeable)
75import Data.Vector (Vector)
44import 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
85import qualified Data.Map as M
45import 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
89import qualified Data.Vector as V
46import 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
99-- | The result of running a 'Parser'.
48-- | The result of running a 'Parser'.
100data Result a = Error String
49data Result a = Error String
@@ -259,19 +208,6 @@ isEmptyArray _ = False
259emptyObject :: Value
208emptyObject :: Value
260emptyObject = Object M.empty
209emptyObject = Object M.empty
262−-- | A key\/value pair for an 'Object'.
263−type Pair = (Text, Value)
265−-- | Construct a 'Pair' from a key and a value.
266−(.=) :: ToJSON a => Text -> a -> Pair
267−name .= value = (name, toJSON value)
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 #-}
275-- | Run a 'Parser'.
211-- | Run a 'Parser'.
276parse :: (a -> Parser b) -> a -> Result b
212parse :: (a -> Parser b) -> a -> Result b
277parse m v = runParser (m v) Error Success
213parse m v = runParser (m v) Error Success
@@ -285,900 +221,13 @@ parseMaybe m v = runParser (m v) (const Nothing) Just
285-- | Run a 'Parser' with an 'Either' result type.
221-- | Run a 'Parser' with an 'Either' result type.
286parseEither :: (a -> Parser b) -> a -> Either String b
222parseEither :: (a -> Parser b) -> a -> Either String b
287parseEither m v = runParser (m v) Left Right
223parseEither m v = runParser (m v) Left Right
288−{-# INLINE parseEither #-}
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.
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
303−-- | Retrieve the value associated with the given key of an 'Object'.
225+-- | A key\/value pair for an 'Object'.
304−-- The result is 'Nothing' if the key is not present, or 'empty' if
226+type Pair = (Text, Value)
305−-- the value cannot be converted to the desired type.
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
228+{-# INLINE parseEither #-}
316-- | Create a 'Value' from a list of name\/value 'Pair's. If duplicate
229-- | Create a 'Value' from a list of name\/value 'Pair's. If duplicate
317-- keys arise, earlier keys and their associated values win.
230-- keys arise, earlier keys and their associated values win.
318object :: [Pair] -> Value
231object :: [Pair] -> Value
319object = Object . M.fromList
232object = Object . M.fromList
320{-# INLINE object #-}
233{-# INLINE object #-}
322−-- | A type that can be converted to JSON.
324−-- An example type and instance:
326−-- @{-\# LANGUAGE OverloadedStrings #-}
328−-- data Coord { x :: Double, y :: Double }
330−-- instance ToJSON Coord where
331−-- toJSON (Coord x y) = 'object' [\"x\" '.=' x, \"y\" '.=' y]
334−-- Note the use of the @OverloadedStrings@ language extension which enables
335−-- 'Text' values to be written as string literals.
337−-- Instead of manually writing your 'ToJSON' instance, there are three options
338−-- to do it automatically:
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:
344−-- * 'Data.Aeson.Generic' provides a generic @toJSON@ function that accepts any
345−-- type which is an instance of 'Data'.
347−-- * If your compiler has support for the @DeriveGeneric@ and
348−-- @DefaultSignatures@ language extensions, @toJSON@ will have a default generic
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@.
355−-- For example the previous example can be simplified to just:
357−-- @{-\# LANGUAGE DeriveGeneric \#-}
359−-- import GHC.Generics
361−-- data Coord { x :: Double, y :: Double } deriving Generic
363−-- instance ToJSON Coord
366− toJSON :: a -> Value
369− default toJSON :: (Generic a, GToJSON (Rep a)) => a -> Value
370− toJSON = gToJSON . from
373−-- | A type that can be converted from JSON, with the possibility of
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.
380−-- An example type and instance:
382−-- @{-\# LANGUAGE OverloadedStrings #-}
384−-- data Coord { x :: Double, y :: Double }
386−-- instance FromJSON Coord where
387−-- parseJSON ('Object' v) = Coord '<$>'
388−-- v '.:' \"x\" '<*>'
391−-- \-- A non-'Object' value is of the wrong type, so use 'mzero' to fail.
392−-- parseJSON _ = 'mzero'
395−-- Note the use of the @OverloadedStrings@ language extension which enables
396−-- 'Text' values to be written as string literals.
398−-- Instead of manually writing your 'FromJSON' instance, there are three options
399−-- to do it automatically:
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:
405−-- * 'Data.Aeson.Generic' provides a generic @fromJSON@ function that parses to
406−-- any type which is an instance of 'Data'.
408−-- * If your compiler has support for the @DeriveGeneric@ and
409−-- @DefaultSignatures@ language extensions, @parseJSON@ will have a default
410−-- generic implementation.
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
416−-- For example the previous example can be simplified to just:
418−-- @{-\# LANGUAGE DeriveGeneric \#-}
420−-- import GHC.Generics
422−-- data Coord { x :: Double, y :: Double } deriving Generic
424−-- instance FromJSON Coord
426−class FromJSON a where
427− parseJSON :: Value -> Parser a
430− default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a
431− parseJSON = fmap to . gParseJSON
434−instance (ToJSON a) => ToJSON (Maybe a) where
435− toJSON (Just a) = toJSON a
436− toJSON Nothing = Null
437− {-# INLINE toJSON #-}
439−instance (FromJSON a) => FromJSON (Maybe a) where
440− parseJSON Null = pure Nothing
441− parseJSON a = Just <$> parseJSON a
442− {-# INLINE parseJSON #-}
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 #-}
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
454− {-# INLINE parseJSON #-}
460−instance ToJSON Bool where
462− {-# INLINE toJSON #-}
464−instance FromJSON Bool where
465− parseJSON (Bool b) = pure b
466− parseJSON v = typeMismatch "Bool" v
467− {-# INLINE parseJSON #-}
469−instance ToJSON () where
470− toJSON _ = emptyArray
471− {-# INLINE toJSON #-}
473−instance FromJSON () where
474− parseJSON (Array v) | V.null v = pure ()
475− parseJSON v = typeMismatch "()" v
476− {-# INLINE parseJSON #-}
478−instance ToJSON [Char] where
479− toJSON = String . T.pack
480− {-# INLINE toJSON #-}
482−instance FromJSON [Char] where
483− parseJSON (String t) = pure (T.unpack t)
484− parseJSON v = typeMismatch "String" v
485− {-# INLINE parseJSON #-}
487−instance ToJSON Char where
488− toJSON = String . T.singleton
489− {-# INLINE toJSON #-}
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 #-}
497−instance ToJSON Double where
499− {-# INLINE toJSON #-}
501−instance FromJSON Double where
502− parseJSON (Number n) = case n of
504− I i -> pure (fromIntegral i)
505− parseJSON Null = pure (0/0)
506− parseJSON v = typeMismatch "Double" v
507− {-# INLINE parseJSON #-}
509−instance ToJSON Number where
511− {-# INLINE toJSON #-}
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 #-}
519−instance ToJSON Float where
520− toJSON = Number . realToFrac
521− {-# INLINE toJSON #-}
523−instance FromJSON Float where
524− parseJSON (Number n) = pure $ case n of
526− I i -> fromIntegral i
527− parseJSON Null = pure (0/0)
528− parseJSON v = typeMismatch "Float" v
529− {-# INLINE parseJSON #-}
531−instance ToJSON (Ratio Integer) where
532− toJSON = Number . fromRational
533− {-# INLINE toJSON #-}
535−instance FromJSON (Ratio Integer) where
536− parseJSON (Number n) = pure $ case n of
538− I i -> fromIntegral i
539− parseJSON v = typeMismatch "Ratio Integer" v
540− {-# INLINE parseJSON #-}
542−instance ToJSON Int where
543− toJSON = Number . fromIntegral
544− {-# INLINE toJSON #-}
546−instance FromJSON Int where
547− parseJSON = parseIntegral
548− {-# INLINE parseJSON #-}
550−parseIntegral :: Integral a => Value -> Parser a
551−parseIntegral (Number n) = pure (floor n)
552−parseIntegral v = typeMismatch "Integral" v
553−{-# INLINE parseIntegral #-}
555−instance ToJSON Integer where
556− toJSON = Number . fromIntegral
557− {-# INLINE toJSON #-}
559−instance FromJSON Integer where
560− parseJSON = parseIntegral
561− {-# INLINE parseJSON #-}
563−instance ToJSON Int8 where
564− toJSON = Number . fromIntegral
565− {-# INLINE toJSON #-}
567−instance FromJSON Int8 where
568− parseJSON = parseIntegral
569− {-# INLINE parseJSON #-}
571−instance ToJSON Int16 where
572− toJSON = Number . fromIntegral
573− {-# INLINE toJSON #-}
575−instance FromJSON Int16 where
576− parseJSON = parseIntegral
577− {-# INLINE parseJSON #-}
579−instance ToJSON Int32 where
580− toJSON = Number . fromIntegral
581− {-# INLINE toJSON #-}
583−instance FromJSON Int32 where
584− parseJSON = parseIntegral
585− {-# INLINE parseJSON #-}
587−instance ToJSON Int64 where
588− toJSON = Number . fromIntegral
589− {-# INLINE toJSON #-}
591−instance FromJSON Int64 where
592− parseJSON = parseIntegral
593− {-# INLINE parseJSON #-}
595−instance ToJSON Word where
596− toJSON = Number . fromIntegral
597− {-# INLINE toJSON #-}
599−instance FromJSON Word where
600− parseJSON = parseIntegral
601− {-# INLINE parseJSON #-}
603−instance ToJSON Word8 where
604− toJSON = Number . fromIntegral
605− {-# INLINE toJSON #-}
607−instance FromJSON Word8 where
608− parseJSON = parseIntegral
609− {-# INLINE parseJSON #-}
611−instance ToJSON Word16 where
612− toJSON = Number . fromIntegral
613− {-# INLINE toJSON #-}
615−instance FromJSON Word16 where
616− parseJSON = parseIntegral
617− {-# INLINE parseJSON #-}
619−instance ToJSON Word32 where
620− toJSON = Number . fromIntegral
621− {-# INLINE toJSON #-}
623−instance FromJSON Word32 where
624− parseJSON = parseIntegral
625− {-# INLINE parseJSON #-}
627−instance ToJSON Word64 where
628− toJSON = Number . fromIntegral
629− {-# INLINE toJSON #-}
631−instance FromJSON Word64 where
632− parseJSON = parseIntegral
633− {-# INLINE parseJSON #-}
635−instance ToJSON Text where
637− {-# INLINE toJSON #-}
639−instance FromJSON Text where
640− parseJSON (String t) = pure t
641− parseJSON v = typeMismatch "Text" v
642− {-# INLINE parseJSON #-}
644−instance ToJSON LT.Text where
645− toJSON = String . LT.toStrict
646− {-# INLINE toJSON #-}
648−instance FromJSON LT.Text where
649− parseJSON (String t) = pure (LT.fromStrict t)
650− parseJSON v = typeMismatch "Lazy Text" v
651− {-# INLINE parseJSON #-}
653−instance ToJSON B.ByteString where
654− toJSON = String . decode
655− {-# INLINE toJSON #-}
657−instance FromJSON B.ByteString where
658− parseJSON (String t) = pure . encodeUtf8 $ t
659− parseJSON v = typeMismatch "ByteString" v
660− {-# INLINE parseJSON #-}
662−instance ToJSON LB.ByteString where
663− toJSON = toJSON . strict
664− {-# INLINE toJSON #-}
666−instance FromJSON LB.ByteString where
667− parseJSON (String t) = pure . lazy $ t
668− parseJSON v = typeMismatch "Lazy ByteString" v
669− {-# INLINE parseJSON #-}
671−instance (ToJSON a) => ToJSON [a] where
672− toJSON = Array . V.fromList . map toJSON
673− {-# INLINE toJSON #-}
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 #-}
680−instance (ToJSON a) => ToJSON (Vector a) where
681− toJSON = Array . V.map toJSON
682− {-# INLINE toJSON #-}
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 #-}
689−vectorToJSON :: (VG.Vector v a, ToJSON a) => v a -> Value
690−vectorToJSON = Array . V.map toJSON . V.convert
691−{-# INLINE vectorToJSON #-}
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 #-}
698−instance (Storable a, ToJSON a) => ToJSON (VS.Vector a) where
699− toJSON = vectorToJSON
701−instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where
702− parseJSON = vectorParseJSON "Data.Vector.Storable.Vector a"
704−instance (VP.Prim a, ToJSON a) => ToJSON (VP.Vector a) where
705− toJSON = vectorToJSON
707−instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where
708− parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector a"
710−instance (VG.Vector VU.Vector a, ToJSON a) => ToJSON (VU.Vector a) where
711− toJSON = vectorToJSON
713−instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where
714− parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"
716−instance (ToJSON a) => ToJSON (Set.Set a) where
717− toJSON = toJSON . Set.toList
718− {-# INLINE toJSON #-}
720−instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
721− parseJSON = fmap Set.fromList . parseJSON
722− {-# INLINE parseJSON #-}
724−instance (ToJSON a) => ToJSON (HashSet.HashSet a) where
725− toJSON = toJSON . HashSet.toList
726− {-# INLINE toJSON #-}
728−instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
729− parseJSON = fmap HashSet.fromList . parseJSON
730− {-# INLINE parseJSON #-}
732−instance ToJSON IntSet.IntSet where
733− toJSON = toJSON . IntSet.toList
734− {-# INLINE toJSON #-}
736−instance FromJSON IntSet.IntSet where
737− parseJSON = fmap IntSet.fromList . parseJSON
738− {-# INLINE parseJSON #-}
740−instance ToJSON a => ToJSON (IntMap.IntMap a) where
741− toJSON = toJSON . IntMap.toList
742− {-# INLINE toJSON #-}
744−instance FromJSON a => FromJSON (IntMap.IntMap a) where
745− parseJSON = fmap IntMap.fromList . parseJSON
746− {-# INLINE parseJSON #-}
748−instance (ToJSON v) => ToJSON (M.Map Text v) where
749− toJSON = Object . M.map toJSON
750− {-# INLINE toJSON #-}
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
757−instance (ToJSON v) => ToJSON (M.Map LT.Text v) where
758− toJSON = Object . transformMap LT.toStrict toJSON
760−instance (FromJSON v) => FromJSON (M.Map LT.Text v) where
761− parseJSON = fmap (M.mapKeysMonotonic LT.fromStrict) . parseJSON
763−instance (ToJSON v) => ToJSON (M.Map String v) where
764− toJSON = Object . transformMap pack toJSON
766−instance (FromJSON v) => FromJSON (M.Map String v) where
767− parseJSON = fmap (M.mapKeysMonotonic unpack) . parseJSON
769−instance (ToJSON v) => ToJSON (M.Map B.ByteString v) where
770− toJSON = Object . transformMap decode toJSON
772−instance (FromJSON v) => FromJSON (M.Map B.ByteString v) where
773− parseJSON = fmap (M.mapKeysMonotonic encodeUtf8) . parseJSON
775−instance (ToJSON v) => ToJSON (M.Map LB.ByteString v) where
776− toJSON = Object . transformMap strict toJSON
778−instance (FromJSON v) => FromJSON (M.Map LB.ByteString v) where
779− parseJSON = fmap (M.mapKeysMonotonic lazy) . parseJSON
781−instance (ToJSON v) => ToJSON (H.HashMap Text v) where
782− toJSON = Object . hashMap id toJSON
783− {-# INLINE toJSON #-}
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
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) :)) []
793−instance (FromJSON v) => FromJSON (H.HashMap LT.Text v) where
794− parseJSON = fmap (mapHash LT.fromStrict) . parseJSON
796−instance (ToJSON v) => ToJSON (H.HashMap String v) where
797− toJSON = Object . hashMap pack toJSON
799−instance (FromJSON v) => FromJSON (H.HashMap String v) where
800− parseJSON = fmap (mapHash unpack) . parseJSON
802−instance (ToJSON v) => ToJSON (H.HashMap B.ByteString v) where
803− toJSON = Object . hashMap decode toJSON
805−instance (FromJSON v) => FromJSON (H.HashMap B.ByteString v) where
806− parseJSON = fmap (mapHash encodeUtf8) . parseJSON
808−instance (ToJSON v) => ToJSON (H.HashMap LB.ByteString v) where
809− toJSON = Object . hashMap strict toJSON
811−instance (FromJSON v) => FromJSON (H.HashMap LB.ByteString v) where
812− parseJSON = fmap (mapHash lazy) . parseJSON
814−instance ToJSON Value where
816− {-# INLINE toJSON #-}
818−instance FromJSON Value where
819− parseJSON a = pure a
820− {-# INLINE parseJSON #-}
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:
826−-- > /Date(1302547608878)/
828−-- The number represents milliseconds since the Unix epoch.
829−newtype DotNetTime = DotNetTime {
830− fromDotNetTime :: UTCTime
831− } deriving (Eq, Ord, Read, Show, Typeable, FormatTime)
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 #-}
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 #-}
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 #-}
855−instance FromJSON UTCTime where
856− parseJSON (String t) =
857− case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of
859− _ -> fail "could not parse ISO-8601 date"
860− parseJSON v = typeMismatch "UTCTime" v
861− {-# INLINE parseJSON #-}
863−instance (ToJSON a, ToJSON b) => ToJSON (a,b) where
864− toJSON (a,b) = toJSON [toJSON a, toJSON b]
865− {-# INLINE toJSON #-}
867−instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
868− parseJSON (Array ab) =
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 #-}
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 #-}
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 #-}
889−instance ToJSON a => ToJSON (Dual a) where
890− toJSON = toJSON . getDual
891− {-# INLINE toJSON #-}
893−instance FromJSON a => FromJSON (Dual a) where
894− parseJSON = fmap Dual . parseJSON
895− {-# INLINE parseJSON #-}
897−instance ToJSON a => ToJSON (First a) where
898− toJSON = toJSON . getFirst
899− {-# INLINE toJSON #-}
901−instance FromJSON a => FromJSON (First a) where
902− parseJSON = fmap First . parseJSON
903− {-# INLINE parseJSON #-}
905−instance ToJSON a => ToJSON (Last a) where
906− toJSON = toJSON . getLast
907− {-# INLINE toJSON #-}
909−instance FromJSON a => FromJSON (Last a) where
910− parseJSON = fmap Last . parseJSON
911− {-# INLINE parseJSON #-}
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.
917−typeMismatch expected actual =
918− fail $ "when expecting a " ++ expected ++ ", encountered " ++ name ++
921− name = case actual of
922− Object _ -> "Object"
924− String _ -> "String"
925− Number _ -> "Number"
930−--------------------------------------------------------------------------------
933−class GToJSON f where
934− gToJSON :: f a -> Value
936−instance (GToJSON a) => GToJSON (M1 i c a) where
937− gToJSON = gToJSON . unM1
938− {-# INLINE gToJSON #-}
940−instance (ToJSON a) => GToJSON (K1 i a) where
941− gToJSON = toJSON . unK1
942− {-# INLINE gToJSON #-}
944−instance GToJSON U1 where
945− gToJSON _ = emptyArray
946− {-# INLINE gToJSON #-}
948−instance (ConsToJSON a) => GToJSON (C1 c a) where
949− gToJSON = consToJSON . unM1
950− {-# INLINE gToJSON #-}
952−instance (GProductToValues a, GProductToValues b) => GToJSON (a :*: b) where
953− gToJSON = toJSON . toList . gProductToValues
954− {-# INLINE gToJSON #-}
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 #-}
961−--------------------------------------------------------------------------------
963−class ConsToJSON f where consToJSON :: f a -> Value
964−class ConsToJSON' b f where consToJSON' :: Tagged b (f a -> Value)
966−newtype Tagged s b = Tagged {unTagged :: b}
968−instance (IsRecord f b, ConsToJSON' b f) => ConsToJSON f where
969− consToJSON = unTagged (consToJSON' :: Tagged b (f a -> Value))
970− {-# INLINE consToJSON #-}
972−instance (GRecordToPairs f) => ConsToJSON' True f where
973− consToJSON' = Tagged (object . toList . gRecordToPairs)
974− {-# INLINE consToJSON' #-}
976−instance GToJSON f => ConsToJSON' False f where
977− consToJSON' = Tagged gToJSON
978− {-# INLINE consToJSON' #-}
980−--------------------------------------------------------------------------------
982−class GRecordToPairs f where
983− gRecordToPairs :: f a -> DList Pair
985−instance (GRecordToPairs a, GRecordToPairs b) => GRecordToPairs (a :*: b) where
986− gRecordToPairs (a :*: b) = gRecordToPairs a `append` gRecordToPairs b
987− {-# INLINE gRecordToPairs #-}
989−instance (Selector s, GToJSON a) => GRecordToPairs (S1 s a) where
990− gRecordToPairs m1 = singleton (pack (selName m1), gToJSON (unM1 m1))
991− {-# INLINE gRecordToPairs #-}
993−--------------------------------------------------------------------------------
995−class GProductToValues f where
996− gProductToValues :: f a -> DList Value
998−instance (GProductToValues a, GProductToValues b) => GProductToValues (a :*: b) where
999− gProductToValues (a :*: b) = gProductToValues a `append` gProductToValues b
1000− {-# INLINE gProductToValues #-}
1002−instance (GToJSON a) => GProductToValues a where
1003− gProductToValues = singleton . gToJSON
1004− {-# INLINE gProductToValues #-}
1006−--------------------------------------------------------------------------------
1008−class GObject f where
1009− gObject :: f a -> Object
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 #-}
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 #-}
1020−--------------------------------------------------------------------------------
1021−-- Generic parseJSON
1023−class GFromJSON f where
1024− gParseJSON :: Value -> Parser (f a)
1026−instance (GFromJSON a) => GFromJSON (M1 i c a) where
1027− gParseJSON = fmap M1 . gParseJSON
1028− {-# INLINE gParseJSON #-}
1030−instance (FromJSON a) => GFromJSON (K1 i a) where
1031− gParseJSON = fmap K1 . parseJSON
1032− {-# INLINE gParseJSON #-}
1034−instance GFromJSON U1 where
1036− | isEmptyArray v = pure U1
1037− | otherwise = typeMismatch "unit constructor (U1)" v
1038− {-# INLINE gParseJSON #-}
1040−instance (ConsFromJSON a) => GFromJSON (C1 c a) where
1041− gParseJSON = fmap M1 . consParseJSON
1042− {-# INLINE gParseJSON #-}
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
1049− fail $ "When expecting a product of " ++ show lenProduct ++
1050− " values, encountered an Array of " ++ show lenArray ++
1051− " elements instead"
1053− lenArray = V.length arr
1054− lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int)
1056− gParseJSON v = typeMismatch "product (:*:)" v
1057− {-# INLINE gParseJSON #-}
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
1064− gParseJSON v = typeMismatch "sum (:+:)" v
1065− {-# INLINE gParseJSON #-}
1067−notFound :: String -> Parser a
1068−notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
1069−{-# INLINE notFound #-}
1071−--------------------------------------------------------------------------------
1073−class ConsFromJSON f where consParseJSON :: Value -> Parser (f a)
1074−class ConsFromJSON' b f where consParseJSON' :: Tagged b (Value -> Parser (f a))
1076−instance (IsRecord f b, ConsFromJSON' b f) => ConsFromJSON f where
1077− consParseJSON = unTagged (consParseJSON' :: Tagged b (Value -> Parser (f a)))
1078− {-# INLINE consParseJSON #-}
1080−instance (GFromRecord f) => ConsFromJSON' True f where
1081− consParseJSON' = Tagged parseRecord
1083− parseRecord (Object obj) = gParseRecord obj
1084− parseRecord v = typeMismatch "record (:*:)" v
1085− {-# INLINE consParseJSON' #-}
1087−instance (GFromJSON f) => ConsFromJSON' False f where
1088− consParseJSON' = Tagged gParseJSON
1089− {-# INLINE consParseJSON' #-}
1091−--------------------------------------------------------------------------------
1093−class GFromRecord f where
1094− gParseRecord :: Object -> Parser (f a)
1096−instance (GFromRecord a, GFromRecord b) => GFromRecord (a :*: b) where
1097− gParseRecord obj = (:*:) <$> gParseRecord obj <*> gParseRecord obj
1098− {-# INLINE gParseRecord #-}
1100−instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
1101− gParseRecord = maybe (notFound key) gParseJSON . M.lookup (T.pack key)
1103− key = selName (undefined :: t s a p)
1104− {-# INLINE gParseRecord #-}
1106−--------------------------------------------------------------------------------
1108−class ProductSize f where
1109− productSize :: Tagged2 f Int
1111−newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}
1113−instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where
1114− productSize = Tagged2 $ unTagged2 (productSize :: Tagged2 a Int) +
1115− unTagged2 (productSize :: Tagged2 b Int)
1117−instance ProductSize (S1 s a) where
1118− productSize = Tagged2 1
1120−--------------------------------------------------------------------------------
1122−class GFromProduct f where
1123− gParseProduct :: Array -> Int -> Int -> Parser (f a)
1125−instance (GFromProduct a, GFromProduct b) => GFromProduct (a :*: b) where
1126− gParseProduct arr ix len = (:*:) <$> gParseProduct arr ix lenL
1127− <*> gParseProduct arr ixR lenR
1129− lenL = len `shiftR` 1
1132− {-# INLINE gParseProduct #-}
1134−instance (GFromJSON a) => GFromProduct (S1 s a) where
1135− gParseProduct arr ix _ = gParseJSON $ V.unsafeIndex arr ix
1136− {-# INLINE gParseProduct #-}
1138−--------------------------------------------------------------------------------
1140−class GFromSum f where
1141− gParseSum :: Pair -> Maybe (Parser (f a))
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 #-}
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 #-}
1154−--------------------------------------------------------------------------------
1156−class IsRecord (f :: * -> *) b | f -> b
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
1167−--------------------------------------------------------------------------------
1169−type DList a = [a] -> [a]
1171−toList :: DList a -> [a]
1173−{-# INLINE toList #-}
1175−singleton :: a -> DList a
1177−{-# INLINE singleton #-}
1179−append :: DList a -> DList a -> DList a
1181−{-# INLINE append #-}
1183−--------------------------------------------------------------------------------