months (empty) → 0.1
raw patch · 4 files changed
+724/−0 lines, 4 filesdep +QuickCheckdep +aesondep +attoparsec
Dependencies added: QuickCheck, aeson, attoparsec, base, base-compat, bifunctors, cassava, deepseq, hashable, http-api-data, intervals, lens, lucid, swagger2, text, time-compat
Files
- LICENSE +30/−0
- months.cabal +100/−0
- src/Data/Time/Month.hs +311/−0
- src/Data/Time/Quarter.hs +283/−0
+ LICENSE view
@@ -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.
+ months.cabal view
@@ -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 <oleg.grenrus@iki.fi>+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>+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
+ src/Data/Time/Month.hs view
@@ -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
+ src/Data/Time/Quarter.hs view
@@ -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