Handle multiple stints of employment

3 files changed, 37 insertions, 29 deletions

diff --git a/Handler/Vacation.hs b/Handler/Vacation.hs
index 18a96cb..e6c95f9 100644
--- a/Handler/Vacation.hs
+++ b/Handler/Vacation.hs
@@ -14,7 +14,7 @@ getVacationR cid = do
     user <- runDB $ get404 cid
     ma <- maybeAuth
     today <- fmap utctDay (liftIO getCurrentTime)
-    [e'] <- runDB $ fmap (map entityVal) (selectList [EmploymentUser ==. cid] [])
+    (e':es) <- runDB $ fmap (map entityVal) (selectList [EmploymentUser ==. cid] [])
     let twoyear = twoYearsFrom $ employmentStartDate e'
         username = userIdent user
         (currentyear, currentmonth) = monthOf today
diff --git a/PTO.hs b/PTO.hs
index 01ffda8..19dd13f 100644
--- a/PTO.hs
+++ b/PTO.hs
@@ -5,32 +5,36 @@
 module PTO where
 
 import Import
-import Data.Maybe (fromJust)
-import Data.Time.Calendar (Day, fromGregorian, toGregorian, gregorianMonthLength, diffDays)
+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'] <- fmap (map entityVal) (selectList [EmploymentUser ==. u'] [])
-    return $ accrual' e' (y',m')
+    (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
-        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
+        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
@@ -48,6 +52,7 @@ deductibles = do
                   ||. [TimeCategoryName ==. "/admin/vacation"]) []
     return $ map entityKey ds
 
+yearlySacrifice :: Num a => a -> a
 yearlySacrifice hs = 160 - hs
 
 -- monthlyTransactions :: UserId -> (Integer, Int) -> m (Rational, Double)
@@ -62,14 +67,18 @@ 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
+
+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)
diff --git a/config/settings.yml b/config/settings.yml
index 686c9fc..f51e2c2 100644
--- a/config/settings.yml
+++ b/config/settings.yml
@@ -1,7 +1,6 @@
 Default: &defaults
   host: "*4" # any IPv4 host
   port: 3000
-  approot: "http://burrell.hq.sflc.info:80"
   copyright: sflctimekeeper pre-release
   #Copyright (C) 2012-2013  Clint Adams
   #analytics: UA-YOURCODE
@@ -16,5 +15,5 @@ Staging:
   <<: *defaults
 
 Production:
-  #approot: "http://www.example.com"
+  approot: "http://burrell.hq.sflc.info:80"
   <<: *defaults