diff options
Diffstat (limited to 'PTO.hs')
| -rw-r--r-- | PTO.hs | 75 |
1 files changed, 75 insertions, 0 deletions
@@ -0,0 +1,75 @@ +{-# 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 |