@@ -1,5 +1,5 @@
11{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,
2− IncoherentInstances, OverlappingInstances,
2+ GeneralizedNewtypeDeriving, IncoherentInstances, OverlappingInstances,
33 OverloadedStrings, UndecidableInstances, ViewPatterns #-}
44{-# OPTIONS_GHC -fno-warn-orphans #-}
55
@@ -39,6 +39,7 @@ module Data.Aeson.Types.Instances
3939 , withText
4040 , withArray
4141 , withNumber
42+ , withScientific
4243 , withBool
4344
4445 -- * Functions
@@ -54,13 +55,14 @@ import Control.Applicative ((<$>), (<*>), (<|>), pure, empty)
5455import Data.Aeson.Functions
5556import Data.Aeson.Types.Class
5657import Data.Aeson.Types.Internal
57−import Data.Attoparsec.Char8 (Number(..))
58+import Data.Scientific (Scientific, coefficient, base10Exponent)
59+import Data.Attoparsec.Number (Number(..))
5860import Data.Fixed
5961import Data.Hashable (Hashable(..))
6062import Data.Int (Int8, Int16, Int32, Int64)
6163import Data.Maybe (fromMaybe)
6264import Data.Monoid (Dual(..), First(..), Last(..), mappend)
63−import Data.Ratio (Ratio)
65+import Data.Ratio (Ratio, (%), numerator, denominator)
6466import Data.Text (Text, pack, unpack)
6567import Data.Time (UTCTime, ZonedTime(..), TimeZone(..))
6668import Data.Time.Format (formatTime, parseTime)
@@ -150,48 +152,52 @@ instance FromJSON Char where
150152 {-# INLINE parseJSON #-}
151153
152154instance ToJSON Double where
153− toJSON = Number . D
155+ toJSON = realFloatToJSON
154156 {-# INLINE toJSON #-}
155157
158+realFloatToJSON :: RealFloat a => a -> Value
159+realFloatToJSON d
160+ | isNaN d || isInfinite d = Null
161+ | otherwise = Number $ realToFrac d
162+{-# INLINE realFloatToJSON #-}
163+
156164instance FromJSON Double where
157− parseJSON (Number n) = case n of
158− D d -> pure d
159− I i -> pure (fromIntegral i)
165+ parseJSON (Number s) = pure $ realToFrac s
160166 parseJSON Null = pure (0/0)
161167 parseJSON v = typeMismatch "Double" v
162168 {-# INLINE parseJSON #-}
163169
164170instance ToJSON Number where
165− toJSON = Number
171+ toJSON (D d) = toJSON d
172+ toJSON (I i) = Number $ fromInteger i
166173 {-# INLINE toJSON #-}
167174
168175instance FromJSON Number where
169− parseJSON (Number n) = pure n
176+ parseJSON (Number s) = pure $ scientificToNumber s
170177 parseJSON Null = pure (D (0/0))
171178 parseJSON v = typeMismatch "Number" v
172179 {-# INLINE parseJSON #-}
173180
174181instance ToJSON Float where
175− toJSON = Number . realToFrac
182+ toJSON = realFloatToJSON
176183 {-# INLINE toJSON #-}
177184
178185instance FromJSON Float where
179− parseJSON (Number n) = pure $ case n of
180− D d -> realToFrac d
181− I i -> fromIntegral i
186+ parseJSON (Number s) = pure $ realToFrac s
182187 parseJSON Null = pure (0/0)
183188 parseJSON v = typeMismatch "Float" v
184189 {-# INLINE parseJSON #-}
185190
186191instance ToJSON (Ratio Integer) where
187− toJSON = Number . fromRational
192+ toJSON r = object [ "numerator" .= numerator r
193+ , "denominator" .= denominator r
194+ ]
188195 {-# INLINE toJSON #-}
189196
190197instance FromJSON (Ratio Integer) where
191− parseJSON = withNumber "Ration Integer" $ \n ->
192− pure $ case n of
193− D d -> toRational d
194− I i -> fromIntegral i
198+ parseJSON = withObject "Rational" $ \obj ->
199+ (%) <$> obj .: "numerator"
200+ <*> obj .: "denominator"
195201 {-# INLINE parseJSON #-}
196202
197203instance HasResolution a => ToJSON (Fixed a) where
@@ -199,10 +205,7 @@ instance HasResolution a => ToJSON (Fixed a) where
199205 {-# INLINE toJSON #-}
200206
201207instance HasResolution a => FromJSON (Fixed a) where
202− parseJSON (Number n) = pure $ case n of
203− D d -> realToFrac d
204− I i -> fromIntegral i
205− parseJSON v = typeMismatch "Fixed" v
208+ parseJSON = withScientific "Fixed" $ pure . realToFrac
206209 {-# INLINE parseJSON #-}
207210
208211instance ToJSON Int where
@@ -214,7 +217,7 @@ instance FromJSON Int where
214217 {-# INLINE parseJSON #-}
215218
216219parseIntegral :: Integral a => Value -> Parser a
217−parseIntegral = withNumber "Integral" $ pure . floor
220+parseIntegral = withScientific "Integral" $ pure . floor
218221{-# INLINE parseIntegral #-}
219222
220223instance ToJSON Integer where
@@ -667,28 +670,35 @@ withObject _ f (Object obj) = f obj
667670withObject expected _ v = typeMismatch expected v
668671{-# INLINE withObject #-}
669672
670−-- | @withObject expected f value@ applies @f@ to the 'Text' when @value@ is a @String@
673+-- | @withText expected f value@ applies @f@ to the 'Text' when @value@ is a @String@
671674-- and fails using @'typeMismatch' expected@ otherwise.
672675withText :: String -> (Text -> Parser a) -> Value -> Parser a
673676withText _ f (String txt) = f txt
674677withText expected _ v = typeMismatch expected v
675678{-# INLINE withText #-}
676679
677−-- | @withObject expected f value@ applies @f@ to the 'Array' when @value@ is an @Array@
680+-- | @withArray expected f value@ applies @f@ to the 'Array' when @value@ is an @Array@
678681-- and fails using @'typeMismatch' expected@ otherwise.
679682withArray :: String -> (Array -> Parser a) -> Value -> Parser a
680683withArray _ f (Array arr) = f arr
681684withArray expected _ v = typeMismatch expected v
682685{-# INLINE withArray #-}
683686
684−-- | @withObject expected f value@ applies @f@ to the 'Number' when @value@ is a @Number@
687+-- | @withNumber expected f value@ applies @f@ to the 'Number' when @value@ is a 'Number'.
685688-- and fails using @'typeMismatch' expected@ otherwise.
686689withNumber :: String -> (Number -> Parser a) -> Value -> Parser a
687−withNumber _ f (Number num) = f num
688−withNumber expected _ v = typeMismatch expected v
690+withNumber expected f = withScientific expected (f . scientificToNumber)
689691{-# INLINE withNumber #-}
692+{-# DEPRECATED withNumber "Use withScientific instead" #-}
693+
694+-- | @withScientific expected f value@ applies @f@ to the 'Scientific' number when @value@ is a 'Number'.
695+-- and fails using @'typeMismatch' expected@ otherwise.
696+withScientific :: String -> (Scientific -> Parser a) -> Value -> Parser a
697+withScientific _ f (Number scientific) = f scientific
698+withScientific expected _ v = typeMismatch expected v
699+{-# INLINE withScientific #-}
690700
691−-- | @withObject expected f value@ applies @f@ to the 'Bool' when @value@ is a @Bool@
701+-- | @withBool expected f value@ applies @f@ to the 'Bool' when @value@ is a @Bool@
692702-- and fails using @'typeMismatch' expected@ otherwise.
693703withBool :: String -> (Bool -> Parser a) -> Value -> Parser a
694704withBool _ f (Bool arr) = f arr
@@ -764,3 +774,12 @@ typeMismatch expected actual =
764774 Number _ -> "Number"
765775 Bool _ -> "Boolean"
766776 Null -> "Null"
777+
778+scientificToNumber :: Scientific -> Number
779+scientificToNumber s
780+ | e < 0 = D $ fromInteger c / 10 ^ negate e
781+ | otherwise = I $ c * 10 ^ e
782+ where
783+ e = base10Exponent s
784+ c = coefficient s
785+{-# INLINE scientificToNumber #-}