diff --git a/Data/Aeson/Encoding.hs b/Data/Aeson/Encoding.hs --- a/Data/Aeson/Encoding.hs +++ b/Data/Aeson/Encoding.hs @@ -42,6 +42,8 @@ -- ** Time , day + , month + , quarter , localTime , utcTime , timeOfDay diff --git a/Data/Aeson/Encoding/Builder.hs b/Data/Aeson/Encoding/Builder.hs --- a/Data/Aeson/Encoding/Builder.hs +++ b/Data/Aeson/Encoding/Builder.hs @@ -27,6 +27,8 @@ , quote , scientific , day + , month + , quarter , localTime , utcTime , timeOfDay @@ -48,6 +50,8 @@ import Data.Text.Encoding (encodeUtf8BuilderEscaped) import Data.Time (UTCTime(..)) import Data.Time.Calendar (Day(..), toGregorian) +import Data.Time.Calendar.Month.Compat (Month, toYearMonth) +import Data.Time.Calendar.Quarter.Compat (Quarter, toYearQuarter, QuarterOfYear (..)) import Data.Time.LocalTime import Data.Word (Word8) import qualified Data.HashMap.Strict as HMS @@ -147,6 +151,11 @@ ascii2 cs = BP.liftFixedToBounded $ const cs BP.>$< BP.char7 >*< BP.char7 {-# INLINE ascii2 #-} +ascii3 :: (Char, (Char, Char)) -> BP.BoundedPrim a +ascii3 cs = BP.liftFixedToBounded $ const cs >$< + BP.char7 >*< BP.char7 >*< BP.char7 +{-# INLINE ascii3 #-} + ascii4 :: (Char, (Char, (Char, Char))) -> BP.BoundedPrim a ascii4 cs = BP.liftFixedToBounded $ const cs >$< BP.char7 >*< BP.char7 >*< BP.char7 >*< BP.char7 @@ -175,16 +184,39 @@ where (yr,m,d) = toGregorian dd !(T mh ml) = twoDigits m !(T dh dl) = twoDigits d - encodeYear y - | y >= 1000 = B.integerDec y - | y >= 0 = BP.primBounded (ascii4 (padYear y)) () - | y >= -999 = BP.primBounded (ascii5 ('-',padYear (- y))) () - | otherwise = B.integerDec y - padYear y = - let (ab,c) = fromIntegral y `quotRem` 10 - (a,b) = ab `quotRem` 10 - in ('0',(digit a,(digit b,digit c))) {-# INLINE day #-} + +month :: Month -> Builder +month mm = encodeYear yr <> + BP.primBounded (ascii3 ('-',(mh,ml))) () + where (yr,m) = toYearMonth mm + !(T mh ml) = twoDigits m +{-# INLINE month #-} + +quarter :: Quarter -> Builder +quarter qq = encodeYear yr <> + BP.primBounded (ascii3 ('-',('q',qd))) () + where (yr,q) = toYearQuarter qq + qd = case q of + Q1 -> '1' + Q2 -> '2' + Q3 -> '3' + Q4 -> '4' +{-# INLINE quarter #-} + +-- | Used in encoding day, month, quarter +encodeYear :: Integer -> Builder +encodeYear y + | y >= 1000 = B.integerDec y + | y >= 0 = BP.primBounded (ascii4 (padYear y)) () + | y >= -999 = BP.primBounded (ascii5 ('-',padYear (- y))) () + | otherwise = B.integerDec y + where + padYear y' = + let (ab,c) = fromIntegral y' `quotRem` 10 + (a,b) = ab `quotRem` 10 + in ('0',(digit a,(digit b,digit c))) +{-# INLINE encodeYear #-} timeOfDay :: TimeOfDay -> Builder timeOfDay t = timeOfDay64 (toTimeOfDay64 t) diff --git a/Data/Aeson/Encoding/Internal.hs b/Data/Aeson/Encoding/Internal.hs --- a/Data/Aeson/Encoding/Internal.hs +++ b/Data/Aeson/Encoding/Internal.hs @@ -47,6 +47,8 @@ , integerText, floatText, doubleText, scientificText -- ** Time , day + , month + , quarter , localTime , utcTime , timeOfDay @@ -65,6 +67,8 @@ import Data.Scientific (Scientific) import Data.Text (Text) import Data.Time (Day, LocalTime, TimeOfDay, UTCTime, ZonedTime) +import Data.Time.Calendar.Month.Compat (Month) +import Data.Time.Calendar.Quarter.Compat (Quarter) import Data.Typeable (Typeable) import Data.Word import qualified Data.Aeson.Encoding.Builder as EB @@ -349,6 +353,12 @@ day :: Day -> Encoding' a day = Encoding . EB.quote . EB.day + +month :: Month -> Encoding' a +month = Encoding . EB.quote . EB.month + +quarter :: Quarter -> Encoding' a +quarter = Encoding . EB.quote . EB.quarter localTime :: LocalTime -> Encoding' a localTime = Encoding . EB.quote . EB.localTime diff --git a/Data/Aeson/Parser/Time.hs b/Data/Aeson/Parser/Time.hs --- a/Data/Aeson/Parser/Time.hs +++ b/Data/Aeson/Parser/Time.hs @@ -4,6 +4,8 @@ ( run , day + , month + , quarter , localTime , timeOfDay , timeZone @@ -16,6 +18,8 @@ import Data.Attoparsec.Text (Parser) import Data.Text (Text) import Data.Time.Calendar (Day) +import Data.Time.Calendar.Quarter.Compat (Quarter) +import Data.Time.Calendar.Month.Compat (Month) import Data.Time.Clock (UTCTime(..)) import qualified Data.Aeson.Types.Internal as Aeson import qualified Data.Attoparsec.Text as A @@ -33,10 +37,22 @@ day = T.day {-# INLINE day #-} +-- | Parse a date of the form @[+,-]YYYY-MM@. +month :: Parser Month +month = T.month +{-# INLINE month #-} + +-- | Parse a date of the form @[+,-]YYYY-QN@. +quarter :: Parser Quarter +quarter = T.quarter +{-# INLINE quarter #-} + -- | Parse a time of the form @HH:MM[:SS[.SSS]]@. timeOfDay :: Parser Local.TimeOfDay timeOfDay = T.timeOfDay {-# INLINE timeOfDay #-} + +-- | Parse a quarter of the form @[+,-]YYYY-QN@. -- | Parse a time zone, and return 'Nothing' if the offset from UTC is -- zero. (This makes some speedups possible.) diff --git a/Data/Aeson/Types/FromJSON.hs b/Data/Aeson/Types/FromJSON.hs --- a/Data/Aeson/Types/FromJSON.hs +++ b/Data/Aeson/Types/FromJSON.hs @@ -105,6 +105,8 @@ import Data.These (These (..)) import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime) import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..)) +import Data.Time.Calendar.Month.Compat (Month) +import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..)) import Data.Time.LocalTime.Compat (CalendarDiffTime (..)) import Data.Time.Clock.System.Compat (SystemTime (..)) import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale) @@ -2122,6 +2124,32 @@ instance FromJSONKey DayOfWeek where fromJSONKey = FromJSONKeyTextParser parseDayOfWeek + +instance FromJSON QuarterOfYear where + parseJSON = withText "DaysOfWeek" parseQuarterOfYear + +parseQuarterOfYear :: T.Text -> Parser QuarterOfYear +parseQuarterOfYear t = case T.toLower t of + "q1" -> return Q1 + "q2" -> return Q2 + "q3" -> return Q3 + "e4 " -> return Q4 + _ -> fail "Ivalid quarter of year" + +instance FromJSONKey QuarterOfYear where + fromJSONKey = FromJSONKeyTextParser parseQuarterOfYear + +instance FromJSON Quarter where + parseJSON = withText "Quarter" (Time.run Time.quarter) + +instance FromJSONKey Quarter where + fromJSONKey = FromJSONKeyTextParser (Time.run Time.quarter) + +instance FromJSON Month where + parseJSON = withText "Month" (Time.run Time.month) + +instance FromJSONKey Month where + fromJSONKey = FromJSONKeyTextParser (Time.run Time.month) ------------------------------------------------------------------------------- -- base Monoid/Semigroup diff --git a/Data/Aeson/Types/ToJSON.hs b/Data/Aeson/Types/ToJSON.hs --- a/Data/Aeson/Types/ToJSON.hs +++ b/Data/Aeson/Types/ToJSON.hs @@ -87,6 +87,8 @@ import Data.Text (Text, pack) import Data.These (These (..)) import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime) +import Data.Time.Calendar.Month.Compat (Month) +import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..)) import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..)) import Data.Time.LocalTime.Compat (CalendarDiffTime (..)) import Data.Time.Clock.System.Compat (SystemTime (..)) @@ -2016,7 +2018,20 @@ instance ToJSONKey Day where toJSONKey = toJSONKeyTextEnc E.day +instance ToJSON Month where + toJSON = stringEncoding . E.month + toEncoding = E.month +instance ToJSONKey Month where + toJSONKey = toJSONKeyTextEnc E.month + +instance ToJSON Quarter where + toJSON = stringEncoding . E.quarter + toEncoding = E.quarter + +instance ToJSONKey Quarter where + toJSONKey = toJSONKeyTextEnc E.quarter + instance ToJSON TimeOfDay where toJSON = stringEncoding . E.timeOfDay toEncoding = E.timeOfDay @@ -2105,7 +2120,9 @@ toJSON Saturday = "saturday" toJSON Sunday = "sunday" -toEncodingDayOfWeek :: DayOfWeek -> E.Encoding' Text + toEncoding = toEncodingDayOfWeek + +toEncodingDayOfWeek :: DayOfWeek -> E.Encoding' a toEncodingDayOfWeek Monday = E.unsafeToEncoding "\"monday\"" toEncodingDayOfWeek Tuesday = E.unsafeToEncoding "\"tuesday\"" toEncodingDayOfWeek Wednesday = E.unsafeToEncoding "\"wednesday\"" @@ -2116,6 +2133,21 @@ instance ToJSONKey DayOfWeek where toJSONKey = toJSONKeyTextEnc toEncodingDayOfWeek + +instance ToJSON QuarterOfYear where + toJSON Q1 = "q1" + toJSON Q2 = "q2" + toJSON Q3 = "q3" + toJSON Q4 = "q4" + +toEncodingQuarterOfYear :: QuarterOfYear -> E.Encoding' a +toEncodingQuarterOfYear Q1 = E.unsafeToEncoding "\"q1\"" +toEncodingQuarterOfYear Q2 = E.unsafeToEncoding "\"q2\"" +toEncodingQuarterOfYear Q3 = E.unsafeToEncoding "\"q3\"" +toEncodingQuarterOfYear Q4 = E.unsafeToEncoding "\"q4\"" + +instance ToJSONKey QuarterOfYear where + toJSONKey = toJSONKeyTextEnc toEncodingQuarterOfYear ------------------------------------------------------------------------------- -- base Monoid/Semigroup diff --git a/aeson.cabal b/aeson.cabal --- a/aeson.cabal +++ b/aeson.cabal @@ -1,5 +1,5 @@ name: aeson -version: 1.5.4.1 +version: 1.5.5.0 license: BSD3 license-file: LICENSE category: Text, Web, JSON @@ -11,8 +11,8 @@ tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.3, GHC == 8.10.1 synopsis: Fast JSON parsing and encoding cabal-version: >= 1.10 -homepage: https://github.com/bos/aeson -bug-reports: https://github.com/bos/aeson/issues +homepage: https://github.com/haskell/aeson +bug-reports: https://github.com/haskell/aeson/issues build-type: Simple description: A JSON parsing and encoding library optimized for ease of use @@ -106,7 +106,7 @@ ghc-prim >= 0.2 && < 0.8, template-haskell >= 2.9.0.0 && < 2.18, text >= 1.2.3.0 && < 1.3, - time >= 1.4 && < 1.11 + time >= 1.4 && < 1.12 if impl(ghc >= 8.0) build-depends: bytestring >= 0.10.8.1 @@ -114,7 +114,7 @@ -- Compat build-depends: base-compat-batteries >= 0.10.0 && < 0.12, - time-compat >= 1.9.2.2 && < 1.10 + time-compat >= 1.9.4 && < 1.10 if !impl(ghc >= 8.6) build-depends: @@ -254,11 +254,11 @@ void >=0.7.2 && <0.8 if impl(ghc >= 7.8) - build-depends: hashable-time >= 0.2 && <0.3 + build-depends: hashable-time >= 0.2.0.1 && <0.3 if flag(fast) ghc-options: -fno-enable-rewrite-rules source-repository head type: git - location: git://github.com/bos/aeson.git + location: git://github.com/haskell/aeson.git diff --git a/attoparsec-iso8601/Data/Attoparsec/Time.hs b/attoparsec-iso8601/Data/Attoparsec/Time.hs --- a/attoparsec-iso8601/Data/Attoparsec/Time.hs +++ b/attoparsec-iso8601/Data/Attoparsec/Time.hs @@ -19,6 +19,8 @@ , timeZone , utcTime , zonedTime + , month + , quarter ) where import Prelude.Compat @@ -33,6 +35,8 @@ import Data.Int (Int64) import Data.Maybe (fromMaybe) import Data.Time.Calendar (Day, fromGregorianValid) +import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..), fromYearQuarter) +import Data.Time.Calendar.Month.Compat (Month, fromYearMonthValid) import Data.Time.Clock (UTCTime(..)) import qualified Data.Text as T import qualified Data.Time.LocalTime as Local @@ -45,6 +49,28 @@ m <- (twoDigits <* char '-') <|> fail "date must be of form [+,-]YYYY-MM-DD" d <- twoDigits <|> fail "date must be of form [+,-]YYYY-MM-DD" maybe (fail "invalid date") return (fromGregorianValid (absOrNeg y) m d) + +-- | Parse a month of the form @[+,-]YYYY-MM@. +month :: Parser Month +month = do + absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id + y <- (decimal <* char '-') <|> fail "month must be of form [+,-]YYYY-MM" + m <- twoDigits <|> fail "month must be of form [+,-]YYYY-MM" + maybe (fail "invalid month") return (fromYearMonthValid (absOrNeg y) m) + +-- | Parse a quarter of the form @[+,-]YYYY-QN@. +quarter :: Parser Quarter +quarter = do + absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id + y <- (decimal <* char '-') <|> fail "month must be of form [+,-]YYYY-MM" + _ <- char 'q' <|> char 'Q' + q <- parseQ + return $! fromYearQuarter (absOrNeg y) q + where + parseQ = Q1 <$ char '1' + <|> Q2 <$ char '2' + <|> Q3 <$ char '3' + <|> Q4 <$ char '4' -- | Parse a two-digit integer (e.g. day of month, hour). twoDigits :: Parser Int diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,10 @@ For the latest version of this document, please see [https://github.com/bos/aeson/blob/master/changelog.md](https://github.com/bos/aeson/blob/master/changelog.md). +### 1.5.5.0 +* Add instances for `Month`, `Quarter` and `QuarterOfYear` (from `time-1.11`), thanks to Oleg Grenrus. + +* The aeson repository has been moved to the haskell github organization! + #### 1.5.4.1 * Use `Text.Encoding.decodeLatin1` to speed up ASCII string decoding, thanks to Dmitry Ivanov. * Support `bytestring 0.11.*` and `th-abstraction 0.4.*`, thanks to Oleg Grenrus. diff --git a/tests/PropertyKeys.hs b/tests/PropertyKeys.hs --- a/tests/PropertyKeys.hs +++ b/tests/PropertyKeys.hs @@ -5,7 +5,10 @@ import Prelude.Compat import Control.Applicative (Const) -import Data.Time (Day, LocalTime, TimeOfDay, UTCTime) +import Data.Time.Compat (Day, LocalTime, TimeOfDay, UTCTime) +import Data.Time.Calendar.Compat (DayOfWeek) +import Data.Time.Calendar.Month.Compat (Month) +import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear) import Data.Version (Version) import Instances () import Numeric.Natural (Natural) @@ -32,6 +35,11 @@ , testProperty "Float" $ roundTripKey (undefined :: Float) , testProperty "Double" $ roundTripKey (undefined :: Double) , testProperty "Day" $ roundTripKey (undefined :: Day) + -- TODO: needs https://github.com/w3rs/hashable-time/pull/12 + -- , testProperty "DayOfWeek" $ roundTripKey (undefined :: DayOfWeek) + -- , testProperty "Month" $ roundTripKey (undefined :: Month) + -- , testProperty "Quarter" $ roundTripKey (undefined :: Quarter) + -- , testProperty "QuarterOfYear" $ roundTripKey (undefined :: QuarterOfYear) , testProperty "LocalTime" $ roundTripKey (undefined :: LocalTime) , testProperty "TimeOfDay" $ roundTripKey (undefined :: TimeOfDay) , testProperty "UTCTime" $ roundTripKey (undefined :: UTCTime) diff --git a/tests/PropertyRoundTrip.hs b/tests/PropertyRoundTrip.hs --- a/tests/PropertyRoundTrip.hs +++ b/tests/PropertyRoundTrip.hs @@ -14,6 +14,8 @@ import Data.Tagged (Tagged) import Data.These (These (..)) import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime) +import Data.Time.Calendar.Month.Compat (Month) +import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear) import Data.Version (Version) import Data.Time.Calendar.Compat (CalendarDiffDays, DayOfWeek) import Data.Time.LocalTime.Compat (CalendarDiffTime) @@ -45,6 +47,9 @@ , testProperty "Lazy Text" $ roundTripEq LT.empty , testProperty "Foo" $ roundTripEq (undefined :: Foo) , testProperty "Day" $ roundTripEq (undefined :: Day) + , testProperty "Month" $ roundTripEq (undefined :: Month) + , testProperty "Quarter" $ roundTripEq (undefined :: Quarter) + , testProperty "QuarterOfYear" $ roundTripEq (undefined :: QuarterOfYear) , testProperty "BCE Day" $ roundTripEq (undefined :: BCEDay) , testProperty "DotNetTime" $ roundTripEq (undefined :: Approx DotNetTime) , testProperty "LocalTime" $ roundTripEq (undefined :: LocalTime) diff --git a/tests/SerializationFormatSpec.hs b/tests/SerializationFormatSpec.hs --- a/tests/SerializationFormatSpec.hs +++ b/tests/SerializationFormatSpec.hs @@ -17,7 +17,7 @@ import Prelude.Compat import Control.Applicative (Const(..)) -import Data.Aeson (FromJSON(..), decode, encode, genericParseJSON, genericToEncoding, genericToJSON) +import Data.Aeson (FromJSON(..), decode, eitherDecode, encode, genericParseJSON, genericToEncoding, genericToJSON) import Data.Aeson.Types (Options(..), SumEncoding(..), ToJSON(..), defaultOptions) import Data.Fixed (Pico) import Data.Foldable (for_, toList) @@ -31,6 +31,8 @@ import Data.Tagged (Tagged(..)) import Data.These (These (..)) import Data.Time (fromGregorian) +import Data.Time.Calendar.Month.Compat (fromYearMonth) +import Data.Time.Calendar.Quarter.Compat (fromYearQuarter, QuarterOfYear (..)) import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..)) import Data.Time.LocalTime.Compat (CalendarDiffTime (..)) import Data.Time.Clock.System.Compat (SystemTime (..)) @@ -148,6 +150,20 @@ , example "Day; year < 0" "\"-0234-01-01\"" (fromGregorian (-234) 1 1) , example "Day; year < -1000" "\"-1234-01-01\"" (fromGregorian (-1234) 1 1) + , example "Month; year >= 1000" "\"1999-10\"" (fromYearMonth 1999 10) + , example "Month; year > 0 && < 1000" "\"0500-03\"" (fromYearMonth 500 3) + , example "Month; year == 0" "\"0000-02\"" (fromYearMonth 0 2) + , example "Month; year < 0" "\"-0234-01\"" (fromYearMonth (-234) 1) + , example "Month; year < -1000" "\"-1234-01\"" (fromYearMonth (-1234) 1) + + , example "Quarter; year >= 1000" "\"1999-q1\"" (fromYearQuarter 1999 Q1) + , example "Quarter; year > 0 && < 1000" "\"0500-q4\"" (fromYearQuarter 500 Q4) + , example "Quarter; year == 0" "\"0000-q3\"" (fromYearQuarter 0 Q3) + , example "Quarter; year < 0" "\"-0234-q2\"" (fromYearQuarter (-234) Q2) + , example "Quarter; year < -1000" "\"-1234-q1\"" (fromYearQuarter (-1234) Q1) + + , example "QuarterOfYear" "\"q1\"" Q1 + , example "Product I Maybe Int" "[1,2]" (Pair (pure 1) (pure 2) :: Product I Maybe Int) , example "Product I Maybe Int" "[1,null]" (Pair (pure 1) Nothing :: Product I Maybe Int) , example "Product I [] Char" "[\"a\",\"foo\"]" (Pair (pure 'a') "foo" :: Product I [] Char) @@ -306,7 +322,8 @@ assertSomeEqual "encode" bss (encode val) assertSomeEqual "encode/via value" bss (encode $ toJSON val) for_ bss $ \bs -> - assertEqual "decode" (Just val') (decode bs) + assertEqual "decode" (Right val') (eitherDecode bs) + assertJsonExample (MaybeExample name bs mval) = testCase name $ assertEqual "decode" mval (decode bs)