ch24 - Log parser - exercise 5

exLog.hs

{-# LANGUAGE QuasiQuotes #-}

module Exlog where

import           Control.Applicative
import           Control.Monad       (unless, void)
import           Data.Char           (isSpace)
import           Data.List           (dropWhile, dropWhileEnd)
import qualified Data.Map.Strict     as M
import           Data.Time
import           Text.Groom
import           Text.RawString.QQ
import           Text.Trifecta

logStr :: String
logStr =
  [r|
-- wheee a comment


# 2025-02-05
08:00 Breakfast
09:00 Sanitizing moisture collector
11:00 Exercising in high-grav gym
12:00 Lunch
13:00 Programming
17:00 Commuting home in rover
17:30 R&R
19:00 Dinner
21:00 Shower
21:15 Read
22:00 Sleep

# 2025-02-07 -- dates not nececessarily sequential
08:00 Breakfast -- should I try skippin bfast?
09:00 Bumped head, passed out
13:36 Wake up, headache
13:37 Go to medbay
13:40 Patch self up
13:45 Commute home for rest
14:15 Read
21:00 Dinner
21:15 Read
22:00 Sleep
|]

logDayRecord :: String
logDayRecord =
  [r|
# 2025-02-07 -- dates not nececessarily sequential
08:00 Breakfast -- should I try skippin bfast?
09:00 Bumped head, passed out
13:36 Wake up, headache
13:37 Go to medbay
13:40 Patch self up
13:45 Commute home for rest
14:15 Read
21:00 Dinner
21:15 Read
22:00 Sleep
|]

-- types
-- show
data LogRecord = LogRecord
  { time  :: TimeOfDay
  , event :: String
  }

instance Show LogRecord where
  show lrec = "   time: " ++ show (time lrec) ++ "  event: " ++ event lrec

data LogDay = LogDay
  { date      :: Day
  , eventList :: [LogRecord]
  }

showDayHeader :: Day -> String
showDayHeader d = "\n date :" ++ show d

showRecords :: [LogRecord] -> [String]
showRecords = map show

instance Show LogDay where
  show (LogDay d rs) = unlines $ showDayHeader d : showRecords rs

newtype Log =
  Log [LogDay]

showLog :: Log -> [String]
showLog (Log [])            = []
showLog (Log (dayLog:logs)) = show dayLog : showLog (Log logs)

instance Show Log where
  show l = unlines $ showLog l

-- trim
ltrim :: String -> String
ltrim = dropWhile isSpace

rtrim :: String -> String
rtrim = dropWhileEnd isSpace

trim :: String -> String
trim = rtrim . ltrim

--
-- skip ws and line comments
skipEOL :: Parser ()
skipEOL = skipMany (char '\n')

skipComments :: Parser ()
skipComments =
  skipMany
    (do _ <- string "--"
        _ <- skipMany (noneOf "\n")
        skipEOL)

skipWhitespace :: Parser ()
skipWhitespace = skipMany (char ' ' <|> char '\n')

-- cleans whitespaces and comments
skipWhitespaceAndComments :: Parser ()
skipWhitespaceAndComments = do
  skipWhitespace
  s <- try (string "--" <* many (noneOf "\n") <* string "\n") <|> return []
  unless (s /= "--") skipWhitespaceAndComments

---
-- parsing
parseDay :: Parser Day
parseDay = do
  skipWhitespaceAndComments
  _ <- char '#'
  spaces
  yyyy <- count 4 digit
  _ <- char '-'
  mm <- count 2 digit
  _ <- char '-'
  dd <- count 2 digit
  skipComments
  skipWhitespaceAndComments
  return (fromGregorian (read yyyy) (read mm) (read dd))

parseLogRecord :: Parser LogRecord
parseLogRecord = do
  skipWhitespaceAndComments
  hh <- count 2 digit
  char ':'
  mn <- count 2 digit
  spaces
  s <-
    manyTill
      (noneOf "\n")
      (try (string "--" >> many (noneOf "\n") >> string "\n") <|>
       (char '\n' >> return []))
  let timeofday = TimeOfDay (read hh) (read mn) 0
  skipWhitespaceAndComments
  return (LogRecord timeofday (trim s))

parseLogDay :: Parser LogDay
parseLogDay = do
  d <- parseDay
  recs <- some parseLogRecord
  return (LogDay d recs)

parseLog :: Parser Log
parseLog = do
  l <- many parseLogDay
  return (Log l)

-- calculations
logDayToList :: LogDay -> [(String, TimeOfDay)]
logDayToList (LogDay _ ls) = map (\l -> (event l, time l)) ls

toTimeDiffList :: [(String, TimeOfDay)] -> [(String, DiffTime)]
toTimeDiffList [] = []
toTimeDiffList [s] = [(fst s, 0)]
toTimeDiffList (s:s2:xs) = (fst s, t2 - t) : toTimeDiffList (s2 : xs)
  where
    t2 = timeOfDayToTime (snd s2)
    t = timeOfDayToTime (snd s)

logDayToDiffList :: LogDay -> [(String, DiffTime)]
logDayToDiffList logDay = toTimeDiffList (logDayToList logDay)

data Stat = Stat
  { arg    :: DiffTime
  , events :: Integer
  } deriving (Show)

logDayToMap :: LogDay -> M.Map String Stat -> M.Map String Stat
logDayToMap ld = lDayToMap (logDayToDiffList ld)

lDayToMap :: [(String, DiffTime)] -> M.Map String Stat -> M.Map String Stat
lDayToMap [] m = m
lDayToMap (l:xs) m =
  M.insertWith insWith (fst l) (Stat (snd l) 1) (lDayToMap xs m)
  where
    insWith :: Stat -> Stat -> Stat
    insWith (Stat dt _) (Stat dt2 i2) = Stat avg numb
      where
        n2 = fromInteger i2
        avg = (dt + (dt2 * n2)) / (n2 + 1)
        numb = round (n2 + 1)

logCalc :: Log -> M.Map String Stat
logCalc (Log []) = M.empty
logCalc (Log l) = go l M.empty
  where
    go xs m = foldr logDayToMap m xs

--
--
-- test function
pst :: Parser a -> String -> Result a
pst p = parseString p mempty

main :: IO ()
main = do
  print $ pst parseLog logStr
  putStrLn $ groom $logCalc <$> pst parseLog logStr