1{-# LANGUAGE RecordWildCards, NamedFieldPuns, TypeOperators, TupleSections, GADTSyntax, ExistentialQuantification, CPP #-} 2module Stats ( 3 Report(..), 4 ReportOptions(..), 5 ReportFormat(..), 6 ReportResults(..), 7 ActivityFilter(..), 8 Filter(..), 9 Repeater(..), 10 defaultFilter, 11 defaultReportOptions, 12 parseActivityMatcher, 13 filterPredicate, 14 prepareCalculations, 15 processReport, 16 processRepeater, 17 renderReport 18 ) where 19 20import Data.Time 21import Data.Maybe 22import Data.List 23import Data.Ord 24import Text.Printf 25import qualified Data.Map.Strict as M 26import qualified Data.Set as S 27import Data.MyText (Text,pack,unpack) 28import Data.Function (on) 29#if MIN_VERSION_time(1,5,0) 30import Data.Time.Format(defaultTimeLocale) 31#else 32import System.Locale (defaultTimeLocale) 33#endif 34import Control.Applicative 35import Data.Strict ((:!:), Pair(..)) 36import qualified Data.Strict as Strict 37import Data.Traversable (sequenceA) 38import Control.Arrow 39import Debug.Trace 40 41import Data 42import Categorize 43import LeftFold 44import DumpFormat 45 46 47data Report = GeneralInfos 48 | TotalTime 49 | Category Category 50 | EachCategory 51 | IntervalCategory Category 52 | IntervalTag Activity 53 | DumpSamples 54 deriving (Show, Eq) 55 56data Filter = Exclude ActivityMatcher | Only ActivityMatcher | GeneralCond String 57 deriving (Show, Eq) 58 59data ActivityMatcher = MatchActivity Activity | MatchCategory Category 60 deriving (Show, Eq) 61 62data ActivityFilter = ExcludeActivity ActivityMatcher | OnlyActivity ActivityMatcher 63 deriving (Show, Eq) 64 65data Repeater = ByMinute | ByHour | ByDay | ByMonth | ByYear 66 deriving (Show, Eq) 67 68-- Supported report output formats: text, comma-separated values and 69-- tab-separated values 70data ReportFormat = RFText | RFCSV | RFTSV 71 deriving (Show, Eq) 72 73data ReportOptions = ReportOptions 74 { roMinPercentage :: Double 75 , roReportFormat :: ReportFormat 76 , roActivityFilter :: [ActivityFilter] 77 } 78 deriving (Show, Eq) 79 80defaultReportOptions :: ReportOptions 81defaultReportOptions = ReportOptions 82 { roMinPercentage = 1 83 , roReportFormat = RFText 84 , roActivityFilter = [] 85 } 86 87-- Data format semantically representing the result of a report, including the 88-- title 89type Interval = (String,String,String,String) 90data ReportResults = 91 ListOfFields String [(String, String)] 92 | ListOfTimePercValues String [(String, String, Double)] 93 | PieChartOfTimePercValues String [(String, String, Double)] 94 | ListOfIntervals String [Interval] 95 | MultipleReportResults [ReportResults] 96 | RepeatedReportResults String [(String, ReportResults)] 97 | DumpResult (TimeLog (CaptureData, TimeZone, ActivityData)) 98 99 100filterPredicate :: [Filter] -> TimeLogEntry (Ctx, ActivityData) -> Bool 101filterPredicate filters tl = 102 all (\flag -> case flag of 103 Exclude act -> excludeTag act tl 104 Only act -> onlyTag act tl 105 GeneralCond s-> applyCond s (cTimeZone (fst (tlData tl))) M.empty tl) filters 106 107filterActivity :: [ActivityFilter] -> ActivityData -> ActivityData 108filterActivity fs = filter (applyActivityFilter fs) 109 110applyActivityFilter :: [ActivityFilter] -> Activity -> Bool 111applyActivityFilter fs act = all go fs 112 where go (ExcludeActivity matcher) = not (matchActivityMatcher matcher act) 113 go (OnlyActivity matcher) = matchActivityMatcher matcher act 114 115excludeTag matcher = not . any (matchActivityMatcher matcher) . snd . tlData 116onlyTag matcher = any (matchActivityMatcher matcher) . snd . tlData 117 118defaultFilter :: Filter 119defaultFilter = Exclude (MatchActivity inactiveActivity) 120 121matchActivityMatcher :: ActivityMatcher -> Activity -> Bool 122matchActivityMatcher (MatchActivity act1) act2 = act1 == act2 123matchActivityMatcher (MatchCategory cat) act2 = Just cat == activityCategory act2 124 125parseActivityMatcher :: String -> ActivityMatcher 126parseActivityMatcher str | last str == ':' = MatchCategory (pack (init str)) 127 | otherwise = MatchActivity (read str) 128 129-- | to be used lazily, to re-use computation when generating more than one 130-- report at a time 131data Calculations = Calculations 132 { firstDate :: UTCTime 133 , lastDate :: UTCTime 134 , timeDiff :: NominalDiffTime 135 , totalTimeRec :: NominalDiffTime 136 , totalTimeSel :: NominalDiffTime 137 , fractionRec :: Double 138 , fractionSel :: Double 139 , fractionSelRec :: Double 140 , sums :: M.Map Activity NominalDiffTime 141 -- , allTags :: TimeLog (Ctx, ActivityData) 142 -- tags is a list of uninterrupted entries 143 -- , tags :: [TimeLog (Ctx, ActivityData)] 144 } 145 146prepareCalculations :: LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) Calculations 147prepareCalculations = 148 pure (\fd ld ttr tts s -> 149 let c = Calculations 150 { firstDate = fd 151 , lastDate = ld 152 , timeDiff = diffUTCTime (lastDate c) (firstDate c) 153 , totalTimeRec = ttr 154 , totalTimeSel = tts 155 , fractionRec = realToFrac (totalTimeRec c) / realToFrac (timeDiff c) 156 , fractionSel = realToFrac (totalTimeSel c) / realToFrac (timeDiff c) 157 , fractionSelRec = realToFrac (totalTimeSel c) / realToFrac (totalTimeRec c) 158 , sums = s 159 } in c) <*> 160 onAll calcFirstDate <*> 161 onAll calcLastDate <*> 162 onAll calcTotalTime <*> 163 onSelected calcTotalTime <*> 164 onSelected calcSums 165 166calcFirstDate :: LeftFold (TimeLogEntry a) UTCTime 167calcFirstDate = fromJust <$> lfFirst `mapElems` tlTime 168 169calcLastDate :: LeftFold (TimeLogEntry a) UTCTime 170calcLastDate = fromJust <$> lfLast `mapElems` tlTime 171 172calcTotalTime :: LeftFold (TimeLogEntry a) NominalDiffTime 173calcTotalTime = (/1000) <$> LeftFold 0 (+) fromInteger `mapElems` tlRate 174 175calcSums :: LeftFold (TimeLogEntry (a, [Activity])) (M.Map Activity NominalDiffTime) 176calcSums = LeftFold M.empty 177 (\m tl -> 178 let go' m act = M.insertWith (+) act (fromInteger (tlRate tl)/1000) m 179 in foldl' go' m (snd (tlData tl))) id 180 181processRepeater :: TimeZone -> Repeater -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults 182processRepeater tz r rep = case repeaterImpl r of 183 RepeaterImpl catR showR -> 184 filterElems (\(b :!: _) -> b) $ 185 pure (RepeatedReportResults (repeaterTitle r) . map (first showR) . M.toList) <*> 186 multiplex (catR . utcToLocalTime tz . tlTime . Strict.snd) rep 187 188data RepeaterImpl where 189 RepeaterImpl :: Ord r => (LocalTime -> r) -> (r -> String) -> RepeaterImpl 190 191repeaterTitle :: Repeater -> String 192repeaterTitle ByMinute = "Minute" 193repeaterTitle ByHour = "Hour" 194repeaterTitle ByDay = "Day" 195repeaterTitle ByMonth = "Month" 196repeaterTitle ByYear = "Year" 197 198repeaterImpl :: Repeater -> RepeaterImpl 199repeaterImpl ByMinute = RepeaterImpl 200 -- a somewhat lazy implementations, using strings... 201 (formatTime defaultTimeLocale "%F %H:%M") 202 id 203repeaterImpl ByHour = RepeaterImpl 204 (formatTime defaultTimeLocale "%F %H:00") 205 id 206repeaterImpl ByDay = RepeaterImpl 207 localDay 208 showGregorian 209repeaterImpl ByMonth = RepeaterImpl 210 ((\(y,m,_) -> (y, m)) . toGregorian . localDay) 211 (\(y,m) -> show y ++ "-" ++ show m) 212repeaterImpl ByYear = RepeaterImpl 213 ((\(y,_,_) -> y) . toGregorian . localDay) 214 show 215 216processReport :: TimeZone -> ReportOptions -> Report -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults 217processReport tz opts GeneralInfos = 218 pure (\n firstDate lastDate ttr tts -> 219 let timeDiff = diffUTCTime lastDate firstDate 220 fractionRec = realToFrac ttr / realToFrac timeDiff :: Double 221 fractionSel = realToFrac tts / realToFrac timeDiff :: Double 222 fractionSelRec = realToFrac tts / realToFrac ttr :: Double 223 in ListOfFields "General Information" 224 [ ("FirstRecord", show firstDate) 225 , ("LastRecord", show lastDate) 226 , ("Number of records", show n) 227 , ("Total time recorded", showTimeDiff opts ttr) 228 , ("Total time selected", showTimeDiff opts tts) 229 , ("Fraction of total time recorded", printf "%3.0f%%" (fractionRec * 100)) 230 , ("Fraction of total time selected", printf "%3.0f%%" (fractionSel * 100)) 231 , ("Fraction of recorded time selected", printf "%3.0f%%" (fractionSelRec * 100)) 232 ]) <*> 233 onAll lfLength <*> 234 onAll calcFirstDate <*> 235 onAll calcLastDate <*> 236 onAll calcTotalTime <*> 237 onSelected calcTotalTime 238 239processReport tz opts TotalTime = 240 onSelected $ 241 pure (\totalTimeSel sums -> 242 ListOfTimePercValues "Total time per tag" . 243 mapMaybe (\(tag,time) -> 244 let perc = realToFrac time/realToFrac totalTimeSel 245 pick = applyActivityFilter (roActivityFilter opts) tag 246 in if pick && perc*100 >= roMinPercentage opts 247 then Just ( show tag , showTimeDiff opts time , perc) 248 else Nothing 249 ) . 250 sortOn (Down . snd) $ 251 M.toList sums) <*> 252 calcTotalTime <*> 253 calcSums 254 255processReport tz opts (Category cat) = pure (\c -> processCategoryReport opts c cat) <*> 256 prepareCalculations 257 258processReport tz opts EachCategory = 259 pure (\c cats -> MultipleReportResults $ map (processCategoryReport opts c) cats) <*> 260 prepareCalculations <*> 261 onSelected calcCategories 262 263processReport tz opts (IntervalCategory cat) = 264 processIntervalReport tz opts ("Intervals for category " ++ show cat) (extractCat cat) 265 where 266 extractCat :: Category -> ActivityData -> Maybe String 267 extractCat cat = fmap (unpack . activityName) . listToMaybe . filter ( (==Just cat) . activityCategory ) 268 269processReport tz opts (IntervalTag tag) = 270 processIntervalReport tz opts ("Intervals for category " ++ show tag) (extractTag tag) 271 where 272 extractTag :: Activity -> ActivityData -> Maybe String 273 extractTag tag = fmap show . listToMaybe . filter (==tag) 274 275processReport tz opts DumpSamples = 276 DumpResult <$> onSelected (mapElems toList $ fmap $ 277 \(cd,ad) -> (tlData (cNow cd), cTimeZone cd, filterActivity (roActivityFilter opts) ad) 278 ) 279 280calcCategories :: LeftFold (TimeLogEntry (Ctx, ActivityData)) [Category] 281calcCategories = fmap S.toList $ leftFold S.empty $ \s tl -> 282 foldl' go' s (snd (tlData tl)) 283 where go' s (Activity (Just cat) _) = S.insert cat s 284 go' s _ = s 285 286processCategoryReport opts ~Calculations{..} cat = 287 PieChartOfTimePercValues ("Statistics for category " ++ show cat) $ 288 let filteredSums = M.filterWithKey (\a _ -> isCategory cat a) sums 289 uncategorizedTime = totalTimeSel - M.foldl' (+) 0 filteredSums 290 tooSmallSums = M.filter (\t -> realToFrac t / realToFrac totalTimeSel * 100 < roMinPercentage opts) filteredSums 291 tooSmallTimes = M.foldl' (+) 0 tooSmallSums 292 in 293 [ (show tag, showTimeDiff opts time, perc) 294 | (tag,time) <- sortOn (Down . snd) $ M.toList filteredSums 295 , applyActivityFilter (roActivityFilter opts) tag 296 , let perc = realToFrac time/realToFrac totalTimeSel 297 , perc*100 >= roMinPercentage opts 298 ] 299 ++ 300 [ ( printf "(%d entries omitted)" (M.size tooSmallSums) 301 , showTimeDiff opts tooSmallTimes 302 , realToFrac tooSmallTimes/realToFrac totalTimeSel 303 ) | tooSmallTimes > 0 ] 304 ++ 305 [ ( "(unmatched time)" 306 , showTimeDiff opts uncategorizedTime 307 , realToFrac uncategorizedTime/realToFrac totalTimeSel 308 ) | uncategorizedTime > 0] 309 ++ 310 [ ( "(total time)" 311 , showTimeDiff opts totalTimeSel 312 , realToFrac totalTimeSel/realToFrac totalTimeSel 313 ) 314 ] 315 316tlRateTimediff :: TimeLogEntry a -> NominalDiffTime 317tlRateTimediff tle = fromIntegral (tlRate tle) / 1000 318 319processIntervalReport :: TimeZone -> ReportOptions -> String -> (ActivityData -> Maybe String) -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults 320processIntervalReport tz opts title extr = runOnIntervals go1 go2 321 where 322 go1 :: LeftFold (TimeLogEntry (Ctx, ActivityData)) [Interval] 323 go1 = go3 `mapElems` fmap (extr . snd) 324 go3 :: LeftFold (TimeLogEntry (Maybe String)) [Interval] 325 go3 = runOnGroups sameGroup go4 (onJusts toList) 326 sameGroup tl1 tl2 = 327 tlData tl1 == tlData tl2 328 && tlTime tl2 `diffUTCTime` tlTime tl1 < 2 * tlRateTimediff tl1 329 go4 :: LeftFold (TimeLogEntry (Maybe String)) (Maybe Interval) 330 go4 = pure (\fe le -> 331 case tlData fe of 332 Just str -> Just 333 ( str 334 , showAsLocalTime tz (tlTime fe) 335 , showAsLocalTime tz (tlRateTimediff le `addUTCTime` tlTime le) 336 , showTimeDiff opts $ 337 tlTime le `diffUTCTime` tlTime fe + tlRateTimediff le 338 ) 339 Nothing -> Nothing) <*> 340 (fromJust <$> lfFirst) <*> 341 (fromJust <$> lfLast) 342 go2 :: LeftFold [Interval] ReportResults 343 go2 = ListOfIntervals title <$> concatFold 344 345 346{- 347 ((extr. snd) `filterWith` 348 runOnIntervals 349 (runOnGroups ((==) `on` tlData) 350-} 351 352 353{- 354intervalReportToTable :: TimeZone -> String -> (ActivityData -> Maybe String) -> ReportResults 355intervalReportToTable tz title extr = ListOfIntervals title $ 356 map (\tles -> 357 let str = fromJust (tlData (head tles)) 358 firstE = showAsLocalTime tz (tlTime (head tles)) 359 lastE = showAsLocalTime tz (tlTime (last tles)) 360 timeLength = showTimeDiff $ 361 tlTime (last tles) `diffUTCTime` tlTime (head tles) + 362 fromIntegral (tlRate (last tles))/1000 363 in (str, firstE, lastE, timeLength)) $ 364 filter (isJust . tlData . head ) $ 365 concat $ 366 fmap (groupBy ((==) `on` tlData) . 367 (fmap.fmap) (extr . snd)) $ 368 tags 369-} 370 371renderReport :: ReportOptions -> ReportResults -> IO () 372renderReport opts (DumpResult samples) = 373 dumpActivity samples 374renderReport opts (MultipleReportResults reports) = 375 sequence_ . intersperse (putStrLn "") . map (renderReport opts) $ reports 376renderReport opts reportdata = 377 putStr $ doRender opts reportdata 378 379doRender :: ReportOptions -> ReportResults -> String 380doRender opts reportdata = case roReportFormat opts of 381 RFText -> renderReportText id reportdata 382 RFCSV -> renderWithDelimiter "," $ renderXSV reportdata 383 RFTSV -> renderWithDelimiter "\t" $ renderXSV reportdata 384 385renderReportText titleMod (ListOfFields title dats) = 386 underline (titleMod title) ++ 387 tabulate False (map (\(f,v) -> [f,v]) dats) 388 389renderReportText titleMod (ListOfTimePercValues title dats) = 390 underline (titleMod title) ++ tabulate True (listOfValues dats) 391 392renderReportText titleMod (PieChartOfTimePercValues title dats) = 393 underline (titleMod title) ++ tabulate True (piechartOfValues dats) 394 395renderReportText titleMod (ListOfIntervals title dats) = 396 underline (titleMod title) ++ tabulate True (listOfIntervals dats) 397 398renderReportText titleMod (RepeatedReportResults cat reps) = 399 intercalate "\n" $ map (\(v,rr) -> renderReportText (titleMod . mod v) rr) reps 400 where mod v s = s ++ " (" ++ cat ++ " " ++ v ++ ")" 401 402listOfValues dats = 403 ["Tag","Time","Percentage"] : 404 map (\(f,t,p) -> [f,t,printf "%.2f" (p*100)]) dats 405 406piechartOfValues dats = 407 ["Tag","Time","Percentage"] : 408 map (\(f,t,p) -> [f,t,printf "%.2f" (p*100)]) dats 409 410listOfIntervals dats = 411 ["Tag","From","Until","Duration"] : 412 map (\(t,f,u,d) -> [t,f,u,d]) dats 413 414-- The reporting of "General Information" is not supported for the 415-- comma-separated output format. 416renderXSV (ListOfFields title dats) = 417 error ("\"" ++ title ++ "\"" ++ " not supported for this output format") 418 419renderXSV (ListOfTimePercValues _ dats) = listOfValues dats 420 421renderXSV (PieChartOfTimePercValues _ dats) = piechartOfValues dats 422 423renderXSV (ListOfIntervals title dats) = listOfIntervals dats 424 425-- A bit code-smelly here. 426renderXSV (RepeatedReportResults cat reps) = title : fields 427 where 428 title = cat : head (renderXSV (snd (head reps))) 429 fields = concatMap (\(v,rr) -> map (v:) (tail (renderXSV rr))) reps 430 431renderWithDelimiter :: String -> [[String]] -> String 432renderWithDelimiter delim datasource = 433 unlines $ map (intercalate delim) datasource 434 435tabulate :: Bool -> [[String]] -> String 436tabulate titlerow rows = unlines $ addTitleRow $ map (intercalate " | " . zipWith (\l s -> take (l - length s) (repeat ' ') ++ s) colwidths) rows 437 where cols = transpose rows 438 colwidths = map (maximum . map length) cols 439 addTitleRow | titlerow = \(l:ls) -> (map (\c -> if c == ' ' then '_' else c) l ++ "_") 440 : ls 441 -- | titlerow = \(l:ls) -> l : (take (length l) (repeat '-')) : ls 442 | otherwise = id 443 444showTimeDiff :: ReportOptions -> NominalDiffTime -> String 445showTimeDiff (ReportOptions { roReportFormat = RFText }) = showTimeDiffHuman 446showTimeDiff _ = showTimeDiffMachine 447 448showTimeDiffHuman :: NominalDiffTime -> String 449showTimeDiffHuman t = go False $ zip [days,hours,mins,secs] ["d","h","m","s"] 450 where s = round t :: Integer 451 days = s `div` (24*60*60) 452 hours = (s `div` (60*60)) `mod` 24 453 mins = (s `div` 60) `mod` 60 454 secs = s `mod` 60 455 go False [] = "0s" 456 go True [] = "" 457-- go True vs | all (==0) (map fst vs) = concat (replicate (length vs) " ") 458 go True ((a,u):vs) = printf "%02d%s" a u ++ go True vs 459 go False ((a,u):vs) | a > 0 = printf "%2d%s" a u ++ go True vs 460 | otherwise = go False vs 461 462showTimeDiffMachine :: NominalDiffTime -> String 463showTimeDiffMachine t = printf "%d:%02d:%02d" hours mins secs 464 where s = round t :: Integer 465 hours = s `div` (60*60) 466 mins = (s `div` 60) `mod` 60 467 secs = s `mod` 60 468 469showAsLocalTime :: TimeZone -> UTCTime -> String 470showAsLocalTime tz = formatTime defaultTimeLocale "%x %X" . utcToZonedTime tz 471 472underline :: String -> String 473underline str = unlines 474 [ str 475 , map (const '=') str 476 ] 477