{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} #if SHOW_INTERNAL {-# LANGUAGE StandaloneDeriving #-} #endif {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_HADDOCK hide #-} #include "thyme.h" #if HLINT #include "cabal_macros.h" #endif module Data.Thyme.Calendar.Internal where import Prelude #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif import Control.Arrow import Control.DeepSeq import Control.Lens import Control.Monad import Data.AffineSpace import Data.Bits import Data.Data import Data.Hashable import Data.Int import Data.Ix import Data.Thyme.Format.Internal #if __GLASGOW_HASKELL__ == 704 import qualified Data.Vector.Generic import qualified Data.Vector.Generic.Mutable #endif import qualified Data.Vector.Unboxed as VU import Data.Vector.Unboxed.Deriving import GHC.Generics (Generic) import System.Random import Test.QuickCheck hiding ((.&.)) -- | A duration/count of years. type Years = Int -- | A duration/count of months. type Months = Int -- | A duration/count of days. type Days = Int -- | A calendar-agnostic day, internally represented as a count of days -- since /1858-11-17/, the -- -- (MJD) epoch. -- -- To convert a 'Day' to the corresponding 'YearMonthDay' in the W_GREGORIAN -- calendar, see 'gregorian'. -- -- @ -- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1 -- 2016-03-01 -- @ -- -- 'Day' is an instance of 'AffineSpace' where @'Diff' 'Day' = 'Days'@, so -- arithmetic on 'Day' and 'Days' can be performed with the '.-.', '.+^', -- and '.-^' operators. -- -- @ -- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1 '.-.' 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 2 1 -- 29 -- @ -- -- @ -- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1 '.-^' 1 -- 2016-02-29 -- @ -- -- Other ways of viewing a 'Day' include 'ordinalDate', and 'weekDate'. newtype Day = ModifiedJulianDay { toModifiedJulianDay :: Int } deriving (INSTANCES_NEWTYPE, CoArbitrary) instance AffineSpace Day where type Diff Day = Days {-# INLINE (.-.) #-} (.-.) = \ (ModifiedJulianDay a) (ModifiedJulianDay b) -> a - b {-# INLINE (.+^) #-} (.+^) = \ (ModifiedJulianDay a) d -> ModifiedJulianDay (a + d) -- | Convert between a 'Day' and the corresponding count of days from -- 1858-11-17, the MJD epoch. -- -- @ -- 'modifiedJulianDay' = 'iso' 'toModifiedJulianDay' 'ModifiedJulianDay' -- @ -- -- @ -- > 'modifiedJulianDay' 'Control.Lens.#' 0 -- 1858-11-17 -- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 2016 3 1 '&' 'modifiedJulianDay' '%~' 'subtract' 1 -- 2016-02-29 -- @ {-# INLINE modifiedJulianDay #-} modifiedJulianDay :: Iso' Day Int modifiedJulianDay = iso toModifiedJulianDay ModifiedJulianDay -- | Conversion between a W_GREGORIAN 'OrdinalDate' and the corresponding -- 'YearMonthDay'. -- -- @ -- > 'OrdinalDate' 2016 32 '^.' 'yearMonthDay' -- 'YearMonthDay' {ymdYear = 2016, ymdMonth = 2, ymdDay = 1} -- @ -- -- @ -- > 'yearMonthDay' 'Control.Lens.#' 'YearMonthDay' 2016 2 1 -- 'OrdinalDate' {odYear = 2016, odDay = 32} -- @ {-# INLINE yearMonthDay #-} yearMonthDay :: Iso' OrdinalDate YearMonthDay yearMonthDay = iso fromOrdinal toOrdinal where {-# INLINEABLE fromOrdinal #-} fromOrdinal :: OrdinalDate -> YearMonthDay fromOrdinal (OrdinalDate y yd) = YearMonthDay y m d where MonthDay m d = yd ^. monthDay (isLeapYear y) {-# INLINEABLE toOrdinal #-} toOrdinal :: YearMonthDay -> OrdinalDate toOrdinal (YearMonthDay y m d) = OrdinalDate y $ monthDay (isLeapYear y) # MonthDay m d -- | Conversion between a 'Day' and its 'YearMonthDay'. -- -- @ -- 'gregorian' = 'ordinalDate' . 'yearMonthDay' -- @ -- -- @ -- > 'ModifiedJulianDay' 0 '^.' 'gregorian' -- 'YearMonthDay' {ymdYear = 1858, ymdMonth = 11, ymdDay = 17} -- @ -- -- @ -- > 'gregorian' 'Control.Lens.#' 'YearMonthDay' 1858 11 17 -- 1858-11-17 -- @ {-# INLINE gregorian #-} gregorian :: Iso' Day YearMonthDay gregorian = ordinalDate . yearMonthDay -- | Conversion between a 'YearMonthDay' and the corresponding 'Day'. -- Returns 'Nothing' for invalid input. -- -- @ -- > 'gregorianValid' ('YearMonthDay' 2015 2 28) -- 'Just' 2015-02-28 -- @ -- -- @ -- > 'gregorianValid' ('YearMonthDay' 2015 2 29) -- 'Nothing' -- @ {-# INLINEABLE gregorianValid #-} gregorianValid :: YearMonthDay -> Maybe Day gregorianValid (YearMonthDay y m d) = review ordinalDate . OrdinalDate y <$> monthDayValid (isLeapYear y) (MonthDay m d) -- | Shows a 'Day' in -- -- /YYYY-MM-DD/ format. -- -- See "Data.Thyme.Format" for other possibilities. {-# INLINEABLE showGregorian #-} showGregorian :: Day -> String showGregorian (view gregorian -> YearMonthDay y m d) = showsYear y . (:) '-' . shows02 m . (:) '-' . shows02 d $ "" #if SHOW_INTERNAL deriving instance Show Day #else instance Show Day where show = showGregorian #endif ------------------------------------------------------------------------ -- | Calendar year. type Year = Int -- | Calendar month. /January = 1/ type Month = Int -- | Calendar day-of-month, starting from /1/. type DayOfMonth = Int -- | A strict triple of a 'Year', a 'Day', and a 'Month'. data YearMonthDay = YearMonthDay { ymdYear :: {-# UNPACK #-}!Year , ymdMonth :: {-# UNPACK #-}!Month , ymdDay :: {-# UNPACK #-}!DayOfMonth } deriving (INSTANCES_USUAL, Show) LENS(YearMonthDay,ymdYear,Year) LENS(YearMonthDay,ymdMonth,Month) LENS(YearMonthDay,ymdDay,DayOfMonth) instance Hashable YearMonthDay instance NFData YearMonthDay ------------------------------------------------------------------------ -- | Is it a leap year according to the W_GREGORIAN calendar? isLeapYear :: Year -> Bool isLeapYear y = y .&. 3 == 0 && (r100 /= 0 || q100 .&. 3 == 0) where (q100, r100) = y `quotRem` 100 -- | The day of the year, with /1 = January 1st/. type DayOfYear = Int -- | An -- . data OrdinalDate = OrdinalDate { odYear :: {-# UNPACK #-}!Year , odDay :: {-# UNPACK #-}!DayOfYear } deriving (INSTANCES_USUAL, Show) LENS(OrdinalDate,odYear,Year) LENS(OrdinalDate,odDay,DayOfYear) instance Hashable OrdinalDate instance NFData OrdinalDate -- | Conversion between the MJD 'Day' and 'OrdinalDate'. -- -- @ -- > 'ordinalDate' 'Control.Lens.#' 'OrdinalDate' 2016 32 -- 2016-02-01 -- @ -- -- @ -- > 'toModifiedJulianDay' $ 'ordinalDate' 'Control.Lens.#' 'OrdinalDate' 2016 32 -- 57419 -- @ -- -- @ -- > 'ModifiedJulianDay' 57419 '^.' 'ordinalDate' -- 'OrdinalDate' {odYear = 2016, odDay = 32} -- @ {-# INLINE ordinalDate #-} ordinalDate :: Iso' Day OrdinalDate ordinalDate = iso toOrd fromOrd where -- Brief description of the toOrd computation -- -- The length of the years in the Gregorian calendar is periodic with period -- of /400/ years. There are /100 - 4 + 1 = 97/ leap years in a period, so -- the average length of a year is /365 + 97\/400 = 146097\/400/ days. -- -- Now, if you consider these — let's call them nominal — years, -- then for any point in time, for any linear day number we can -- determine which nominal year does it fall into by a single -- division. Moreover, if we align the start of the calendar year /1/ -- with the start of the nominal year /1/, then the calendar years and -- nominal years never get too much out of sync. Specifically: -- -- * The start of the first day of a calendar year might fall into the -- preceding nominal year, but never more than by /1.5/ days (/591\/400/ -- days, to be precise). -- -- * The start of the last day of a calendar year always falls into -- its nominal year (even for the leap years). -- -- So, to find out the calendar year for a given day, we calculate -- on which nominal year does its start fall. And, if we are not too -- close to the end of year, we have the right calendar -- year. Othewise, we just check whether it falls within the next -- calendar year. -- -- Notes: to make the reasoning simpler and more efficient ('quot' is -- faster than 'div') we do the computation directly only for positive -- years (days after /0001-01-01/). For earlier dates we translate by an -- integral number of /400/ year periods, do the computation and -- translate back. {-# INLINEABLE toOrd #-} toOrd :: Day -> OrdinalDate toOrd (ModifiedJulianDay mjd) | dayB0 <= 0 = case toOrdB0 dayInQC of OrdinalDate y yd -> OrdinalDate (y + quadCent * 400) yd | otherwise = toOrdB0 dayB0 where dayB0 = mjd + 678575 (quadCent, dayInQC) = dayB0 `divMod` 146097 -- Input: days since 0001-01-01. Precondition: has to be positive! {-# INLINE toOrdB0 #-} toOrdB0 :: Int -> OrdinalDate toOrdB0 dayB0 = res where (y0, r) = (400 * dayB0) `quotRem` 146097 d0 = dayInYear y0 dayB0 d1 = dayInYear (y0 + 1) dayB0 res = if r > 146097 - 600 && d1 > 0 then OrdinalDate (y0 + 1 + 1) d1 else OrdinalDate (y0 + 1) d0 -- Input: (year - 1) (day as days since 0001-01-01) -- Precondition: year is positive! {-# INLINE dayInYear #-} dayInYear :: Int -> Int -> Int dayInYear y0 dayB0 = dayB0 - 365 * y0 - leaps + 1 where leaps = y0 `shiftR` 2 - centuries + centuries `shiftR` 2 centuries = y0 `quot` 100 {-# INLINEABLE fromOrd #-} fromOrd :: OrdinalDate -> Day fromOrd (OrdinalDate year yd) = ModifiedJulianDay mjd where years = year - 1 centuries = years `div` 100 leaps = years `shiftR` 2 - centuries + centuries `shiftR` 2 mjd = 365 * years + leaps - 678576 + clip 1 (if isLeapYear year then 366 else 365) yd clip a b = max a . min b ------------------------------------------------------------------------ -- Lookup tables for Data.Thyme.Calendar.MonthDay {-# NOINLINE monthLengths #-} {-# NOINLINE monthLengthsLeap #-} monthLengths, monthLengthsLeap :: VU.Vector Days monthLengths = VU.fromList [31,28,31,30,31,30,31,31,30,31,30,31] monthLengthsLeap = VU.fromList [31,29,31,30,31,30,31,31,30,31,30,31] -- J F M A M J J A S O N D {-# ANN monthDays "HLint: ignore Use fromMaybe" #-} {-# NOINLINE monthDays #-} monthDays :: VU.Vector ({-Month-}Int8, {-DayOfMonth-}Int8) monthDays = VU.generate 365 go where dom01 = VU.prescanl' (+) 0 monthLengths go yd = (fromIntegral m, fromIntegral d) where m = maybe 12 id $ VU.findIndex (yd <) dom01 d = succ yd - VU.unsafeIndex dom01 (pred m) {-# ANN monthDaysLeap "HLint: ignore Use fromMaybe" #-} {-# NOINLINE monthDaysLeap #-} monthDaysLeap :: VU.Vector ({-Month-}Int8, {-DayOfMonth-}Int8) monthDaysLeap = VU.generate 366 go where dom01 = VU.prescanl' (+) 0 monthLengthsLeap go yd = (fromIntegral m, fromIntegral d) where m = maybe 12 id $ VU.findIndex (yd <) dom01 d = succ yd - VU.unsafeIndex dom01 (pred m) -- | No good home for this within the current hierarchy. This will do. {-# INLINEABLE randomIsoR #-} randomIsoR :: (Random s, RandomGen g) => Iso' s a -> (a, a) -> g -> (a, g) randomIsoR l (x, y) = first (^. l) . randomR (l # x, l # y) ------------------------------------------------------------------------ -- | A strict pair of a 'Month' and a 'DayOfMonth'. data MonthDay = MonthDay { mdMonth :: {-# UNPACK #-}!Month , mdDay :: {-# UNPACK #-}!DayOfMonth } deriving (INSTANCES_USUAL, Show) LENS(MonthDay,mdMonth,Month) LENS(MonthDay,mdDay,DayOfMonth) instance Hashable MonthDay instance NFData MonthDay instance Bounded MonthDay where minBound = MonthDay 1 1 maxBound = MonthDay 12 31 instance Random MonthDay where randomR r g = randomIsoR (monthDay leap) r g' where (isLeapYear -> leap, g') = random g random = randomR (minBound, maxBound) instance Arbitrary MonthDay where arbitrary = choose (minBound, maxBound) shrink md = view (monthDay True) <$> shrink (monthDay True # md) instance CoArbitrary MonthDay where coarbitrary (MonthDay m d) = coarbitrary m . coarbitrary d -- | Predicated on whether or not it's a leap year, convert between an -- ordinal 'DayOfYear' and the corresponding 'Month' and 'DayOfMonth'. -- -- @ -- > 60 '^.' 'monthDay' ('isLeapYear' 2015) -- 'MonthDay' {'mdMonth' = 3, 'mdDay' = 1} -- @ -- -- @ -- > 60 '^.' 'monthDay' ('isLeapYear' 2016) -- 'MonthDay' {'mdMonth' = 2, 'mdDay' = 29} -- @ -- -- @ -- > 'monthDay' ('isLeapYear' 2016) 'Control.Lens.#' 'MonthDay' 2 29 -- 60 -- @ -- -- @ -- > 'monthDay' ('isLeapYear' 2015) 'Control.Lens.#' 'MonthDay' 2 28 -- 59 -- @ -- -- Note that 'monthDay' is an improper 'Iso', as the following example -- shows. To handle this case correctly, use 'monthDayValid'. -- -- @ -- > 'monthDay' ('isLeapYear' 2015) 'Control.Lens.#' 'MonthDay' 2 29 -- 59 -- @ {-# INLINE monthDay #-} monthDay :: Bool -- ^ 'isLeapYear'? -> Iso' DayOfYear MonthDay monthDay leap = iso fromOrdinal toOrdinal where (lastDay, lengths, table, ok) = if leap then (365, monthLengthsLeap, monthDaysLeap, -1) else (364, monthLengths, monthDays, -2) {-# INLINE fromOrdinal #-} fromOrdinal :: DayOfYear -> MonthDay fromOrdinal (max 0 . min lastDay . pred -> i) = MonthDay m d where (fromIntegral -> m, fromIntegral -> d) = VU.unsafeIndex table i {-# INLINE toOrdinal #-} toOrdinal :: MonthDay -> DayOfYear toOrdinal (MonthDay month day) = div (367 * m - 362) 12 + k + d where m = max 1 . min 12 $ month l = VU.unsafeIndex lengths (pred m) d = max 1 . min l $ day k = if m <= 2 then 0 else ok -- | Predicated on whether or not it's a leap year, convert a 'MonthDay' to -- an ordinal 'DayOfYear'. -- -- @ -- > 'monthDayValid' ('isLeapYear' 2016) ('MonthDay' 2 29) -- 'Just' 60 -- @ -- -- @ -- > 'monthDayValid' ('isLeapYear' 2015) ('MonthDay' 2 29) -- 'Nothing' -- @ {-# INLINEABLE monthDayValid #-} monthDayValid :: Bool -- ^ 'isLeapYear'? -> MonthDay -> Maybe DayOfYear monthDayValid leap md@(MonthDay m d) = monthDay leap # md <$ guard (1 <= m && m <= 12 && 1 <= d && d <= monthLength leap m) -- | Predicated on whether or not the year is a leap year, return the number -- of 'Days' in the given 'Month'. -- -- @ -- > monthLength ('isLeapYear' 2015) 2 -- 28 -- @ -- -- @ -- > monthLength ('isLeapYear' 2016) 2 -- 29 -- @ {-# INLINEABLE monthLength #-} monthLength :: Bool -- ^ 'isLeapYear'? -> Month -> Days monthLength leap = VU.unsafeIndex ls . max 0 . min 11 . pred where ls = if leap then monthLengthsLeap else monthLengths ------------------------------------------------------------------------ -- | Week of the year. -- -- Meaning of values depends on context; see 'wdWeek', 'swWeek', 'mwWeek'. type WeekOfYear = Int -- | Day of the week. -- -- [/0/] /Sunday/ for 'SundayWeek' -- -- [/1/…/6/] /Monday/…/Saturday/ -- -- [/7/] /Sunday/ for 'WeekDate', 'MondayWeek', and 'Data.Thyme.Calendar.WeekdayOfMonth.WeekdayOfMonth' type DayOfWeek = Int -- | . -- -- Note that week /01/ is defined as the week with the first Thursday, thus -- 'wdYear' may differ from the Gregorian year between /December 29th/ and -- /January 3rd/. data WeekDate = WeekDate { wdYear :: {-# UNPACK #-}!Year , wdWeek :: {-# UNPACK #-}!WeekOfYear -- ^ Numbered /01/ to /53/. Days before week /01/ are considered to -- belong to the previous year. , wdDay :: {-# UNPACK #-}!DayOfWeek -- ^ /1 = Monday/ … /7 = Sunday/. } deriving (INSTANCES_USUAL, Show) LENS(WeekDate,wdYear,Year) LENS(WeekDate,wdWeek,WeekOfYear) LENS(WeekDate,wdDay,DayOfWeek) instance Hashable WeekDate instance NFData WeekDate -- | Convert between a 'Day' and an ISO 8601 'WeekDate'. -- -- @ -- > 'YearMonthDay' 2016 1 1 '^.' 'from' 'gregorian' '.' 'weekDate' -- 'WeekDate' {'wdYear' = 2015, 'wdWeek' = 53, 'wdDay' = 5} -- @ {-# INLINE weekDate #-} weekDate :: Iso' Day WeekDate weekDate = iso toWeek fromWeek where {-# INLINEABLE toWeek #-} toWeek :: Day -> WeekDate toWeek = join (toWeekOrdinal . view ordinalDate) {-# INLINEABLE fromWeek #-} fromWeek :: WeekDate -> Day fromWeek wd@(WeekDate y _ _) = fromWeekLast (lastWeekOfYear y) wd {-# INLINE toWeekOrdinal #-} toWeekOrdinal :: OrdinalDate -> Day -> WeekDate toWeekOrdinal (OrdinalDate y0 yd) (ModifiedJulianDay mjd) = WeekDate y1 (w1 + 1) (d7mod + 1) where -- pilfered and refactored; no idea what foo and bar mean d = mjd + 2 (d7div, d7mod) = divMod d 7 foo :: Year -> {-WeekOfYear-1-}Int foo y = bar $ ordinalDate # OrdinalDate y 6 bar :: Day -> {-WeekOfYear-1-}Int bar (ModifiedJulianDay k) = d7div - div k 7 w0 = bar $ ModifiedJulianDay (d - yd + 4) (y1, w1) = case w0 of -1 -> (y0 - 1, foo (y0 - 1)) 52 | foo (y0 + 1) == 0 -> (y0 + 1, 0) _ -> (y0, w0) {-# INLINE lastWeekOfYear #-} lastWeekOfYear :: Year -> WeekOfYear lastWeekOfYear y = if wdWeek wd == 53 then 53 else 52 where wd = OrdinalDate y 365 ^. from ordinalDate . weekDate {-# INLINE fromWeekLast #-} fromWeekLast :: WeekOfYear -> WeekDate -> Day fromWeekLast wMax (WeekDate y w d) = ModifiedJulianDay mjd where -- pilfered and refactored ModifiedJulianDay k = ordinalDate # OrdinalDate y 6 mjd = k - mod k 7 - 10 + clip 1 7 d + clip 1 wMax w * 7 clip a b = max a . min b -- | Convert a 'WeekDate' to a 'Day', or 'Nothing' for invalid 'WeekDate'. {-# INLINEABLE weekDateValid #-} weekDateValid :: WeekDate -> Maybe Day weekDateValid wd@(WeekDate (lastWeekOfYear -> wMax) w d) = fromWeekLast wMax wd <$ guard (1 <= d && d <= 7 && 1 <= w && w <= wMax) -- | Shows a 'Day' using the @yyyy-Www-d@ ISO 8601 Week Date format. -- -- @ -- > 'showWeekDate' ('gregorian' 'Control.Lens.#' 'YearMonthDay' 2006 11 15) -- "2006-W46-3" -- @ {-# INLINEABLE showWeekDate #-} showWeekDate :: Day -> String showWeekDate (view weekDate -> WeekDate y w d) = showsYear y . (++) "-W" . shows02 w . (:) '-' $ show d ------------------------------------------------------------------------ -- | Week-based calendar date with the first /Sunday/ of the year as the first -- day of week /01/. This corresponds to @%U@ and @%w@ of -- @@. -- -- The final week of a given year and week /00/ of the next both refer to -- the same week. data SundayWeek = SundayWeek { swYear :: {-# UNPACK #-}!Year -- ^ Coincides with that of 'gregorian'. , swWeek :: {-# UNPACK #-}!WeekOfYear -- ^ Weeks numbered from /00/ to /53/, starting with the first -- /Sunday/ of the year as the first day of week /01/. , swDay :: {-# UNPACK #-}!DayOfWeek -- ^ /0 = Sunday/. } deriving (INSTANCES_USUAL, Show) LENS(SundayWeek,swYear,Year) LENS(SundayWeek,swWeek,WeekOfYear) LENS(SundayWeek,swDay,DayOfWeek) instance Hashable SundayWeek instance NFData SundayWeek -- | Conversion between 'Day' and 'SundayWeek'. -- -- @ -- > 'YearMonthDay' 2016 1 3 '^.' 'from' 'gregorian' '.' 'sundayWeek' -- 'SundayWeek' {'swYear' = 2016, 'swWeek' = 1, 'swDay' = 0} -- @ {-# INLINE sundayWeek #-} sundayWeek :: Iso' Day SundayWeek sundayWeek = iso toSunday fromSunday where {-# INLINEABLE toSunday #-} toSunday :: Day -> SundayWeek toSunday = join (toSundayOrdinal . view ordinalDate) {-# INLINEABLE fromSunday #-} fromSunday :: SundayWeek -> Day fromSunday (SundayWeek y w d) = ModifiedJulianDay (firstDay + yd) where ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1 -- following are all 0-based year days firstSunday = mod (4 - firstDay) 7 yd = firstSunday + 7 * (w - 1) + d {-# INLINE toSundayOrdinal #-} toSundayOrdinal :: OrdinalDate -> Day -> SundayWeek toSundayOrdinal (OrdinalDate y yd) (ModifiedJulianDay mjd) = SundayWeek y (d7div - div k 7) d7mod where d = mjd + 3 k = d - yd (d7div, d7mod) = divMod d 7 -- | Convert a 'SundayWeek' to a 'Day', or 'Nothing' for invalid 'SundayWeek'. {-# INLINEABLE sundayWeekValid #-} sundayWeekValid :: SundayWeek -> Maybe Day sundayWeekValid (SundayWeek y w d) = ModifiedJulianDay (firstDay + yd) <$ guard (0 <= d && d <= 6 && 0 <= yd && yd <= lastDay) where ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1 -- following are all 0-based year days firstSunday = mod (4 - firstDay) 7 yd = firstSunday + 7 * (w - 1) + d lastDay = if isLeapYear y then 365 else 364 ------------------------------------------------------------------------ -- | Week-based calendar date with the first /Monday/ of the year as the first -- day of week /01/. This corresponds to @%W@ and @%u@ of -- @@. -- -- The final week of a given year and week /00/ of the next both refer to -- the same week. data MondayWeek = MondayWeek { mwYear :: {-# UNPACK #-}!Year -- ^ Coincides with that of 'gregorian'. , mwWeek :: {-# UNPACK #-}!WeekOfYear -- ^ Weeks numbered from /00/ to /53/, starting with the first -- /Monday/ of the year as the first day of week /01/. , mwDay :: {-# UNPACK #-}!DayOfWeek -- ^ /7 = Sunday/. } deriving (INSTANCES_USUAL, Show) LENS(MondayWeek,mwYear,Year) LENS(MondayWeek,mwWeek,WeekOfYear) LENS(MondayWeek,mwDay,DayOfWeek) instance Hashable MondayWeek instance NFData MondayWeek -- | Conversion between 'Day' and 'MondayWeek'. -- -- @ -- > 'YearMonthDay' 2016 1 3 '^.' 'from' 'gregorian' '.' 'mondayWeek' -- 'MondayWeek' {'mwYear' = 2016, 'mwWeek' = 0, 'mwDay' = 7} -- @ {-# INLINE mondayWeek #-} mondayWeek :: Iso' Day MondayWeek mondayWeek = iso toMonday fromMonday where {-# INLINEABLE toMonday #-} toMonday :: Day -> MondayWeek toMonday = join (toMondayOrdinal . view ordinalDate) {-# INLINEABLE fromMonday #-} fromMonday :: MondayWeek -> Day fromMonday (MondayWeek y w d) = ModifiedJulianDay (firstDay + yd) where ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1 -- following are all 0-based year days firstMonday = mod (5 - firstDay) 7 yd = firstMonday + 7 * (w - 1) + d - 1 {-# INLINE toMondayOrdinal #-} toMondayOrdinal :: OrdinalDate -> Day -> MondayWeek toMondayOrdinal (OrdinalDate y yd) (ModifiedJulianDay mjd) = MondayWeek y (d7div - div k 7) (d7mod + 1) where d = mjd + 2 k = d - yd (d7div, d7mod) = divMod d 7 -- | Convert a 'MondayWeek' to a 'Day', or 'Nothing' for invalid 'MondayWeek'. {-# INLINEABLE mondayWeekValid #-} mondayWeekValid :: MondayWeek -> Maybe Day mondayWeekValid (MondayWeek y w d) = ModifiedJulianDay (firstDay + yd) <$ guard (1 <= d && d <= 7 && 0 <= yd && yd <= lastDay) where ModifiedJulianDay firstDay = ordinalDate # OrdinalDate y 1 -- following are all 0-based year days firstMonday = mod (5 - firstDay) 7 yd = firstMonday + 7 * (w - 1) + d - 1 lastDay = if isLeapYear y then 365 else 364 ------------------------------------------------------------------------ -- Unbox instances at the end avoids TH-related declaration order issues derivingUnbox "Day" [t| Day -> Int |] [| toModifiedJulianDay |] [| ModifiedJulianDay |] derivingUnbox "YearMonthDay" [t| YearMonthDay -> Int |] [| \ YearMonthDay {..} -> shiftL ymdYear 9 .|. shiftL ymdMonth 5 .|. ymdDay |] [| \ n -> YearMonthDay (shiftR n 9) (shiftR n 5 .&. 0xf) (n .&. 0x1f) |] derivingUnbox "OrdinalDate" [t| OrdinalDate -> Int |] [| \ OrdinalDate {..} -> shiftL odYear 9 .|. odDay |] [| \ n -> OrdinalDate (shiftR n 9) (n .&. 0x1ff) |] derivingUnbox "MonthDay" [t| MonthDay -> Int |] [| \ MonthDay {..} -> shiftL mdMonth 5 .|. mdDay |] [| \ n -> MonthDay (shiftR n 5) (n .&. 0x1f) |] derivingUnbox "WeekDate" [t| WeekDate -> Int |] [| \ WeekDate {..} -> shiftL wdYear 9 .|. shiftL wdWeek 3 .|. wdDay |] [| \ n -> WeekDate (shiftR n 9) (shiftR n 3 .&. 0x3f) (n .&. 0x7) |] derivingUnbox "SundayWeek" [t| SundayWeek -> Int |] [| \ SundayWeek {..} -> shiftL swYear 9 .|. shiftL swWeek 3 .|. swDay |] [| \ n -> SundayWeek (shiftR n 9) (shiftR n 3 .&. 0x3f) (n .&. 0x7) |] derivingUnbox "MondayWeek" [t| MondayWeek -> Int |] [| \ MondayWeek {..} -> shiftL mwYear 9 .|. shiftL mwWeek 3 .|. mwDay |] [| \ n -> MondayWeek (shiftR n 9) (shiftR n 3 .&. 0x3f) (n .&. 0x7) |]