nptools-0.2.1: what-I-have-done-today.hs

{-# LANGUAGE PatternGuards #-}
import System.Locale (defaultTimeLocale)
import System.Environment (getEnv)
import Data.Time.Clock (DiffTime, UTCTime(..), getCurrentTime)
import Data.Time.LocalTime
import Data.Time.Format (readTime, formatTime)
import Control.Monad
import Control.Applicative
import Control.Arrow
import Data.Maybe
import Data.List
import Data.Function
import Data.Ord

readMyTime :: String -> UTCTime
readMyTime = readTime defaultTimeLocale "%T%Q"

splitEvent :: String -> String -> Maybe (String, UTCTime)
splitEvent today event =
   case words event of
     date : time : _ : "tags:" : tags | [tag] <- tags ->
                                          guard (date == today) >> Just (tag, readMyTime time)
                                      | otherwise -> Nothing
     _ -> error ("splitEvent: " ++ event)

formatDiffTime :: DiffTime -> String
formatDiffTime = formatTime defaultTimeLocale "%T%Q" . timeToTimeOfDay

pack :: (Ord a) => [(a, b)] -> [(a, [b])]
pack = map ((fst . head) &&& map snd)
     . groupBy ((==) `on` fst)
     . sortBy (comparing fst)


work :: String -> [String] -> String
work today = unlines . map (uncurry (++) . second ((": "++) . formatDiffTime))
           . sortBy (comparing snd)
           . map (second sum) . pack . uncurry zip
           . second ((map (uncurry (flip (-)))) . (zip`ap`tail) . map utctDayTime)
           . unzip . catMaybes . map (splitEvent today)

main :: IO ()
main =
  do now <- getCurrentTime
     eventsFile <- getEnv "EVENTS_LOG"
     let today = formatTime defaultTimeLocale "%Y-%m-%d" now
     events <- lines <$> readFile eventsFile
     putStr $ work today events