Add support for a comment column in timelines

ChangeLog.md

@@ -1,5 +1,9 @@
 # Revision history for pilu
 
+## 0.1.1.0  -- 2019-08-31
+
+* Add support for a comment column in timelines
+
 ## 0.1.0.0  -- YYYY-mm-dd
 
 * First version. Released on an unsuspecting world.

pilu.cabal

@@ -2,7 +2,7 @@
 -- see http://haskell.org/cabal/users-guide/
 
 name:                pilu
-version:             0.1.0.0
+version:             0.1.1.0
 -- synopsis:            
 -- description:         
 license:             BSD3

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
+      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' Schedule
-      (long "schedule" <> help "Show when next to go for provisioning")
-  <|> flag Inventory (Version versionStr)
-      (long "version" <> help "Show the version number")
+invocation = Invocation
+  <$> flag Schedule Inventory
+      (short 'i' <> long "inventory" <> help "Show a full inventory")
+  <*> 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/Event.hs

@@ -7,7 +7,7 @@ import CSV (Row(..))
 import Control.Monad (foldM)
 import Data.List (isSuffixOf, takeWhile)
 import Data.Map (Map)
-import qualified Data.Map as Map (delete, empty, insert, lookup, toList)
+import qualified Data.Map as Map (difference, empty, fromList, insert, lookup, toList)
 import Data.Time (Day)
 import Medicine (MedicineName)
 import Text.ParserCombinators.Parsec.Error (Message(..))
@@ -23,7 +23,7 @@ data Event = Event {
 instance Row Event where
   fromRow assoc = do
       rowDate <- read <$> get "date"
-      (kind, ints) <- foldM addAmount (Nothing, Map.empty) . Map.toList $ Map.delete "date" assoc
+      (kind, ints) <- foldM addAmount (Nothing, Map.empty) $ Map.toList medicineNames
       maybe
         (Left $ Expect "A prescription or provisioning for a medicine")
         (Right . Event rowDate ints)
@@ -31,6 +31,8 @@ instance Row Event where
     where
       get key = maybe (Left $ Expect key) Right $ Map.lookup key assoc
       unexpected = Left . UnExpect . show
+      ignoredKeys = Map.fromList [("date", ""), ("comment", "")]
+      medicineNames = Map.difference assoc ignoredKeys
       addAmount (evType, ints) (key, val) = do
         (newEvType, amount) <- readAmount val
         let newFloats = Map.insert key amount ints

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/Schedule.hs

@@ -4,7 +4,7 @@ module Schedule (
     schedule
   ) where
 
-import Data.Map ((!), Map, elems, lookupMin, mapWithKey, partition, size, toList)
+import Data.Map ((!), Map, elems, lookupMin, mapWithKey, partition, size)
 import qualified Data.Map as Map (filter)
 import Data.Time (Day, addDays)
 import Medicine (Medicine(..), MedicineName, Pharmacy)
@@ -56,7 +56,7 @@ scheduleByMedicine pharmacy day medicineName stockLeft rate =
   where
     (Medicine {minStock, content}) = pharmacy ! medicineName
     truncateF = fromInteger . truncate
-    leftInBox = content - (truncateF (content / stockLeft) * stockLeft)
+    leftInBox = stockLeft - (truncateF (stockLeft / content) * content)
 
 typeAndAmount :: Float -> Float -> Float -> (ScheduleType, Float)
 typeAndAmount stockLeft minStock leftInBox =

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)