@@ -76,6 +76,10 @@ module Data.Aeson.Types.Instances
7676 , tuple
7777 , (>*<)
7878 , typeMismatch
79+
80+ , listEncoding
81+ , listValue
82+ , listParser
7983 ) where
8084
8185import Data.Aeson.Types.Instances.Tuple (tuple, (>*<))
@@ -152,6 +156,10 @@ import Data.Time.Format (defaultTimeLocale)
152156import System.Locale (defaultTimeLocale)
153157#endif
154158
159+-------------------------------------------------------------------------------
160+-- Helpers
161+-------------------------------------------------------------------------------
162+
155163parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a
156164parseIndexedJSON p idx value = p value <?> Index idx
157165{-# INLINE parseIndexedJSON #-}
@@ -179,6 +187,40 @@ toJSONPair keySerialiser valSerializer (a, b) = Array $ V.create $ do
179187 return mv
180188{-# INLINE toJSONPair #-}
181189
190+realFloatToJSON :: RealFloat a => a -> Value
191+realFloatToJSON d
192+ | isNaN d || isInfinite d = Null
193+ | otherwise = Number $ Scientific.fromFloatDigits d
194+{-# INLINE realFloatToJSON #-}
195+
196+realFloatToEncoding :: RealFloat a => a -> Encoding
197+realFloatToEncoding d
198+ | isNaN d || isInfinite d = Encoding E.null_
199+ | otherwise = toEncoding (Scientific.fromFloatDigits d)
200+{-# INLINE realFloatToEncoding #-}
201+
202+scientificToNumber :: Scientific -> Number
203+scientificToNumber s
204+ | e < 0 = D $ Scientific.toRealFloat s
205+ | otherwise = I $ c * 10 ^ e
206+ where
207+ e = Scientific.base10Exponent s
208+ c = Scientific.coefficient s
209+{-# INLINE scientificToNumber #-}
210+
211+parseRealFloat :: RealFloat a => String -> Value -> Parser a
212+parseRealFloat _ (Number s) = pure $ Scientific.toRealFloat s
213+parseRealFloat _ Null = pure (0/0)
214+parseRealFloat expected v = typeMismatch expected v
215+{-# INLINE parseRealFloat #-}
216+
217+parseIntegral :: Integral a => String -> Value -> Parser a
218+parseIntegral expected = withScientific expected $ pure . truncate
219+{-# INLINE parseIntegral #-}
220+
221+-------------------------------------------------------------------------------
222+-- base
223+-------------------------------------------------------------------------------
182224
183225instance ToJSON1 Identity where
184226 liftToJSON to _ (Identity a) = to a
@@ -203,6 +245,40 @@ instance (FromJSON a) => FromJSON (Identity a) where
203245 {-# INLINE parseJSON #-}
204246
205247
248+instance ToJSON2 Const where
249+ liftToJSON2 to _ _ _ (Const x) = to x
250+ {-# INLINE liftToJSON2 #-}
251+
252+ liftToEncoding2 to _ _ _ (Const x) = to x
253+ {-# INLINE liftToEncoding2 #-}
254+
255+instance FromJSON2 Const where
256+ liftParseJSON2 p _ _ _ = fmap Const . p
257+ {-# INLINE liftParseJSON2 #-}
258+
259+instance ToJSON a => ToJSON1 (Const a) where
260+ liftToJSON _ _ (Const x) = toJSON x
261+ {-# INLINE liftToJSON #-}
262+
263+ liftToEncoding _ _ (Const x) = toEncoding x
264+ {-# INLINE liftToEncoding #-}
265+
266+instance FromJSON a => FromJSON1 (Const a) where
267+ liftParseJSON _ _ = fmap Const . parseJSON
268+ {-# INLINE liftParseJSON #-}
269+
270+instance ToJSON a => ToJSON (Const a b) where
271+ toJSON (Const x) = toJSON x
272+ {-# INLINE toJSON #-}
273+
274+ toEncoding (Const x) = toEncoding x
275+ {-# INLINE toEncoding #-}
276+
277+instance FromJSON a => FromJSON (Const a b) where
278+ {-# INLINE parseJSON #-}
279+ parseJSON = fmap Const . parseJSON
280+
281+
206282instance ToJSON1 Maybe where
207283 liftToJSON to _ (Just a) = to a
208284 liftToJSON _ _ Nothing = Null
@@ -282,6 +358,7 @@ left, right :: Text
282358left = "Left"
283359right = "Right"
284360
361+
285362instance ToJSON Bool where
286363 toJSON = Bool
287364 {-# INLINE toJSON #-}
@@ -348,17 +425,6 @@ instance FromJSON Char where
348425 parseJSONList = withText "String" $ pure . T.unpack
349426 {-# INLINE parseJSONList #-}
350427
351−instance ToJSON Scientific where
352− toJSON = Number
353− {-# INLINE toJSON #-}
354−
355− toEncoding = Encoding . E.number
356− {-# INLINE toEncoding #-}
357−
358−instance FromJSON Scientific where
359− parseJSON = withScientific "Scientific" pure
360− {-# INLINE parseJSON #-}
361−
362428instance ToJSON Double where
363429 toJSON = realFloatToJSON
364430 {-# INLINE toJSON #-}
@@ -591,6 +657,25 @@ instance FromJSON LT.Text where
591657 parseJSON = withText "Lazy Text" $ pure . LT.fromStrict
592658 {-# INLINE parseJSON #-}
593659
660+instance ToJSON Version where
661+ toJSON = toJSON . showVersion
662+ {-# INLINE toJSON #-}
663+
664+ toEncoding = toEncoding . showVersion
665+ {-# INLINE toEncoding #-}
666+
667+instance FromJSON Version where
668+ {-# INLINE parseJSON #-}
669+ parseJSON = withText "Version" $ go . readP_to_S parseVersion . unpack
670+ where
671+ go [(v,[])] = return v
672+ go (_ : xs) = go xs
673+ go _ = fail $ "could not parse Version"
674+
675+-------------------------------------------------------------------------------
676+-- semigroups NonEmpty
677+-------------------------------------------------------------------------------
678+
594679instance ToJSON1 NonEmpty where
595680 liftToJSON to _ = listValue to . toList
596681 {-# INLINE liftToJSON #-}
@@ -615,29 +700,27 @@ instance FromJSON1 NonEmpty where
615700
616701instance (FromJSON a) => FromJSON (NonEmpty a) where
617702 parseJSON = parseJSON1
703+ {-# INLINE parseJSON #-}
618704
619−instance ToJSON1 [] where
620− liftToJSON _ to' = to'
621− {-# INLINE liftToJSON #-}
622−
623− liftToEncoding _ to' = to'
624− {-# INLINE liftToEncoding #-}
705+-------------------------------------------------------------------------------
706+-- scientific
707+-------------------------------------------------------------------------------
625708
626−instance (ToJSON a) => ToJSON [a] where
627− toJSON = toJSON1
709+instance ToJSON Scientific where
710+ toJSON = Number
628711 {-# INLINE toJSON #-}
629712
630− toEncoding = toEncoding1
713+ toEncoding = Encoding . E.number
631714 {-# INLINE toEncoding #-}
632715
633−instance FromJSON1 [] where
634− liftParseJSON _ p' = p'
635− {-# INLINE liftParseJSON #-}
636−
637−instance (FromJSON a) => FromJSON [a] where
638− parseJSON = parseJSON1
716+instance FromJSON Scientific where
717+ parseJSON = withScientific "Scientific" pure
639718 {-# INLINE parseJSON #-}
640719
720+-------------------------------------------------------------------------------
721+-- containers
722+-------------------------------------------------------------------------------
723+
641724instance ToJSON1 Seq.Seq where
642725 liftToJSON to _ = listValue to . toList
643726 {-# INLINE liftToJSON #-}
@@ -662,6 +745,152 @@ instance (FromJSON a) => FromJSON (Seq.Seq a) where
662745 parseJSON = parseJSON1
663746 {-# INLINE parseJSON #-}
664747
748+
749+instance ToJSON1 Set.Set where
750+ liftToJSON to _ = listValue to . Set.toList
751+ {-# INLINE liftToJSON #-}
752+
753+ liftToEncoding to _ = listEncoding to . Set.toList
754+ {-# INLINE liftToEncoding #-}
755+
756+instance (ToJSON a) => ToJSON (Set.Set a) where
757+ toJSON = toJSON1
758+ {-# INLINE toJSON #-}
759+
760+ toEncoding = toEncoding1
761+ {-# INLINE toEncoding #-}
762+
763+instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
764+ parseJSON = fmap Set.fromList . parseJSON
765+ {-# INLINE parseJSON #-}
766+
767+
768+instance FromJSON IntSet.IntSet where
769+ parseJSON = fmap IntSet.fromList . parseJSON
770+ {-# INLINE parseJSON #-}
771+
772+instance ToJSON IntSet.IntSet where
773+ toJSON = toJSON . IntSet.toList
774+ {-# INLINE toJSON #-}
775+
776+ toEncoding = toEncoding . IntSet.toList
777+ {-# INLINE toEncoding #-}
778+
779+
780+instance ToJSON1 IntMap.IntMap where
781+ liftToJSON to tol = liftToJSON to' tol' . IntMap.toList
782+ where
783+ to' = liftToJSON2 toJSON toJSONList to tol
784+ tol' = liftToJSONList2 toJSON toJSONList to tol
785+ {-# INLINE liftToJSON #-}
786+
787+ liftToEncoding to tol = liftToEncoding to' tol' . IntMap.toList
788+ where
789+ to' = liftToEncoding2 toEncoding toEncodingList to tol
790+ tol' = liftToEncodingList2 toEncoding toEncodingList to tol
791+ {-# INLINE liftToEncoding #-}
792+
793+instance ToJSON a => ToJSON (IntMap.IntMap a) where
794+ toJSON = toJSON1
795+ {-# INLINE toJSON #-}
796+
797+ toEncoding = toEncoding1
798+ {-# INLINE toEncoding #-}
799+
800+instance FromJSON1 IntMap.IntMap where
801+ liftParseJSON p pl = fmap IntMap.fromList . liftParseJSON p' pl'
802+ where
803+ p' = liftParseJSON2 parseJSON parseJSONList p pl
804+ pl' = liftParseJSONList2 parseJSON parseJSONList p pl
805+ {-# INLINE liftParseJSON #-}
806+
807+instance FromJSON a => FromJSON (IntMap.IntMap a) where
808+ parseJSON = fmap IntMap.fromList . parseJSON
809+ {-# INLINE parseJSON #-}
810+
811+
812+instance ToJSONKey k => ToJSON1 (M.Map k) where
813+ liftToJSON g _ = case toJSONKey of
814+ ToJSONKeyText (f,_) -> Object . mapHashKeyVal f g
815+ ToJSONKeyValue (f,_) -> Array . V.fromList . map (toJSONPair f g) . M.toList
816+ {-# INLINE liftToJSON #-}
817+
818+ -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> M.Map k a -> Encoding
819+ liftToEncoding g _ = case toJSONKey of
820+ ToJSONKeyText (_,f) -> encodeMap f g M.minViewWithKey M.foldrWithKey
821+ ToJSONKeyValue (_,f) -> list (pairEncoding f) . M.toList
822+ where
823+ -- pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding
824+ pairEncoding f (a, b) = tuple $ fromEncoding (f a) >*< builder' g b
825+ {-# INLINE liftToEncoding #-}
826+
827+instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where
828+ liftParseJSON p _ = case fromJSONKey of
829+ FromJSONKeyCoerce _-> withObject "Map k v" $
830+ fmap (H.foldrWithKey (M.insert . unsafeCoerce) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
831+ FromJSONKeyText f -> withObject "Map k v" $
832+ fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
833+ FromJSONKeyTextParser f -> withObject "Map k v" $
834+ H.foldrWithKey (\k v m -> M.insert <$> f k <*> (p v <?> Key k) <*> m) (pure M.empty)
835+ FromJSONKeyValue f -> withArray "Map k v" $ \arr ->
836+ M.fromList <$> (Tr.sequence .
837+ zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr)
838+ {-# INLINE liftParseJSON #-}
839+
840+instance (ToJSON v, ToJSONKey k) => ToJSON (M.Map k v) where
841+ toJSON = toJSON1
842+ {-# INLINE toJSON #-}
843+
844+ toEncoding = toEncoding1
845+ {-# INLINE toEncoding #-}
846+
847+instance (FromJSON v, FromJSONKey k, Ord k) => FromJSON (M.Map k v) where
848+ parseJSON = parseJSON1
849+ {-# INLINE parseJSON #-}
850+
851+
852+instance ToJSON1 Tree.Tree where
853+ liftToJSON to tol = go
854+ where
855+ go (Tree.Node root branches) =
856+ liftToJSON2 to tol to' tol' (root, branches)
857+
858+ to' = liftToJSON go (listValue go)
859+ tol' = liftToJSONList go (listValue go)
860+ {-# INLINE liftToJSON #-}
861+
862+ liftToEncoding to tol = go
863+ where
864+ go (Tree.Node root branches) =
865+ liftToEncoding2 to tol to' tol' (root, branches)
866+
867+ to' = liftToEncoding go (listEncoding go)
868+ tol' = liftToEncodingList go (listEncoding go)
869+ {-# INLINE liftToEncoding #-}
870+
871+instance (ToJSON v) => ToJSON (Tree.Tree v) where
872+ toJSON = toJSON1
873+ {-# INLINE toJSON #-}
874+
875+ toEncoding = toEncoding1
876+ {-# INLINE toEncoding #-}
877+
878+instance FromJSON1 Tree.Tree where
879+ liftParseJSON p pl = go
880+ where
881+ go v = uncurry Tree.Node <$> liftParseJSON2 p pl p' pl' v
882+
883+ p' = liftParseJSON go (listParser go)
884+ pl'= liftParseJSONList go (listParser go)
885+
886+instance (FromJSON v) => FromJSON (Tree.Tree v) where
887+ parseJSON = parseJSON1
888+ {-# INLINE parseJSON #-}
889+
890+-------------------------------------------------------------------------------
891+-- vector
892+-------------------------------------------------------------------------------
893+
665894instance ToJSON1 Vector where
666895 liftToJSON to _ = Array . V.map to
667896 {-# INLINE liftToJSON #-}
@@ -740,101 +969,29 @@ instance (VG.Vector VU.Vector a, FromJSON a) => FromJSON (VU.Vector a) where
740969 parseJSON = vectorParseJSON "Data.Vector.Unboxed.Vector a"
741970 {-# INLINE parseJSON #-}
742971
743−instance (ToJSON a) => ToJSON (Set.Set a) where
744− toJSON = toJSON . Set.toList
745− {-# INLINE toJSON #-}
746−
747− toEncoding = encodeSet Set.minView Set.foldr
748− {-# INLINE toEncoding #-}
749−
750−instance (Ord a, FromJSON a) => FromJSON (Set.Set a) where
751− parseJSON = fmap Set.fromList . parseJSON
752− {-# INLINE parseJSON #-}
753−
754−instance (ToJSON a) => ToJSON (HashSet.HashSet a) where
755− toJSON = toJSON . HashSet.toList
756− {-# INLINE toJSON #-}
972+-------------------------------------------------------------------------------
973+-- unordered-containers
974+-------------------------------------------------------------------------------
757975
758− toEncoding = foldable toEncoding
759− {-# INLINE toEncoding #-}
760−
761−instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
762− parseJSON = fmap HashSet.fromList . parseJSON
763− {-# INLINE parseJSON #-}
764−
765−instance ToJSON IntSet.IntSet where
766− toJSON = toJSON . IntSet.toList
767− {-# INLINE toJSON #-}
768−
769− toEncoding = encodeSet IntSet.minView IntSet.foldr
770− {-# INLINE toEncoding #-}
771−
772−encodeSet :: (ToJSON a) =>
773− (s -> Maybe (a, s))
774− -> ((a -> B.Builder -> B.Builder) -> B.Builder -> s -> B.Builder)
775− -> s -> Encoding
776−encodeSet minView foldr xs =
777− case minView xs of
778− Nothing -> E.emptyArray_
779− Just (m,ys) -> Encoding $
780− B.char7 '[' <> builder m <> foldr go (B.char7 ']') ys
781− where go v b = B.char7 ',' <> builder v <> b
782−{-# INLINE encodeSet #-}
783−
784−instance FromJSON IntSet.IntSet where
785− parseJSON = fmap IntSet.fromList . parseJSON
786− {-# INLINE parseJSON #-}
787−
788−instance ToJSON a => ToJSON (IntMap.IntMap a) where
789− toJSON = toJSON . IntMap.toList
790− {-# INLINE toJSON #-}
791−
792− toEncoding = toEncoding . IntMap.toList
793− {-# INLINE toEncoding #-}
794−
795−instance FromJSON a => FromJSON (IntMap.IntMap a) where
796− parseJSON = fmap IntMap.fromList . parseJSON
797− {-# INLINE parseJSON #-}
798−
799−instance ToJSONKey k => ToJSON1 (M.Map k) where
800− liftToJSON g _ = case toJSONKey of
801− ToJSONKeyText (f,_) -> Object . mapHashKeyVal f g
802− ToJSONKeyValue (f,_) -> Array . V.fromList . map (toJSONPair f g) . M.toList
976+instance ToJSON1 HashSet.HashSet where
977+ liftToJSON to _ = listValue to . HashSet.toList
803978 {-# INLINE liftToJSON #-}
804979
805− -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> M.Map k a -> Encoding
806− liftToEncoding g _ = case toJSONKey of
807− ToJSONKeyText (_,f) -> encodeMap f g M.minViewWithKey M.foldrWithKey
808− ToJSONKeyValue (_,f) -> list (pairEncoding f) . M.toList
809− where
810− -- pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding
811− pairEncoding f (a, b) = tuple $ fromEncoding (f a) >*< builder' g b
980+ liftToEncoding to _ = listEncoding to . HashSet.toList
812981 {-# INLINE liftToEncoding #-}
813982
814−instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where
815− liftParseJSON p _ = case fromJSONKey of
816− FromJSONKeyCoerce _-> withObject "Map k v" $
817− fmap (H.foldrWithKey (M.insert . unsafeCoerce) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
818− FromJSONKeyText f -> withObject "Map k v" $
819− fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
820− FromJSONKeyTextParser f -> withObject "Map k v" $
821− H.foldrWithKey (\k v m -> M.insert <$> f k <*> (p v <?> Key k) <*> m) (pure M.empty)
822− FromJSONKeyValue f -> withArray "Map k v" $ \arr ->
823− M.fromList <$> (Tr.sequence .
824− zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr)
825− {-# INLINE liftParseJSON #-}
826−
827−instance (ToJSON v, ToJSONKey k) => ToJSON (M.Map k v) where
983+instance (ToJSON a) => ToJSON (HashSet.HashSet a) where
828984 toJSON = toJSON1
829985 {-# INLINE toJSON #-}
830986
831987 toEncoding = toEncoding1
832988 {-# INLINE toEncoding #-}
833989
834−instance (FromJSON v, FromJSONKey k, Ord k) => FromJSON (M.Map k v) where
835− parseJSON = parseJSON1
990+instance (Eq a, Hashable a, FromJSON a) => FromJSON (HashSet.HashSet a) where
991+ parseJSON = fmap HashSet.fromList . parseJSON
836992 {-# INLINE parseJSON #-}
837993
994+
838995instance ToJSONKey k => ToJSON1 (H.HashMap k) where
839996 liftToJSON g _ = case toJSONKey of
840997 ToJSONKeyText (f,_) -> Object . mapKeyVal f g
@@ -876,16 +1033,9 @@ instance (FromJSON v, FromJSONKey k, Eq k, Hashable k) => FromJSON (H.HashMap k
8761033 parseJSON = parseJSON1
8771034 {-# INLINE parseJSON #-}
8781035
879−instance (ToJSON v) => ToJSON (Tree.Tree v) where
880− toJSON (Tree.Node root branches) = toJSON (root,branches)
881− {-# INLINE toJSON #-}
882−
883− toEncoding (Tree.Node root branches) = toEncoding (root,branches)
884− {-# INLINE toEncoding #-}
885−
886−instance (FromJSON v) => FromJSON (Tree.Tree v) where
887− parseJSON j = uncurry Tree.Node <$> parseJSON j
888− {-# INLINE parseJSON #-}
1036+-------------------------------------------------------------------------------
1037+-- aeson
1038+-------------------------------------------------------------------------------
8891039
8901040instance ToJSON Value where
8911041 toJSON a = a
@@ -916,6 +1066,10 @@ instance FromJSON DotNetTime where
9161066 _ -> fail "could not parse .NET time"
9171067 {-# INLINE parseJSON #-}
9181068
1069+-------------------------------------------------------------------------------
1070+-- time
1071+-------------------------------------------------------------------------------
1072+
9191073instance ToJSON Day where
9201074 toJSON = stringEncoding
9211075 toEncoding z = Encoding (E.quote $ E.day z)
@@ -976,6 +1130,10 @@ instance FromJSON NominalDiffTime where
9761130 parseJSON = withScientific "NominalDiffTime" $ pure . realToFrac
9771131 {-# INLINE parseJSON #-}
9781132
1133+-------------------------------------------------------------------------------
1134+-- base Monoid/Semigroup
1135+-------------------------------------------------------------------------------
1136+
9791137instance ToJSON1 Dual where
9801138 liftToJSON to _ = to . getDual
9811139 {-# INLINE liftToJSON #-}
@@ -1044,21 +1202,9 @@ instance FromJSON a => FromJSON (Last a) where
10441202 parseJSON = parseJSON1
10451203 {-# INLINE parseJSON #-}
10461204
1047−
1048−instance ToJSON Version where
1049− toJSON = toJSON . showVersion
1050− {-# INLINE toJSON #-}
1051−
1052− toEncoding = toEncoding . showVersion
1053− {-# INLINE toEncoding #-}
1054−
1055−instance FromJSON Version where
1056− {-# INLINE parseJSON #-}
1057− parseJSON = withText "Version" $ go . readP_to_S parseVersion . unpack
1058− where
1059− go [(v,[])] = return v
1060− go (_ : xs) = go xs
1061− go _ = fail $ "could not parse Version"
1205+-------------------------------------------------------------------------------
1206+-- tagged
1207+-------------------------------------------------------------------------------
10621208
10631209instance ToJSON (Proxy a) where
10641210 toJSON _ = Null
@@ -1072,6 +1218,7 @@ instance FromJSON (Proxy a) where
10721218 parseJSON Null = pure Proxy
10731219 parseJSON v = typeMismatch "Proxy" v
10741220
1221+
10751222instance ToJSON1 (Tagged a) where
10761223 liftToJSON to _ (Tagged x) = to x
10771224 {-# INLINE liftToJSON #-}
@@ -1094,35 +1241,19 @@ instance FromJSON b => FromJSON (Tagged a b) where
10941241 parseJSON = parseJSON1
10951242 {-# INLINE parseJSON #-}
10961243
1097−instance ToJSON a => ToJSON (Const a b) where
1098− toJSON (Const x) = toJSON x
1099− {-# INLINE toJSON #-}
1100−
1101− toEncoding (Const x) = toEncoding x
1102− {-# INLINE toEncoding #-}
1244+instance FromJSONKey b => FromJSONKey (Tagged a b) where
1245+ fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction b)
1246+ fromJSONKeyList = (fmap . fmap) Tagged fromJSONKeyList
11031247
1104−instance FromJSON a => FromJSON (Const a b) where
1105− {-# INLINE parseJSON #-}
1106− parseJSON = fmap Const . parseJSON
1248+instance ToJSONKey b => ToJSONKey (Tagged a b) where
1249+ toJSONKey = contramapToJSONKeyFunction unTagged toJSONKey
1250+ toJSONKeyList = contramapToJSONKeyFunction (fmap unTagged) toJSONKeyList
11071251
1108−--------------------------------------------
1252+-------------------------------------------------------------------------------
11091253-- Instances for converting to/from map keys
1110−--------------------------------------------
1111−class ToJSONKey a where
1112− toJSONKey :: ToJSONKeyFunction a
1113− default toJSONKey :: ToJSON a => ToJSONKeyFunction a
1114− toJSONKey = ToJSONKeyValue (toJSON, toEncoding)
1115− toJSONKeyList :: ToJSONKeyFunction [a]
1116− default toJSONKeyList :: ToJSON a => ToJSONKeyFunction [a]
1117− toJSONKeyList = ToJSONKeyValue (toJSON, toEncoding)
1118−
1119−class FromJSONKey a where
1120− fromJSONKey :: FromJSONKeyFunction a
1121− default fromJSONKey :: FromJSON a => FromJSONKeyFunction a
1122− fromJSONKey = FromJSONKeyValue parseJSON
1123− fromJSONKeyList :: FromJSONKeyFunction [a]
1124− default fromJSONKeyList :: FromJSON a => FromJSONKeyFunction [a]
1125− fromJSONKeyList = FromJSONKeyValue parseJSON
1254+-------------------------------------------------------------------------------
1255+
1256+
11261257
11271258instance ToJSONKey Text where
11281259 toJSONKey = ToJSONKeyText (id,toEncoding)
@@ -1130,10 +1261,7 @@ instance ToJSONKey Text where
11301261instance FromJSONKey Text where
11311262 fromJSONKey = fromJSONKeyCoerce
11321263
1133−-- | TODO: where ToJSONKey instance
1134−instance FromJSONKey b => FromJSONKey (Tagged a b) where
1135− fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction b)
1136− fromJSONKeyList = (fmap . fmap) Tagged fromJSONKeyList
1264+
11371265
11381266instance ToJSONKey Bool where
11391267 toJSONKey = ToJSONKeyText
@@ -1187,7 +1315,9 @@ instance (ToJSONKey a, ToJSON a) => ToJSONKey (Identity a) where
11871315instance (FromJSONKey a, FromJSON a) => FromJSONKey (Identity a) where
11881316 fromJSONKey = mapFromJSONKeyFunction Identity fromJSONKey
11891317
1190−
1318+-------------------------------------------------------------------------------
1319+-- Functions
1320+-------------------------------------------------------------------------------
11911321
11921322-- | @withObject expected f value@ applies @f@ to the 'Object' when @value@ is an @Object@
11931323-- and fails using @'typeMismatch' expected@ otherwise.
@@ -1310,34 +1440,3 @@ obj .:! key = case H.lookup key obj of
13101440(.!=) :: Parser (Maybe a) -> a -> Parser a
13111441pmval .!= val = fromMaybe val <$> pmval
13121442{-# INLINE (.!=) #-}
1313−
1314−realFloatToJSON :: RealFloat a => a -> Value
1315−realFloatToJSON d
1316− | isNaN d || isInfinite d = Null
1317− | otherwise = Number $ Scientific.fromFloatDigits d
1318−{-# INLINE realFloatToJSON #-}
1319−
1320−realFloatToEncoding :: RealFloat a => a -> Encoding
1321−realFloatToEncoding d
1322− | isNaN d || isInfinite d = Encoding E.null_
1323− | otherwise = toEncoding (Scientific.fromFloatDigits d)
1324−{-# INLINE realFloatToEncoding #-}
1325−
1326−scientificToNumber :: Scientific -> Number
1327−scientificToNumber s
1328− | e < 0 = D $ Scientific.toRealFloat s
1329− | otherwise = I $ c * 10 ^ e
1330− where
1331− e = Scientific.base10Exponent s
1332− c = Scientific.coefficient s
1333−{-# INLINE scientificToNumber #-}
1334−
1335−parseRealFloat :: RealFloat a => String -> Value -> Parser a
1336−parseRealFloat _ (Number s) = pure $ Scientific.toRealFloat s
1337−parseRealFloat _ Null = pure (0/0)
1338−parseRealFloat expected v = typeMismatch expected v
1339−{-# INLINE parseRealFloat #-}
1340−
1341−parseIntegral :: Integral a => String -> Value -> Parser a
1342−parseIntegral expected = withScientific expected $ pure . truncate
1343−{-# INLINE parseIntegral #-}