diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/months.cabal b/months.cabal --- a/months.cabal +++ b/months.cabal @@ -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 -maintainer: Oleg Grenrus -license: BSD-3-Clause -license-file: LICENSE +homepage: https://github.com/phadej/months +bug-reports: https://github.com/phadej/months/issues +author: Oleg Grenrus +maintainer: Oleg Grenrus +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 diff --git a/src/Data/Time/Month.hs b/src/Data/Time/Month.hs deleted file mode 100644 --- a/src/Data/Time/Month.hs +++ /dev/null @@ -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 diff --git a/src/Data/Time/MonthName.hs b/src/Data/Time/MonthName.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/MonthName.hs @@ -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 diff --git a/src/Data/Time/Quarter.hs b/src/Data/Time/Quarter.hs deleted file mode 100644 --- a/src/Data/Time/Quarter.hs +++ /dev/null @@ -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