{- scheduled activities
 - 
 - Copyright 2013-2014 Joey Hess <id@joeyh.name>
 -
 - License: BSD-2-clause
 -}

module Utility.Scheduled (
        Schedule(..),
        Recurrance(..),
        ScheduledTime(..),
        NextTime(..),
        WeekDay,
        MonthDay,
        YearDay,
        nextTime,
        calcNextTime,
        startTime,
        fromSchedule,
        fromScheduledTime,
        toScheduledTime,
        fromRecurrance,
        toRecurrance,
        toSchedule,
        parseSchedule,
        prop_past_sane,
) where

import Utility.Data
import Utility.PartialPrelude
import Utility.Misc
import Utility.Tuple
import Utility.Split

import Data.List
import Data.Time.Clock
import Data.Time.LocalTime
import Data.Time.Calendar
import Data.Time.Calendar.WeekDate
import Data.Time.Calendar.OrdinalDate
import Data.Time.Format ()
import Data.Char
import Control.Applicative
import Prelude

{- Some sort of scheduled event. -}
data Schedule = Schedule Recurrance ScheduledTime
        deriving (Eq, Read, Show, Ord)

data Recurrance
        = Daily
        | Weekly (Maybe WeekDay)
        | Monthly (Maybe MonthDay)
        | Yearly (Maybe YearDay)
        | Divisible Int Recurrance
        -- ^ Days, Weeks, or Months of the year evenly divisible by a number.
        -- (Divisible Year is years evenly divisible by a number.)
        deriving (Eq, Read, Show, Ord)

type WeekDay = Int
type MonthDay = Int
type YearDay = Int

data ScheduledTime
        = AnyTime
        | SpecificTime Hour Minute
        deriving (Eq, Read, Show, Ord)

type Hour = Int
type Minute = Int

-- | Next time a Schedule should take effect. The NextTimeWindow is used
-- when a Schedule is allowed to start at some point within the window.
data NextTime
        = NextTimeExactly LocalTime
        | NextTimeWindow LocalTime LocalTime
        deriving (Eq, Read, Show)

startTime :: NextTime -> LocalTime
startTime (NextTimeExactly t) = t
startTime (NextTimeWindow t _) = t

nextTime :: Schedule -> Maybe LocalTime -> IO (Maybe NextTime)
nextTime schedule lasttime = do
        now <- getCurrentTime
        tz <- getTimeZone now
        return $ calcNextTime schedule lasttime $ utcToLocalTime tz now

-- | Calculate the next time that fits a Schedule, based on the
-- last time it occurred, and the current time.
calcNextTime :: Schedule -> Maybe LocalTime -> LocalTime -> Maybe NextTime
calcNextTime schedule@(Schedule recurrance scheduledtime) lasttime currenttime
        | scheduledtime == AnyTime = do
                next <- findfromtoday True
                return $ case next of
                        NextTimeWindow _ _ -> next
                        NextTimeExactly t -> window (localDay t) (localDay t)
        | otherwise = NextTimeExactly . startTime <$> findfromtoday False
  where
        findfromtoday anytime = findfrom recurrance afterday today
          where
                today = localDay currenttime
                afterday = sameaslastrun || toolatetoday
                toolatetoday = not anytime && localTimeOfDay currenttime >= nexttime
                sameaslastrun = lastrun == Just today
        lastrun = localDay <$> lasttime
        nexttime = case scheduledtime of
                AnyTime -> TimeOfDay 0 0 0
                SpecificTime h m -> TimeOfDay h m 0
        exactly d = NextTimeExactly $ LocalTime d nexttime
        window startd endd = NextTimeWindow
                (LocalTime startd nexttime)
                (LocalTime endd (TimeOfDay 23 59 0))
        findfrom r afterday candidate
                | ynum candidate > (ynum (localDay currenttime)) + 100 =
                        -- avoid possible infinite recusion
                        error $ "bug: calcNextTime did not find a time within 100 years to run " ++
                        show (schedule, lasttime, currenttime)
                | otherwise = findfromChecked r afterday candidate
        findfromChecked r afterday candidate = case r of
                Daily
                        | afterday -> Just $ exactly $ addDays 1 candidate
                        | otherwise -> Just $ exactly candidate
                Weekly Nothing
                        | afterday -> skip 1
                        | otherwise -> case (wday <$> lastrun, wday candidate) of
                                (Nothing, _) -> Just $ window candidate (addDays 6 candidate)
                                (Just old, curr)
                                        | old == curr -> Just $ window candidate (addDays 6 candidate)
                                        | otherwise -> skip 1
                Monthly Nothing
                        | afterday -> skip 1
                        | maybe True (candidate `oneMonthPast`) lastrun ->
                                Just $ window candidate (endOfMonth candidate)
                        | otherwise -> skip 1
                Yearly Nothing
                        | afterday -> skip 1
                        | maybe True (candidate `oneYearPast`) lastrun ->
                                Just $ window candidate (endOfYear candidate)
                        | otherwise -> skip 1
                Weekly (Just w)
                        | w < 0 || w > maxwday -> Nothing
                        | w == wday candidate -> if afterday
                                then Just $ exactly $ addDays 7 candidate
                                else Just $ exactly candidate
                        | otherwise -> Just $ exactly $
                                addDays (fromIntegral $ (w - wday candidate) `mod` 7) candidate
                Monthly (Just m)
                        | m < 0 || m > maxmday -> Nothing
                        -- TODO can be done more efficiently than recursing
                        | m == mday candidate -> if afterday
                                then skip 1
                                else Just $ exactly candidate
                        | otherwise -> skip 1
                Yearly (Just y)
                        | y < 0 || y > maxyday -> Nothing
                        | y == yday candidate -> if afterday
                                then skip 365
                                else Just $ exactly candidate
                        | otherwise -> skip 1
                Divisible n r'@Daily -> handlediv n r' yday (Just maxyday)
                Divisible n r'@(Weekly _) -> handlediv n r' wnum (Just maxwnum)
                Divisible n r'@(Monthly _) -> handlediv n r' mnum (Just maxmnum)
                Divisible n r'@(Yearly _) -> handlediv n r' ynum Nothing
                Divisible _ r'@(Divisible _ _) -> findfrom r' afterday candidate
          where
                skip n = findfrom r False (addDays n candidate)
                handlediv n r' getval mmax
                        | n > 0 && maybe True (n <=) mmax =
                                findfromwhere r' (divisible n . getval) afterday candidate
                        | otherwise = Nothing
        findfromwhere r p afterday candidate
                | maybe True (p . getday) next = next
                | otherwise = maybe Nothing (findfromwhere r p True . getday) next
          where
                next = findfrom r afterday candidate
                getday = localDay . startTime
        divisible n v = v `rem` n == 0

-- Check if the new Day occurs one month or more past the old Day.
oneMonthPast :: Day -> Day -> Bool
new `oneMonthPast` old = fromGregorian y (m+1) d <= new
  where
        (y,m,d) = toGregorian old

-- Check if the new Day occurs one year or more past the old Day.
oneYearPast :: Day -> Day -> Bool
new `oneYearPast` old = fromGregorian (y+1) m d <= new
  where
        (y,m,d) = toGregorian old

endOfMonth :: Day -> Day
endOfMonth day =
        let (y,m,_d) = toGregorian day
        in fromGregorian y m (gregorianMonthLength y m)

endOfYear :: Day -> Day
endOfYear day =
        let (y,_m,_d) = toGregorian day
        in endOfMonth (fromGregorian y maxmnum 1)

-- extracting various quantities from a Day
wday :: Day -> Int
wday = thd3 . toWeekDate
wnum :: Day -> Int
wnum = snd3 . toWeekDate
mday :: Day -> Int
mday = thd3 . toGregorian
mnum :: Day -> Int
mnum = snd3 . toGregorian
yday :: Day -> Int
yday = snd . toOrdinalDate
ynum :: Day -> Int
ynum = fromIntegral . fst . toOrdinalDate

-- Calendar max values.
maxyday :: Int
maxyday = 366 -- with leap days
maxwnum :: Int
maxwnum = 53 -- some years have more than 52
maxmday :: Int
maxmday = 31
maxmnum :: Int
maxmnum = 12
maxwday :: Int
maxwday = 7

fromRecurrance :: Recurrance -> String
fromRecurrance (Divisible n r) =
        fromRecurrance' (++ "s divisible by " ++ show n) r
fromRecurrance r = fromRecurrance' ("every " ++) r

fromRecurrance' :: (String -> String) -> Recurrance -> String
fromRecurrance' a Daily = a "day"
fromRecurrance' a (Weekly n) = onday n (a "week")
fromRecurrance' a (Monthly n) = onday n (a "month")
fromRecurrance' a (Yearly n) = onday n (a "year")
fromRecurrance' a (Divisible _n r) = fromRecurrance' a r -- not used

onday :: Maybe Int -> String -> String
onday (Just n) s = "on day " ++ show n ++ " of " ++ s
onday Nothing s = s

toRecurrance :: String -> Maybe Recurrance
toRecurrance s = case words s of
        ("every":"day":[]) -> Just Daily
        ("on":"day":sd:"of":"every":something:[]) -> withday sd something
        ("every":something:[]) -> noday something
        ("days":"divisible":"by":sn:[]) ->
                Divisible <$> getdivisor sn <*> pure Daily
        ("on":"day":sd:"of":something:"divisible":"by":sn:[]) ->
                Divisible
                        <$> getdivisor sn
                        <*> withday sd something
        ("every":something:"divisible":"by":sn:[]) ->
                Divisible
                        <$> getdivisor sn
                        <*> noday something
        (something:"divisible":"by":sn:[]) ->
                Divisible
                        <$> getdivisor sn
                        <*> noday something
        _ -> Nothing
  where
        constructor "week" = Just Weekly
        constructor "month" = Just Monthly
        constructor "year" = Just Yearly
        constructor u
                | "s" `isSuffixOf` u = constructor $ dropFromEnd 1 u
                | otherwise = Nothing
        withday sd u = do
                c <- constructor u
                d <- readish sd
                Just $ c (Just d)
        noday u = do
                c <- constructor u
                Just $ c Nothing
        getdivisor sn = do
                n <- readish sn
                if n > 0
                        then Just n
                        else Nothing

fromScheduledTime :: ScheduledTime -> String
fromScheduledTime AnyTime = "any time"
fromScheduledTime (SpecificTime h m) =
        show h' ++ (if m > 0 then ":" ++ pad 2 (show m) else "") ++ " " ++ ampm
  where
        pad n s = replicate (n - length s) '0' ++ s
        (h', ampm)
                | h == 0 = (12, "AM")
                | h < 12 = (h, "AM")
                | h == 12 = (h, "PM")
                | otherwise = (h - 12, "PM")

toScheduledTime :: String -> Maybe ScheduledTime
toScheduledTime "any time" = Just AnyTime
toScheduledTime v = case words v of
        (s:ampm:[])
                | map toUpper ampm == "AM" ->
                        go s h0
                | map toUpper ampm == "PM" ->
                        go s (\h -> (h0 h) + 12)
                | otherwise -> Nothing
        (s:[]) -> go s id
        _ -> Nothing
  where
        h0 h
                | h == 12 = 0
                | otherwise = h
        go :: String -> (Int -> Int) -> Maybe ScheduledTime
        go s adjust =
                let (h, m) = separate (== ':') s
                in SpecificTime
                        <$> (adjust <$> readish h)
                        <*> if null m then Just 0 else readish m

fromSchedule :: Schedule -> String
fromSchedule (Schedule recurrance scheduledtime) = unwords
        [ fromRecurrance recurrance
        , "at"
        , fromScheduledTime scheduledtime
        ]

toSchedule :: String -> Maybe Schedule
toSchedule = eitherToMaybe . parseSchedule

parseSchedule :: String -> Either String Schedule
parseSchedule s = do
        r <- maybe (Left $ "bad recurrance: " ++ recurrance) Right
                (toRecurrance recurrance)
        t <- maybe (Left $ "bad time of day: " ++ scheduledtime) Right
                (toScheduledTime scheduledtime)
        Right $ Schedule r t
  where
        (rws, tws) = separate (== "at") (words s)
        recurrance = unwords rws
        scheduledtime = unwords tws

prop_past_sane :: Bool
prop_past_sane = and
        [ all (checksout oneMonthPast) (mplus1 ++ yplus1)
        , all (not . (checksout oneMonthPast)) (map swap (mplus1 ++ yplus1))
        , all (checksout oneYearPast) yplus1
        , all (not . (checksout oneYearPast)) (map swap yplus1)
        ]
  where
        mplus1 =   -- new date               old date, 1+ months before it
                [ (fromGregorian 2014 01 15, fromGregorian 2013 12 15)
                , (fromGregorian 2014 01 15, fromGregorian 2013 02 15)
                , (fromGregorian 2014 02 15, fromGregorian 2013 01 15)
                , (fromGregorian 2014 03 01, fromGregorian 2013 01 15)
                , (fromGregorian 2014 03 01, fromGregorian 2013 12 15)
                , (fromGregorian 2015 01 01, fromGregorian 2010 01 01)
                ]
        yplus1 =   -- new date               old date, 1+ years before it
                [ (fromGregorian 2014 01 15, fromGregorian 2012 01 16)
                , (fromGregorian 2014 01 15, fromGregorian 2013 01 14)
                , (fromGregorian 2022 12 31, fromGregorian 2000 01 01)
                ]
        checksout cmp (new, old) = new `cmp` old
        swap (a,b) = (b,a)