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