@@ -1,7 +1,4 @@
1−{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,
2− GeneralizedNewtypeDeriving, IncoherentInstances, OverlappingInstances,
3− OverloadedStrings, UndecidableInstances, ViewPatterns #-}
4−{-# OPTIONS_GHC -fno-warn-orphans #-}
1+{-# LANGUAGE CPP, FlexibleContexts #-}
52
63#ifdef GENERICS
74{-# LANGUAGE DefaultSignatures #-}
@@ -9,7 +6,7 @@
96
107-- |
118-- Module: Data.Aeson.Types.Class
12−-- Copyright: (c) 2011, 2012 Bryan O'Sullivan
9+-- Copyright: (c) 2011-2013 Bryan O'Sullivan
1310-- (c) 2011 MailRank, Inc.
1411-- License: Apache
1512-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>
@@ -31,59 +28,9 @@ module Data.Aeson.Types.Class
3128 , genericToJSON
3229 , genericParseJSON
3330#endif
34− -- * Types
35− , DotNetTime(..)
36−
37− -- * Inspecting @'Value's@
38− , withObject
39− , withText
40− , withArray
41− , withNumber
42− , withBool
43−
44− -- * Functions
45− , fromJSON
46− , (.:)
47− , (.:?)
48− , (.!=)
49− , (.=)
50− , typeMismatch
5131 ) where
5232
53−import Control.Applicative ((<$>), (<*>), (<|>), pure, empty)
54−import Data.Aeson.Functions
5533import Data.Aeson.Types.Internal
56−import Data.Attoparsec.Char8 (Number(..))
57−import Data.Fixed
58−import Data.Hashable (Hashable(..))
59−import Data.Int (Int8, Int16, Int32, Int64)
60−import Data.Maybe (fromMaybe)
61−import Data.Monoid (Dual(..), First(..), Last(..), mappend)
62−import Data.Ratio (Ratio)
63−import Data.Text (Text, pack, unpack)
64−import Data.Time (UTCTime, ZonedTime(..), TimeZone(..))
65−import Data.Time.Format (FormatTime, formatTime, parseTime)
66−import Data.Traversable (traverse)
67−import Data.Typeable (Typeable)
68−import Data.Vector (Vector)
69−import Data.Word (Word, Word8, Word16, Word32, Word64)
70−import Foreign.Storable (Storable)
71−import System.Locale (defaultTimeLocale, dateTimeFmt)
72−import qualified Data.HashMap.Strict as H
73−import qualified Data.HashSet as HashSet
74−import qualified Data.IntMap as IntMap
75−import qualified Data.IntSet as IntSet
76−import qualified Data.Map as M
77−import qualified Data.Set as Set
78−import qualified Data.Tree as Tree
79−import qualified Data.Text as T
80−import qualified Data.Text.Lazy as LT
81−import qualified Data.Vector as V
82−import qualified Data.Vector.Generic as VG
83−import qualified Data.Vector.Primitive as VP
84−import qualified Data.Vector.Storable as VS
85−import qualified Data.Vector.Unboxed as VU
86−import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
8734
8835#ifdef GENERICS
8936import GHC.Generics
@@ -243,694 +190,3 @@ class FromJSON a where
243190 default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a
244191 parseJSON = genericParseJSON defaultOptions
245192#endif
246−
247−instance (ToJSON a) => ToJSON (Maybe a) where
248− toJSON (Just a) = toJSON a
249− toJSON Nothing = Null
250− {-# INLINE toJSON #-}
251−
252−instance (FromJSON a) => FromJSON (Maybe a) where
253− parseJSON Null = pure Nothing
254− parseJSON a = Just <$> parseJSON a
255− {-# INLINE parseJSON #-}
256−
257−instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where
258− toJSON (Left a) = object [left .= a]
259− toJSON (Right b) = object [right .= b]
260− {-# INLINE toJSON #-}
261−
262−instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
263− parseJSON (Object (H.toList -> [(key, value)]))
264− | key == left = Left <$> parseJSON value
265− | key == right = Right <$> parseJSON value
266− parseJSON _ = fail ""
267− {-# INLINE parseJSON #-}
268−
269−left, right :: Text
270−left = "Left"
271−right = "Right"
272−
273−instance ToJSON Bool where
274− toJSON = Bool
275− {-# INLINE toJSON #-}
276−
277−instance FromJSON Bool where
278− parseJSON = withBool "Bool" pure
279− {-# INLINE parseJSON #-}
280−
281−instance ToJSON () where
282− toJSON _ = emptyArray
283− {-# INLINE toJSON #-}
284−
285−instance FromJSON () where
286− parseJSON = withArray "()" $ \v ->
287− if V.null v
288− then pure ()
289− else fail "Expected an empty array"
290− {-# INLINE parseJSON #-}
291−
292−instance ToJSON [Char] where
293− toJSON = String . T.pack
294− {-# INLINE toJSON #-}
295−
296−instance FromJSON [Char] where
297− parseJSON = withText "String" $ pure . T.unpack
298− {-# INLINE parseJSON #-}
299−
300−instance ToJSON Char where
301− toJSON = String . T.singleton
302− {-# INLINE toJSON #-}
303−
304−instance FromJSON Char where
305− parseJSON = withText "Char" $ \t ->
306− if T.compareLength t 1 == EQ
307− then pure $ T.head t
308− else fail "Expected a string of length 1"
309− {-# INLINE parseJSON #-}
310−
311−instance ToJSON Double where
312− toJSON = Number . D
313− {-# INLINE toJSON #-}
314−
315−instance FromJSON Double where
316− parseJSON (Number n) = case n of
317− D d -> pure d
318− I i -> pure (fromIntegral i)
319− parseJSON Null = pure (0/0)
320− parseJSON v = typeMismatch "Double" v
321− {-# INLINE parseJSON #-}
322−
323−instance ToJSON Number where
324− toJSON = Number
325− {-# INLINE toJSON #-}
326−
327−instance FromJSON Number where
328− parseJSON (Number n) = pure n
329− parseJSON Null = pure (D (0/0))
330− parseJSON v = typeMismatch "Number" v
331− {-# INLINE parseJSON #-}
332−
333−instance ToJSON Float where
334− toJSON = Number . realToFrac
335− {-# INLINE toJSON #-}
336−
337−instance FromJSON Float where
338− parseJSON (Number n) = pure $ case n of
339− D d -> realToFrac d
340− I i -> fromIntegral i
341− parseJSON Null = pure (0/0)
342− parseJSON v = typeMismatch "Float" v
343− {-# INLINE parseJSON #-}
344−
345−instance ToJSON (Ratio Integer) where
346− toJSON = Number . fromRational
347− {-# INLINE toJSON #-}
348−
349−instance FromJSON (Ratio Integer) where
350− parseJSON = withNumber "Ration Integer" $ \n ->
351− pure $ case n of
352− D d -> toRational d
353− I i -> fromIntegral i
354− {-# INLINE parseJSON #-}
355−
356−instance HasResolution a => ToJSON (Fixed a) where
357− toJSON = Number . realToFrac
358− {-# INLINE toJSON #-}
359−
360−instance HasResolution a => FromJSON (Fixed a) where
361− parseJSON (Number n) = pure $ case n of
362− D d -> realToFrac d
363− I i -> fromIntegral i
364− parseJSON v = typeMismatch "Fixed" v
365− {-# INLINE parseJSON #-}
366−
367−instance ToJSON Int where
368− toJSON = Number . fromIntegral
369− {-# INLINE toJSON #-}
370−
371−instance FromJSON Int where
372− parseJSON = parseIntegral
373− {-# INLINE parseJSON #-}
374−
375−parseIntegral :: Integral a => Value -> Parser a
376−parseIntegral = withNumber "Integral" $ pure . floor
377−{-# INLINE parseIntegral #-}
378−
379−instance ToJSON Integer where
380− toJSON = Number . fromIntegral
381− {-# INLINE toJSON #-}
382−
383−instance FromJSON Integer where
384− parseJSON = parseIntegral
385− {-# INLINE parseJSON #-}
386−
387−instance ToJSON Int8 where
388− toJSON = Number . fromIntegral
389− {-# INLINE toJSON #-}
390−
391−instance FromJSON Int8 where
392− parseJSON = parseIntegral
393− {-# INLINE parseJSON #-}
394−
395−instance ToJSON Int16 where
396− toJSON = Number . fromIntegral
397− {-# INLINE toJSON #-}
398−
399−instance FromJSON Int16 where
400− parseJSON = parseIntegral
401− {-# INLINE parseJSON #-}
402−
403−instance ToJSON Int32 where
404− toJSON = Number . fromIntegral
405− {-# INLINE toJSON #-}
406−
407−instance FromJSON Int32 where
408− parseJSON = parseIntegral
409− {-# INLINE parseJSON #-}
410−
411−instance ToJSON Int64 where
412− toJSON = Number . fromIntegral
413− {-# INLINE toJSON #-}
414−
415−instance FromJSON Int64 where
416− parseJSON = parseIntegral
417− {-# INLINE parseJSON #-}
418−
419−instance ToJSON Word where
420− toJSON = Number . fromIntegral
421− {-# INLINE toJSON #-}
422−
423−instance FromJSON Word where
424− parseJSON = parseIntegral
425− {-# INLINE parseJSON #-}
426−
427−instance ToJSON Word8 where
428− toJSON = Number . fromIntegral
429− {-# INLINE toJSON #-}
430−
431−instance FromJSON Word8 where
432− parseJSON = parseIntegral
433− {-# INLINE parseJSON #-}
434−
435−instance ToJSON Word16 where
436− toJSON = Number . fromIntegral
437− {-# INLINE toJSON #-}
438−
439−instance FromJSON Word16 where
440− parseJSON = parseIntegral
441− {-# INLINE parseJSON #-}
442−
443−instance ToJSON Word32 where
444− toJSON = Number . fromIntegral
445− {-# INLINE toJSON #-}
446−
447−instance FromJSON Word32 where
448− parseJSON = parseIntegral
449− {-# INLINE parseJSON #-}
450−
451−instance ToJSON Word64 where
452− toJSON = Number . fromIntegral
453− {-# INLINE toJSON #-}
454−
455−instance FromJSON Word64 where
456− parseJSON = parseIntegral
457− {-# INLINE parseJSON #-}
458−
459−instance ToJSON Text where
460− toJSON = String
461− {-# INLINE toJSON #-}
462−
463−instance FromJSON Text where
464− parseJSON = withText "Text" pure
465− {-# INLINE parseJSON #-}
466−
467−instance ToJSON LT.Text where
468− toJSON = String . LT.toStrict
469− {-# INLINE toJSON #-}
470−
471−instance FromJSON LT.Text where
472− parseJSON = withText "Lazy Text" $ pure . LT.fromStrict
473− {-# INLINE parseJSON #-}
474−
475−instance (ToJSON a) => ToJSON [a] where
476− toJSON = Array . V.fromList . map toJSON
477− {-# INLINE toJSON #-}
478−
479−instance (FromJSON a) => FromJSON [a] where
480− parseJSON = withArray "[a]" $ mapM parseJSON . V.toList
481− {-# INLINE parseJSON #-}
482−
483−instance (ToJSON a) => ToJSON (Vector a) where
484− toJSON = Array . V.map toJSON
485− {-# INLINE toJSON #-}
486−
487−instance (FromJSON a) => FromJSON (Vector a) where
488− parseJSON = withArray "Vector a" $ V.mapM parseJSON
489− {-# INLINE parseJSON #-}
490−
491−vectorToJSON :: (VG.Vector v a, ToJSON a) => v a -> Value
492−vectorToJSON = Array . V.map toJSON . V.convert
493−{-# INLINE vectorToJSON #-}
494−
495−vectorParseJSON :: (FromJSON a, VG.Vector w a) => String -> Value -> Parser (w a)
496−vectorParseJSON s = withArray s $ fmap V.convert . V.mapM parseJSON
497−{-# INLINE vectorParseJSON #-}
498−
499−instance (Storable a, ToJSON a) => ToJSON (VS.Vector a) where
500− toJSON = vectorToJSON
501−
502−instance (Storable a, FromJSON a) => FromJSON (VS.Vector a) where
503− parseJSON = vectorParseJSON "Data.Vector.Storable.Vector a"
504−
505−instance (VP.Prim a, ToJSON a) => ToJSON (VP.Vector a) where
506− toJSON = vectorToJSON
507−
508−instance (VP.Prim a, FromJSON a) => FromJSON (VP.Vector a) where
509− parseJSON = vectorParseJSON "Data.Vector.Primitive.Vector a"
510−
511−instance (VG.Vector VU.Vector a, ToJSON a) => ToJSON (VU.Vector a) where
512− toJSON = vectorToJSON
513−
514−instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where
515− parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"
516−
517−instance (ToJSON a) => ToJSON (Set.Set a) where
518− toJSON = toJSON . Set.toList
519− {-# INLINE toJSON #-}
520−
521−instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
522− parseJSON = fmap Set.fromList . parseJSON
523− {-# INLINE parseJSON #-}
524−
525−instance (ToJSON a) => ToJSON (HashSet.HashSet a) where
526− toJSON = toJSON . HashSet.toList
527− {-# INLINE toJSON #-}
528−
529−instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
530− parseJSON = fmap HashSet.fromList . parseJSON
531− {-# INLINE parseJSON #-}
532−
533−instance ToJSON IntSet.IntSet where
534− toJSON = toJSON . IntSet.toList
535− {-# INLINE toJSON #-}
536−
537−instance FromJSON IntSet.IntSet where
538− parseJSON = fmap IntSet.fromList . parseJSON
539− {-# INLINE parseJSON #-}
540−
541−instance ToJSON a => ToJSON (IntMap.IntMap a) where
542− toJSON = toJSON . IntMap.toList
543− {-# INLINE toJSON #-}
544−
545−instance FromJSON a => FromJSON (IntMap.IntMap a) where
546− parseJSON = fmap IntMap.fromList . parseJSON
547− {-# INLINE parseJSON #-}
548−
549−instance (ToJSON v) => ToJSON (M.Map Text v) where
550− toJSON = Object . M.foldrWithKey (\k -> H.insert k . toJSON) H.empty
551− {-# INLINE toJSON #-}
552−
553−instance (FromJSON v) => FromJSON (M.Map Text v) where
554− parseJSON = withObject "Map Text a" $
555− fmap (H.foldrWithKey M.insert M.empty) . traverse parseJSON
556−
557−instance (ToJSON v) => ToJSON (M.Map LT.Text v) where
558− toJSON = Object . mapHashKeyVal LT.toStrict toJSON
559−
560−instance (FromJSON v) => FromJSON (M.Map LT.Text v) where
561− parseJSON = fmap (hashMapKey LT.fromStrict) . parseJSON
562−
563−instance (ToJSON v) => ToJSON (M.Map String v) where
564− toJSON = Object . mapHashKeyVal pack toJSON
565−
566−instance (FromJSON v) => FromJSON (M.Map String v) where
567− parseJSON = fmap (hashMapKey unpack) . parseJSON
568−
569−instance (ToJSON v) => ToJSON (H.HashMap Text v) where
570− toJSON = Object . H.map toJSON
571− {-# INLINE toJSON #-}
572−
573−instance (FromJSON v) => FromJSON (H.HashMap Text v) where
574− parseJSON = withObject "HashMap Text a" $ traverse parseJSON
575−
576−instance (ToJSON v) => ToJSON (H.HashMap LT.Text v) where
577− toJSON = Object . mapKeyVal LT.toStrict toJSON
578−
579−instance (FromJSON v) => FromJSON (H.HashMap LT.Text v) where
580− parseJSON = fmap (mapKey LT.fromStrict) . parseJSON
581−
582−instance (ToJSON v) => ToJSON (H.HashMap String v) where
583− toJSON = Object . mapKeyVal pack toJSON
584−
585−instance (FromJSON v) => FromJSON (H.HashMap String v) where
586− parseJSON = fmap (mapKey unpack) . parseJSON
587−
588−instance (ToJSON v) => ToJSON (Tree.Tree v) where
589− toJSON (Tree.Node root branches) = toJSON (root,branches)
590−
591−instance (FromJSON v) => FromJSON (Tree.Tree v) where
592− parseJSON j = uncurry Tree.Node <$> parseJSON j
593−
594−instance ToJSON Value where
595− toJSON a = a
596− {-# INLINE toJSON #-}
597−
598−instance FromJSON Value where
599− parseJSON a = pure a
600− {-# INLINE parseJSON #-}
601−
602−-- | A newtype wrapper for 'UTCTime' that uses the same non-standard
603−-- serialization format as Microsoft .NET, whose @System.DateTime@
604−-- type is by default serialized to JSON as in the following example:
605−--
606−-- > /Date(1302547608878)/
607−--
608−-- The number represents milliseconds since the Unix epoch.
609−newtype DotNetTime = DotNetTime {
610− fromDotNetTime :: UTCTime
611− } deriving (Eq, Ord, Read, Show, Typeable, FormatTime)
612−
613−instance ToJSON DotNetTime where
614− toJSON (DotNetTime t) =
615− String (pack (secs ++ msecs ++ ")/"))
616− where secs = formatTime defaultTimeLocale "/Date(%s" t
617− msecs = take 3 $ formatTime defaultTimeLocale "%q" t
618− {-# INLINE toJSON #-}
619−
620−instance FromJSON DotNetTime where
621− parseJSON = withText "DotNetTime" $ \t ->
622− let (s,m) = T.splitAt (T.length t - 5) t
623− t' = T.concat [s,".",m]
624− in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of
625− Just d -> pure (DotNetTime d)
626− _ -> fail "could not parse .NET time"
627− {-# INLINE parseJSON #-}
628−
629−instance ToJSON ZonedTime where
630− toJSON t = String $ pack $ formatTime defaultTimeLocale format t
631− where
632− format = "%FT%T" ++ milliseconds ++ tzFormat
633− milliseconds = take 4 $ formatTime defaultTimeLocale "%Q" t
634− tzFormat
635− | 0 == timeZoneMinutes (zonedTimeZone t) = "Z"
636− | otherwise = "%z"
637−
638−instance FromJSON ZonedTime where
639− parseJSON (String t) =
640− tryFormats alternateFormats
641− <|> fail "could not parse ECMA-262 ISO-8601 date"
642− where
643− tryFormat f =
644− case parseTime defaultTimeLocale f (unpack t) of
645− Just d -> pure d
646− Nothing -> empty
647− tryFormats = foldr1 (<|>) . map tryFormat
648− alternateFormats =
649− dateTimeFmt defaultTimeLocale :
650− distributeList ["%Y", "%Y-%m", "%F"]
651− ["T%R", "T%T", "T%T%Q", "T%T%QZ", "T%T%Q%z"]
652−
653− distributeList xs ys =
654− foldr (\x acc -> acc ++ distribute x ys) [] xs
655− distribute x = map (mappend x)
656−
657− parseJSON v = typeMismatch "ZonedTime" v
658−
659−instance ToJSON UTCTime where
660− toJSON t = String (pack (take 23 str ++ "Z"))
661− where str = formatTime defaultTimeLocale "%FT%T%Q" t
662− {-# INLINE toJSON #-}
663−
664−instance FromJSON UTCTime where
665− parseJSON = withText "UTCTime" $ \t ->
666− case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of
667− Just d -> pure d
668− _ -> fail "could not parse ISO-8601 date"
669− {-# INLINE parseJSON #-}
670−
671−instance (ToJSON a, ToJSON b) => ToJSON (a,b) where
672− toJSON (a,b) = Array $ V.create $ do
673− mv <- VM.unsafeNew 2
674− VM.unsafeWrite mv 0 (toJSON a)
675− VM.unsafeWrite mv 1 (toJSON b)
676− return mv
677− {-# INLINE toJSON #-}
678−
679−instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
680− parseJSON = withArray "(a,b)" $ \ab ->
681− let n = V.length ab
682− in if n == 2
683− then (,) <$> parseJSON (V.unsafeIndex ab 0)
684− <*> parseJSON (V.unsafeIndex ab 1)
685− else fail $ "cannot unpack array of length " ++
686− show n ++ " into a pair"
687− {-# INLINE parseJSON #-}
688−
689−instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where
690− toJSON (a,b,c) = Array $ V.create $ do
691− mv <- VM.unsafeNew 3
692− VM.unsafeWrite mv 0 (toJSON a)
693− VM.unsafeWrite mv 1 (toJSON b)
694− VM.unsafeWrite mv 2 (toJSON c)
695− return mv
696− {-# INLINE toJSON #-}
697−
698−instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where
699− parseJSON = withArray "(a,b,c)" $ \abc ->
700− let n = V.length abc
701− in if n == 3
702− then (,,) <$> parseJSON (V.unsafeIndex abc 0)
703− <*> parseJSON (V.unsafeIndex abc 1)
704− <*> parseJSON (V.unsafeIndex abc 2)
705− else fail $ "cannot unpack array of length " ++
706− show n ++ " into a 3-tuple"
707− {-# INLINE parseJSON #-}
708−
709−instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
710− toJSON (a,b,c,d) = Array $ V.create $ do
711− mv <- VM.unsafeNew 4
712− VM.unsafeWrite mv 0 (toJSON a)
713− VM.unsafeWrite mv 1 (toJSON b)
714− VM.unsafeWrite mv 2 (toJSON c)
715− VM.unsafeWrite mv 3 (toJSON d)
716− return mv
717− {-# INLINE toJSON #-}
718−
719−instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON (a,b,c,d) where
720− parseJSON = withArray "(a,b,c,d)" $ \abcd ->
721− let n = V.length abcd
722− in if n == 4
723− then (,,,) <$> parseJSON (V.unsafeIndex abcd 0)
724− <*> parseJSON (V.unsafeIndex abcd 1)
725− <*> parseJSON (V.unsafeIndex abcd 2)
726− <*> parseJSON (V.unsafeIndex abcd 3)
727− else fail $ "cannot unpack array of length " ++
728− show n ++ " into a 4-tuple"
729− {-# INLINE parseJSON #-}
730−
731−instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e) => ToJSON (a,b,c,d,e) where
732− toJSON (a,b,c,d,e) = Array $ V.create $ do
733− mv <- VM.unsafeNew 5
734− VM.unsafeWrite mv 0 (toJSON a)
735− VM.unsafeWrite mv 1 (toJSON b)
736− VM.unsafeWrite mv 2 (toJSON c)
737− VM.unsafeWrite mv 3 (toJSON d)
738− VM.unsafeWrite mv 4 (toJSON e)
739− return mv
740− {-# INLINE toJSON #-}
741−
742−instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e) => FromJSON (a,b,c,d,e) where
743− parseJSON = withArray "(a,b,c,d,e)" $ \abcde ->
744− let n = V.length abcde
745− in if n == 5
746− then (,,,,) <$> parseJSON (V.unsafeIndex abcde 0)
747− <*> parseJSON (V.unsafeIndex abcde 1)
748− <*> parseJSON (V.unsafeIndex abcde 2)
749− <*> parseJSON (V.unsafeIndex abcde 3)
750− <*> parseJSON (V.unsafeIndex abcde 4)
751− else fail $ "cannot unpack array of length " ++
752− show n ++ " into a 5-tuple"
753− {-# INLINE parseJSON #-}
754−
755−instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f) => ToJSON (a,b,c,d,e,f) where
756− toJSON (a,b,c,d,e,f) = Array $ V.create $ do
757− mv <- VM.unsafeNew 6
758− VM.unsafeWrite mv 0 (toJSON a)
759− VM.unsafeWrite mv 1 (toJSON b)
760− VM.unsafeWrite mv 2 (toJSON c)
761− VM.unsafeWrite mv 3 (toJSON d)
762− VM.unsafeWrite mv 4 (toJSON e)
763− VM.unsafeWrite mv 5 (toJSON f)
764− return mv
765− {-# INLINE toJSON #-}
766−
767−instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f) => FromJSON (a,b,c,d,e,f) where
768− parseJSON = withArray "(a,b,c,d,e,f)" $ \abcdef ->
769− let n = V.length abcdef
770− in if n == 6
771− then (,,,,,) <$> parseJSON (V.unsafeIndex abcdef 0)
772− <*> parseJSON (V.unsafeIndex abcdef 1)
773− <*> parseJSON (V.unsafeIndex abcdef 2)
774− <*> parseJSON (V.unsafeIndex abcdef 3)
775− <*> parseJSON (V.unsafeIndex abcdef 4)
776− <*> parseJSON (V.unsafeIndex abcdef 5)
777− else fail $ "cannot unpack array of length " ++
778− show n ++ " into a 6-tuple"
779− {-# INLINE parseJSON #-}
780−
781−instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g) => ToJSON (a,b,c,d,e,f,g) where
782− toJSON (a,b,c,d,e,f,g) = Array $ V.create $ do
783− mv <- VM.unsafeNew 7
784− VM.unsafeWrite mv 0 (toJSON a)
785− VM.unsafeWrite mv 1 (toJSON b)
786− VM.unsafeWrite mv 2 (toJSON c)
787− VM.unsafeWrite mv 3 (toJSON d)
788− VM.unsafeWrite mv 4 (toJSON e)
789− VM.unsafeWrite mv 5 (toJSON f)
790− VM.unsafeWrite mv 6 (toJSON g)
791− return mv
792− {-# INLINE toJSON #-}
793−
794−instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d, FromJSON e, FromJSON f, FromJSON g) => FromJSON (a,b,c,d,e,f,g) where
795− parseJSON = withArray "(a,b,c,d,e,f,g)" $ \abcdefg ->
796− let n = V.length abcdefg
797− in if n == 7
798− then (,,,,,,) <$> parseJSON (V.unsafeIndex abcdefg 0)
799− <*> parseJSON (V.unsafeIndex abcdefg 1)
800− <*> parseJSON (V.unsafeIndex abcdefg 2)
801− <*> parseJSON (V.unsafeIndex abcdefg 3)
802− <*> parseJSON (V.unsafeIndex abcdefg 4)
803− <*> parseJSON (V.unsafeIndex abcdefg 5)
804− <*> parseJSON (V.unsafeIndex abcdefg 6)
805− else fail $ "cannot unpack array of length " ++
806− show n ++ " into a 7-tuple"
807− {-# INLINE parseJSON #-}
808−
809−instance ToJSON a => ToJSON (Dual a) where
810− toJSON = toJSON . getDual
811− {-# INLINE toJSON #-}
812−
813−instance FromJSON a => FromJSON (Dual a) where
814− parseJSON = fmap Dual . parseJSON
815− {-# INLINE parseJSON #-}
816−
817−instance ToJSON a => ToJSON (First a) where
818− toJSON = toJSON . getFirst
819− {-# INLINE toJSON #-}
820−
821−instance FromJSON a => FromJSON (First a) where
822− parseJSON = fmap First . parseJSON
823− {-# INLINE parseJSON #-}
824−
825−instance ToJSON a => ToJSON (Last a) where
826− toJSON = toJSON . getLast
827− {-# INLINE toJSON #-}
828−
829−instance FromJSON a => FromJSON (Last a) where
830− parseJSON = fmap Last . parseJSON
831− {-# INLINE parseJSON #-}
832−
833−-- | @withObject expected f value@ applies @f@ to the 'Object' when @value@ is an @Object@
834−-- and fails using @'typeMismatch' expected@ otherwise.
835−withObject :: String -> (Object -> Parser a) -> Value -> Parser a
836−withObject _ f (Object obj) = f obj
837−withObject expected _ v = typeMismatch expected v
838−{-# INLINE withObject #-}
839−
840−-- | @withObject expected f value@ applies @f@ to the 'Text' when @value@ is a @String@
841−-- and fails using @'typeMismatch' expected@ otherwise.
842−withText :: String -> (Text -> Parser a) -> Value -> Parser a
843−withText _ f (String txt) = f txt
844−withText expected _ v = typeMismatch expected v
845−{-# INLINE withText #-}
846−
847−-- | @withObject expected f value@ applies @f@ to the 'Array' when @value@ is an @Array@
848−-- and fails using @'typeMismatch' expected@ otherwise.
849−withArray :: String -> (Array -> Parser a) -> Value -> Parser a
850−withArray _ f (Array arr) = f arr
851−withArray expected _ v = typeMismatch expected v
852−{-# INLINE withArray #-}
853−
854−-- | @withObject expected f value@ applies @f@ to the 'Number' when @value@ is a @Number@
855−-- and fails using @'typeMismatch' expected@ otherwise.
856−withNumber :: String -> (Number -> Parser a) -> Value -> Parser a
857−withNumber _ f (Number num) = f num
858−withNumber expected _ v = typeMismatch expected v
859−{-# INLINE withNumber #-}
860−
861−-- | @withObject expected f value@ applies @f@ to the 'Bool' when @value@ is a @Bool@
862−-- and fails using @'typeMismatch' expected@ otherwise.
863−withBool :: String -> (Bool -> Parser a) -> Value -> Parser a
864−withBool _ f (Bool arr) = f arr
865−withBool expected _ v = typeMismatch expected v
866−{-# INLINE withBool #-}
867−
868−-- | Construct a 'Pair' from a key and a value.
869−(.=) :: ToJSON a => Text -> a -> Pair
870−name .= value = (name, toJSON value)
871−{-# INLINE (.=) #-}
872−
873−-- | Convert a value from JSON, failing if the types do not match.
874−fromJSON :: (FromJSON a) => Value -> Result a
875−fromJSON = parse parseJSON
876−{-# INLINE fromJSON #-}
877−
878−-- | Retrieve the value associated with the given key of an 'Object'.
879−-- The result is 'empty' if the key is not present or the value cannot
880−-- be converted to the desired type.
881−--
882−-- This accessor is appropriate if the key and value /must/ be present
883−-- in an object for it to be valid. If the key and value are
884−-- optional, use '(.:?)' instead.
885−(.:) :: (FromJSON a) => Object -> Text -> Parser a
886−obj .: key = case H.lookup key obj of
887− Nothing -> fail $ "key " ++ show key ++ " not present"
888− Just v -> parseJSON v
889−{-# INLINE (.:) #-}
890−
891−-- | Retrieve the value associated with the given key of an 'Object'.
892−-- The result is 'Nothing' if the key is not present, or 'empty' if
893−-- the value cannot be converted to the desired type.
894−--
895−-- This accessor is most useful if the key and value can be absent
896−-- from an object without affecting its validity. If the key and
897−-- value are mandatory, use '(.:)' instead.
898−(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
899−obj .:? key = case H.lookup key obj of
900− Nothing -> pure Nothing
901− Just v -> parseJSON v
902−{-# INLINE (.:?) #-}
903−
904−-- | Helper for use in combination with '.:?' to provide default
905−-- values for optional JSON object fields.
906−--
907−-- This combinator is most useful if the key and value can be absent
908−-- from an object without affecting its validity and we know a default
909−-- value to assign in that case. If the key and value are mandatory,
910−-- use '(.:)' instead.
911−--
912−-- Example usage:
913−--
914−-- @ v1 <- o '.:?' \"opt_field_with_dfl\" .!= \"default_val\"
915−-- v2 <- o '.:' \"mandatory_field\"
916−-- v3 <- o '.:?' \"opt_field2\"
917−-- @
918−(.!=) :: Parser (Maybe a) -> a -> Parser a
919−pmval .!= val = fromMaybe val <$> pmval
920−{-# INLINE (.!=) #-}
921−
922−-- | Fail parsing due to a type mismatch, with a descriptive message.
923−typeMismatch :: String -- ^ The name of the type you are trying to parse.
924− -> Value -- ^ The actual value encountered.
925− -> Parser a
926−typeMismatch expected actual =
927− fail $ "when expecting a " ++ expected ++ ", encountered " ++ name ++
928− " instead"
929− where
930− name = case actual of
931− Object _ -> "Object"
932− Array _ -> "Array"
933− String _ -> "String"
934− Number _ -> "Number"
935− Bool _ -> "Boolean"
936− Null -> "Null"