Take Schedule out to a separate module, implement a mini YAML module for output and clean various warning, simplify code a little bit

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

@@ -3,13 +3,12 @@ module Main where
 
 import CLI (Invocation(..), invoked)
 import CSV (Row, parse)
-import Data.List (minimum)
-import Data.Map (elems, mergeWithKey)
-import Data.Time (UTCTime(..), getCurrentTime, addDays)
-import Event (Event)
-import Medicine (Medicine, Pharmacy, pharmacy)
+import Data.Time (UTCTime(..), getCurrentTime)
+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
@@ -18,27 +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"
 
-schedule :: State -> String
-schedule (State {day, stock, consumptionRate}) = unlines [
-      "Days left: " ++ show deltaDays
-    , "Provision on: " ++ show (deltaDays `addDays` day )
-  ]
-  where
-    daysLeftByMedicine =
-      mergeWithKey (\k a b -> Just $ a / b) id id stock consumptionRate
-    deltaDays = truncate . minimum $ elems daysLeftByMedicine
-
 main :: IO ()
 main = do
   invocation <- invoked
-  case invocation of
-    Inventory -> show <$> getCurrentState >>= putStrLn
-    Schedule -> schedule <$> getCurrentState >>= putStrLn
+  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
 
@@ -29,7 +28,6 @@ instance Row Medicine 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,30 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Schedule (
+    schedule
+  ) where
+
+import Data.Map (elems, mergeWithKey)
+import Data.Time (Day, addDays)
+import Medicine (Pharmacy)
+import Timeline (State(..))
+import YAML ((.:), Value(..), YAML(..))
+
+data Schedule = Schedule {
+      daysLeft :: Integer
+    , provisionDate :: Day
+  }
+
+instance YAML Schedule where
+  toYAML (Schedule {daysLeft, provisionDate}) = Object [
+        "Days left" .: daysLeft
+      , "Provision on" .: provisionDate
+    ]
+
+schedule :: Pharmacy -> State -> Schedule
+schedule _ (State {day, stock, consumptionRate}) =
+  Schedule {daysLeft , provisionDate = daysLeft `addDays` day}
+  where
+    daysLeftByMedicine =
+      mergeWithKey (\_ a b -> Just $ a / b) id id stock consumptionRate
+    daysLeft = truncate . minimum $ elems daysLeftByMedicine
+

src/Timeline.hs

@@ -1,40 +1,31 @@
 {-# LANGUAGE NamedFieldPuns #-}
 module Timeline (
       State(..)
-    , currentState
+    , 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)]
+
+class YAML a where
+  toYAML :: a -> Value
+
+instance YAML Value where
+  toYAML = id
+
+instance Show Value where
+  show = encode
+
+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 = encodeValue . toYAML
+  where
+    encodeValue = intercalate "\n" . getLines
+    getLines (Simple s) = [s]
+    getLines (Array l) = fmap (("- " ++) . concat . getLines) l
+    getLines (Object m) = fmap keyVal m
+    keyVal (k, (Simple s)) = k ++ ": " ++ s
+    keyVal (k, v) = intercalate "\n" $ (k ++ ":") : (indent <$> getLines v)
+    indent = ('\t' :)
+
+(.:) :: YAML a => String -> a -> (String, Value)
+(.:) k v = (k, toYAML v)