classify-frog-0.2.3: src/Time.hs

module Time (
   parseRecordingName, timeLabels,
   parseLog, LogEntry(..),
   Hour(..), hours, formatHour, parseHour, splitHour, nextHour,
   ) where

import qualified Data.Time.Format as TimeFormat
import qualified Data.Time.LocalTime as LocalTime
import qualified Data.Time.Clock as Clock
import Data.Time.LocalTime (LocalTime, TimeOfDay)
import Data.Time.Calendar (Day, addDays)

import qualified LabelChain

import qualified System.Path as Path

import Control.DeepSeq (NFData, rnf)
import Control.Monad (guard)

import qualified Data.List.Reverse.StrictElement as Rev
import qualified Data.List.HT as ListHT
import Data.Maybe (listToMaybe)
import Data.Char (isSpace)


{- |
Parse time from file names like @T2014-03-11_18-01-27_0000111.WAV@.
-}
parseRecordingName :: Path.RelFile -> Maybe LocalTime
parseRecordingName =
   TimeFormat.parseTimeM True
      TimeFormat.defaultTimeLocale "T%Y-%m-%d_%H-%M-%S_" .
   take (length "T2014-03-11_18-01-27_") .
   Path.toString

timeLabels :: Double -> TimeOfDay -> LabelChain.T Double String
timeLabels duration =
   fmap (TimeFormat.formatTime TimeFormat.defaultTimeLocale "%H:%M:%S") .
   LabelChain.fromAdjacentChunks .
   zip (chopDuration duration) . iterate nextSecond

chopDuration :: Double -> [Double]
chopDuration =
   let go dur = if dur>1 then 1 : go (dur-1) else [dur]
   in  go

nextSecond :: TimeOfDay -> TimeOfDay
nextSecond =
   LocalTime.timeToTimeOfDay .
   (Clock.secondsToDiffTime 1 +) .
   LocalTime.timeOfDayToTime


parseLogTime :: (String,String) -> Maybe LocalTime
parseLogTime (date,time) =
   TimeFormat.parseTimeM True TimeFormat.defaultTimeLocale "%m/%d/%y %H:%M:%S" $
   date ++ " " ++ time


data LogEntry = Start FilePath | Stop | Recording Path.RelFile Double
   deriving Show

parseLog :: String -> [Either String (LocalTime, LogEntry)]
parseLog =
   filter (either (not . null) (const True)) .
   mergeAdjacent
      (\row0 row1 ->
         case (row0,row1) of
            ((fileName, Nothing), (_, Just (time, ["Monitoring_started"]))) ->
               Just $ Right (time, Start fileName)
            _ -> Nothing)
      (\(row,remd) -> maybe (Left row) Right $ do
         (time, ss) <- remd
         fmap ((,) time) $
            case ss of
               ["Monitoring_stopped"] -> Just Stop
               [fileName, durStr] -> do
                  path <- Path.maybe fileName
                  listToMaybe $ do
                     (dur, seconds) <- reads durStr
                     guard (dropWhile isSpace seconds == "s")
                     return $ Recording path dur
               _ -> Nothing) .
   map
      (\row -> (,) row $ do
         s0:s1:ss <- Just $ ListHT.chop ('\t'==) row
         dateTime <- parseLogTime (s0,s1)
         return (dateTime, ss)) .
   map (Rev.dropWhile ('\r'==)) .
   lines

mergeAdjacent :: (a -> a -> Maybe b) -> (a -> b) -> [a] -> [b]
mergeAdjacent g f =
   let go [] = []
       go [x] = [f x]
       go (x0:x0s@(x1:x1s)) =
         case g x0 x1 of
            Nothing -> f x0 : go x0s
            Just y -> y : go x1s
   in  go


data Hour = Hour {hourDay :: Day, hourOfDay :: Int}
   deriving (Eq, Ord, Show)

instance NFData Hour where
   rnf (Hour day hour) = rnf (day, hour)

hours :: LocalTime -> LabelChain.T Double Hour
hours start =
   let (h,s) = splitHour start
   in  LabelChain.fromAdjacentChunks .
       zip (max 0 (3600 - s) : repeat 3600) . iterate nextHour $ h

formatHour :: String -> Hour -> String
formatHour fmt =
   TimeFormat.formatTime TimeFormat.defaultTimeLocale fmt . localTimeFromHour

localTimeFromHour :: Hour -> LocalTime
localTimeFromHour (Hour day hour) =
   LocalTime.LocalTime {
      LocalTime.localDay = day,
      LocalTime.localTimeOfDay = LocalTime.midnight{LocalTime.todHour = hour}
   }

parseHour :: String -> String -> Maybe Hour
parseHour fmt =
   fmap hourFromLocalTime .
   TimeFormat.parseTimeM True TimeFormat.defaultTimeLocale fmt

hourFromLocalTime :: LocalTime -> Hour
hourFromLocalTime time =
   Hour
      (LocalTime.localDay time)
      (LocalTime.todHour $ LocalTime.localTimeOfDay time)

splitHour :: LocalTime -> (Hour, Double)
splitHour
      (LocalTime.LocalTime {
         LocalTime.localDay = day,
         LocalTime.localTimeOfDay = tod
      }) =
   (Hour day (LocalTime.todHour tod),
    fromIntegral (LocalTime.todMin tod) * 60 +
      realToFrac (LocalTime.todSec tod))

nextHour :: Hour -> Hour
nextHour (Hour day hour0) =
   let (dayInc, hour1) = divMod (hour0+1) 24
   in  Hour (addDays (fromIntegral dayInc) day) hour1