diff --git a/pilu.cabal b/pilu.cabal index 8db2174..187ce1d 100644 --- a/pilu.cabal +++ b/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 diff --git a/src/CSV.hs b/src/CSV.hs index 4190a58..97a5665 100644 --- a/src/CSV.hs +++ b/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 diff --git a/src/Event.hs b/src/Event.hs index 6a2db63..c4ae2dc 100644 --- a/src/Event.hs +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index 23a9ab3..158767e 100644 --- a/src/Main.hs +++ b/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 diff --git a/src/Medicine.hs b/src/Medicine.hs index 253ac44..3736356 100644 --- a/src/Medicine.hs +++ b/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 diff --git a/src/Schedule.hs b/src/Schedule.hs new file mode 100644 index 0000000..16c4bab --- /dev/null +++ b/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 + diff --git a/src/Timeline.hs b/src/Timeline.hs index 5e400a9..95bfe4a 100644 --- a/src/Timeline.hs +++ b/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) diff --git a/src/YAML.hs b/src/YAML.hs new file mode 100644 index 0000000..4f062a5 --- /dev/null +++ b/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)