module Data.Thyme.Calendar.Internal where
import Prelude
import Control.DeepSeq
import Control.Lens
import Data.AffineSpace
import Data.Data
import Data.Int
import Data.Ix
newtype Day = ModifiedJulianDay
{ toModifiedJulianDay :: Int64
} deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable)
instance AffineSpace Day where
type Diff Day = Int
ModifiedJulianDay a .-. ModifiedJulianDay b = fromIntegral (a b)
ModifiedJulianDay a .+^ d = ModifiedJulianDay (a + fromIntegral d)
type Year = Int
type Month = Int
type DayOfMonth = Int
data YearMonthDay = YearMonthDay
{ ymdYear :: !Year
, ymdMonth :: !Month
, ymdDay :: !DayOfMonth
} deriving (Eq, Ord, Data, Typeable, Show)
instance NFData YearMonthDay
isLeapYear :: Year -> Bool
isLeapYear y = mod y 4 == 0 && (mod y 400 == 0 || mod y 100 /= 0)
type DayOfYear = Int
data OrdinalDate = OrdinalDate
{ odYear :: !Year
, odDay :: !DayOfYear
} deriving (Eq, Ord, Data, Typeable, Show)
instance NFData OrdinalDate
ordinalDate :: Simple Iso Day OrdinalDate
ordinalDate = iso toOrd fromOrd where
toOrd :: Day -> OrdinalDate
toOrd (ModifiedJulianDay mjd) = OrdinalDate
(fromIntegral year) (fromIntegral yd) where
a = mjd + 678575
quadcent = div a 146097
b = mod a 146097
cent = min (div b 36524) 3
c = b cent * 36524
quad = div c 1461
d = mod c 1461
y = min (div d 365) 3
yd = d y * 365 + 1
year = quadcent * 400 + cent * 100 + quad * 4 + y + 1
fromOrd :: OrdinalDate -> Day
fromOrd (OrdinalDate year yd) = ModifiedJulianDay mjd where
y = fromIntegral (year 1)
mjd = 365 * y + div y 4 div y 100 + div y 400 678576
+ clip 1 (if isLeapYear year then 366 else 365) (fromIntegral yd)
clip a b = max a . min b
type WeekOfYear = Int
type DayOfWeek = Int
data WeekDate = WeekDate
{ wdYear :: !Year
, wdWeek :: !WeekOfYear
, wdDay :: !DayOfWeek
} deriving (Eq, Ord, Data, Typeable, Show)
instance NFData WeekDate
weekDate :: Simple Iso Day WeekDate
weekDate = iso toWeek fromWeek where
toWeek :: Day -> WeekDate
toWeek day@(ModifiedJulianDay mjd) = WeekDate
y1 (fromIntegral $ w1 + 1) (fromIntegral $ mod d 7 + 1) where
OrdinalDate y0 yd = view ordinalDate day
d = mjd + 2
foo :: Year -> Int64
foo y = bar $ review ordinalDate (OrdinalDate y 6)
bar :: Day -> Int64
bar (ModifiedJulianDay k) = div d 7 div k 7
w0 = bar $ ModifiedJulianDay (d fromIntegral yd + 4)
(y1, w1) = case w0 of
1 -> (y0 1, foo (y0 1))
52 | foo (y0 + 1) == 0 -> (y0 + 1, 0)
_ -> (y0, w0)
fromWeek :: WeekDate -> Day
fromWeek wd@(WeekDate y _ _) = fromWeekMax wMax wd where
WeekDate _ wMax _ = toWeek $ review ordinalDate (OrdinalDate y 365)
fromWeekMax :: WeekOfYear -> WeekDate -> Day
fromWeekMax wMax (WeekDate y w d) = ModifiedJulianDay mjd where
ModifiedJulianDay k = review ordinalDate (OrdinalDate y 6)
mjd = k mod k 7 10 + clip 0 7 (fromIntegral d)
+ fromIntegral (clip 0 wMax w) * 7
clip a b = max a . min b