{-# LANGUAGE TypeFamilies #-}
module Data.HodaTime.Calendar.Gregorian.Internal
(
daysToYearMonthDay
,fromWeekDate
,Gregorian
,Month(..)
,DayOfWeek(..)
,invalidDayThresh
,epochDayOfWeek
,maxDaysInMonth
,yearMonthDayToDays
,nthDayToDayOfMonth
,dayOfWeekFromDays
,instantToYearMonthDay
)
where
import Data.HodaTime.Constants (daysPerCycle, daysPerCentury, daysPerFourYears)
import Data.HodaTime.CalendarDateTime.Internal (IsCalendar(..), CalendarDate(..), IsCalendarDateTime(..), DayOfMonth, Year, WeekNumber, CalendarDateTime(..), LocalTime(..))
import Data.HodaTime.Calendar.Gregorian.CacheTable (DTCacheTable(..), decodeMonth, decodeYear, decodeDay, cacheTable)
import Data.HodaTime.Calendar.Constants (daysPerStandardYear)
import Data.HodaTime.Instant.Internal (Instant(..))
import Control.Arrow ((>>>), (&&&), (***), first)
import Data.Maybe (fromJust)
import Data.List (findIndex)
import Data.Int (Int32, Int8)
import Data.Word (Word8, Word32)
import Control.Monad (guard)
invalidDayThresh :: Integral a => a
invalidDayThresh = -152445
firstGregDayTuple :: (Integral a, Integral b, Integral c) => (a, b, c)
firstGregDayTuple = (1582, 9, 15)
epochDayOfWeek :: DayOfWeek Gregorian
epochDayOfWeek = Wednesday
monthDayOffsets :: Num a => [a]
monthDayOffsets = 0 : rest
where
rest = zipWith (+) daysPerMonth (0:rest)
daysPerMonth = [31, 30, 31, 30, 31, 31, 30, 31, 30, 31, 31, 28]
data Gregorian
instance IsCalendar Gregorian where
type Date Gregorian = CalendarDate Gregorian
data DayOfWeek Gregorian = Sunday | Monday | Tuesday | Wednesday | Thursday | Friday | Saturday
deriving (Show, Eq, Ord, Enum, Bounded)
data Month Gregorian = January | February | March | April | May | June | July | August | September | October | November | December
deriving (Show, Eq, Ord, Enum, Bounded)
day' f (CalendarDate _ d m y) = mkcd . (rest+) <$> f (fromIntegral d)
where
rest = pred $ yearMonthDayToDays (fromIntegral y) (toEnum . fromIntegral $ m) 1
mkcd days =
let
days' = fromIntegral $ if days > invalidDayThresh then days else invalidDayThresh + 1
(y', m', d') = daysToYearMonthDay days'
in CalendarDate days' d' m' y'
{-# INLINE day' #-}
month' (CalendarDate _ _ m _) = toEnum . fromIntegral $ m
monthl' f (CalendarDate _ d m y) = mkcd <$> f (fromEnum m)
where
mkcd months = CalendarDate (fromIntegral days) d'' (fromIntegral m') (fromIntegral y'')
where
(y', months') = flip divMod 12 >>> first (+ fromIntegral y) $ months
(y'', m', d') = if (y', months', d) < firstGregDayTuple then firstGregDayTuple else (y', months', d)
mdim = fromIntegral $ maxDaysInMonth (toEnum m') y'
d'' = if d' > mdim then mdim else d'
days = yearMonthDayToDays y'' (toEnum m') (fromIntegral d'')
{-# INLINE monthl' #-}
year' f (CalendarDate _ d m y) = mkcd <$> f (fromIntegral y)
where
mkcd y' = CalendarDate days d'' m' (fromIntegral y'')
where
(y'', m', d') = if (y', m, d) < firstGregDayTuple then firstGregDayTuple else (y', m, d)
m'' = toEnum . fromIntegral $ m'
mdim = fromIntegral $ maxDaysInMonth m'' y''
d'' = if d' > mdim then mdim else d'
days = fromIntegral $ yearMonthDayToDays y'' m'' (fromIntegral d'')
{-# INLINE year' #-}
dayOfWeek' (CalendarDate days _ _ _) = toEnum . dayOfWeekFromDays . fromIntegral $ days
next' n dow (CalendarDate days _ _ _) = moveByDow n dow (-) (+) (fromIntegral days)
previous' n dow (CalendarDate days _ _ _) = moveByDow n dow subtract (-) (fromIntegral days)
instance IsCalendarDateTime Gregorian where
fromAdjustedInstant (Instant days secs nsecs) = CalendarDateTime cd lt
where
cd = CalendarDate days d m y
(y, m, d) = daysToYearMonthDay days
lt = LocalTime secs nsecs
toUnadjustedInstant (CalendarDateTime (CalendarDate days _ _ _) (LocalTime secs nsecs)) = Instant days secs nsecs
fromWeekDate :: Int -> DayOfWeek Gregorian -> WeekNumber -> DayOfWeek Gregorian -> Year -> Maybe (Date Gregorian)
fromWeekDate minWeekDays wkStartDoW weekNum dow y = do
guard $ days > invalidDayThresh
return $ CalendarDate days d m y'
where
soyDays = yearMonthDayToDays y January minWeekDays
soyDoW = dayOfWeekFromDays soyDays
startDoWDistance = fromEnum soyDoW - fromEnum wkStartDoW
dowDistance = fromEnum dow - fromEnum wkStartDoW
dowDistance' = if dowDistance < 0 then dowDistance + 7 else dowDistance
startDays = soyDays - startDoWDistance
weekNum' = pred weekNum
days = fromIntegral $ startDays + weekNum' * 7 + dowDistance'
(y', m, d) = daysToYearMonthDay days
nthDayToDayOfMonth :: Int -> Int -> Month Gregorian -> Int -> Int
nthDayToDayOfMonth nth day month y = dom + d' + 7 * nth
where
mdm = maxDaysInMonth month y
dom = if nth < 0 then mdm else 1
m = fromEnum month
dow = (dom + (13 * m' - 1) `div` 5 + yrhs + (yrhs `div` 4) + (ylhs `div` 4) - 2 * ylhs) `mod` 7
d = day - dow
d' = if d < 0 then d + 7 else d
(m', y') = if m < 2 then (m + 11, y - 1) else (m - 1, y)
yrhs = y' `mod` 100
ylhs = y' `div` 100
dayOfWeekFromDays :: Int -> Int
dayOfWeekFromDays = normalize . (fromEnum epochDayOfWeek +) . flip mod 7
where
normalize n = if n >= 7 then n - 7 else n
moveByDow :: Int -> DayOfWeek Gregorian -> (Int -> Int -> Int) -> (Int -> Int -> Int) -> Int -> CalendarDate Gregorian
moveByDow n dow distanceF adjust days = CalendarDate days' d m y
where
currentDoW = dayOfWeekFromDays days
targetDow = fromIntegral . fromEnum $ dow
distance = distanceF targetDow currentDoW
days' = fromIntegral $ fromIntegral days `adjust` (7 * n) `adjust` distance
(y, m, d) = daysToYearMonthDay days'
maxDaysInMonth :: Month Gregorian -> Year -> Int
maxDaysInMonth February y
| isLeap = 29
| otherwise = 28
where
isLeap
| 0 == y `mod` 100 = 0 == y `mod` 400
| otherwise = 0 == y `mod` 4
maxDaysInMonth m _
| m == April || m == June || m == September || m == November = 30
| otherwise = 31
yearMonthDayToDays :: Year -> Month Gregorian -> DayOfMonth -> Int
yearMonthDayToDays y m d = days
where
m' = if m > February then fromEnum m - 2 else fromEnum m + 10
years = if m < March then y - 2001 else y - 2000
yearDays = years * daysPerStandardYear + years `div` 4 + years `div` 400 - years `div` 100
days = yearDays + monthDayOffsets !! m' + d - 1
borders :: (Num a, Eq a) => a -> a -> Bool
borders c x = x == c - 1
calculateCenturyDays :: Int32 -> (Int32, Int32, Bool)
calculateCenturyDays days = (y, centuryDays, isExtraCycleDay)
where
(cycleYears, (cycleDays, isExtraCycleDay)) = flip divMod daysPerCycle >>> (* 400) *** id &&& borders daysPerCycle $ days
(centuryYears, centuryDays) = flip divMod daysPerCentury >>> first (* 100) $ cycleDays
y = cycleYears + centuryYears
daysToYearMonthDay :: Int32 -> (Word32, Word8, Word8)
daysToYearMonthDay days = (fromIntegral y, fromIntegral m'', fromIntegral d')
where
(centuryYears, centuryDays, isExtraCycleDay) = calculateCenturyDays days
(fourYears, (remaining, isLeapDay)) = flip divMod daysPerFourYears >>> (* 4) *** id &&& borders daysPerFourYears $ centuryDays
(oneYears, yearDays) = remaining `divMod` daysPerStandardYear
m = pred . fromJust . findIndex (\mo -> yearDays < mo) $ monthDayOffsets
(m', startDate) = if m >= 10 then (m - 10, 2001) else (m + 2, 2000)
d = yearDays - monthDayOffsets !! m + 1
(m'', d') = if isExtraCycleDay || isLeapDay then (1, 29) else (m', d)
y = startDate + centuryYears + fourYears + oneYears
_daysToYearMonthDay' :: Int32 -> (Int32, Int8, Int8)
_daysToYearMonthDay' days = (y',m'', fromIntegral d')
where
(centuryYears, centuryDays, isExtraCycleDay) = calculateCenturyDays days
decodeEntry (DTCacheTable xs _ _) = (\x -> (decodeYear x, decodeMonth x, decodeDay x)) . (!!) xs
(y,m,d) = decodeEntry cacheTable . fromIntegral $ centuryDays
(m',d') = if isExtraCycleDay then (1,29) else (m,d)
(y',m'') = (2000 + centuryYears + fromIntegral y, fromIntegral $ m')
instantToYearMonthDay :: Instant -> (Word32, Word8, Word8)
instantToYearMonthDay (Instant days _ _) = daysToYearMonthDay days