Merge pull request #816 from phadej/issue-811-time-compat-1.9.4

Add instances for time-1.11 / time-compat-1.9.4 types: Month, Quarter, QuarterOfYear

Author: bergmark

Data/Aeson/Encoding.hs

@@ -42,6 +42,8 @@ module Data.Aeson.Encoding
 
     -- ** Time
     , day
+    , month
+    , quarter
     , localTime
     , utcTime
     , timeOfDay

Data/Aeson/Encoding/Builder.hs

@@ -27,6 +27,8 @@ module Data.Aeson.Encoding.Builder
     , quote
     , scientific
     , day
+    , month
+    , quarter
     , localTime
     , utcTime
     , timeOfDay
@@ -48,6 +50,8 @@ import Data.Scientific (Scientific, base10Exponent, coefficient)
 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 :: (Char, Char) -> BP.BoundedPrim a
 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,17 +184,40 @@ day dd = encodeYear yr <>
   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)
 {-# INLINE timeOfDay #-}

Data/Aeson/Encoding/Internal.hs

@@ -47,6 +47,8 @@ module Data.Aeson.Encoding.Internal
     , integerText, floatText, doubleText, scientificText
     -- ** Time
     , day
+    , month
+    , quarter
     , localTime
     , utcTime
     , timeOfDay
@@ -65,6 +67,8 @@ import Data.Int
 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
@@ -350,6 +354,12 @@ scientificText = Encoding . EB.quote . EB.scientific
 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
 

Data/Aeson/Parser/Time.hs

@@ -4,6 +4,8 @@ module Data.Aeson.Parser.Time
     (
       run
     , day
+    , month
+    , quarter
     , localTime
     , timeOfDay
     , timeZone
@@ -16,6 +18,8 @@ import Prelude.Compat
 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,11 +37,23 @@ day :: Parser Day
 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.)
 timeZone :: Parser (Maybe Local.TimeZone)

Data/Aeson/Types/FromJSON.hs

@@ -105,6 +105,8 @@ import Data.Text (Text, pack, unpack)
 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)
@@ -2123,6 +2125,32 @@ parseDayOfWeek t = case T.toLower t of
 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
 -------------------------------------------------------------------------------

Data/Aeson/Types/ToJSON.hs

@@ -87,6 +87,8 @@ import Data.Tagged (Tagged(..))
 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,6 +2018,19 @@ instance ToJSON Day where
 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
@@ -2105,7 +2120,9 @@ instance ToJSON DayOfWeek where
     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\""
@@ -2117,6 +2134,21 @@ toEncodingDayOfWeek Sunday    = E.unsafeToEncoding "\"sunday\""
 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
 -------------------------------------------------------------------------------

aeson.cabal

@@ -106,15 +106,15 @@ library
     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
 
   -- 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,7 +254,7 @@ test-suite aeson-tests
                    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

attoparsec-iso8601/Data/Attoparsec/Time.hs

@@ -19,6 +19,8 @@ module Data.Attoparsec.Time
     , timeZone
     , utcTime
     , zonedTime
+    , month
+    , quarter
     ) where
 
 import Prelude.Compat
@@ -33,6 +35,8 @@ import Data.Fixed (Pico)
 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
@@ -46,6 +50,28 @@ day = do
   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
 twoDigits = do

attoparsec-iso8601/attoparsec-iso8601.cabal

@@ -1,5 +1,5 @@
 name:            attoparsec-iso8601
-version:         1.0.1.0
+version:         1.0.2.0
 synopsis:        Parsing of ISO 8601 dates, originally from aeson.
 description:     Parsing of ISO 8601 dates, originally from aeson.
 license:         BSD3
@@ -39,9 +39,9 @@ library
     attoparsec >= 0.13.0.1 && < 0.14.0.0,
     base >= 4.7 && < 5,
     base-compat-batteries >= 0.10.0 && < 0.12,
-    time-compat >= 1.9.2.2 && < 1.10,
+    time-compat >= 1.9.4 && < 1.10,
     text >= 1.1.1.0 && < 1.3.0.0,
-    time >= 1.1.1.4 && < 1.11
+    time >= 1.1.1.4 && < 1.12
 
   if flag(fast)
     ghc-options: -O0

attoparsec-iso8601/changelog.md

@@ -1,5 +1,9 @@
 For the latest version of this document, please see [https://github.com/bos/aeson/blob/master/attoparsec-iso8601/changelog.md](https://github.com/bos/aeson/blob/master/attoparsec-iso8601/changelog.md).
 
+### 1.0.2.0
+
+* Add `month :: Parser Month` and `quarter :: Parser Quarter`
+
 ### 1.0.1.0
 
 * Fixes handling of `UTCTime` wrt. leap seconds , thanks to Adam Schønemann