Implement full schedule with warnings for out of stocks

pilu.cabal

@@ -22,7 +22,9 @@ executable pilu
                      , Event
                      , Medicine
                      , Paths_pilu
+                     , Schedule
                      , Timeline
+                     , YAML
   -- other-extensions:    
   build-depends:       base >=4.9 && <4.13
                      , containers
@@ -30,5 +32,6 @@ executable pilu
                      , optparse-applicative
                      , parsec
                      , time
+  ghc-options:         -Wall -dynamic
   hs-source-dirs:      src
   default-language:    Haskell2010

src/CSV.hs

@@ -32,11 +32,11 @@ quoted = char '"' *> many quotedChar <* char '"' <?> "quote ending the cell"
 
 parse :: Row a => String -> Char -> String -> Either ParseError [a]
 parse name separator input = do
-  lines <- Parsec.parse (csvFile separator) name input
-  case lines of
+  rows <- Parsec.parse (csvFile separator) name input
+  case rows of
     [] -> Right []
-    (header:rows) -> 
-      let assocs = Map.fromList . zipWith (,) header <$> rows in
+    (header:contents) ->
+      let assocs = Map.fromList . zipWith (,) header <$> contents in
       sequence $ zipWith parseRow [1..] assocs
   where
     parseRow n row = either (errorAt n) return $ fromRow row

src/Event.hs

@@ -5,7 +5,7 @@ module Event (
 
 import CSV (Row(..))
 import Control.Monad (foldM)
-import Data.List (isSuffixOf, takeWhile, sortOn)
+import Data.List (isSuffixOf, takeWhile)
 import Data.Map (Map)
 import qualified Data.Map as Map (delete, empty, insert, lookup, toList)
 import Data.Time (Day)
@@ -22,11 +22,11 @@ data Event = Event {
 
 instance Row Event where
   fromRow assoc = do
-      date <- read <$> get "date"
+      rowDate <- read <$> get "date"
       (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 date ints)
+        (Right . Event rowDate ints)
         kind
     where
       get key = maybe (Left $ Expect key) Right $ Map.lookup key assoc

src/Main.hs

@@ -1,12 +1,14 @@
+{-# LANGUAGE NamedFieldPuns #-}
 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 Medicine (Pharmacy, pharmacy)
 import System.Exit (exitFailure, exitSuccess)
-import Timeline (State, currentState)
+import Schedule (schedule)
+import Timeline (State(..), stateAt)
+import YAML (encode)
 
 readCSV :: Row a => FilePath -> IO [a]
 readCSV filePath = do
@@ -15,17 +17,20 @@ readCSV filePath = do
     Left e -> (putStrLn $ show e) >> exitFailure
     Right rows -> return rows
 
-getCurrentState :: IO State
-getCurrentState =
-    currentState
+getState :: Pharmacy -> IO State
+getState aPharmacy =
+    stateAt
   <$> (utctDay <$> getCurrentTime)
-  <*> (pharmacy <$> readCSV "medicine.csv")
+  <*> (return aPharmacy)
   <*> readCSV "timeline.csv"
 
 main :: IO ()
 main = do
   invocation <- invoked
-  case invocation of
-    Inventory -> show <$> getCurrentState >>= putStrLn
-    Schedule -> putStrLn "schedule"
+  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

src/Medicine.hs

@@ -3,7 +3,6 @@ module Medicine (
       Medicine(..)
     , MedicineName
     , Pharmacy
-    , Stock
     , pharmacy
   ) where
 
@@ -16,18 +15,19 @@ type MedicineName = String
 
 data Medicine = Medicine {
       name :: MedicineName
+    , content :: Float
     , 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 MedicineName Medicine
-type Stock = Map MedicineName Float
 
 pharmacy :: [Medicine] -> Pharmacy
 pharmacy = foldr (\medicine -> Map.insert (name medicine) medicine) Map.empty

src/Schedule.hs

@@ -0,0 +1,80 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Schedule (
+    schedule
+  ) where
+
+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)
+import Timeline (State(..))
+import YAML ((.:), Value(..), YAML(..))
+
+data ScheduleType = NextBox | Provision | OutOfStock deriving (Eq, Show)
+
+instance YAML ScheduleType where
+  toYAML NextBox = Simple "start a new box"
+  toYAML Provision = Simple "go to the pharmacy get some more"
+  toYAML OutOfStock = Simple "out of it"
+
+data Schedule = Schedule {
+      days :: Integer
+    , date :: Day
+    , scheduleType :: ScheduleType
+  } deriving (Show)
+
+instance YAML (Map MedicineName Schedule) where
+  toYAML schedules = Object $ outOfStocks ++ nextDay
+    where
+      (urgent, normal) = partition ((== OutOfStock) . scheduleType) schedules
+      outOfStocks =
+        if size urgent > 0
+        then ["Warning ! Out of" .: (Object . timing <$> urgent)]
+        else []
+      nextDay = maybe [] (scheduleNext normal) (snd <$> lookupMin normal)
+
+scheduleNext :: Map MedicineName Schedule -> Schedule -> [(String, Value)]
+scheduleNext schedules aSchedule = ["Schedule" .: (Object $
+      timing aSchedule
+    ++ ["TODO" .: (scheduleType <$> schedules)]
+  )]
+
+timing :: Schedule -> [(String, Value)]
+timing aSchedule =
+  ["On" .: date aSchedule, "In" .: (show (days aSchedule) ++ " days")]
+
+zipWithKey :: Ord k => (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c
+zipWithKey f as bs =
+  mapWithKey (\k -> f k $ as ! k) bs
+
+scheduleByMedicine :: Pharmacy -> Day -> MedicineName -> Float -> Float -> Schedule
+scheduleByMedicine pharmacy day medicineName stockLeft rate =
+  let (scheduleType, amount) = typeAndAmount stockLeft minStock leftInBox in
+  let days = truncate (amount / rate) in
+  Schedule {days, date = days `addDays` day, scheduleType}
+  where
+    (Medicine {minStock, content}) = pharmacy ! medicineName
+    truncateF = fromInteger . truncate
+    leftInBox = content - (truncateF (content / stockLeft) * stockLeft)
+
+typeAndAmount :: Float -> Float -> Float -> (ScheduleType, Float)
+typeAndAmount stockLeft minStock leftInBox =
+  if secureLeft > 0
+  then
+    if secureLeft < leftInBox
+    then (Provision, secureLeft)
+    else (NextBox, leftInBox)
+  else (OutOfStock, stockLeft)
+  where
+    secureLeft = stockLeft - minStock
+
+schedule :: Pharmacy -> State -> Map MedicineName Schedule
+schedule pharmacy (State {day, stock, consumptionRate}) =
+  Map.filter keep schedules
+  where
+    schedules =
+      zipWithKey (scheduleByMedicine pharmacy day) stock consumptionRate
+    minDays = minimum . elems $ days <$> schedules
+    keep aSchedule =
+      days aSchedule == minDays || scheduleType aSchedule == OutOfStock

src/Timeline.hs

@@ -1,40 +1,31 @@
 {-# LANGUAGE NamedFieldPuns #-}
 module Timeline (
-      State
-    , currentState
+      State(..)
+    , stateAt
   ) 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.Map ((!), Map, mapWithKey)
 import Data.Time (Day, diffDays)
 import Event (Event(..), EventType(..))
-import Medicine (Pharmacy, Stock)
-
-type ConsumptionRate = Map String Float
+import Medicine (MedicineName, Pharmacy)
+import YAML ((.:), Value(..), YAML(..))
 
 data State = State {
       day :: Day
-    , stock :: Stock
-    , consumptionRate :: ConsumptionRate
+    , stock :: Map MedicineName Float
+    , consumptionRate :: Map String Float
   }
 
-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
+instance YAML State where
+  toYAML (State {day, stock, consumptionRate}) = Object [
+        "date" .: day
+      , "stock" .: stock
+      , "consumption rates" .: consumptionRate
+    ]
 
-initState :: Reader Pharmacy State
-initState = do
-  pharmacy <- ask
-  return $ State {
+initState :: Pharmacy -> State
+initState pharmacy = State {
       day = toEnum 0
     , stock = const 0 <$> pharmacy
     , consumptionRate = const 0 <$> pharmacy
@@ -59,10 +50,8 @@ setDay newDay state@(State {day, stock, consumptionRate}) = state {
     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)
+stateAt :: Day -> Pharmacy -> [Event] -> State
+stateAt targetDay pharmacy events =
+  setDay targetDay lastState
+  where
+    lastState = foldl applyEvent (initState pharmacy) (sortOn date events)

src/YAML.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
+module YAML (
+      (.:)
+    , Value(..)
+    , YAML(..)
+    , encode
+  ) where
+
+import Data.List (intercalate)
+import Data.Map (Map, toList)
+
+data Value = Simple String | Array [Value] | Object [(String, Value)] deriving (Show)
+
+class YAML a where
+  toYAML :: a -> Value
+
+instance YAML Value where
+  toYAML = id
+
+instance {-# OVERLAPPABLE #-} YAML a => YAML [a] where
+  toYAML = Array . fmap toYAML
+
+instance {-# OVERLAPPABLE #-} YAML a => YAML (Map String a) where
+  toYAML = Object . toList . fmap toYAML
+
+instance {-# OVERLAPPABLE #-} Show a => YAML a where
+  toYAML = Simple . show
+
+instance YAML String where
+  toYAML = Simple
+
+encode :: YAML a => a -> String
+encode = intercalate "\n" . getLines . toYAML
+  where
+    getLines (Simple s) = lines s
+    getLines (Array l) = concat $ (dashFirst . getLines) <$> l
+    getLines (Object m) = concat $ keyVal <$> m
+    dashFirst [] = []
+    dashFirst (l:ls) = ("- " ++ l) : (("  " ++) <$> ls)
+    keyVal (k, Simple s) =
+      case lines s of
+        [v] -> [k ++ ": " ++ v]
+        l -> (k ++ ": |") : (('\t' :) <$> l)
+    keyVal (k, v) = (k ++ ":") : (('\t' :) <$> getLines v)
+
+(.:) :: YAML a => String -> a -> (String, Value)
+(.:) k v = (k, toYAML v)