Julian.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}

#include "thyme.h"

-- | Proleptic Julian Dates
module Data.Thyme.Calendar.Julian
    ( OrdinalDate (..), Year, DayOfYear
    , module Data.Thyme.Calendar.Julian
    , _odYear, _odDay
    ) where

import Prelude
import Control.Applicative
{- import Control.DeepSeq -}
import Control.Monad
import Control.Lens
{- import Data.Data -}
import Data.Thyme.Calendar
import Data.Thyme.Calendar.Internal
import Data.Thyme.Calendar.OrdinalDate
{- import Data.Thyme.TH -}
{- import System.Random -}
{- import Test.QuickCheck -}

{-# INLINE julianOrdinal #-}
julianOrdinal :: Iso' Day OrdinalDate
julianOrdinal = iso toOrdinal fromOrdinal where

    {-# INLINEABLE toOrdinal #-}
    toOrdinal :: Day -> OrdinalDate
    toOrdinal (ModifiedJulianDay mjd) = OrdinalDate {..} where
        (quad, d) = divMod (mjd + 678577) 1461
        yoff = min (div d 365) 3
        odDay = d - (yoff * 365) + 1
        odYear = quad * 4 + yoff + 1

    {-# INLINEABLE fromOrdinal #-}
    fromOrdinal :: OrdinalDate -> Day
    fromOrdinal OrdinalDate {..} = ModifiedJulianDay mjd where
        yd = clip 1 (if isJulianLeapYear odYear then 366 else 365) odDay
        clip a b = max a . min b
        y = odYear - 1
        mjd = yd + 365 * y + div y 4 - 678578

{-# INLINEABLE julianOrdinalValid #-}
julianOrdinalValid :: OrdinalDate -> Maybe Day
julianOrdinalValid OrdinalDate {..} = ModifiedJulianDay mjd
        <$ guard (1 <= odDay && odDay <= lastDay) where
    lastDay = if isJulianLeapYear odYear then 366 else 365
    y = odYear - 1
    mjd = odDay + 365 * y + div y 4 - 678578

{-# INLINE isJulianLeapYear #-}
isJulianLeapYear :: Year -> Bool
isJulianLeapYear y = mod y 4 == 0

------------------------------------------------------------------------

{-# INLINE julianYearMonthDay #-}
julianYearMonthDay :: Iso' OrdinalDate YearMonthDay
julianYearMonthDay = iso fromOrdinal toOrdinal where

    {-# INLINEABLE fromOrdinal #-}
    fromOrdinal :: OrdinalDate -> YearMonthDay
    fromOrdinal OrdinalDate {..} = YearMonthDay odYear m d where
        MonthDay m d = odDay ^. monthDay (isJulianLeapYear odYear)

    {-# INLINEABLE toOrdinal #-}
    toOrdinal :: YearMonthDay -> OrdinalDate
    toOrdinal YearMonthDay {..} = OrdinalDate ymdYear yd where
        yd = monthDay (isJulianLeapYear ymdYear) # MonthDay ymdMonth ymdDay

{-# INLINE julianYearMonthDayValid #-}
julianYearMonthDayValid :: YearMonthDay -> Maybe OrdinalDate
julianYearMonthDayValid YearMonthDay {..} = OrdinalDate ymdYear
    <$> monthDayValid (isJulianLeapYear ymdYear) (MonthDay ymdMonth ymdDay)

------------------------------------------------------------------------

{-# INLINE julian #-}
julian :: Iso' Day YearMonthDay
julian = julianOrdinal . julianYearMonthDay

{-# INLINE julianValid #-}
julianValid :: YearMonthDay -> Maybe Day
julianValid ymd = review julianOrdinal <$> julianYearMonthDayValid ymd