Implement --date option to evaluate the situation at a different date than when the command is run

src/CLI.hs

@@ -1,30 +1,47 @@
 module CLI (
       Invocation(..)
+    , Mode(..)
     , invoked
   ) where
 
 import Options.Applicative (
-    Parser, execParser, flag, flag', fullDesc, header, help, helper, info, long, short
+      Parser, auto, execParser, flag, fullDesc, header, help, helper, info
+    , infoOption, long, option, short, value
   )
-import Control.Applicative ((<**>), (<|>))
+import Control.Applicative ((<**>), optional)
 import Data.Monoid ((<>))
+import Data.Time (Day)
 import Data.Version (showVersion)
 import qualified Paths_pilu as Pilu (version)
 
-data Invocation = Inventory | Schedule | Version String
+data Mode = Inventory | Schedule
+
+data Invocation = Invocation {
+      mode :: Mode
+    , date :: Maybe Day
+  }
 
 versionStr :: String
 versionStr = showVersion Pilu.version
 
+version :: Parser (Invocation -> Invocation)
+version =
+  infoOption versionStr
+  (short 'v' <> long "version" <> help "Show the version number")
+
 invocation :: Parser Invocation
-invocation =
-    flag' Inventory
+invocation = Invocation
+  <$> flag Schedule Inventory
       (short 'i' <> long "inventory" <> help "Show a full inventory")
-  <|> flag Schedule (Version versionStr)
-      (long "version" <> help "Show the version number")
+  <*> option (optional auto) (
+          value Nothing
+        <> short 'd'
+        <> long "date"
+        <> help "Evaluate the situation at that date"
+      )
 
 invoked :: IO Invocation
 invoked = execParser $
   info
-    (invocation <**> helper)
+    (invocation <**> version <**> helper)
     (fullDesc <> header ("Pilu v" ++ versionStr))

src/Main.hs

@@ -1,11 +1,11 @@
 {-# LANGUAGE NamedFieldPuns #-}
 module Main where
 
-import CLI (Invocation(..), invoked)
+import CLI (Invocation(..), Mode(..), invoked)
 import CSV (Row, parse)
-import Data.Time (UTCTime(..), getCurrentTime)
+import Data.Time (Day, UTCTime(..), getCurrentTime)
 import Medicine (Pharmacy, pharmacy)
-import System.Exit (exitFailure, exitSuccess)
+import System.Exit (exitFailure)
 import Schedule (schedule)
 import Timeline (State(..), stateAt)
 import YAML (encode)
@@ -17,20 +17,19 @@ readCSV filePath = do
     Left e -> (putStrLn $ show e) >> exitFailure
     Right rows -> return rows
 
-getState :: Pharmacy -> IO State
-getState aPharmacy =
+getState :: Pharmacy -> Maybe Day -> IO State
+getState aPharmacy atDate =
     stateAt
-  <$> (utctDay <$> getCurrentTime)
-  <*> (return aPharmacy)
+  <$> maybe (utctDay <$> getCurrentTime) return atDate
+  <*> return aPharmacy
   <*> readCSV "timeline.csv"
 
 main :: IO ()
 main = do
   invocation <- invoked
-  display <- case invocation of
-    Inventory -> return $ const encode
-    Schedule -> return $ \ph -> encode . schedule ph
-    Version version -> putStrLn version >> exitSuccess
   thePharmacy <- pharmacy <$> readCSV "medicine.csv"
-  theState <- getState thePharmacy
-  putStrLn $ display thePharmacy theState
+  theState <- getState thePharmacy $ date invocation
+  let display = case mode invocation of
+                  Inventory -> encode
+                  Schedule -> encode . schedule thePharmacy
+  putStrLn $ display theState

src/Timeline.hs

@@ -51,7 +51,10 @@ setDay newDay state@(State {day, stock, consumptionRate}) = state {
       max 0 $ initialAmount - duration * (consumptionRate ! medicineName)
 
 stateAt :: Day -> Pharmacy -> [Event] -> State
-stateAt targetDay pharmacy events =
-  setDay targetDay lastState
+stateAt targetDay pharmacy =
+  setDay targetDay . lastState
   where
-    lastState = foldl applyEvent (initState pharmacy) (sortOn date events)
+    lastState =
+        foldl applyEvent (initState pharmacy)
+      . sortOn date
+      . filter ((<= targetDay) . date)