Implement full schedule with warnings for out of stocks

ChangeLog.md

@@ -1,9 +1,5 @@
 # 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.1.0
+version:             0.1.0.0
 -- synopsis:            
 -- description:         
 license:             BSD3

src/CLI.hs

@@ -1,47 +1,30 @@
 module CLI (
       Invocation(..)
-    , Mode(..)
     , invoked
   ) where
 
 import Options.Applicative (
-      Parser, auto, execParser, flag, fullDesc, header, help, helper, info
+    Parser, execParser, flag, flag', fullDesc, header, help, helper, info, long
-    , infoOption, long, option, short, value
   )
-import Control.Applicative ((<**>), optional)
+import Control.Applicative ((<**>), (<|>))
 import Data.Monoid ((<>))
-import Data.Time (Day)
 import Data.Version (showVersion)
 import qualified Paths_pilu as Pilu (version)
 
-data Mode = Inventory | Schedule
+data Invocation = Inventory | Schedule | Version String
-
-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 = Invocation
+invocation =
-  <$> flag Schedule Inventory
+    flag' Schedule
-      (short 'i' <> long "inventory" <> help "Show a full inventory")
+      (long "schedule" <> help "Show when next to go for provisioning")
-  <*> option (optional auto) (
+  <|> flag Inventory (Version versionStr)
-          value Nothing
+      (long "version" <> help "Show the version number")
-        <> short 'd'
-        <> long "date"
-        <> help "Evaluate the situation at that date"
-      )
 
 invoked :: IO Invocation
 invoked = execParser $
   info
-    (invocation <**> version <**> helper)
+    (invocation <**> 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 (difference, empty, fromList, insert, lookup, toList)
+import qualified Data.Map as Map (delete, empty, 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 medicineNames
+      (kind, ints) <- foldM addAmount (Nothing, Map.empty) . Map.toList $ Map.delete "date" assoc
       maybe
         (Left $ Expect "A prescription or provisioning for a medicine")
         (Right . Event rowDate ints)
@@ -31,8 +31,6 @@ 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(..), Mode(..), invoked)
+import CLI (Invocation(..), invoked)
 import CSV (Row, parse)
-import Data.Time (Day, UTCTime(..), getCurrentTime)
+import Data.Time (UTCTime(..), getCurrentTime)
 import Medicine (Pharmacy, pharmacy)
-import System.Exit (exitFailure)
+import System.Exit (exitFailure, exitSuccess)
 import Schedule (schedule)
 import Timeline (State(..), stateAt)
 import YAML (encode)
@@ -17,19 +17,20 @@ readCSV filePath = do
     Left e -> (putStrLn $ show e) >> exitFailure
     Right rows -> return rows
 
-getState :: Pharmacy -> Maybe Day -> IO State
+getState :: Pharmacy -> IO State
-getState aPharmacy atDate =
+getState aPharmacy =
     stateAt
-  <$> maybe (utctDay <$> getCurrentTime) return atDate
+  <$> (utctDay <$> getCurrentTime)
-  <*> return aPharmacy
+  <*> (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 $ date invocation
+  theState <- getState thePharmacy
-  let display = case mode invocation of
+  putStrLn $ display thePharmacy theState
-                  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)
+import Data.Map ((!), Map, elems, lookupMin, mapWithKey, partition, size, toList)
 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 = stockLeft - (truncateF (stockLeft / content) * content)
+    leftInBox = content - (truncateF (content / stockLeft) * stockLeft)
 
 typeAndAmount :: Float -> Float -> Float -> (ScheduleType, Float)
 typeAndAmount stockLeft minStock leftInBox =

src/Timeline.hs

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