module Data.Time.Recurrence
    (
      -- * The @WeekDay@ type
      WeekDay (..)

      -- * The @Month@ type
    , Month (..)

      -- * The @Moment@ type class
    , Moment (..)

      -- * The @DateTime@ type class
    , DateTime (..)

      -- * The @InitialMoment@ type
    , InitialMoment (..)

    , toInterval
    , toStartOfWeek

    , secondly
    , minutely
    , hourly
    , daily
    , weekly
    , monthly
    , yearly

    , secondlyUTC
    , minutelyUTC
    , hourlyUTC
    , dailyUTC
    , weeklyUTC
    , monthlyUTC
    , yearlyUTC

      -- * Recurrence combinators
    , enumYear
    , enumMonth
    , enumWeek

    , restrict
    , bySeconds
    , byMinutes
    , byHours
    , byWeekDays
    , byMonthDays
    , byMonths
    , byYearDays

    , expand
    , onWeekNumbers
    , onMonths
    , onMonthDays
    , onYearDays

    , onEachWeek
    , onEachMonth
    , onEachYear

    , repeatSchedule
    , repeatSchedule'
    )
  where

import Control.Applicative
import Control.Monad.Reader
import Data.List.Ordered (nubSort)
import Data.Maybe (fromJust, mapMaybe)
import Data.Time
import Data.Time.Calendar.MonthDay (monthLength)
import Data.Time.Calendar.OrdinalDate (toOrdinalDate, fromOrdinalDateValid, fromMondayStartWeekValid, mondayStartWeek)
import Data.Traversable

-- | Symbolic week days.
--
-- Note: The first Day of the Week is Monday 
-- TODO: Move this to a more general library
data WeekDay
    = Monday
    | Tuesday
    | Wednesday
    | Thursday
    | Friday
    | Saturday
    | Sunday
  deriving (Show, Eq, Ord, Enum, Bounded)

-- | Symbolic months.
--
-- TODO: Move this to a more general library
data Month
    = January
    | February
    | March
    | April
    | May
    | June
    | July
    | August
    | September
    | October
    | November
    | December
  deriving (Show, Eq, Ord, Bounded)

instance Enum Month where
  fromEnum January   = 1
  fromEnum February  = 2
  fromEnum March     = 3
  fromEnum April     = 4
  fromEnum May       = 5
  fromEnum June      = 6
  fromEnum July      = 7
  fromEnum August    = 8
  fromEnum September = 9
  fromEnum October   = 10
  fromEnum November  = 11
  fromEnum December  = 12

  toEnum 1  = January
  toEnum 2  = February
  toEnum 3  = March
  toEnum 4  = April
  toEnum 5  = May
  toEnum 6  = June
  toEnum 7  = July
  toEnum 8  = August
  toEnum 9  = September
  toEnum 10 = October
  toEnum 11 = November
  toEnum 12 = December

  toEnum unmatched = error ("Month.toEnum: Cannot match " ++ show unmatched)

-- | @DateTime@ data type
--   This is a componentized version of a time value
--   simmilar to a 'struct tm'
data DateTime = DateTime
    { dtSecond   :: Int
    , dtMinute   :: Int
    , dtHour     :: Int
    , dtDay      :: Int
    , dtMonth    :: Month
    , dtYear     :: Integer
    , dtWeekDay  :: WeekDay
    , dtYearDay  :: Int
    , dtTimeZone :: TimeZone
    }
  deriving (Show)

-- | @Frequency@ data type
data Frequency
    = Seconds
    | Minutes
    | Hours
    | Days
    | Weeks
    | Months
    | Years
  deriving (Show)

newtype Interval = Interval Integer deriving (Show)
newtype StartOfWeek = StartOfWeek { fromStartOfWeek :: WeekDay } deriving (Show)

toInterval :: Integer -> Interval
toInterval = Interval

toStartOfWeek :: WeekDay -> StartOfWeek
toStartOfWeek = StartOfWeek

-- useful time constants
oneSecond :: Integer
oneSecond = 1

oneMinute :: Integer
oneMinute = 60 * oneSecond

oneHour :: Integer
oneHour   = 60 * oneMinute

oneDay :: Integer
oneDay    = 24 * oneHour

oneWeek :: Integer
oneWeek   = 7  * oneDay

-- | The @Moment@ class is for representing a instance in time.
--
-- Instances of @Moment@ can be derived for any user-defined
-- datatype for which can satisfy the minimal complete definition.
--
-- Minimal complete definition: 'epoch', 'toDateTime', 'fromDateTime',
-- 'scaleTime', 'scaleMonth', 'scaleYear', 'alterWeekNumber',
-- 'alterYearDay'

class Moment a where

  -- | Provide a default moment.
  epoch           :: a

  -- | Convert a @Moment@ into a @DateTime@
  toDateTime      :: a -> DateTime

  -- | Convert a @DateTime@ into a @Moment@
  fromDateTime    :: DateTime -> Maybe a

  -- | Produce a new @Moment@ offset by a given number of seconds.
  scaleTime       :: a -> Integer -> a

  -- | Produce a new @Moment@ offset by a given number of months.
  scaleMonth      :: a -> Integer -> a

  -- | Produce a new @Moment@ offset by a given number of years.
  scaleYear       :: a -> Integer -> a

  -- | Possibly produce a new @Moment@ shifted to a different week of the year.
  alterWeekNumber :: StartOfWeek -> a -> Int -> Maybe a

  -- | Possibly produce a new @Moment@ shifted to a different day of the year.
  alterYearDay    :: a -> Int -> Maybe a

  -- | The 'alter*' methods can potentially produce invalid dates.
  -- 
  -- For each user-defined @Moment@ instance the definitions of
  -- 'toDateTime', 'fromDateTime', 'alterWeekNumber' and 'alterYearDay' 
  -- will determine if an altered @Moment@ that lands on an invalid date
  -- in the given calendar will be reduced to @Nothing@

  -- | Possibly produce a new @Moment@ shifted to a different second of the day.
  alterSecond     :: a -> Int -> Maybe a
  alterSecond x s = fromDateTime (toDateTime x){dtSecond = s}

  -- | Possibly produce a new @Moment@ shifted to a different minute of the day.
  alterMinute     :: a -> Int -> Maybe a
  alterMinute x m = fromDateTime (toDateTime x){dtMinute = m}

  -- | Possibly produce a new @Moment@ shifted to a different hour of the day.
  alterHour       :: a -> Int -> Maybe a
  alterHour x h = fromDateTime (toDateTime x){dtHour = h}

  -- | Possibly produce a new @Moment@ shifted to a different day of the month.
  alterDay        :: a -> Int -> Maybe a
  alterDay x d = fromDateTime (toDateTime x){dtDay = d}

  -- | Possibly produce a new @Moment@ shifted to a different month of the year.
  alterMonth      :: a -> Month -> Maybe a
  alterMonth x m = fromDateTime (toDateTime x){dtMonth = m}

  -- | Possibly produce a new @Moment@ shifted to a different year.
  alterYear       :: a -> Integer -> Maybe a
  alterYear x y = fromDateTime (toDateTime x){dtYear = y}

  -- | Produce a new @Moment@ in the future ocurring at (/interval/ * /freq/)
  next :: Interval -> Frequency -> a -> a
  next (Interval interval) freq =
    case freq of
      Seconds -> scale oneSecond
      Minutes -> scale oneMinute
      Hours   -> scale oneHour
      Days    -> scale oneDay
      Weeks   -> scale oneWeek
      Months  -> flip scaleMonth interval
      Years   -> flip scaleYear interval
    where
      scale x = flip scaleTime (interval * x)

  -- | Produce a new @Moment@ in the past ocurring at (-/interval/ * /freq/)
  prev :: Interval -> Frequency -> a -> a
  prev (Interval interval) = next $ Interval (-interval)

-- | The @InitialMoment@ datatype

data InitialMoment a = InitialMoment
    { frequency   :: Frequency
    , interval    :: Interval
    , startOfWeek :: StartOfWeek
    , moment      :: a
    }
  deriving (Show)

mkIM :: Moment a => Frequency -> InitialMoment a
mkIM f = InitialMoment f (toInterval 1) (StartOfWeek Monday) epoch

-- | Default initial moments

secondly :: Moment a => InitialMoment a
secondly = mkIM Seconds

minutely :: Moment a => InitialMoment a
minutely = mkIM Minutes

hourly :: Moment a => InitialMoment a
hourly = mkIM Hours

daily :: Moment a => InitialMoment a
daily = mkIM Days

weekly :: Moment a => InitialMoment a
weekly = mkIM Weeks

monthly :: Moment a => InitialMoment a
monthly = mkIM Months

yearly :: Moment a => InitialMoment a
yearly = mkIM Years

-- | The @Schedule@ datatype

newtype Schedule a = Schedule {fromSchedule :: [a]} deriving (Show, Eq, Ord)

-- | Produce an infinite list from an initial @Moment@ and a step function.
iterateMoments :: Moment a => (a -> a) -> a -> [a]
iterateMoments = iterate

type RecurringSchedule a = Reader (InitialMoment a) (Schedule a)

enumMoments :: Moment a => 
               (Interval -> Frequency -> a -> a) 
            -> RecurringSchedule a
enumMoments step = do
  i <- ask
  return $ Schedule $ iterateMoments (step' i) (moment i)
  where
    step' i = step (interval i) (frequency i)

-- | 'enumFutureMoments' is a @Schedule@ of all future moments derived
-- from the @InitialMoment@
enumFutureMoments :: Moment a => RecurringSchedule a
enumFutureMoments = enumMoments next

-- | 'enumPastMoments' goes in the opposite direction of 'enumFutureMoments'
enumPastMoments :: Moment a => RecurringSchedule a
enumPastMoments = enumMoments prev

-- | 'enumPeriod' produces a period from /beg/ to /end/
enumPeriod :: (Moment a, Ord a) => a -> a -> RecurringSchedule a
enumPeriod beg end = do
  i <- ask
  return $ Schedule $ takeWhile (<= end) $ iterateMoments (step i) beg
  where
    step i = next (interval i) (frequency i)

-- | 'enumPeriodFrom' generalizes 'enumPeriod' by allowing an explicit
-- starting moment
enumPeriodFrom :: (Moment a, Ord a) => 
                  InitialMoment a
               -> a
               -> a
               -> RecurringSchedule a
enumPeriodFrom i' beg end = local (const i') (enumPeriod beg end)

-- | 'enumYear' produces all days in the year starting with /m/
enumYear :: (Moment a, Ord a) => a -> RecurringSchedule a
enumYear m = do
  i <- ask
  let mi = moment i
  enumPeriodFrom (daily `asTypeOf` i){moment = mi} (startDate' mi) endDate
  where
    eoy = if isLeapYear $ dtYear $ toDateTime m then 366 else 365
    endDate = fromJust $ alterYearDay m eoy
    startDate' = max (fromJust $ alterYearDay m 1)

-- | 'enumMonth' produces all days in the current month starting with /m/
enumMonth :: (Moment a, Ord a) => a -> RecurringSchedule a
enumMonth m = do
  i <- ask
  let mi = moment i
  enumPeriodFrom (daily `asTypeOf` i){moment = mi} (startDate' mi) endDate
  where
    dt = toDateTime m
    eom = monthLength (isLeapYear $ dtYear dt) (fromEnum $ dtMonth dt)
    endDate = fromJust $ alterDay m eom
    startDate' = max (fromJust $ alterDay m 1)

-- | 'enumWeek' produces all days in the current week starting with /m/
enumWeek :: (Moment a, Ord a) => a -> RecurringSchedule a
enumWeek m = do
  i <- ask
  let mi = moment i
  let sow = startOfWeek i
  let dt = toDateTime m
  let delta = fromEnum (dtWeekDay dt) - fromEnum (fromStartOfWeek sow)
  let delta' = toInteger delta
  let endDate = scaleTime m $ (7 - delta') * oneDay
  enumPeriodFrom (daily `asTypeOf` i){moment = mi} m endDate

-- | Normalize an bounded index
--   Pass an upper-bound 'ub' and an index 'idx'
--   Converts 'idx' < 0 into valid 'idx' > 0 or
--   Nothing
normIndex :: Int -> Int -> Maybe Int
normIndex _ 0 = Nothing
normIndex ub idx =
  if abs idx > ub
    then Nothing
    else Just $ (idx + ub') `mod` ub'
  where
    ub' = ub + 1

mapNormIndex :: Int -> [Int] -> [Int]
mapNormIndex n = mapMaybe (normIndex n)

-- | 'restrict', applied to a predicate and a @Schedule@, returns a @Schedule@
-- of those moments that statisfy the predicate.
restrict :: Moment a => (a -> Bool) -> Schedule a -> RecurringSchedule a
restrict f s = return $ Schedule $ filter f $ fromSchedule s

by :: (Moment a, Ord b) => (DateTime -> b) -> [b] -> a -> Bool
by f bs a = f (toDateTime a) `elem` nubSort bs

by' :: Moment a => (DateTime -> Int) -> Int -> [Int] -> a -> Bool
by' f n bs = by f $ mapNormIndex n bs

bySeconds :: Moment a => [Int] -> a -> Bool
bySeconds = by dtSecond

byMinutes :: Moment a => [Int] -> a -> Bool
byMinutes = by dtMinute

byHours :: Moment a => [Int] -> a -> Bool
byHours = by dtHour

byWeekDays :: Moment a => [WeekDay] -> a -> Bool
byWeekDays = by dtWeekDay

byMonthDays :: Moment a => [Int] -> a -> Bool
byMonthDays = by' dtDay 31

byMonths :: Moment a => [Month] -> a -> Bool
byMonths = by dtMonth

byYearDays :: Moment a => [Int] -> a -> Bool
byYearDays = by' dtYearDay 366

-- monadic concatMap
concatMapM :: Applicative m => (a -> m [b]) -> [a] -> m [b]
concatMapM f xs = concat <$> traverse f xs

-- | 'expand', takes an expansion function and a @Schedule@, and maps the
-- expansion function over the moments.
-- Each moment is then replaced with its expansions.
expand :: Moment a => (a -> Reader (InitialMoment a) [a]) -> Schedule a -> RecurringSchedule a
expand f s = do
  xs <- concatMapM f (fromSchedule s)
  return $ Schedule xs

on :: Moment a => 
      (a -> b -> Maybe a) 
   -> [b] 
   -> a 
   -> Reader (InitialMoment a) [a]
on f bs a = return $ mapMaybe (f a) bs

on' :: Moment a =>
       (InitialMoment a -> a -> b -> Maybe a)
     -> [b]
     -> a
     -> Reader (InitialMoment a) [a]
on' f bs a = ask >>= \i -> on (f i) bs a

onEach :: (Moment a, Ord a) => 
          (a -> RecurringSchedule a) 
       -> a 
       -> Reader (InitialMoment a) [a]
onEach f m = fmap fromSchedule (f m)

onEachYear :: (Moment a, Ord a) => a -> Reader (InitialMoment a) [a]
onEachYear = onEach enumYear

onEachMonth :: (Moment a, Ord a) => a -> Reader (InitialMoment a) [a]
onEachMonth = onEach enumMonth

onEachWeek :: (Moment a, Ord a) => a -> Reader (InitialMoment a) [a]
onEachWeek = onEach enumWeek

onMonths :: Moment a => [Month] -> a -> Reader (InitialMoment a) [a]
onMonths = on alterMonth

onMonthDays :: Moment a => [Int] -> a -> Reader (InitialMoment a) [a]
onMonthDays ds = on alterDay (mapNormIndex 31 ds)

onYearDays :: Moment a => [Int] -> a -> Reader (InitialMoment a) [a]
onYearDays ds = on alterYearDay (mapNormIndex 366 ds)

onWeekNumbers :: Moment a => [Int] -> a -> Reader (InitialMoment a) [a]
onWeekNumbers ds = on' (alterWeekNumber . startOfWeek) (mapNormIndex 53 ds)

-- | 'repeatSchedule' runs a schedule with a given /init/ and rule /r/
repeatSchedule :: Moment a => 
                  InitialMoment a 
               -> (Schedule a -> RecurringSchedule a)
               -> [a]
repeatSchedule init r = fromSchedule $ runReader (enumFutureMoments >>= r) init

-- | 'repeatSchedule'' is like 'repeatSchedule' but it takes no rules
repeatSchedule' :: Moment a =>
                   InitialMoment a
                -> [a]
repeatSchedule' init = repeatSchedule init return

-- | Instance of the @Moment@ class defined for the @UTCTime@ datatype.

instance Moment UTCTime where
  epoch = UTCTime (toEnum 0) 0
  toDateTime (UTCTime utcDay utcTime) =
    DateTime (fromEnum seconds) minutes hours
             day (toEnum month) year
             weekDay yearDay utc
    where
     (TimeOfDay hours minutes seconds) = timeToTimeOfDay utcTime
     (year, month, day) = toGregorian utcDay
     yearDay = snd $ toOrdinalDate utcDay
     weekDay = toEnum $ snd (mondayStartWeek utcDay) - 1

  fromDateTime dt = do
      let _ = dtTimeZone dt -- just called here to shut GHC up for now
      day <- fromGregorianValid (dtYear dt) (fromEnum $ dtMonth dt) (dtDay dt)
      time <- makeTimeOfDayValid (dtHour dt) (dtMinute dt) (toEnum $ dtSecond dt)
      return $ UTCTime day (timeOfDayToTime time)

  scaleTime utc i = addUTCTime (fromIntegral i) utc
  scaleMonth (UTCTime d t) i = UTCTime (addGregorianMonthsRollOver i d) t
  scaleYear (UTCTime d t) i = UTCTime (addGregorianYearsRollOver i d) t

  -- TODO: First argument is StartOfWeek and is ignored right now. fix.
  alterWeekNumber _ utc@(UTCTime _ time) week = do
    let dt = toDateTime utc
    day <- fromMondayStartWeekValid (dtYear dt) week (fromEnum $ dtWeekDay dt)
    return $ UTCTime day time

  alterYearDay utc@(UTCTime _ time) yearDay = do
    let dt = toDateTime utc
    day <- fromOrdinalDateValid (dtYear dt) yearDay
    return $ UTCTime day time

-- | @InitialMoment@ defaults for @UTCTime@

secondlyUTC :: InitialMoment UTCTime
secondlyUTC = secondly

minutelyUTC :: InitialMoment UTCTime
minutelyUTC = minutely

hourlyUTC :: InitialMoment UTCTime
hourlyUTC = hourly

dailyUTC :: InitialMoment UTCTime
dailyUTC = daily

weeklyUTC :: InitialMoment UTCTime
weeklyUTC = weekly

monthlyUTC :: InitialMoment UTCTime
monthlyUTC = monthly

yearlyUTC :: InitialMoment UTCTime
yearlyUTC = yearly