module Data.Thyme.Calendar.Internal where
import Prelude
import Control.Applicative
import Control.DeepSeq
import Control.Lens
import Control.Monad
import Data.AffineSpace
import Data.Data
import Data.Int
import Data.Ix
import Data.Thyme.Format.Internal
import Data.Vector.Unboxed (Vector)
import qualified Data.Vector.Unboxed as V
type Years = Int
type Months = Int
type Days = Int
newtype Day = ModifiedJulianDay
{ toModifiedJulianDay :: Int64
} deriving (Eq, Ord, Enum, Ix, Bounded, NFData, Data, Typeable)
instance AffineSpace Day where
type Diff Day = Days
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 :: Iso' Day OrdinalDate
ordinalDate = iso toOrd fromOrd where
toOrd :: Day -> OrdinalDate
toOrd (ModifiedJulianDay mjd) = OrdinalDate
(fromIntegral year) (fromIntegral yd) where
a = mjd + 678575
(quadcent, b) = divMod a 146097
cent = min (div b 36524) 3
c = b cent * 36524
(quad, d) = divMod 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
monthLengths, monthLengthsLeap :: Vector Days
monthLengths = V.fromList [31,28,31,30,31,30,31,31,30,31,30,31]
monthLengthsLeap = V.fromList [31,29,31,30,31,30,31,31,30,31,30,31]
monthDays :: Vector (Int8, Int8)
monthDays = V.generate 365 go where
first = V.prescanl' (+) 0 monthLengths
go yd = (fromIntegral m, fromIntegral d) where
m = maybe 12 id $ V.findIndex (yd <) first
d = succ yd V.unsafeIndex first (pred m)
monthDaysLeap :: Vector (Int8, Int8)
monthDaysLeap = V.generate 366 go where
first = V.prescanl' (+) 0 monthLengthsLeap
go yd = (fromIntegral m, fromIntegral d) where
m = maybe 12 id $ V.findIndex (yd <) first
d = succ yd V.unsafeIndex first (pred m)
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 :: Iso' Day WeekDate
weekDate = iso toWeek fromWeek where
toWeek :: Day -> WeekDate
toWeek = join (toWeekOrdinal . view ordinalDate)
fromWeek :: WeekDate -> Day
fromWeek wd@(WeekDate y _ _) = fromWeekLast (lastWeekOfYear y) wd
toWeekOrdinal :: OrdinalDate -> Day -> WeekDate
toWeekOrdinal (OrdinalDate y0 yd) (ModifiedJulianDay mjd) = WeekDate y1
(fromIntegral $ w1 + 1) (fromIntegral $ d7mod + 1) where
d = mjd + 2
(d7div, d7mod) = divMod d 7
foo :: Year -> Int64
foo y = bar $ review ordinalDate (OrdinalDate y 6)
bar :: Day -> Int64
bar (ModifiedJulianDay k) = d7div 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)
lastWeekOfYear :: Year -> WeekOfYear
lastWeekOfYear y = if wdWeek wd == 53 then 53 else 52 where
wd = view (from ordinalDate . weekDate) (OrdinalDate y 365)
fromWeekLast :: WeekOfYear -> WeekDate -> Day
fromWeekLast wMax (WeekDate y w d) = ModifiedJulianDay mjd where
ModifiedJulianDay k = review ordinalDate (OrdinalDate y 6)
mjd = k mod k 7 10 + clip 1 7 (fromIntegral d)
+ fromIntegral (clip 1 wMax w) * 7
clip a b = max a . min b
weekDateValid :: WeekDate -> Maybe Day
weekDateValid wd@(WeekDate (lastWeekOfYear -> wMax) w d) =
fromWeekLast wMax wd <$ guard (1 <= d && d <= 7 && 1 <= w && w <= wMax)
showWeekDate :: Day -> String
showWeekDate (view weekDate -> WeekDate y w d) =
showsYear y . (++) "-W" . shows02 w . (:) '-' . shows d $ ""
data SundayWeek = SundayWeek
{ swYear :: !Year
, swWeek :: !WeekOfYear
, swDay :: !DayOfWeek
} deriving (Eq, Ord, Data, Typeable, Show)
instance NFData SundayWeek
sundayWeek :: Iso' Day SundayWeek
sundayWeek = iso toSunday fromSunday where
toSunday :: Day -> SundayWeek
toSunday = join (toSundayOrdinal . view ordinalDate)
fromSunday :: SundayWeek -> Day
fromSunday (SundayWeek y w d) = ModifiedJulianDay (firstDay + yd) where
ModifiedJulianDay firstDay = review ordinalDate (OrdinalDate y 1)
firstSunday = mod (4 firstDay) 7
yd = firstSunday + 7 * (fromIntegral w 1) + fromIntegral d
toSundayOrdinal :: OrdinalDate -> Day -> SundayWeek
toSundayOrdinal (OrdinalDate y yd) (ModifiedJulianDay mjd) = SundayWeek y
(fromIntegral $ d7div div k 7) (fromIntegral d7mod) where
d = mjd + 3
k = d fromIntegral yd
(d7div, d7mod) = divMod d 7
sundayWeekValid :: SundayWeek -> Maybe Day
sundayWeekValid (SundayWeek y w d) = ModifiedJulianDay (firstDay + yd)
<$ guard (0 <= d && d <= 6 && 0 <= yd && yd <= lastDay) where
ModifiedJulianDay firstDay = review ordinalDate (OrdinalDate y 1)
firstSunday = mod (4 firstDay) 7
yd = firstSunday + 7 * (fromIntegral w 1) + fromIntegral d
lastDay = if isLeapYear y then 365 else 364
data MondayWeek = MondayWeek
{ mwYear :: !Year
, mwWeek :: !WeekOfYear
, mwDay :: !DayOfWeek
} deriving (Eq, Ord, Data, Typeable, Show)
instance NFData MondayWeek
mondayWeek :: Iso' Day MondayWeek
mondayWeek = iso toMonday fromMonday where
toMonday :: Day -> MondayWeek
toMonday = join (toMondayOrdinal . view ordinalDate)
fromMonday :: MondayWeek -> Day
fromMonday (MondayWeek y w d) = ModifiedJulianDay (firstDay + yd) where
ModifiedJulianDay firstDay = review ordinalDate (OrdinalDate y 1)
firstMonday = mod (5 firstDay) 7
yd = firstMonday + 7 * (fromIntegral w 1) + fromIntegral d 1
toMondayOrdinal :: OrdinalDate -> Day -> MondayWeek
toMondayOrdinal (OrdinalDate y yd) (ModifiedJulianDay mjd) = MondayWeek y
(fromIntegral $ d7div div k 7) (fromIntegral $ d7mod + 1) where
d = mjd + 2
k = d fromIntegral yd
(d7div, d7mod) = divMod d 7
mondayWeekValid :: MondayWeek -> Maybe Day
mondayWeekValid (MondayWeek y w d) = ModifiedJulianDay (firstDay + yd)
<$ guard (1 <= d && d <= 7 && 0 <= yd && yd <= lastDay) where
ModifiedJulianDay firstDay = review ordinalDate (OrdinalDate y 1)
firstMonday = mod (5 firstDay) 7
yd = firstMonday + 7 * (fromIntegral w 1) + fromIntegral d 1
lastDay = if isLeapYear y then 365 else 364