months 0.1 → 0.2
raw patch · 5 files changed
+261/−652 lines, 5 filesdep −bifunctorsdep −cassavadep −http-api-datadep ~QuickCheckdep ~aesondep ~attoparsec
Dependencies removed: bifunctors, cassava, http-api-data, lens, lucid, swagger2
Dependency ranges changed: QuickCheck, aeson, attoparsec, base, base-compat, deepseq, hashable, text, time-compat
Files
- CHANGELOG.md +10/−0
- months.cabal +23/−58
- src/Data/Time/Month.hs +0/−311
- src/Data/Time/MonthName.hs +228/−0
- src/Data/Time/Quarter.hs +0/−283
+ CHANGELOG.md view
@@ -0,0 +1,10 @@+0.2 [2021-01-xx]+----------------++* Move to use `time-1.11` types where applicable+* Strip API to provide just `MonthName`++0.1 [2019-11-06]+----------------++* Initial release
months.cabal view
@@ -1,17 +1,18 @@-cabal-version: 2.2-name: months-version: 0.1-synopsis: Month, YearMonth, Quarter, YearQuarter types-category: Data, Time+cabal-version: 2.2+name: months+version: 0.2+synopsis: MonthName+category: Data, Time description: Month and Quarter enumerations and some basic function and instances. -homepage: https://github.com/phadej/months-bug-reports: https://github.com/phadej/months/issues-author: Oleg Grenrus <oleg.grenrus@iki.fi>-maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>-license: BSD-3-Clause-license-file: LICENSE+homepage: https://github.com/phadej/months+bug-reports: https://github.com/phadej/months/issues+author: Oleg Grenrus <oleg.grenrus@iki.fi>+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>+license: BSD-3-Clause+license-file: LICENSE+extra-source-files: CHANGELOG.md tested-with: GHC ==7.8.4 || ==7.10.3@@ -19,7 +20,9 @@ || ==8.2.2 || ==8.4.4 || ==8.6.5- || ==8.8.1+ || ==8.8.4+ || ==8.10.4+ || ==9.0.1 source-repository head type: git@@ -30,71 +33,33 @@ default: True manual: True -flag cassava- description: Provide cassava instances- default: True- manual: True--flag http-api-data- description: Provide http-api-data instances- default: True- manual: True- flag intervals description: Provide to Interval functions default: True manual: True -flag lucid- description: Provide lucid instances- default: True- manual: True--flag swagger2- description: Provide swagger2 instances- default: True- manual: True- library default-language: Haskell2010 hs-source-dirs: src- exposed-modules:- Data.Time.Month- Data.Time.Quarter+ ghc-options: -Wall+ exposed-modules: Data.Time.MonthName -- GHC boot libraries build-depends:- , base >=4.7 && <4.14- , deepseq+ , base >=4.7 && <4.16+ , deepseq ^>=1.3.0.0 || ^>=1.4.0.0 , text ^>=1.2.3.0 -- other depednencies build-depends: , attoparsec ^>=0.13.2.2 , base-compat ^>=0.11- , hashable ^>=1.3.0.0- , QuickCheck ^>=2.13.2- , time-compat ^>=1.9.2.2+ , hashable ^>=1.3.1.0+ , QuickCheck ^>=2.14.2+ , time-compat ^>=1.9.5 if flag(aeson)- build-depends: aeson ^>=1.4.5.0-- if flag(cassava)- build-depends: cassava ^>=0.5.2.0-- if flag(http-api-data)- build-depends: http-api-data ^>=0.4.1+ build-depends: aeson ^>=1.5.5.0 if flag(intervals) build-depends: intervals ^>=0.9-- if flag(lucid)- build-depends: lucid ^>=2.9.9-- if flag(aeson) && flag(swagger2)- build-depends:- , lens ^>=4.18.1- , swagger2 ^>=2.4-- if (flag(cassava) || flag(http-api-data)) && !impl(ghc >=8.2)- build-depends: bifunctors ^>=5.5.2
− src/Data/Time/Month.hs
@@ -1,311 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Trustworthy #-}--- | 'Month' data type.-module Data.Time.Month (- -- * Types- Month (..),- YearMonth (..),- -- * Conversion with Day- dayToYearMonth,- firstDayOfYearMonth,- lastDayOfYearMonth,-#ifdef MIN_VERSION_intervals- yearMonthInterval,-#endif- -- * Conversions with Text- yearMonthToText,- parseYearMonth,- ) where--import Control.Applicative ((<|>))-import Control.DeepSeq (NFData (..))-import Data.Bits ((.&.))-import Data.Char (ord)-import Data.Hashable (Hashable)-import Data.String (fromString)-import Data.Text (Text)-import Data.Time.Compat- (Day, fromGregorian, gregorianMonthLength, toGregorian)-import Data.Typeable (Typeable)-import GHC.Generics (Generic)-import Prelude ()-import Prelude.Compat-import Test.QuickCheck (Arbitrary (..), arbitraryBoundedEnum)--import qualified Data.Attoparsec.Text as AT-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import qualified Data.Text.Encoding.Error as TE--#ifdef MIN_VERSION_aeson-import Data.Aeson- (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..), withText)-import Data.Aeson.Types (FromJSONKeyFunction (..), ToJSONKeyFunction (..))--import qualified Data.Aeson.Encoding as Aeson.Encoding-#endif--#ifdef MIN_VERSION_cassava-import qualified Data.Csv as Csv-#endif--#ifdef MIN_VERSION_http_api_data-import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))-#endif--#ifdef MIN_VERSION_intervals-import Numeric.Interval.NonEmpty (Interval, (...))-#endif--#ifdef MIN_VERSION_lucid-import Lucid (ToHtml (..))-#endif--#ifdef MIN_VERSION_swagger2-import Control.Lens ((&), (.~), (?~))-import Data.Swagger (ToParamSchema (..), ToSchema (..))--import qualified Data.Swagger as Swagger-#endif--#if defined(MIN_VERSION_cassava) || defined(MIN_VERSION_http_api_data)-import Data.Bifunctor (first)-#endif------------------------------------------------------------------------------------ Month------------------------------------------------------------------------------------ | We explicitly enumerate month names. Using an 'Int' is unsafe.-data Month- = January- | February- | March- | April- | May- | June- | July- | August- | September- | October- | November- | December- deriving (Eq, Ord, Show, Read, Generic, Typeable, Bounded)--instance Hashable Month-instance NFData Month--instance Enum Month where- fromEnum January = 1- fromEnum February = 2- fromEnum March = 3- fromEnum April = 4- fromEnum May = 5- fromEnum June = 6- fromEnum July = 7- fromEnum August = 8- fromEnum September = 9- fromEnum October = 10- fromEnum November = 11- fromEnum December = 12-- toEnum 1 = January- toEnum 2 = February- toEnum 3 = March- toEnum 4 = April- toEnum 5 = May- toEnum 6 = June- toEnum 7 = July- toEnum 8 = August- toEnum 9 = September- toEnum 10 = October- toEnum 11 = November- toEnum 12 = December- toEnum _ = error "toEnum @Month: out-of-range"--instance Arbitrary Month where- arbitrary = arbitraryBoundedEnum- shrink January = []- shrink m = [January .. pred m]------------------------------------------------------------------------------------ Month------------------------------------------------------------------------------------ | A month in Julian/Gregorian calendar.-data YearMonth = YearMonth { monthYear :: !Integer, monthName :: !Month }- deriving (Eq, Ord, Generic, Typeable)---- | Doesn't print field names.-instance Show YearMonth where- showsPrec d (YearMonth y n) = showParen (d > 10)- $ showString "YearMonth "- . showsPrec 11 y- . showChar ' '- . showsPrec 11 n---- TODO write Read instance to match above Show instance--instance Hashable YearMonth--instance NFData YearMonth where rnf (YearMonth _ _) = ()--instance Enum YearMonth where- succ (YearMonth y December) = YearMonth (y + 1) January- succ (YearMonth y m) = YearMonth y (succ m)-- pred (YearMonth y January) = YearMonth (y - 1) December- pred (YearMonth y m) = YearMonth y (pred m)-- fromEnum (YearMonth y m) = fromIntegral y * 12 + fromEnum m - 1- toEnum i =- let (y, m) = divMod i 12- in YearMonth (fromIntegral y) (toEnum $ m + 1)--#ifdef MIN_VERSION_cassava-instance Csv.ToField YearMonth where- toField = Csv.toField . yearMonthToString--instance Csv.FromField YearMonth where- parseField field =- let monthtext = TE.decodeUtf8With TE.lenientDecode field- month = first T.pack (parseYearMonth monthtext)- in case month of- Left err -> fail $ T.unpack err- Right m -> pure m-#endif--#ifdef MIN_VERSION_aeson--- | TODO: use builder if we really want speed-instance ToJSON YearMonth where- toJSON = fromString . yearMonthToString- toEncoding = Aeson.Encoding.string . yearMonthToString--instance FromJSON YearMonth where- parseJSON = withText "YearMonth" $- either fail pure . parseYearMonth--instance ToJSONKey YearMonth where- toJSONKey = ToJSONKeyText- (fromString . yearMonthToString)- (Aeson.Encoding.string . yearMonthToString)--instance FromJSONKey YearMonth where- fromJSONKey = FromJSONKeyTextParser $- either fail pure . parseYearMonth-#endif--#ifdef MIN_VERSION_swagger2-instance ToSchema YearMonth where- declareNamedSchema _ = pure $ Swagger.NamedSchema (Just "YearMonth") $ mempty- & Swagger.type_ ?~ Swagger.SwaggerString- & Swagger.format ?~ "month"---- | Format @"month"@ corresponds to @yyyy-mm@ format.-instance ToParamSchema YearMonth where- toParamSchema _ = mempty- & Swagger.type_ ?~ Swagger.SwaggerString- & Swagger.format ?~ "month"-#endif--#ifdef MIN_VERSION_http_api_data-instance ToHttpApiData YearMonth where- toUrlPiece = fromString . yearMonthToString--instance FromHttpApiData YearMonth where- parseUrlPiece = first T.pack . parseYearMonth-#endif--#ifdef MIN_VERSION_lucid-instance ToHtml YearMonth where- toHtmlRaw = toHtml- toHtml = toHtml . yearMonthToText-#endif--instance Arbitrary YearMonth where- arbitrary = mk <$> arbitrary <*> arbitrary- where- mk y m = YearMonth (y + 2019) m-- shrink (YearMonth y m) =- [ YearMonth (y' + 2019) m | y' <- shrink (y - 2019) ] ++- [ YearMonth y m' | m' <- shrink m ]------------------------------------------------------------------------------------ functions------------------------------------------------------------------------------------ | Extract 'Month' from 'Day'------ >>> dayToYearMonth (read "2017-02-03")--- YearMonth 2017 February----dayToYearMonth :: Day -> YearMonth-dayToYearMonth d =- let (y, m, _) = toGregorian d- in mkYearMonth (y, m)---- | First day of the month.------ >>> firstDayOfYearMonth $ YearMonth 2017 February--- 2017-02-01----firstDayOfYearMonth :: YearMonth -> Day-firstDayOfYearMonth (YearMonth y m) = fromGregorian y (fromEnum m) 1---- | Last day of the month------ >>> lastDayOfYearMonth $ YearMonth 2017 February--- 2017-02-28------ >>> lastDayOfYearMonth $ YearMonth 2016 February--- 2016-02-29----lastDayOfYearMonth :: YearMonth -> Day-lastDayOfYearMonth (YearMonth y m) = fromGregorian y m' (gregorianMonthLength y m')- where- m' = fromEnum m--parseYearMonth :: Text -> Either String YearMonth-parseYearMonth = AT.parseOnly $ do- s <- negate <$ AT.char '-' <|> id <$ AT.char '+' <|> return id- y <- AT.decimal- _ <- AT.char '-'- m <- twoDigits- if 1 <= m && m <= 12- then return $ YearMonth y (toEnum m)- else fail "Invalid month"- where- twoDigits = do- a <- AT.digit- b <- AT.digit- let c2d c = ord c .&. 15- return $! c2d a * 10 + c2d b--#ifdef MIN_VERSION_intervals--- | Day interval of month------ >>> yearMonthInterval $ YearMonth 2017 February--- 2017-02-01 ... 2017-02-28-yearMonthInterval :: YearMonth -> Interval Day-yearMonthInterval m = firstDayOfYearMonth m ... lastDayOfYearMonth m-#endif------------------------------------------------------------------------------------ Internals----------------------------------------------------------------------------------mkYearMonth :: (Integer, Int) -> YearMonth-mkYearMonth (y, m) = YearMonth y (toEnum m)--yearMonthToString :: YearMonth -> String-yearMonthToString (YearMonth y October) = show y ++ "-10"-yearMonthToString (YearMonth y November) = show y ++ "-11"-yearMonthToString (YearMonth y December) = show y ++ "-12"-yearMonthToString (YearMonth y m) = show y ++ "-0" ++ show (fromEnum m)--yearMonthToText :: YearMonth -> Text-yearMonthToText = T.pack . yearMonthToString
+ src/Data/Time/MonthName.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Trustworthy #-}+-- | 'Month' data type.+module Data.Time.MonthName (+ -- * Types+ MonthName (..),+ -- * Conversion with Day+ dayToYearMonthName,+ firstDayOfYearMonthName,+ lastDayOfYearMonthName,+#ifdef MIN_VERSION_intervals+ yearMonthNameInterval,+#endif+ -- * Conversions with Text+ monthNameToText,+ parseMonthName,+ yearMonthNameToText,+ parseYearMonthName,+) where++import Control.Applicative ((<|>))+import Control.DeepSeq (NFData (..))+import Data.Bits ((.&.))+import Data.Char (ord)+import Data.Hashable (Hashable (..))+import Data.Text (Text)+import Data.Time.Compat+ (Year, Day, fromGregorian, gregorianMonthLength, toGregorian)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import Prelude ()+import Prelude.Compat+import Test.QuickCheck (Arbitrary (..), arbitraryBoundedEnum)++import qualified Data.Attoparsec.Text as AT+import qualified Data.Text as T++#ifdef MIN_VERSION_aeson+import Data.Aeson+ (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..), withText)+import Data.Aeson.Types (FromJSONKeyFunction (..), toJSONKeyText)+#endif++#ifdef MIN_VERSION_intervals+import Numeric.Interval.NonEmpty (Interval, (...))+#endif++-------------------------------------------------------------------------------+-- Month+-------------------------------------------------------------------------------++-- | We explicitly enumerate month names. Using an 'Int' is unsafe.+data MonthName+ = January+ | February+ | March+ | April+ | May+ | June+ | July+ | August+ | September+ | October+ | November+ | December+ deriving (Eq, Ord, Show, Read, Generic, Typeable, Bounded)++instance Hashable MonthName where+ hashWithSalt salt m = hashWithSalt salt (fromEnum m)++instance NFData MonthName where+ rnf m = m `seq` ()++instance Enum MonthName where+ fromEnum January = 1+ fromEnum February = 2+ fromEnum March = 3+ fromEnum April = 4+ fromEnum May = 5+ fromEnum June = 6+ fromEnum July = 7+ fromEnum August = 8+ fromEnum September = 9+ fromEnum October = 10+ fromEnum November = 11+ fromEnum December = 12++ toEnum 1 = January+ toEnum 2 = February+ toEnum 3 = March+ toEnum 4 = April+ toEnum 5 = May+ toEnum 6 = June+ toEnum 7 = July+ toEnum 8 = August+ toEnum 9 = September+ toEnum 10 = October+ toEnum 11 = November+ toEnum 12 = December+ toEnum _ = error "toEnum @MonthName: out-of-range"++instance Arbitrary MonthName where+ arbitrary = arbitraryBoundedEnum+ shrink January = []+ shrink m = [January .. pred m]++instance ToJSON MonthName where+ toJSON = toJSON . monthNameToText+ toEncoding = toEncoding . monthNameToText++instance FromJSON MonthName where+ parseJSON = withText "MonthName" $+ either fail return . parseMonthName++instance ToJSONKey MonthName where+ toJSONKey = toJSONKeyText monthNameToText++instance FromJSONKey MonthName where+ fromJSONKey = FromJSONKeyTextParser $+ either fail return . parseMonthName++-------------------------------------------------------------------------------+-- functions+-------------------------------------------------------------------------------++-- | Extract 'Month' from 'Day'+--+-- >>> dayToYearMonthName (read "2017-02-03")+-- (2017,February)+--+dayToYearMonthName :: Day -> (Year, MonthName)+dayToYearMonthName d =+ let (y, m, _) = toGregorian d+ in (y, toEnum m)++-- | First day of the month.+--+-- >>> firstDayOfYearMonthName (2017, February)+-- 2017-02-01+--+firstDayOfYearMonthName :: (Year, MonthName) -> Day+firstDayOfYearMonthName (y, m) = fromGregorian y (fromEnum m) 1++-- | Last day of the month+--+-- >>> lastDayOfYearMonthName (2017, February)+-- 2017-02-28+--+-- >>> lastDayOfYearMonthName (2016, February)+-- 2016-02-29+--+lastDayOfYearMonthName :: (Year, MonthName) -> Day+lastDayOfYearMonthName (y, m) = fromGregorian y m' (gregorianMonthLength y m')+ where+ m' = fromEnum m++parseYearMonthName :: Text -> Either String (Year, MonthName)+parseYearMonthName = AT.parseOnly $ do+ s <- negate <$ AT.char '-' <|> id <$ AT.char '+' <|> return id+ y <- AT.decimal+ _ <- AT.char '-'+ m <- twoDigits+ if 1 <= m && m <= 12+ then return (s y, toEnum m)+ else fail "Invalid month"+ where+ twoDigits = do+ a <- AT.digit+ b <- AT.digit+ let c2d c = ord c .&. 15+ return $! c2d a * 10 + c2d b++parseMonthName :: Text -> Either String MonthName+parseMonthName "jan" = Right January+parseMonthName "feb" = Right February+parseMonthName "mar" = Right March+parseMonthName "apr" = Right April+parseMonthName "may" = Right May+parseMonthName "jun" = Right June+parseMonthName "jul" = Right July+parseMonthName "aug" = Right August+parseMonthName "sep" = Right September+parseMonthName "oct" = Right October+parseMonthName "nov" = Right November+parseMonthName "dec" = Right December+parseMonthName _ = Left "Invalid MonthName"++#ifdef MIN_VERSION_intervals+-- | Day interval of month+--+-- >>> yearMonthNameInterval (2017, February)+-- 2017-02-01 ... 2017-02-28+yearMonthNameInterval :: (Year, MonthName) -> Interval Day+yearMonthNameInterval m = firstDayOfYearMonthName m ... lastDayOfYearMonthName m+#endif++-------------------------------------------------------------------------------+-- Internals+-------------------------------------------------------------------------------++monthNameToString :: MonthName -> String+monthNameToString January = "jan"+monthNameToString February = "feb"+monthNameToString March = "mar"+monthNameToString April = "apr"+monthNameToString May = "may"+monthNameToString June = "jun"+monthNameToString July = "jul"+monthNameToString August = "aug"+monthNameToString September = "sep"+monthNameToString October = "oct"+monthNameToString November = "nov"+monthNameToString December = "dec"++monthNameToText :: MonthName -> Text+monthNameToText = T.pack . monthNameToString++yearMonthNameToString :: (Year, MonthName) -> String+yearMonthNameToString (y, October) = show y ++ "-10"+yearMonthNameToString (y, November) = show y ++ "-11"+yearMonthNameToString (y, December) = show y ++ "-12"+yearMonthNameToString (y, m) = show y ++ "-0" ++ show (fromEnum m)++yearMonthNameToText :: (Year, MonthName) -> Text+yearMonthNameToText = T.pack . yearMonthNameToString
− src/Data/Time/Quarter.hs
@@ -1,283 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE Trustworthy #-}--- | 'Quarter' data type.-module Data.Time.Quarter (- -- * Types- Quarter (..),- YearQuarter (..),- -- * Conversion with Day- dayToYearQuarter,- firstDayOfYearQuarter,- lastDayOfYearQuarter,-#ifdef MIN_VERSION_intervals- yearQuarterInterval,-#endif- -- * Conversions with Text- yearQuarterToText,- parseYearQuarter,- ) where--import Control.Applicative ((<|>))-import Control.DeepSeq (NFData (..))-import Data.Hashable (Hashable)-import Data.String (fromString)-import Data.Text (Text)-import Data.Time.Compat- (Day, fromGregorian, gregorianMonthLength, toGregorian)-import Data.Typeable (Typeable)-import GHC.Generics (Generic)-import Prelude ()-import Prelude.Compat-import Test.QuickCheck (Arbitrary (..), arbitraryBoundedEnum)--import qualified Data.Attoparsec.Text as AT-import qualified Data.Text as T-import qualified Data.Text.Encoding as TE-import qualified Data.Text.Encoding.Error as TE--#ifdef MIN_VERSION_aeson-import Data.Aeson- (FromJSON (..), FromJSONKey (..), ToJSON (..), ToJSONKey (..), withText)-import Data.Aeson.Types (FromJSONKeyFunction (..), ToJSONKeyFunction (..))--import qualified Data.Aeson.Encoding as Aeson.Encoding-#endif--#ifdef MIN_VERSION_cassava-import qualified Data.Csv as Csv-#endif--#ifdef MIN_VERSION_http_api_data-import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..))-#endif--#ifdef MIN_VERSION_lucid-import Lucid (ToHtml (..))-#endif--#ifdef MIN_VERSION_intervals-import Numeric.Interval.NonEmpty (Interval, (...))-#endif--#ifdef MIN_VERSION_swagger2-import Control.Lens ((&), (.~), (?~))-import Data.Swagger (ToParamSchema (..), ToSchema (..))--import qualified Data.Swagger as Swagger-#endif--#if defined(MIN_VERSION_cassava) || defined(MIN_VERSION_http_api_data)-import Data.Bifunctor (first)-#endif------------------------------------------------------------------------------------ Quarter------------------------------------------------------------------------------------ | We explicitly enumerate quarter names. Using an 'Int' is unsafe.-data Quarter- = Q1- | Q2- | Q3- | Q4- deriving (Eq, Ord, Show, Read, Generic, Typeable, Bounded)--instance Hashable Quarter-instance NFData Quarter--instance Enum Quarter where- fromEnum Q1 = 1- fromEnum Q2 = 2- fromEnum Q3 = 3- fromEnum Q4 = 4-- toEnum 1 = Q1- toEnum 2 = Q2- toEnum 3 = Q3- toEnum 4 = Q4- toEnum _ = error "toEnum @Quarter: out-of-range"--instance Arbitrary Quarter where- arbitrary = arbitraryBoundedEnum- shrink Q1 = []- shrink m = [Q1 .. pred m]------------------------------------------------------------------------------------ Quarter------------------------------------------------------------------------------------ | A quarter in Julian/Gregorian calendar.-data YearQuarter = YearQuarter { quarterYear :: !Integer, quarterName :: !Quarter }- deriving (Eq, Ord, Generic, Typeable)---- | Doesn't print field names.-instance Show YearQuarter where- showsPrec d (YearQuarter y n) = showParen (d > 10)- $ showString "YearQuarter "- . showsPrec 11 y- . showChar ' '- . showsPrec 11 n---- TODO write Read instance to match above Show instance--instance Hashable YearQuarter--instance NFData YearQuarter where rnf (YearQuarter _ _) = ()--instance Enum YearQuarter where- succ (YearQuarter y Q4) = YearQuarter (y + 1) Q1- succ (YearQuarter y m) = YearQuarter y (succ m)-- pred (YearQuarter y Q1) = YearQuarter (y - 1) Q4- pred (YearQuarter y m) = YearQuarter y (pred m)-- fromEnum (YearQuarter y m) = fromIntegral y * 4 + fromEnum m - 1- toEnum i =- let (y, m) = divMod i 4- in YearQuarter (fromIntegral y) (toEnum $ m + 1)--#ifdef MIN_VERSION_cassava-instance Csv.ToField YearQuarter where- toField = Csv.toField . yearQuarterToString--instance Csv.FromField YearQuarter where- parseField field =- let quartertext = TE.decodeUtf8With TE.lenientDecode field- quarter = first T.pack (parseYearQuarter quartertext)- in case quarter of- Left err -> fail $ T.unpack err- Right m -> pure m-#endif--#ifdef MIN_VERSION_aeson--- | TODO: use builder if we really want speed-instance ToJSON YearQuarter where- toJSON = fromString . yearQuarterToString- toEncoding = Aeson.Encoding.string . yearQuarterToString--instance FromJSON YearQuarter where- parseJSON = withText "YearQuarter" $- either fail pure . parseYearQuarter--instance ToJSONKey YearQuarter where- toJSONKey = ToJSONKeyText- (fromString . yearQuarterToString)- (Aeson.Encoding.string . yearQuarterToString)--instance FromJSONKey YearQuarter where- fromJSONKey = FromJSONKeyTextParser $- either fail pure . parseYearQuarter-#endif--#ifdef MIN_VERSION_swagger2-instance ToSchema YearQuarter where- declareNamedSchema _ = pure $ Swagger.NamedSchema (Just "YearQuarter") $ mempty- & Swagger.type_ ?~ Swagger.SwaggerString- & Swagger.format ?~ "quarter"---- | Format @"quarter"@ corresponds to @yyyy-mm@ format.-instance ToParamSchema YearQuarter where- toParamSchema _ = mempty- & Swagger.type_ ?~ Swagger.SwaggerString- & Swagger.format ?~ "quarter"-#endif--#ifdef MIN_VERSION_http_api_data-instance ToHttpApiData YearQuarter where- toUrlPiece = fromString . yearQuarterToString--instance FromHttpApiData YearQuarter where- parseUrlPiece = first T.pack . parseYearQuarter-#endif--#ifdef MIN_VERSION_lucid-instance ToHtml YearQuarter where- toHtmlRaw = toHtml- toHtml = toHtml . yearQuarterToText-#endif--instance Arbitrary YearQuarter where- arbitrary = mk <$> arbitrary <*> arbitrary- where- mk y m = YearQuarter (y + 2019) m-- shrink (YearQuarter y m) =- [ YearQuarter (y' + 2019) m | y' <- shrink (y - 2019) ] ++- [ YearQuarter y m' | m' <- shrink m ]------------------------------------------------------------------------------------ functions------------------------------------------------------------------------------------ | Extract 'Quarter' from 'Day'------ >>> dayToYearQuarter (read "2017-02-03")--- YearQuarter 2017 Q1----dayToYearQuarter :: Day -> YearQuarter-dayToYearQuarter d =- let (y, m, _) = toGregorian d- in mkYearQuarter (y, succ (pred m `div` 3))---- | First day of the quarter.------ >>> firstDayOfYearQuarter $ YearQuarter 2017 Q3--- 2017-07-01----firstDayOfYearQuarter :: YearQuarter -> Day-firstDayOfYearQuarter (YearQuarter y m) = fromGregorian y m' 1- where- m' = 3 * fromEnum m - 2---- | Last day of the quarter------ >>> lastDayOfYearQuarter $ YearQuarter 2017 Q1--- 2017-03-31------ >>> lastDayOfYearQuarter $ YearQuarter 2016 Q2 --- 2016-06-30----lastDayOfYearQuarter :: YearQuarter -> Day-lastDayOfYearQuarter (YearQuarter y m) = fromGregorian y m' (gregorianMonthLength y m')- where- m' = 3 * fromEnum m--parseYearQuarter :: Text -> Either String YearQuarter-parseYearQuarter = AT.parseOnly $ do- s <- negate <$ AT.char '-' <|> id <$ AT.char '+' <|> return id- y <- AT.decimal- _ <- AT.char '-'- _ <- AT.char 'Q'- q <- Q1 <$ AT.char '1'- <|> Q2 <$ AT.char '2'- <|> Q3 <$ AT.char '3'- <|> Q4 <$ AT.char '4'- return (YearQuarter y q)--#ifdef MIN_VERSION_intervals--- | Day interval of month------ >>> yearQuarterInterval $ YearQuarter 2017 Q2--- 2017-04-01 ... 2017-06-30-yearQuarterInterval :: YearQuarter -> Interval Day-yearQuarterInterval m = firstDayOfYearQuarter m ... lastDayOfYearQuarter m-#endif------------------------------------------------------------------------------------ Internals----------------------------------------------------------------------------------mkYearQuarter :: (Integer, Int) -> YearQuarter-mkYearQuarter (y, m) = YearQuarter y (toEnum m)--yearQuarterToString :: YearQuarter -> String-yearQuarterToString (YearQuarter y Q1) = show y ++ "-Q1"-yearQuarterToString (YearQuarter y Q2) = show y ++ "-Q2"-yearQuarterToString (YearQuarter y Q3) = show y ++ "-Q3"-yearQuarterToString (YearQuarter y Q4) = show y ++ "-Q4"--yearQuarterToText :: YearQuarter -> Text-yearQuarterToText = T.pack . yearQuarterToString