{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
module Data.HodaTime.Calendar.Internal
(
  mkCommonDaySetter
  ,mkCommonMonthSetter
  ,mkYearSetter
  ,mkFromNthDay
  ,mkFromWeekDate
  ,moveByDow
  ,dayOfWeekFromDays
  ,commonMonthDayOffsets
  ,borders
  ,daysPerStandardYear
  ,daysPerFourYears
  ,daysPerCentury
)
where

import Data.HodaTime.CalendarDateTime.Internal (Year, DayOfMonth, DayNth, WeekNumber)
import Data.Int (Int32)
import Data.Word (Word8)
import Control.Arrow ((>>>), first)
import Control.Monad (guard)

-- Constants

daysPerStandardYear :: Num a => a
daysPerStandardYear :: forall a. Num a => a
daysPerStandardYear = a
365

daysPerFourYears :: Num a => a
daysPerFourYears :: forall a. Num a => a
daysPerFourYears = a
1461

daysPerCentury :: Num a => a
daysPerCentury :: forall a. Num a => a
daysPerCentury = a
36524

-- helper functions
--
-- NOTE: These are representation-agnostic: each calendar passes its own @fromDays@ (build a date from a flat
-- epoch-relative day count) and @toYmd@ (decode a date to year\/month\/day) so the same setter logic works whether
-- the calendar stores a flat day count, a packed cycle, or anything else.

mkCommonDaySetter :: Enum mon =>
     Int
  -> (Year -> mon -> DayOfMonth -> Int)
  -> (Int32 -> d)
  -> (d -> (Int32, Word8, Word8))
  -> DayOfMonth
  -> d
  -> d
mkCommonDaySetter :: forall mon d.
Enum mon =>
Int
-> (Int -> mon -> Int -> Int)
-> (Int32 -> d)
-> (d -> (Int32, Word8, Word8))
-> Int
-> d
-> d
mkCommonDaySetter Int
preStartDay Int -> mon -> Int -> Int
yearMonthDayToDays Int32 -> d
fromDays d -> (Int32, Word8, Word8)
toYmd Int
newDay d
date = Int -> d
mkcd (Int
rest Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
newDay)
    where
      (Int32
y, Word8
m, Word8
_) = d -> (Int32, Word8, Word8)
toYmd d
date
      rest :: Int
rest = Int -> Int
forall a. Enum a => a -> a
pred (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int -> mon -> Int -> Int
yearMonthDayToDays (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
y) (Int -> mon
forall a. Enum a => Int -> a
toEnum (Int -> mon) -> (Word8 -> Int) -> Word8 -> mon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> mon) -> Word8 -> mon
forall a b. (a -> b) -> a -> b
$ Word8
m) Int
1
      mkcd :: Int -> d
mkcd Int
days = Int32 -> d
fromDays Int32
days'
        where days' :: Int32
days' = Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> Int -> Int32
forall a b. (a -> b) -> a -> b
$ if Int
days Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
preStartDay then Int
days else Int
preStartDay Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
{-# INLINE mkCommonDaySetter #-}

mkCommonMonthSetter :: Enum mon =>
     Int
  -> (Int, Int, Word8)
  -> (mon -> Year -> Int)
  -> (Year -> mon -> DayOfMonth -> Int)
  -> (d -> (Int32, Word8, Word8))
  -> (Int32 -> d)
  -> Int
  -> d
  -> d
mkCommonMonthSetter :: forall mon d.
Enum mon =>
Int
-> (Int, Int, Word8)
-> (mon -> Int -> Int)
-> (Int -> mon -> Int -> Int)
-> (d -> (Int32, Word8, Word8))
-> (Int32 -> d)
-> Int
-> d
-> d
mkCommonMonthSetter Int
monthsPerYear (Int, Int, Word8)
firstDayTuple mon -> Int -> Int
maxDaysInMonth Int -> mon -> Int -> Int
yearMonthDayToDays d -> (Int32, Word8, Word8)
toYmd Int32 -> d
fromDays Int
newMonth d
date = Int -> d
mkcd Int
newMonth
    where
      (Int32
y, Word8
_, Word8
d) = d -> (Int32, Word8, Word8)
toYmd d
date
      mkcd :: Int -> d
mkcd Int
months = Int32 -> d
fromDays (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
days)
        where
          (Int
y', Int
months') = (Int -> Int -> (Int, Int)) -> Int -> Int -> (Int, Int)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
divMod Int
monthsPerYear (Int -> (Int, Int))
-> ((Int, Int) -> (Int, Int)) -> Int -> (Int, Int)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (Int -> Int) -> (Int, Int) -> (Int, Int)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
y) (Int -> (Int, Int)) -> Int -> (Int, Int)
forall a b. (a -> b) -> a -> b
$ Int
months
          (Int
y'', Int
m', Word8
d') = if (Int
y', Int
months', Word8
d) (Int, Int, Word8) -> (Int, Int, Word8) -> Bool
forall a. Ord a => a -> a -> Bool
< (Int, Int, Word8)
firstDayTuple then (Int, Int, Word8)
firstDayTuple else (Int
y', Int
months', Word8
d)
          mdim :: Word8
mdim = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ mon -> Int -> Int
maxDaysInMonth (Int -> mon
forall a. Enum a => Int -> a
toEnum Int
m') Int
y'
          d'' :: Word8
d'' = if Word8
d' Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
mdim then Word8
mdim else Word8
d'
          days :: Int
days = Int -> mon -> Int -> Int
yearMonthDayToDays Int
y'' (Int -> mon
forall a. Enum a => Int -> a
toEnum Int
m') (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
d'')
{-# INLINE mkCommonMonthSetter #-}

mkYearSetter :: Enum mon =>
     (Int, Word8, Word8)
  -> (mon -> Year -> Int)
  -> (Year -> mon -> DayOfMonth -> Int)
  -> (d -> (Int32, Word8, Word8))
  -> (Int32 -> d)
  -> Int
  -> d
  -> d
mkYearSetter :: forall mon d.
Enum mon =>
(Int, Word8, Word8)
-> (mon -> Int -> Int)
-> (Int -> mon -> Int -> Int)
-> (d -> (Int32, Word8, Word8))
-> (Int32 -> d)
-> Int
-> d
-> d
mkYearSetter (Int, Word8, Word8)
firstDayTuple mon -> Int -> Int
maxDaysInMonth Int -> mon -> Int -> Int
yearMonthDayToDays d -> (Int32, Word8, Word8)
toYmd Int32 -> d
fromDays Int
newYear d
date = Int -> d
mkcd Int
newYear
    where
      (Int32
_, Word8
m, Word8
d) = d -> (Int32, Word8, Word8)
toYmd d
date
      mkcd :: Int -> d
mkcd Int
y' = Int32 -> d
fromDays Int32
days
        where
          (Int
y'', Word8
m', Word8
d') = if (Int
y', Word8
m, Word8
d) (Int, Word8, Word8) -> (Int, Word8, Word8) -> Bool
forall a. Ord a => a -> a -> Bool
< (Int, Word8, Word8)
firstDayTuple then (Int, Word8, Word8)
firstDayTuple else (Int
y', Word8
m, Word8
d)
          m'' :: mon
m'' = Int -> mon
forall a. Enum a => Int -> a
toEnum (Int -> mon) -> (Word8 -> Int) -> Word8 -> mon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> mon) -> Word8 -> mon
forall a b. (a -> b) -> a -> b
$ Word8
m'
          mdim :: Word8
mdim = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ mon -> Int -> Int
maxDaysInMonth mon
m'' Int
y''
          d'' :: Word8
d'' = if Word8
d' Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
mdim then Word8
mdim else Word8
d'
          days :: Int32
days = Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> Int -> Int32
forall a b. (a -> b) -> a -> b
$ Int -> mon -> Int -> Int
yearMonthDayToDays Int
y'' mon
m'' (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
d'')
{-# INLINE mkYearSetter #-}

-- | Build a date from the nth (or nth-from-last) weekday within a month (e.g. \"the third Monday\").  This is the
--   calendar-agnostic core of a per-calendar @fromNthDay@: it reads the weekday of the anchor day (the 1st, or the
--   last day of the month for a \"from last\" request) via the calendar's own day count, so it needs no per-calendar
--   weekday formula.
mkFromNthDay :: (Enum mon, Enum dow) =>
     Int                                   -- ^ invalid-day threshold (dates on or before this are rejected)
  -> dow                                   -- ^ epoch day of week
  -> (Year -> mon -> DayOfMonth -> Int)    -- ^ yearMonthDayToDays
  -> (mon -> Year -> Int)                  -- ^ maxDaysInMonth
  -> (Int32 -> d)                          -- ^ fromDays
  -> DayNth -> dow -> mon -> Year -> Maybe d
mkFromNthDay :: forall mon dow d.
(Enum mon, Enum dow) =>
Int
-> dow
-> (Int -> mon -> Int -> Int)
-> (mon -> Int -> Int)
-> (Int32 -> d)
-> DayNth
-> dow
-> mon
-> Int
-> Maybe d
mkFromNthDay Int
invalidDayThresh dow
epochDayOfWeek Int -> mon -> Int -> Int
yearMonthDayToDays mon -> Int -> Int
maxDaysInMonth Int32 -> d
fromDays DayNth
nth dow
dow mon
m Int
y = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
mdim
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int
days Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
invalidDayThresh
  d -> Maybe d
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (d -> Maybe d) -> d -> Maybe d
forall a b. (a -> b) -> a -> b
$ Int32 -> d
fromDays (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
days)
    where
      nth' :: Int
nth' = DayNth -> Int
forall a. Enum a => a -> Int
fromEnum DayNth
nth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4
      mdim :: Int
mdim = mon -> Int -> Int
maxDaysInMonth mon
m Int
y
      target :: Int
target = dow -> Int
forall a. Enum a => a -> Int
fromEnum dow
dow
      -- forward (nth' >= 0) counts from the first of the month; \"from last\" (nth' < 0) counts back from the last day.
      -- Using the backward distance for the from-last case is what makes \"the last Friday\" land on the final Friday
      -- even when the month ends exactly on that weekday (where a naive forward offset would be a week short).
      d :: Int
d | Int
nth' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0  = Int
mdim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
backwardDist Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Int
nth' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        | Bool
otherwise = Int
1    Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
forwardDist  Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
nth'
      forwardDist :: Int
forwardDist  = (Int
target Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int
dowOf Int
1)    Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
7
      backwardDist :: Int
backwardDist = (Int -> Int
dowOf Int
mdim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
target) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
7
      dowOf :: Int -> Int
dowOf Int
dom = dow -> Int -> Int
forall dow. Enum dow => dow -> Int -> Int
dayOfWeekFromDays dow
epochDayOfWeek (Int -> mon -> Int -> Int
yearMonthDayToDays Int
y mon
m Int
dom)
      days :: Int
days = Int -> mon -> Int -> Int
yearMonthDayToDays Int
y mon
m Int
d
{-# INLINE mkFromNthDay #-}

-- | Build a date from a week-numbering rule.  @minWeekDays@ and @weekStart@ define the rule (e.g. @1 Sunday@ for the
--   simple rule where week 1 is the first week with any day in the new year, or @4 Monday@ for ISO-8601).  This is the
--   calendar-agnostic core of a per-calendar @fromWeekDate@.
mkFromWeekDate :: (Enum mon, Enum dow) =>
     Int                                   -- ^ invalid-day threshold
  -> dow                                   -- ^ epoch day of week
  -> (Year -> mon -> DayOfMonth -> Int)    -- ^ yearMonthDayToDays
  -> (Int32 -> d)                          -- ^ fromDays
  -> Int                                   -- ^ minimum days of the new year that fall in week 1
  -> dow                                   -- ^ first day of the week
  -> WeekNumber -> dow -> Year -> Maybe d
mkFromWeekDate :: forall mon dow d.
(Enum mon, Enum dow) =>
Int
-> dow
-> (Int -> mon -> Int -> Int)
-> (Int32 -> d)
-> Int
-> dow
-> Int
-> dow
-> Int
-> Maybe d
mkFromWeekDate Int
invalidDayThresh dow
epochDayOfWeek Int -> mon -> Int -> Int
yearMonthDayToDays Int32 -> d
fromDays Int
minWeekDays dow
wkStartDoW Int
weekNum dow
dow Int
y = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int
days Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
invalidDayThresh
  d -> Maybe d
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (d -> Maybe d) -> d -> Maybe d
forall a b. (a -> b) -> a -> b
$ Int32 -> d
fromDays (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
days)
    where
      soyDays :: Int
soyDays = Int -> mon -> Int -> Int
yearMonthDayToDays Int
y (Int -> mon
forall a. Enum a => Int -> a
toEnum Int
0) Int
minWeekDays
      soyDoW :: Int
soyDoW = dow -> Int -> Int
forall dow. Enum dow => dow -> Int -> Int
dayOfWeekFromDays dow
epochDayOfWeek Int
soyDays
      startDoWDistance :: Int
startDoWDistance = Int
soyDoW Int -> Int -> Int
forall a. Num a => a -> a -> a
- dow -> Int
forall a. Enum a => a -> Int
fromEnum dow
wkStartDoW
      dowDistance :: Int
dowDistance = dow -> Int
forall a. Enum a => a -> Int
fromEnum dow
dow Int -> Int -> Int
forall a. Num a => a -> a -> a
- dow -> Int
forall a. Enum a => a -> Int
fromEnum dow
wkStartDoW
      dowDistance' :: Int
dowDistance' = if Int
dowDistance Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Int
dowDistance Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7 else Int
dowDistance
      startDays :: Int
startDays = Int
soyDays Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
startDoWDistance
      days :: Int
days = Int
startDays Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int
forall a. Enum a => a -> a
pred Int
weekNum Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dowDistance'
{-# INLINE mkFromWeekDate #-}

moveByDow :: Enum dow =>
     (Int32 -> d)
  -> dow
  -> Int
  -> dow
  -> (Int -> Int -> Int)
  -> (Int -> Int -> Int)
  -> (Int -> Int -> Bool)
  -> Int
  -> d
moveByDow :: forall dow d.
Enum dow =>
(Int32 -> d)
-> dow
-> Int
-> dow
-> (Int -> Int -> Int)
-> (Int -> Int -> Int)
-> (Int -> Int -> Bool)
-> Int
-> d
moveByDow Int32 -> d
fromDays dow
epochDayOfWeek Int
n dow
dow Int -> Int -> Int
distanceF Int -> Int -> Int
adjust Int -> Int -> Bool
cmp Int
days = Int32 -> d
fromDays Int32
days'
  where
    n' :: Int
n' = if Int
targetDow Int -> Int -> Bool
`cmp` Int
currentDoW then Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1 else Int
n
    currentDoW :: Int
currentDoW = dow -> Int -> Int
forall dow. Enum dow => dow -> Int -> Int
dayOfWeekFromDays dow
epochDayOfWeek Int
days
    targetDow :: Int
targetDow = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> (dow -> Int) -> dow -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. dow -> Int
forall a. Enum a => a -> Int
fromEnum (dow -> Int) -> dow -> Int
forall a b. (a -> b) -> a -> b
$ dow
dow
    distance :: Int
distance = Int -> Int -> Int
distanceF Int
targetDow Int
currentDoW
    days' :: Int32
days' = Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> Int -> Int32
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
days Int -> Int -> Int
`adjust` (Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n') Int -> Int -> Int
`adjust` Int
distance

dayOfWeekFromDays :: Enum dow => dow -> Int -> Int
dayOfWeekFromDays :: forall dow. Enum dow => dow -> Int -> Int
dayOfWeekFromDays dow
epochDayOfWeek = Int -> Int
forall {a}. (Ord a, Num a) => a -> a
normalize (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (dow -> Int
forall a. Enum a => a -> Int
fromEnum dow
epochDayOfWeek Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int) -> Int -> Int -> Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
7
  where
    normalize :: a -> a
normalize a
n = if a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
7 then a
n a -> a -> a
forall a. Num a => a -> a -> a
- a
7 else a
n

commonMonthDayOffsets :: Num a => [a]
commonMonthDayOffsets :: forall a. Num a => [a]
commonMonthDayOffsets = a
0 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
rest
  where
    rest :: [a]
rest = (a -> a -> a) -> [a] -> [a] -> [a]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith a -> a -> a
forall a. Num a => a -> a -> a
(+) [a]
daysPerMonth (a
0a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
rest)
    daysPerMonth :: [a]
daysPerMonth = [a
31, a
30, a
31, a
30, a
31, a
31, a
30, a
31, a
30, a
31, a
31]

-- | The issue is that 4 * daysPerCentury will be one less than daysPerCycle.  The reason for this is that the Gregorian calendar adds one more day per 400 year cycle
--   and this day is missing from adding up 4 individual centuries.  We have the same issue again with 4 years (i.e. 365*4 is daysPerFourYears - 1)
--   so we use this function to check if this has occurred so we can add the missing day back in.
borders :: (Num a, Eq a) => a -> a -> Bool
borders :: forall a. (Num a, Eq a) => a -> a -> Bool
borders a
c a
x = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
c a -> a -> a
forall a. Num a => a -> a -> a
- a
1