{-# LANGUAGE OverloadedStrings, RecordWildCards #-}

-- copyright and license info here

module PTO where

import Import
import Data.Maybe (fromJust)
import Data.Time.Calendar (Day, fromGregorian, toGregorian, gregorianMonthLength, diffDays)
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'] <- fmap (map entityVal) (selectList [EmploymentUser ==. u'] [])
    return $ accrual' e' (y',m')
    where
        accrual' e@Employment{..} (y,m)
          | employmentStartDate > endOfMonth (y,m) = 0
          | fmap (\x -> x < startOfMonth (y,m)) employmentEndDate == Just True = 0
          | monthOf employmentStartDate == (y,m) = percent employmentStartDate (endOfMonth (y,m)) * baseLevel * toRational employmentCommitment
          | Just (y,m) == endMonth e && ((y,m) > monthOf (twoYearsFrom employmentStartDate)) = (percent (startOfMonth (y,m)) (fromJust employmentEndDate)) * afterTwo * toRational employmentCommitment -- FIXME or leave bug-compatible?
          | Just (y,m) == endMonth e = (percent (startOfMonth (y,m)) (fromJust employmentEndDate)) * baseLevel * toRational employmentCommitment -- FIXME or leave bug-compatible?
	  | monthOf (twoYearsFrom employmentStartDate) < (y,m) = afterTwo * toRational employmentCommitment
	  | (y,m) == monthOf (twoYearsFrom employmentStartDate) = toRational employmentCommitment * (((percent (twoYearsFrom employmentStartDate) (endOfMonth (y,m))) * (afterTwo - baseLevel)) + baseLevel)
	  | otherwise = baseLevel * toRational employmentCommitment
	baseLevel = 104/12
	afterTwo = 12
	percent s e
	  | monthOf s == monthOf e = toRational (daysInPeriod s e) / toRational (daysInMonth s)
	  | otherwise = error "this should never happen"
	daysInPeriod s e = diffDays e s + 1 -- is this right or off-by-one?
	daysInMonth = uncurry gregorianMonthLength . monthOf

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

startMonth :: Employment -> (Integer, Int)
startMonth = monthOf . employmentStartDate

endMonth :: Employment -> Maybe (Integer, Int)
endMonth = fmap monthOf . employmentEndDate

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

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