Actually implement inventory handling

pilu.cabal

@@ -17,12 +17,17 @@ cabal-version:       >=1.10
 
 executable pilu
   main-is:             Main.hs
-  other-modules:       CSV
+  other-modules:       CLI
+                     , CSV
                      , Event
                      , Medicine
+                     , Paths_pilu
+                     , Timeline
   -- other-extensions:    
-  build-depends:       base >=4.9 && <4.10
+  build-depends:       base >=4.9 && <4.13
                      , containers
+                     , mtl
+                     , optparse-applicative
                      , parsec
                      , time
   hs-source-dirs:      src

src/CLI.hs

@@ -0,0 +1,29 @@
+module CLI (
+      Invocation(..)
+    , invoked
+  ) where
+
+import Options.Applicative (
+    Parser, execParser, flag, flag', fullDesc, header, help, helper, info, long
+  )
+import Control.Applicative ((<**>), (<|>))
+import Data.Version (showVersion)
+import qualified Paths_pilu as Pilu (version)
+
+data Invocation = Inventory | Schedule | Version String
+
+versionStr :: String
+versionStr = showVersion Pilu.version
+
+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")
+
+invoked :: IO Invocation
+invoked = execParser $
+  info
+    (invocation <**> helper)
+    (fullDesc <> header ("Pilu v" ++ versionStr))

src/CSV.hs

@@ -6,7 +6,7 @@ module CSV (
 
 import Control.Applicative ((<|>))
 import Data.Map (Map)
-import qualified Data.Map as Map (fromList, keys)
+import qualified Data.Map as Map (fromList, elems)
 import Text.Parsec.Pos (newPos)
 import Text.ParserCombinators.Parsec ((<?>), Parser, ParseError, char, endBy, many, noneOf, sepBy, string, try)
 import Text.ParserCombinators.Parsec.Error (Message(..), newErrorMessage)
@@ -16,7 +16,7 @@ class Row a where
   fromRow :: Map String String -> Either Message a
 
 instance Row [String] where
-  fromRow = return . Map.keys
+  fromRow = return . Map.elems
 
 csvFile :: Char -> Parser [[String]]
 csvFile separator = line `endBy` eol

src/Event.hs

@@ -1,4 +1,6 @@
 module Event (
+      Event(..)
+    , EventType(..)
   ) where
 
 import CSV (Row(..))
@@ -7,14 +9,15 @@ import Data.List (isSuffixOf, takeWhile, sortOn)
 import Data.Map (Map)
 import qualified Data.Map as Map (delete, empty, insert, lookup, toList)
 import Data.Time (Day)
+import Medicine (MedicineName)
 import Text.ParserCombinators.Parsec.Error (Message(..))
 
 data EventType = Prescription | Provisioning deriving (Eq, Show)
 
 data Event = Event {
       date :: Day
-    , amounts :: Map String Int
-    , eventtype :: EventType
+    , amounts :: Map MedicineName Float
+    , eventType :: EventType
   } deriving (Show)
 
 instance Row Event where
@@ -30,13 +33,13 @@ instance Row Event where
       unexpected = Left . UnExpect . show
       addAmount (evType, ints) (key, val) = do
         (newEvType, amount) <- readAmount val
-        let newInts = Map.insert key amount ints
+        let newFloats = Map.insert key amount ints
         case evType of
-          Nothing -> Right (Just newEvType, newInts)
+          Nothing -> Right (Just newEvType, newFloats)
           Just currentEvType ->
-            if currentEvType == newEvType then Right (evType, newInts) else unexpected newEvType
+            if currentEvType == newEvType then Right (evType, newFloats) else unexpected newEvType
 
-readAmount :: String -> Either Message (EventType, Int)
+readAmount :: String -> Either Message (EventType, Float)
 readAmount [] = Left $ Expect "prescription or provisioning"
 readAmount ('+':n) = Right (Provisioning, read n)
 readAmount s =

src/Main.hs

@@ -1,4 +1,34 @@
 module Main where
 
+import CLI (Invocation(..), invoked)
+import CSV (Row, parse)
+import Data.Time (UTCTime(..), getCurrentTime)
+import Event (Event)
+import Medicine (Medicine, Pharmacy, pharmacy)
+import System.Exit (exitFailure, exitSuccess)
+import Timeline (State, currentState)
+
+readCSV :: Row a => FilePath -> IO [a]
+readCSV filePath = do
+  parsed <- parse filePath '\t' <$> readFile filePath
+  case parsed of
+    Left e -> (putStrLn $ show e) >> exitFailure
+    Right rows -> return rows
+
+getPharmacy :: String -> IO Pharmacy
+getPharmacy = fmap pharmacy . readCSV
+
+getCurrentState :: IO State
+getCurrentState =
+    currentState
+  <$> (utctDay <$> getCurrentTime)
+  <*> getPharmacy "medicine.csv"
+  <*> readCSV "timeline.csv"
+
 main :: IO ()
-main = putStrLn "Hello, Haskell!"
+main = do
+  invocation <- invoked
+  case invocation of
+    Inventory -> show <$> getCurrentState >>= putStrLn
+    Schedule -> putStrLn "schedule"
+    Version version -> putStrLn version >> exitSuccess

src/Medicine.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE NamedFieldPuns #-}
 module Medicine (
       Medicine(..)
+    , MedicineName
     , Pharmacy
+    , Stock
     , pharmacy
   ) where
 
@@ -10,22 +12,22 @@ import Data.Map (Map)
 import qualified Data.Map as Map (empty, insert, lookup)
 import Text.ParserCombinators.Parsec.Error (Message(..))
 
+type MedicineName = String
+
 data Medicine = Medicine {
-      name :: String
-    , content :: Int
-    , minStock :: Int
+      name :: MedicineName
+    , minStock :: Float
   } deriving (Show)
 
 instance Row Medicine where
   fromRow assoc = Medicine <$>
         get "name"
-      <*> (read <$> get "content")
       <*> (read <$> get "minStock")
     where
       get key = maybe (Left $ Expect key) Right $ Map.lookup key assoc
 
-type Pharmacy = Map String Medicine
+type Pharmacy = Map MedicineName Medicine
+type Stock = Map MedicineName Float
 
 pharmacy :: [Medicine] -> Pharmacy
-pharmacy [] = Map.empty
-pharmacy (medicine:medicines) = Map.insert (name medicine) medicine $ pharmacy medicines
+pharmacy = foldr (\medicine -> Map.insert (name medicine) medicine) Map.empty

src/Timeline.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Timeline (
+      State
+    , currentState
+  ) where
+
+import Control.Monad (foldM, join)
+import Control.Monad.Reader (Reader, runReader, ask)
+import Data.List (sortOn)
+import Data.Map ((!), Map, mapWithKey, toList)
+import Data.Time (Day, diffDays)
+import Event (Event(..), EventType(..))
+import Medicine (Pharmacy, Stock)
+
+type ConsumptionRate = Map String Float
+
+data State = State {
+      day :: Day
+    , stock :: Stock
+    , consumptionRate :: ConsumptionRate
+  }
+
+instance Show State where
+  show (State {day, stock, consumptionRate}) = unlines $
+      ("day: " ++ show day)
+    : ("stock:" : (indent <$> showAssoc stock) :: [String])
+    ++ ("consumptionRate:" : (indent <$> showAssoc consumptionRate))
+    where
+      indent :: String -> String
+      indent = ('\t' :)
+      showAssoc :: Show a => Map String a -> [String]
+      showAssoc = fmap (\(key, val) -> key ++ ": " ++ show val) . toList
+
+initState :: Reader Pharmacy State
+initState = do
+  pharmacy <- ask
+  return $ State {
+      day = toEnum 0
+    , stock = const 0 <$> pharmacy
+    , consumptionRate = const 0 <$> pharmacy
+  }
+
+applyEvent :: State -> Event -> State
+applyEvent state (Event {date, amounts, eventType}) =
+  case eventType of
+    Prescription -> newState {consumptionRate = amounts}
+    Provisioning -> newState {stock = mapWithKey addAmount $ stock newState}
+  where
+    newState = setDay date state
+    addAmount medicineName = (+ (amounts ! medicineName)) 
+
+setDay :: Day -> State -> State
+setDay newDay state@(State {day, stock, consumptionRate}) = state {
+      day = newDay
+    , stock = mapWithKey consume stock
+  }
+  where
+    duration = toEnum . fromEnum $ newDay `diffDays` day
+    consume medicineName initialAmount =
+      max 0 $ initialAmount - duration * (consumptionRate ! medicineName)
+
+lastState :: [Event] -> Reader Pharmacy State
+lastState events =
+  foldl applyEvent <$> initState <*> (return $ sortOn date events)
+
+currentState :: Day -> Pharmacy -> [Event] -> State
+currentState targetDay pharmacy events =
+  setDay targetDay (runReader (lastState events) pharmacy)