1 files changed, 48 insertions, 17 deletions
diff --git a/Handler/Vacation.hs b/Handler/Vacation.hs
index e6c95f9..233d737 100644
--- a/Handler/Vacation.hs
+++ b/Handler/Vacation.hs
@@ -2,25 +2,54 @@
 module Handler.Vacation where
 
 import Import hiding (get)
-import Control.Monad (when, guard)
-import Control.Monad.Trans.RWS.Lazy (ask, tell, get, put, execRWST)
+import Control.Monad (when)
+import Control.Monad.Trans.RWS.Lazy (RWST, ask, tell, get, put, execRWST)
 import qualified Data.Text as T
-import Data.Time.Clock (getCurrentTime, UTCTime, utctDay)
+import Data.Time (UTCTime, fromGregorian, getCurrentTime, utctDay)
 import Yesod.Auth (maybeAuth)
+import qualified Data.Map as Map
+import Text.Printf (printf)
 import PTO
 
+type Month = (Integer, Int)
+
+fmtHours :: Rational -> String
+fmtHours r = printf "%.2f" d
+    where d = fromRational r :: Double
+
+getAnniversaryMax :: [Employment] -> Month -> Maybe Rational
+getAnniversaryMax es (y, m) =
+    case capOverride of
+      Just 0.0 -> Nothing
+      Just v   -> Just (toRational v)
+      Nothing  -> Just 160.0
+  where
+    empMap = Map.fromList [(employmentStartDate e, e) | e <- es]
+    today = fromGregorian y m 0
+
+    todaysEmp :: Maybe Employment
+    todaysEmp =
+      Map.lookupLE today empMap >>=
+	\(_, emp) ->
+	  case employmentEndDate emp of
+ 	    Just end
+	      | end < today -> Nothing 
+	    _               -> Just emp
+    
+    capOverride :: Maybe Double
+    capOverride = todaysEmp >>= employmentPtoMaxRollover
+
 getVacationR :: UserId -> Handler Html
 getVacationR cid = do
     user <- runDB $ get404 cid
     ma <- maybeAuth
     today <- fmap utctDay (liftIO getCurrentTime)
-    (e':es) <- runDB $ fmap (map entityVal) (selectList [EmploymentUser ==. cid] [])
-    let twoyear = twoYearsFrom $ employmentStartDate e'
-        username = userIdent user
-        (currentyear, currentmonth) = monthOf today
-        months = [2005 .. currentyear] >>= \ x -> [1 .. 12] >>= \ y -> guard ((x, y) < (currentyear, currentmonth)) >> return (x, y)
-    (_, transacts') <- execRWST' (cid, twoyear) 0 $ mapM anotherMonth months
-    let transacts = reverse $ map (fmap fromRational) transacts'
+    employments <- runDB $ fmap (map entityVal) (selectList [EmploymentUser ==. cid] [])
+    let username = userIdent user
+        current@(currentyear, currentmonth) = monthOf today
+	months = takeWhile (< current) [(y, m) | y <- [2005..], m <- [1..12]]
+    (_, transacts') <- execRWST' (cid, employments) 0 $ mapM anotherMonth months
+    let transacts = reverse $ transacts' :: [(String, Rational)]
     defaultLayout $ do
         aDomId <- newIdent
         (setTitle . toHtml) ("Vacation report for " `T.append` username)
@@ -28,15 +57,17 @@ getVacationR cid = do
     where
         execRWST' = flip .  flip execRWST
 
--- anotherMonth :: UserId -> (Integer,Int) -> WriterT [Change]
+anotherMonth :: Month -> RWST (UserId, [Employment]) [(String, Rational)] Rational Handler ()
 anotherMonth (y,m) = do
-    currentval <- get
-    (u, twoyear) <- ask
+    (u, employments@(e:_)) <- ask
     (plus, minus) <- lift . runDB $ monthlyTransactions u (y,m)
     when (plus > 0) (add plus)
     when (minus > 0) (subtract (toRational minus))
-    when ((snd . monthOf) twoyear == m) kneecap
+    let twoyear = twoYearsFrom $ employmentStartDate e
+        ptoMax = getAnniversaryMax employments (y,m)
+    when ((snd . monthOf) twoyear == m) $
+         maybe (return ()) kneecap ptoMax
     where
-        add x = get >>= \o -> tell [(show y ++ "-" ++ show m ++ ": adding " ++ show (fromRational x) ++ " hours", o + x)] >> put (o + x)
-        subtract x = get >>= \o -> tell [(show y ++ "-" ++ show m ++ ": subtracting " ++ show (fromRational x) ++ " hours", o - x)] >> put (o - x)
-	kneecap = get >>= \o -> when (o > 160) (tell [(show y ++ "-" ++ show m ++ ": over anniversary max, subtracting " ++ show (fromRational o - 160) ++ " hours", 160)] >> put 160)
+        add x = get >>= \o -> tell [(show y ++ "-" ++ show m ++ ": adding " ++ fmtHours x ++ " hours", o + x)] >> put (o + x)
+        subtract x = get >>= \o -> tell [(show y ++ "-" ++ show m ++ ": subtracting " ++ fmtHours x ++ " hours", o - x)] >> put (o - x)
+	kneecap cap = get >>= \o -> when (o > cap) (tell [(show y ++ "-" ++ show m ++ ": over anniversary max, subtracting " ++ fmtHours (o - cap) ++ " hours", cap)] >> put cap)