{-# LANGUAGE OverloadedStrings, RecordWildCards #-}

-- copyright and license info here

module PTO where

import Import
import Data.Maybe (fromMaybe)
import Data.Time.Calendar (Day, fromGregorian, toGregorian, gregorianMonthLength, diffDays, addDays)
import Database.Persist.Sql (SqlBackend) -- this can't be good

accrual :: (Functor m, PersistQuery m, PersistMonadBackend m ~ SqlBackend) =>
                 UserId -> (Integer, Int) -> m Rational
accrual u' (y',m') = do
    (e':es') <- fmap (map entityVal) (selectList [EmploymentUser ==. u'] [])
    return $ accrualThisMonth (e':es') (y',m')

accrualThisMonth :: [Employment] -> (Integer, Int) -> Rational
accrualThisMonth es@(e1:es') (y,m) = baseRateAccrual + twoYearRateAccrual
    where
        baseRateAccrual = baseLevel * sum (map (proportionOf tmBRRange) es)
        twoYearRateAccrual = afterTwo * sum (map (proportionOf tmTYRRange) es)
        proportionOf r emp = toRational (employmentCommitment emp) *
                             proportion (fromMaybe (Nothing,Nothing)
                             (r >>= rangeIntersection (employmentRange emp)))
                             thisMonthRange
        employmentRange emp = (Just (employmentStartDate emp), employmentEndDate emp)
        proportion (Just a,Just b) (Just a', Just b') = toRational (diffDays b a + 1) / toRational (diffDays b' a' + 1)
        proportion _ _ = 0
        tmBRRange = rangeIntersection brRange thisMonthRange
        tmTYRRange = rangeIntersection tyRange thisMonthRange
        startDate = employmentStartDate e1
        brRange = (Just startDate, Just (addDays (-1) (twoYearsFrom startDate)))
        tyRange = (Just (twoYearsFrom startDate), Nothing)
        thisMonthRange = (Just (startOfMonth (y,m)), Just (endOfMonth (y,m)))
        baseLevel = 104/12
        afterTwo = 12

-- deductions :: PersistQuery backend m => (Integer, Int) -> Key backend (UserGeneric backend) -> backend m [Entity (TimeEntryGeneric backend)]
deductions (year,month) user = do
   let monthstart = startOfMonth (year, month)
       monthend = endOfMonth (year, month)
   cats <- deductibles
   entries <- selectList [TimeEntryUser ==. user, TimeEntryDay >=. monthstart, TimeEntryDay <=. monthend, TimeEntryCategory <-. cats] []
   return entries

-- deductibles :: PersistQuery backend m => backend m [Key backend (TimeCategoryGeneric backend)]
deductibles = do
    ds <- selectList ([TimeCategoryName ==. "/admin/paid-time-off"]
                  ||. [TimeCategoryName ==. "/admin/personal"]
                  ||. [TimeCategoryName ==. "/admin/pto"]
                  ||. [TimeCategoryName ==. "/admin/vacation"]) []
    return $ map entityKey ds

yearlySacrifice :: Num a => a -> a
yearlySacrifice hs = 160 - hs

-- monthlyTransactions :: UserId -> (Integer, Int) -> m (Rational, Double)
monthlyTransactions u (y,m) = do
    accrue <- accrual u (y,m)
    deducts <- fmap (sum . map (timeEntryHours . entityVal)) (deductions (y,m) u)
    return (accrue, deducts)

startOfMonth :: (Integer, Int) -> Day
startOfMonth (year,month) = fromGregorian year month 1

endOfMonth :: (Integer, Int) -> Day
endOfMonth (year,month) = fromGregorian year month 32

twoYearsFrom :: Day -> Day
twoYearsFrom = (\(y,m,d) -> fromGregorian (y+2) m d) . toGregorian

monthOf :: Day -> (Integer, Int)
monthOf = (\(x,y,_) -> (x,y)) . toGregorian

rangeIntersection :: (Maybe Day, Maybe Day) -> (Maybe Day, Maybe Day) -> Maybe (Maybe Day, Maybe Day)
rangeIntersection (a,b) (a',b') = let (c,d) = (newest a a', oldest b b') in if (c > d) then Nothing else Just (c,d)
    where
        newest Nothing x = x
        newest x Nothing = x
        newest (Just x) (Just y) = Just (max x y)
        oldest Nothing x = x
        oldest x Nothing = x
        oldest (Just x) (Just y) = Just (min x y)