thyme-0.4: src/Data/Thyme/Calendar/OrdinalDate.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

#include "thyme.h"
#if HLINT
#include "cabal_macros.h"
#endif

-- | ISO 8601 Ordinal Date format
module Data.Thyme.Calendar.OrdinalDate
    ( Year, isLeapYear
    , DayOfYear
    , OrdinalDate (..), _odYear, _odDay
    , ordinalDate
    , module Data.Thyme.Calendar.OrdinalDate
    ) where

import Prelude
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import Control.Arrow
import Control.Lens
import Control.Monad
import Data.Thyme.Calendar
import Data.Thyme.Calendar.Internal
import System.Random
import Test.QuickCheck

instance Bounded OrdinalDate where
    minBound = minBound ^. ordinalDate
    maxBound = maxBound ^. ordinalDate

instance Random OrdinalDate where
    randomR = randomIsoR ordinalDate
    random = first (^. ordinalDate) . random

instance Arbitrary OrdinalDate where
    arbitrary = view ordinalDate <$> arbitrary
    shrink od = view ordinalDate <$> shrink (ordinalDate # od)

instance CoArbitrary OrdinalDate where
    coarbitrary (OrdinalDate y d) = coarbitrary y . coarbitrary d

-- | Convert an 'OrdinalDate' to a 'Day', or 'Nothing' for invalid input.
--
-- @
-- > 'ordinalDateValid' ('OrdinalDate' 2015 365)
-- 'Just' 2015-12-31
--
-- > 'ordinalDateValid' ('OrdinalDate' 2015 366)
-- 'Nothing'
--
-- > 'ordinalDateValid' ('OrdinalDate' 2016 366)
-- 'Just' 2016-12-31
-- @
{-# INLINE ordinalDateValid #-}
ordinalDateValid :: OrdinalDate -> Maybe Day
ordinalDateValid od@(OrdinalDate y d) = ordinalDate # od
    <$ guard (1 <= d && d <= if isLeapYear y then 366 else 365)

-- * Compatibility

{-# INLINE toOrdinalDate #-}
-- | Convert a 'Day' to its Gregorian 'Year' and 'DayOfYear'.
--
-- @
-- 'toOrdinalDate' ('view' 'ordinalDate' -> 'OrdinalDate' y d) = (y, d)
-- @
toOrdinalDate :: Day -> (Year, DayOfYear)
toOrdinalDate (view ordinalDate -> OrdinalDate y d) = (y, d)

-- | Convert a Gregorian 'Year' and 'DayOfYear' to a 'Day'.
-- Does not validate the input.
--
-- @
-- 'fromOrdinalDate' y d = 'ordinalDate' 'Control.Lens.#' 'OrdinalDate' y d
-- @
{-# INLINE fromOrdinalDate #-}
fromOrdinalDate :: Year -> DayOfYear -> Day
fromOrdinalDate y d = ordinalDate # OrdinalDate y d

-- | Converts a Gregorian 'Year' and 'DayOfYear' to a 'Day'.
-- Returns 'Nothing' on invalid input.
--
-- @
-- 'fromOrdinalDateValid' y d = 'ordinalDateValid' ('OrdinalDate' y d)
-- @
{-# INLINE fromOrdinalDateValid #-}
fromOrdinalDateValid :: Year -> DayOfYear -> Maybe Day
fromOrdinalDateValid y d = ordinalDateValid (OrdinalDate y d)

-- | Converts a 'Day' to its /Sunday/-starting week date.
--
-- The first /Sunday/ of the year belongs to @1 ∷ 'WeekOfYear'@; earlier
-- days in the same year are week @0@. This corresponds to @\"%U\"@ for
-- 'formatTime'.
--
-- /Sunday/ is @0 ∷ 'DayOfWeek'@, /Saturday/ is @6@. This corresponds to
-- @\"%w\"@ for 'formatTime'.
--
-- @
-- 'sundayStartWeek' ('view' 'sundayWeek' -> 'SundayWeek' y w d) = (y, w, d)
-- @
{-# INLINE sundayStartWeek #-}
sundayStartWeek :: Day -> (Year, WeekOfYear, DayOfWeek)
sundayStartWeek (view sundayWeek -> SundayWeek y w d) = (y, w, d)

-- | Converts a /Sunday/-starting week date to the corresponding 'Day'; the
-- inverse of 'sundayStartWeek'.
-- Does not validate the input.
--
-- @
-- 'fromSundayStartWeek' y w d = 'sundayWeek' 'Control.Lens.#' 'SundayWeek' y w d
-- @
{-# INLINE fromSundayStartWeek #-}
fromSundayStartWeek :: Year -> WeekOfYear -> DayOfWeek -> Day
fromSundayStartWeek y w d = sundayWeek # SundayWeek y w d

-- | Converts a /Sunday/-starting week date to the corresponding 'Day'; the
-- inverse of 'sundayStartWeek'.
-- Returns 'Nothing' for invalid input.
--
-- @
-- 'fromSundayStartWeekValid' y w d = 'sundayWeekValid' ('SundayWeek' y w d)
-- @
{-# INLINE fromSundayStartWeekValid #-}
fromSundayStartWeekValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day
fromSundayStartWeekValid y w d = sundayWeekValid (SundayWeek y w d)

-- | Converts a 'Day' to its /Monday/-starting week date.
--
-- The first /Monday/ of the year belongs to @1 ∷ 'WeekOfYear'@; earlier
-- days in the same year are week @0@. This corresponds to @\"%W\"@ for
-- 'formatTime'.
--
-- /Monday/ is @1 ∷ 'DayOfWeek'@, /Sunday/ is @7@. This corresponds to
-- @\"%u\"@ for 'formatTime'.
--
-- @
-- 'mondayStartWeek' ('view' 'mondayWeek' -> 'MondayWeek' y w d) = (y, w, d)
-- @
{-# INLINE mondayStartWeek #-}
mondayStartWeek :: Day -> (Year, WeekOfYear, DayOfWeek)
mondayStartWeek (view mondayWeek -> MondayWeek y w d) = (y, w, d)

-- | Converts a /Monday/-starting week date to the corresponding 'Day'; the
-- inverse of 'mondayStartWeek'.
-- Does not validate the input.
--
-- @
-- 'fromMondayStartWeek' y w d = 'mondayWeek' 'Control.Lens.#' 'MondayWeek' y w d
-- @
{-# INLINE fromMondayStartWeek #-}
fromMondayStartWeek :: Year -> WeekOfYear -> DayOfWeek -> Day
fromMondayStartWeek y w d = mondayWeek # MondayWeek y w d

-- | Converts a /Monday/-starting week date to the corresponding 'Day'; the
-- inverse of 'mondayStartWeek'.
-- Returns 'Nothing' for invalid input.
--
-- @
-- 'fromMondayStartWeekValid' y w d = 'mondayWeekValid' ('MondayWeek' y w d)
-- @
{-# INLINE fromMondayStartWeekValid #-}
fromMondayStartWeekValid :: Year -> WeekOfYear -> DayOfWeek -> Maybe Day
fromMondayStartWeekValid y w d = mondayWeekValid (MondayWeek y w d)