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