arbtt-0.7: src/Stats.hs

{-# LANGUAGE RecordWildCards, NamedFieldPuns, TypeOperators, TupleSections #-}
module Stats (
    Report(..),
    ReportOptions(..),
    ReportFormat(..),
    ReportResults(..),
    ActivityFilter(..),
    Filter(..),
    defaultFilter,
    defaultReportOptions,
    parseActivityMatcher,
    filterPredicate,
    prepareCalculations,
    processReports,
    renderReport
    ) where

import Data.Time
import Data.Maybe
import Data.List
import Data.Ord
import Text.Printf
import qualified Data.Map as M
import qualified Data.Set as S
import Data.MyText (Text,pack,unpack)
import Data.Function (on)
import System.Locale (defaultTimeLocale)
import Control.Applicative
import Data.Strict ((:!:))
import Data.Traversable (sequenceA)

import Data
import Categorize
import LeftFold


data Report = GeneralInfos
    | TotalTime
    | Category Category
    | EachCategory
    | IntervalCategory Category
    | IntervalTag Activity
        deriving (Show, Eq)

data Filter = Exclude ActivityMatcher | Only ActivityMatcher | GeneralCond String
        deriving (Show, Eq)

data ActivityMatcher = MatchActivity Activity | MatchCategory Category
        deriving (Show, Eq)

data ActivityFilter = ExcludeActivity ActivityMatcher | OnlyActivity ActivityMatcher
        deriving (Show, Eq)

-- Supported report output formats: text, comma-separated values and
-- tab-separated values
data ReportFormat = RFText | RFCSV | RFTSV
        deriving (Show, Eq)

data ReportOptions = ReportOptions
    { roMinPercentage :: Double
    , roReportFormat :: ReportFormat
    , roActivityFilter :: [ActivityFilter]
    }
        deriving (Show, Eq)

defaultReportOptions :: ReportOptions
defaultReportOptions = ReportOptions
    { roMinPercentage = 1
    , roReportFormat = RFText
    , roActivityFilter = []
    }

-- Data format semantically representing the result of a report, including the
-- title
type Interval = (String,String,String,String) 
data ReportResults =
        ListOfFields String [(String, String)]
        | ListOfTimePercValues String [(String, String, Double)]
        | PieChartOfTimePercValues  String [(String, String, Double)]
        | ListOfIntervals String [Interval]
        | MultpleReportResults [ReportResults]


filterPredicate :: [Filter] -> TimeLogEntry (Ctx, ActivityData) -> Bool
filterPredicate filters tl = 
       all (\flag -> case flag of 
                Exclude act  -> excludeTag act tl
                Only act     -> onlyTag act tl
                GeneralCond s-> applyCond s (cTimeZone (fst (tlData tl))) tl) filters

applyActivityFilter :: [ActivityFilter] -> Activity -> Bool
applyActivityFilter fs act = all go fs
    where go (ExcludeActivity matcher) = not (matchActivityMatcher matcher act)
          go (OnlyActivity matcher)    =      matchActivityMatcher matcher act 
                                
excludeTag matcher = not . any (matchActivityMatcher matcher) . snd . tlData
onlyTag matcher = any (matchActivityMatcher matcher) . snd . tlData

defaultFilter :: Filter
defaultFilter = Exclude (MatchActivity inactiveActivity)

matchActivityMatcher :: ActivityMatcher -> Activity -> Bool
matchActivityMatcher (MatchActivity act1) act2 = act1 == act2
matchActivityMatcher (MatchCategory cat) act2 = Just cat == activityCategory act2

parseActivityMatcher :: String -> ActivityMatcher 
parseActivityMatcher str | last str == ':' = MatchCategory (pack (init str))
                         | otherwise       = MatchActivity (read str)

-- | to be used lazily, to re-use computation when generating more than one
-- report at a time
data Calculations = Calculations
        { firstDate :: UTCTime
        , lastDate  :: UTCTime
        , timeDiff :: NominalDiffTime
        , totalTimeRec :: NominalDiffTime
        , totalTimeSel :: NominalDiffTime
        , fractionRec :: Double
        , fractionSel :: Double
        , fractionSelRec :: Double
        , sums :: M.Map Activity NominalDiffTime
        -- , allTags :: TimeLog (Ctx, ActivityData)
        -- tags is a list of uninterrupted entries
        -- , tags :: [TimeLog (Ctx, ActivityData)]
        }

prepareCalculations :: LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) Calculations
prepareCalculations =
    pure (\fd ld ttr tts s -> 
        let c = Calculations
                  { firstDate = fd
                  , lastDate = ld
                  , timeDiff = diffUTCTime (lastDate c) (firstDate c)
                  , totalTimeRec = ttr
                  , totalTimeSel = tts
                  , fractionRec = realToFrac (totalTimeRec c) / (realToFrac (timeDiff c))
                  , fractionSel = realToFrac (totalTimeSel c) / (realToFrac (timeDiff c))
                  , fractionSelRec = realToFrac (totalTimeSel c) / realToFrac (totalTimeRec c)
                  , sums = s
                  } in c) <*>
    onAll calcFirstDate <*>
    onAll calcLastDate <*>
    onAll calcTotalTime <*>
    onSelected calcTotalTime <*>
    onSelected calcSums 
  where

calcFirstDate :: LeftFold (TimeLogEntry a) UTCTime
calcFirstDate = fromJust <$> lfFirst `mapElems` tlTime

calcLastDate :: LeftFold (TimeLogEntry a) UTCTime
calcLastDate = fromJust <$> lfLast `mapElems` tlTime

calcTotalTime :: LeftFold (TimeLogEntry a) NominalDiffTime
calcTotalTime = (/1000) <$> LeftFold 0 (+) fromInteger `mapElems` tlRate

calcSums :: LeftFold (TimeLogEntry (a, [Activity])) (M.Map Activity NominalDiffTime)
calcSums = LeftFold M.empty
            (\m tl ->
                let go' m act = M.insertWith' (+) act (fromInteger (tlRate tl)/1000) m
                in foldl' go' m (snd (tlData tl))) id

processReports :: ReportOptions -> Calculations -> [Report] ->  LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) [ReportResults]
processReports opts c = sequenceA . map (processReport opts c)

processReport :: ReportOptions -> Calculations ->  Report -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults
processReport opts ~(Calculations {..}) GeneralInfos =
   pure (\n ->
    ListOfFields "General Information"
        [ ("FirstRecord", show firstDate)
        , ("LastRecord",  show lastDate)
        , ("Number of records", show n)
        , ("Total time recorded",  showTimeDiff totalTimeRec)
        , ("Total time selected",  showTimeDiff totalTimeSel)
        , ("Fraction of total time recorded", printf "%3.0f%%" (fractionRec * 100))
        , ("Fraction of total time selected", printf "%3.0f%%" (fractionSel * 100))
        , ("Fraction of recorded time selected", printf "%3.0f%%" (fractionSelRec * 100))
        ]) <*>
    onAll lfLength

processReport opts ~(Calculations {..}) TotalTime =
        pure $ 
            ListOfTimePercValues "Total time per tag" .
            mapMaybe (\(tag,time) ->
                  let perc = realToFrac time/realToFrac totalTimeSel
                      pick = applyActivityFilter (roActivityFilter opts) tag
                  in if pick && perc*100 >= roMinPercentage opts
                  then Just $ ( show tag
                              , showTimeDiff time
                              , perc)
                  else Nothing
                  ) .
            reverse .
            sortBy (comparing snd) $
            M.toList $
            sums

processReport opts c (Category cat) = pure (processCategoryReport opts c cat)

processReport opts c EachCategory = 
    pure (\cats -> MultpleReportResults $ map (processCategoryReport opts c) cats) <*>
    onSelected calcCategories

processReport opts c (IntervalCategory cat) =
    processIntervalReport opts c ("Intervals for category " ++ show cat) (extractCat cat) 
    where
        extractCat :: Category -> ActivityData -> Maybe String
        extractCat cat = fmap (unpack . activityName) . listToMaybe . filter ( (==Just cat) . activityCategory )

processReport opts c (IntervalTag tag) =
    processIntervalReport opts c ("Intervals for category " ++ show tag) (extractTag tag) 
    where
        extractTag :: Activity -> ActivityData -> Maybe String
        extractTag tag = fmap show . listToMaybe . filter ( (==tag) )

calcCategories :: LeftFold (TimeLogEntry (Ctx, ActivityData)) [Category]
calcCategories = fmap S.toList $ leftFold S.empty $ \s tl ->
    foldl' go' s (snd (tlData tl))
          where go' s (Activity (Just cat) _) = S.insert cat s
                go' s _                       = s

processCategoryReport opts ~(Calculations {..}) cat =
        PieChartOfTimePercValues ("Statistics for category " ++ show cat) $
                let filteredSums = M.filterWithKey (\a _ -> isCategory cat a) sums
                    uncategorizedTime = totalTimeSel - M.fold (+) 0 filteredSums
                    tooSmallSums = M.filter (\t -> realToFrac t / realToFrac totalTimeSel * 100 < roMinPercentage opts) filteredSums
                    tooSmallTimes = M.fold (+) 0 tooSmallSums
                in

                mapMaybe (\(tag,time) ->
                      let perc = realToFrac time/realToFrac totalTimeSel
                          pick = applyActivityFilter (roActivityFilter opts) tag
                      in if pick && perc*100 >= roMinPercentage opts
                      then Just ( show tag
                                , showTimeDiff time
                                , perc)
                      else Nothing
                      )
                      (reverse $ sortBy (comparing snd) $ M.toList filteredSums)
                ++
                (
                if tooSmallTimes > 0
                then [( printf "(%d entries omitted)" (M.size tooSmallSums)
                      , showTimeDiff tooSmallTimes
                      , realToFrac tooSmallTimes/realToFrac totalTimeSel
                      )]
                else []
                )
                ++      
                (if uncategorizedTime > 0
                then [( "(unmatched time)"
                      , showTimeDiff uncategorizedTime
                      , realToFrac uncategorizedTime/realToFrac totalTimeSel
                      )]
                else []
                )

processIntervalReport :: ReportOptions -> Calculations -> String -> (ActivityData -> Maybe String) -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) ReportResults
processIntervalReport _opts _c title extr = runOnIntervals  go1 go2
  where
    go1 :: LeftFold (TimeLogEntry (Ctx, ActivityData)) [Interval]
    go1 = go3 `mapElems` fmap (extr . snd) 
    go3 :: LeftFold (TimeLogEntry (Maybe String)) [Interval]
    go3 = runOnGroups ((==) `on` tlData) go4 (onJusts toList)
    go4 :: LeftFold (TimeLogEntry (Maybe String)) (Maybe Interval)
    go4 = pure (\fe le ->
        case tlData fe of
            Just str -> Just
                ( str
                , showUtcTime (tlTime fe)
                , showUtcTime (tlTime le)
                , showTimeDiff $
                    tlTime le `diffUTCTime` tlTime fe + fromIntegral (tlRate fe)/1000
                )
            Nothing -> Nothing) <*>
        (fromJust <$> lfFirst) <*>
        (fromJust <$> lfLast)
    go2 :: LeftFold [Interval] ReportResults
    go2 = ListOfIntervals title <$> concatFold
        

{-
        ((extr. snd) `filterWith` 
            runOnIntervals
                (runOnGroups ((==) `on` tlData)
-}


{-
intervalReportToTable :: String -> (ActivityData -> Maybe String) -> ReportResults
intervalReportToTable title extr = ListOfIntervals title $
    map (\tles ->
        let str = fromJust (tlData (head tles))
            firstE = showUtcTime (tlTime (head tles))
            lastE = showUtcTime (tlTime (last tles))
            timeLength = showTimeDiff $
                tlTime (last tles) `diffUTCTime` tlTime (head tles) +
                fromIntegral (tlRate (last tles))/1000
        in (str, firstE, lastE, timeLength)) $
    filter (isJust . tlData . head ) $
    concat $
    fmap (groupBy ((==) `on` tlData) .
         (fmap.fmap) (extr . snd)) $
    tags
-}           
            
renderReport :: ReportOptions -> ReportResults -> IO ()
renderReport opts (MultpleReportResults reports) =
    sequence_ . intersperse (putStrLn "") . map (renderReport opts) $ reports
renderReport opts reportdata =
    putStr $ doRender opts reportdata

doRender :: ReportOptions -> ReportResults -> String
doRender opts reportdata = case roReportFormat opts of
                RFText -> renderReportText reportdata
                RFCSV -> renderReportCSV reportdata
                RFTSV -> renderReportTSV reportdata

renderReportText (ListOfFields title dats) = 
    underline title ++
    (tabulate False $ map (\(f,v) -> [f,v]) dats)

renderReportText (ListOfTimePercValues title dats) = 
    underline title ++ (tabulate True $ listOfValues dats)

renderReportText (PieChartOfTimePercValues title dats) = 
    underline title ++ (tabulate True $ piechartOfValues dats)

renderReportText (ListOfIntervals title dats) = 
    underline title ++ (tabulate True $ listOfIntervals dats)

listOfValues dats =
    ["Tag","Time","Percentage"] :
    map (\(f,t,p) -> [f,t,printf "%.2f" (p*100)]) dats

piechartOfValues dats =
    ["Tag","Time","Percentage"] :
    map (\(f,t,p) -> [f,t,printf "%.2f" (p*100)]) dats

listOfIntervals dats =
    ["Tag","From","Until","Duration"] :
    map (\(t,f,u,d) -> [t,f,u,d]) dats

-- The reporting of "General Information" is not supported for the
-- comma-separated output format.
renderReportCSV (ListOfFields title dats) = 
    error ("\"" ++ title ++ "\"" ++ " not supported for comma-separated output format")

renderReportCSV (ListOfTimePercValues _ dats) = 
    renderWithDelimiter "," (listOfValues dats)

renderReportCSV (PieChartOfTimePercValues _ dats) = 
    renderWithDelimiter "," (piechartOfValues dats)

renderReportCSV (ListOfIntervals title dats) = 
    renderWithDelimiter "," (listOfIntervals dats)

-- The reporting of "General Information" is not supported for the
-- TAB-separated output format.
renderReportTSV (ListOfFields title dats) = 
    error ("\"" ++ title ++ "\"" ++ " not supported for TAB-separated output format")

renderReportTSV (ListOfTimePercValues _ dats) = 
    renderWithDelimiter "\t" (listOfValues dats)

renderReportTSV (PieChartOfTimePercValues _ dats) = 
    renderWithDelimiter "\t" (piechartOfValues dats)

renderReportTSV (ListOfIntervals title dats) = 
    renderWithDelimiter "\t" (listOfIntervals dats)

renderWithDelimiter :: String -> [[String]] -> String
renderWithDelimiter delim datasource =
    unlines $ map (injectDelimiter delim) datasource

injectDelimiter :: [a] -> [[a]] -> [a]
injectDelimiter d = concat . intersperse d

tabulate :: Bool -> [[String]] -> String
tabulate titlerow rows = unlines $ addTitleRow $ map (intercalate " | " . zipWith (\l s -> take (l - length s) (repeat ' ') ++ s) colwidths) rows
  where cols = transpose rows
        colwidths = map (maximum . map length) cols
        addTitleRow | titlerow  = \(l:ls) -> (map (\c -> if c == ' ' then '_' else c) l ++ "_")
                                             : ls
                 -- | titlerow  = \(l:ls) -> l : (take (length l) (repeat '-')) : ls
                    | otherwise = id

showTimeDiff :: NominalDiffTime -> String
showTimeDiff t = go False $ zip [days,hours,mins,secs] ["d","h","m","s"]
  where s = round t :: Integer
        days  =  s `div` (24*60*60)
        hours = (s `div` (60*60)) `mod` 24
        mins  = (s `div` 60) `mod` 60
        secs  =  s `mod` 60 
        go False []         = "0s"
        go True  []         = ""
--      go True  vs         | all (==0) (map fst vs) = concat (replicate (length vs) "   ")
        go True  ((a,u):vs)             = printf "%02d%s" a u ++ go True vs
        go False ((a,u):vs) | a > 0     = printf "%2d%s" a u ++ go True vs
                            | otherwise =                       go False vs

showUtcTime :: UTCTime -> String
showUtcTime = formatTime defaultTimeLocale "%x %X"

underline :: String -> String
underline str = unlines 
    [ str
    , map (const '=') str
    ]