    {- 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 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 $ reverse $ drop 1 $ reverse 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)