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