#include "thyme.h"
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
import System.Random
import Test.QuickCheck
type Years = Int
type Months = Int
type Days = Int
newtype Day = ModifiedJulianDay
{ toModifiedJulianDay :: Int
} deriving (INSTANCES_NEWTYPE)
instance AffineSpace Day where
type Diff Day = Days
ModifiedJulianDay a .-. ModifiedJulianDay b = a b
ModifiedJulianDay a .+^ d = ModifiedJulianDay (a + d)
modifiedJulianDay :: Iso' Day Int
modifiedJulianDay = iso toModifiedJulianDay ModifiedJulianDay
yearMonthDay :: Iso' OrdinalDate YearMonthDay
yearMonthDay = iso fromOrdinal toOrdinal where
fromOrdinal :: OrdinalDate -> YearMonthDay
fromOrdinal (OrdinalDate y yd) = YearMonthDay y m d where
MonthDay m d = yd ^. monthDay (isLeapYear y)
toOrdinal :: YearMonthDay -> OrdinalDate
toOrdinal (YearMonthDay y m d) = OrdinalDate y $
monthDay (isLeapYear y) # MonthDay m d
gregorian :: Iso' Day YearMonthDay
gregorian = ordinalDate . yearMonthDay
gregorianValid :: YearMonthDay -> Maybe Day
gregorianValid (YearMonthDay y m d) = review ordinalDate . OrdinalDate y
<$> monthDayValid (isLeapYear y) (MonthDay m d)
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
type Year = Int
type Month = Int
type DayOfMonth = Int
data YearMonthDay = YearMonthDay
{ ymdYear :: !Year
, ymdMonth :: !Month
, ymdDay :: !DayOfMonth
} deriving (INSTANCES_USUAL, 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 (INSTANCES_USUAL, Show)
instance NFData OrdinalDate
ordinalDate :: Iso' Day OrdinalDate
ordinalDate = iso toOrd fromOrd where
toOrd :: Day -> OrdinalDate
toOrd (ModifiedJulianDay mjd) = OrdinalDate year 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 = year 1
mjd = 365 * y + div y 4 div y 100 + div y 400 678576
+ clip 1 (if isLeapYear year then 366 else 365) 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)
randomIsoR :: (Random s, RandomGen g) => Iso' s a -> (a, a) -> g -> (a, g)
randomIsoR l r = over _1 (^. l) . randomR (over both (l #) r)
data MonthDay = MonthDay
{ mdMonth :: !Month
, mdDay :: !DayOfMonth
} deriving (INSTANCES_USUAL, Show)
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)
monthDay :: Bool -> 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)
fromOrdinal :: DayOfYear -> MonthDay
fromOrdinal (max 0 . min lastDay . pred -> i) = MonthDay m d where
(fromIntegral -> m, fromIntegral -> d) = V.unsafeIndex table i
toOrdinal :: MonthDay -> DayOfYear
toOrdinal (MonthDay month day) = div (367 * m 362) 12 + k + d where
m = max 1 . min 12 $ month
l = V.unsafeIndex lengths (pred m)
d = max 1 . min l $ day
k = if m <= 2 then 0 else ok
monthDayValid :: Bool -> MonthDay -> Maybe DayOfYear
monthDayValid leap md@(MonthDay m d) = monthDay leap # md
<$ guard (1 <= m && m <= 12 && 1 <= d && d <= monthLength leap m)
monthLength :: Bool -> Month -> Days
monthLength leap = V.unsafeIndex ls . max 0 . min 11 . pred where
ls = if leap then monthLengthsLeap else monthLengths
type WeekOfYear = Int
type DayOfWeek = Int
data WeekDate = WeekDate
{ wdYear :: !Year
, wdWeek :: !WeekOfYear
, wdDay :: !DayOfWeek
} deriving (INSTANCES_USUAL, 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 (w1 + 1) (d7mod + 1) where
d = mjd + 2
(d7div, d7mod) = divMod d 7
foo :: Year -> Int
foo y = bar $ ordinalDate # OrdinalDate y 6
bar :: Day -> 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)
lastWeekOfYear :: Year -> WeekOfYear
lastWeekOfYear y = if wdWeek wd == 53 then 53 else 52 where
wd = OrdinalDate y 365 ^. from ordinalDate . weekDate
fromWeekLast :: WeekOfYear -> WeekDate -> Day
fromWeekLast wMax (WeekDate y w d) = ModifiedJulianDay mjd where
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
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 (INSTANCES_USUAL, 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 = ordinalDate # OrdinalDate y 1
firstSunday = mod (4 firstDay) 7
yd = firstSunday + 7 * (w 1) + d
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
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
firstSunday = mod (4 firstDay) 7
yd = firstSunday + 7 * (w 1) + d
lastDay = if isLeapYear y then 365 else 364
data MondayWeek = MondayWeek
{ mwYear :: !Year
, mwWeek :: !WeekOfYear
, mwDay :: !DayOfWeek
} deriving (INSTANCES_USUAL, 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 = ordinalDate # OrdinalDate y 1
firstMonday = mod (5 firstDay) 7
yd = firstMonday + 7 * (w 1) + d 1
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
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
firstMonday = mod (5 firstDay) 7
yd = firstMonday + 7 * (w 1) + d 1
lastDay = if isLeapYear y then 365 else 364