Implement full schedule with warnings for out of stocks

src/Schedule.hs

@@ -1,35 +1,80 @@
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE FlexibleInstances #-}
 module Schedule (
     schedule
   ) where
 
-import Data.Map ((!), elems, mergeWithKey)
+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(..), Pharmacy)
+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 {
-      daysLeft :: Integer
+      days :: Integer
-    , provisionDate :: Maybe Day
+    , date :: Day
-  }
+    , scheduleType :: ScheduleType
+  } deriving (Show)
 
-instance YAML Schedule where
+instance YAML (Map MedicineName Schedule) where
-  toYAML (Schedule {daysLeft, provisionDate = Nothing}) = Object [
+  toYAML schedules = Object $ outOfStocks ++ nextDay
-        "Warning" .: "Stock lower than the minimum security amount defined. Go now !"
-      , "Days left" .: daysLeft
-    ]
-  toYAML (Schedule {daysLeft, provisionDate = Just day}) = Object [
-        "Days left" .: daysLeft
-      , "Provision on" .: day
-    ]
-
-schedule :: Pharmacy -> State -> Schedule
-schedule pharmacy (State {day, stock, consumptionRate}) =
-  Schedule {daysLeft , provisionDate = if daysLeft > 0 then Just $ daysLeft `addDays` day else Nothing}
     where
-    stockInDays medicineName stockLeft rate =
+      (urgent, normal) = partition ((== OutOfStock) . scheduleType) schedules
-      Just $ (stockLeft - minStock (pharmacy ! medicineName)) / rate
+      outOfStocks =
-    daysLeftByMedicine = mergeWithKey stockInDays id id stock consumptionRate
+        if size urgent > 0
-    daysLeft = truncate . minimum $ elems daysLeftByMedicine
+        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/YAML.hs

@@ -11,7 +11,7 @@ module YAML (
 import Data.List (intercalate)
 import Data.Map (Map, toList)
 
-data Value = Simple String | Array [Value] | Object [(String, Value)]
+data Value = Simple String | Array [Value] | Object [(String, Value)] deriving (Show)
 
 class YAML a where
   toYAML :: a -> Value
@@ -19,9 +19,6 @@ class YAML a where
 instance YAML Value where
   toYAML = id
 
-instance Show Value where
-  show = encode
-
 instance {-# OVERLAPPABLE #-} YAML a => YAML [a] where
   toYAML = Array . fmap toYAML
 
@@ -35,15 +32,18 @@ instance YAML String where
   toYAML = Simple
 
 encode :: YAML a => a -> String
-encode = encodeValue . toYAML
+encode = intercalate "\n" . getLines . toYAML
   where
-    encodeValue = intercalate "\n" . getLines
+    getLines (Simple s) = lines s
-    getLines (Simple s) = [s]
+    getLines (Array l) = concat $ (dashFirst . getLines) <$> l
-    getLines (Array l) = fmap (("- " ++) . concat . getLines) l
+    getLines (Object m) = concat $ keyVal <$> m
-    getLines (Object m) = fmap keyVal m
+    dashFirst [] = []
-    keyVal (k, (Simple s)) = k ++ ": " ++ s
+    dashFirst (l:ls) = ("- " ++ l) : (("  " ++) <$> ls)
-    keyVal (k, v) = intercalate "\n" $ (k ++ ":") : (indent <$> getLines v)
+    keyVal (k, Simple s) =
-    indent = ('\t' :)
+      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)