diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017 Futurice Oy, 2017-2019 Oleg Grenrus + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Oleg Grenrus nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/months.cabal b/months.cabal new file mode 100644 --- /dev/null +++ b/months.cabal @@ -0,0 +1,100 @@ +cabal-version: 2.2 +name: months +version: 0.1 +synopsis: Month, YearMonth, Quarter, YearQuarter types +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 +tested-with: + GHC ==7.8.4 + || ==7.10.3 + || ==8.0.2 + || ==8.2.2 + || ==8.4.4 + || ==8.6.5 + || ==8.8.1 + +source-repository head + type: git + location: https://github.com/phadej/months + +flag aeson + description: Provide aeson instances + 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 boot libraries + build-depends: + , base >=4.7 && <4.14 + , deepseq + , 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 + + 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 + + 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 new file mode 100644 --- /dev/null +++ b/src/Data/Time/Month.hs @@ -0,0 +1,311 @@ +{-# 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/Quarter.hs b/src/Data/Time/Quarter.hs new file mode 100644 --- /dev/null +++ b/src/Data/Time/Quarter.hs @@ -0,0 +1,283 @@ +{-# 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