    {- 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)