diff --git a/arbtt.cabal b/arbtt.cabal --- a/arbtt.cabal +++ b/arbtt.cabal @@ -1,5 +1,5 @@ name: arbtt -version: 0.6.2 +version: 0.6.4 license: GPL license-file: LICENSE category: Desktop @@ -30,8 +30,8 @@ main-is: capture-main.hs hs-source-dirs: src build-depends: - base == 4.5.*, filepath, directory, mtl, time, utf8-string, - bytestring, binary, deepseq + base == 4.5.*, filepath, directory, mtl, time >= 1.4, utf8-string, + bytestring, binary, deepseq, strict other-modules: Data Data.MyText diff --git a/categorize.cfg b/categorize.cfg --- a/categorize.cfg +++ b/categorize.cfg @@ -12,6 +12,8 @@ -- causes this sample to be ignored by default. $idle > 60 ==> tag inactive, +-- A rule that matches on a list of strings +-- current window $program == ["Navigator","galeon"] ==> tag Web, current window $program == "sun-awt-X11-XFramePeer" && current window $title == "I3P" @@ -47,12 +49,10 @@ -- My diploma thesis is in a different directory -current window $title =~ m!(?:~|home/jojo)/dokumente/Uni/DA! - ==> tag Project:DA, -current window $title =~ m!Diplomarbeit.pdf! - ==> tag Project:DA, -current window $title =~ m!LoopSubgroupPaper.pdf! - ==> tag Project:DA, +-- current window $title =~ [ m!(?:~|home/jojo)/dokumente/Uni/DA! +-- , m!Diplomarbeit.pdf! +-- , m!LoopSubgroupPaper.pdf! ] +-- ==> tag Project:DA, current window $title =~ m!TDM! ==> tag Project:TDM, diff --git a/doc/arbtt.xml b/doc/arbtt.xml --- a/doc/arbtt.xml +++ b/doc/arbtt.xml @@ -267,7 +267,11 @@ <=, >=, > operators. String expressions ($program, $title) can be matched - against regular expressions with =~ operator. + against regular expressions with =~ operator. With these + operatorions, the right hand side can be a comma-separated list of + literals enclosed in square brackets ([ + ..., ..., ]), which + succeeds if any of them succeeds. Regular expressions are written either between slashes @@ -350,8 +354,16 @@ $active + + [ + ] + =~ + =~ + [ + ] + @@ -368,6 +380,12 @@ " string literal " + + ListOfString + " string literal " + " string literal " , + + Number $idle @@ -406,6 +424,12 @@ character. + + ListOfRegex + " " + " " , + + CmpOp <= | < | == @@ -1038,6 +1062,51 @@ The version history with changes relevant for the user are documented here. + + Version 0.6.4 + + + Massive memory footprint reduction, due to processing the data in one run. See my blog post for technical information. + + + + + + Version 0.6.3 + + + Performance improvements. + + + Support comparing a string to a list of strings, or matching it against a list ofregular expressions. + + + + + + Version 0.6.2 + + + Add a warning whtn the system locale is not supported. + + + Allwo RTS options to be passed to the arbtt binaries. + + + GHC 7.4 compatibility. + + + + + + Version 0.6.1 + + + Performance improvements. + + + + Version 0.6 diff --git a/src/Categorize.hs b/src/Categorize.hs --- a/src/Categorize.hs +++ b/src/Categorize.hs @@ -16,6 +16,7 @@ import Text.ParserCombinators.Parsec.ExprFail import System.Exit import Control.Applicative ((<*>),(<$>)) +import Control.DeepSeq import Data.List import Data.Maybe import Data.Char @@ -36,8 +37,6 @@ data Ctx = Ctx { cNow :: TimeLogEntry CaptureData - , cPast :: [TimeLogEntry CaptureData] - , cFuture :: [TimeLogEntry CaptureData] , cWindowInScope :: Maybe (Bool, Text, Text) , cSubsts :: [Text] , cCurrentTime :: UTCTime @@ -45,6 +44,9 @@ } deriving (Show) +instance NFData Ctx where + rnf (Ctx a b c d e) = a `deepseq` b `deepseq` c `deepseq` e `deepseq` e `deepseq` () + type Cond = CtxFun [Text] type CtxFun a = Ctx -> Maybe a @@ -56,6 +58,8 @@ | CondTime (CtxFun NominalDiffTime) | CondDate (CtxFun UTCTime) | CondCond (CtxFun [Text]) + | CondStringList (CtxFun [Text]) + | CondRegexList (CtxFun [RE.Regex]) newtype Cmp = Cmp (forall a. Ord a => a -> a -> Bool) @@ -70,7 +74,7 @@ print err exitFailure Right cat -> return $ - ((fmap . fmap) (mkSecond (postpare . cat)) . prepare time tz) + (map (fmap (mkSecond (postpare . cat))) . prepare time tz) applyCond :: String -> TimeLogEntry (Ctx, ActivityData) -> Bool applyCond s = @@ -79,12 +83,8 @@ Right c -> isJust . c . fst . tlData prepare :: UTCTime -> TimeZone -> TimeLog CaptureData -> TimeLog Ctx -prepare time tz tl = go' [] tl tl - where go' past [] [] - = [] - go' past (this:future) (now:rest) - = now {tlData = Ctx now past future Nothing [] time tz } : - go' (this:past) future rest +prepare time tz = map go + where go now = now {tlData = Ctx now Nothing [] time tz } -- | Here, we filter out tags appearing twice, and make sure that only one of -- each category survives @@ -179,12 +179,18 @@ cpType (CondTime _) = "Time" cpType (CondDate _) = "Date" cpType (CondCond _) = "Condition" +cpType (CondStringList _) = "List of Strings" +cpType (CondRegexList _) = "List of regular expressions" checkRegex :: CondPrim -> CondPrim -> Erring CondPrim checkRegex (CondString getStr) (CondRegex getRegex) = Right $ CondCond $ \ctx -> do str <- getStr ctx regex <- getRegex ctx tail <$> RE.match regex str [RE.exec_no_utf8_check] +checkRegex (CondString getStr) (CondRegexList getRegexList) = Right $ CondCond $ \ctx -> do + str <- getStr ctx + regexes <- getRegexList ctx + tail <$> msum (map (\regex -> RE.match regex str [RE.exec_no_utf8_check]) regexes) checkRegex cp1 cp2 = Left $ printf "Cannot apply =~ to an expression of type %s and type %s" (cpType cp1) (cpType cp2) @@ -230,6 +236,11 @@ s2 <- getS2 ctx guard (s1 ? s2) return [] +checkCmp (Cmp (?)) (CondString getS1) (CondStringList getS2) = Right $ CondCond $ \ctx -> do + s1 <- getS1 ctx + sl <- getS2 ctx + guard (any (s1 ?) sl) + return [] checkCmp _ cp1 cp2 = Left $ printf "Cannot compare expressions of type %s and type %s" (cpType cp1) (cpType cp2) @@ -309,6 +320,14 @@ parseCondPrim :: Parser CondPrim parseCondPrim = choice [ parens lang parseCondExpr + , brackets lang (choice [ + (do list <- commaSep1 lang (stringLiteral lang) + return $ CondStringList (const (Just (map T.pack list))) + ) "list of strings", + (do list <- commaSep1 lang parseRegex + return $ CondRegexList (const (Just list)) + ) "list of regular expressions" + ]) , char '$' >> choice [ do backref <- natural lang return $ CondString (getBackref backref) diff --git a/src/Data.hs b/src/Data.hs --- a/src/Data.hs +++ b/src/Data.hs @@ -48,6 +48,9 @@ } deriving (Ord, Eq) +instance NFData Activity where + rnf (Activity a b) = a `deepseq` b `deepseq` () + -- | An activity with special meaning: ignored by default (i.e. for idle times) inactiveActivity = Activity Nothing "inactive" diff --git a/src/Stats.hs b/src/Stats.hs --- a/src/Stats.hs +++ b/src/Stats.hs @@ -1,5 +1,19 @@ -{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} -module Stats where +{-# 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 @@ -11,10 +25,13 @@ 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 @@ -46,6 +63,7 @@ } deriving (Show, Eq) +defaultReportOptions :: ReportOptions defaultReportOptions = ReportOptions { roMinPercentage = 1 , roReportFormat = RFText @@ -54,17 +72,17 @@ -- 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 [(String,String,String,String)] + | ListOfIntervals String [Interval] + | MultpleReportResults [ReportResults] --- We apply the filters in a way such that consecutive runs of selected samples --- are in the same sublist, and sublists are separated by non-selected samples -applyFilters :: [Filter] -> TimeLog (Ctx, ActivityData) -> [TimeLog (Ctx, ActivityData)] -applyFilters filters = filterAndSeparate $ \tl -> +filterPredicate :: [Filter] -> TimeLogEntry (Ctx, ActivityData) -> Bool +filterPredicate filters tl = all (\flag -> case flag of Exclude act -> excludeTag act tl Only act -> onlyTag act tl @@ -74,17 +92,11 @@ applyActivityFilter fs act = all go fs where go (ExcludeActivity matcher) = not (matchActivityMatcher matcher act) go (OnlyActivity matcher) = matchActivityMatcher matcher act - -filterAndSeparate :: (a -> Bool) -> [a] -> [[a]] -filterAndSeparate pred = fst . go - where go [] = ([],True) - go (x:xs) = case (go xs,pred x) of - ((rs, True) , True) -> ([x]:rs, False) - (((r:rs), False), True) -> ((x:r):rs, False) - ((rs, _) , False) -> (rs, True) 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 @@ -107,75 +119,108 @@ , fractionSel :: Double , fractionSelRec :: Double , sums :: M.Map Activity NominalDiffTime - , allTags :: TimeLog (Ctx, ActivityData) + -- , allTags :: TimeLog (Ctx, ActivityData) -- tags is a list of uninterrupted entries - , tags :: [TimeLog (Ctx, ActivityData)] + -- , tags :: [TimeLog (Ctx, ActivityData)] } -prepareCalculations :: TimeLog (Ctx, ActivityData) -> [TimeLog (Ctx, ActivityData)] -> Calculations -prepareCalculations allTags tags = - let c = Calculations - { firstDate = tlTime (head allTags) - , lastDate = tlTime (last allTags) - , timeDiff = diffUTCTime (lastDate c) (firstDate c) - , totalTimeRec = fromInteger (sum (map tlRate allTags))/1000 - , totalTimeSel = fromInteger (sum (map tlRate (concat tags)))/1000 - , fractionRec = realToFrac (totalTimeRec c) / (realToFrac (timeDiff c)) - , fractionSel = realToFrac (totalTimeSel c) / (realToFrac (timeDiff c)) - , fractionSelRec = realToFrac (totalTimeSel c) / realToFrac (totalTimeRec c) - , sums = sumUp (concat tags) - , allTags - , tags - } in c +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 --- | Sums up each occurence of an 'Activity', weighted by the sampling rate -sumUp :: TimeLog (Ctx, ActivityData) -> M.Map Activity NominalDiffTime -sumUp = foldr go M.empty - where go tl m = foldr go' m (snd (tlData tl)) - where go' act = M.insertWith (+) act (fromInteger (tlRate tl)/1000) +calcFirstDate :: LeftFold (TimeLogEntry a) UTCTime +calcFirstDate = fromJust <$> lfFirst `mapElems` tlTime +calcLastDate :: LeftFold (TimeLogEntry a) UTCTime +calcLastDate = fromJust <$> lfLast `mapElems` tlTime -listCategories :: TimeLog (Ctx, ActivityData) -> [Category] -listCategories = S.toList . foldr go S.empty - where go tl m = foldr go' m (snd (tlData tl)) - where go' (Activity (Just cat) _) = S.insert cat - go' _ = id +calcTotalTime :: LeftFold (TimeLogEntry a) NominalDiffTime +calcTotalTime = (/1000) <$> LeftFold 0 (+) fromInteger `mapElems` tlRate -putReports :: ReportOptions -> Calculations -> [Report] -> IO () -putReports opts c = sequence_ . intersperse (putStrLn "") . map (putReport opts c) +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 -putReport :: ReportOptions -> Calculations -> Report -> IO () -putReport opts c EachCategory = putReports opts c (map Category (listCategories (concat (tags c)))) -putReport opts c r = renderReport opts $ reportToTable opts c r +processReports :: ReportOptions -> Calculations -> [Report] -> LeftFold (Bool :!: TimeLogEntry (Ctx, ActivityData)) [ReportResults] +processReports opts c = sequenceA . map (processReport opts c) -reportToTable :: ReportOptions -> Calculations -> Report -> ReportResults -reportToTable opts (Calculations {..}) r = case r of - GeneralInfos -> ListOfFields "General Information" $ - [ ("FirstRecord", show firstDate) - , ("LastRecord", show lastDate) - , ("Number of records", show (length allTags)) - , ("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)) - ] +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 - TotalTime -> 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 - - Category cat -> PieChartOfTimePercValues ("Statistics for category " ++ show cat) $ +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 @@ -209,41 +254,63 @@ )] 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 - IntervalCategory cat -> intervalReportToTable ("Intervals for category " ++ show cat) - (extractCat cat) - IntervalTag tag -> intervalReportToTable ("Intervals for category " ++ show tag) - (extractTag tag) - where - extractCat :: Category -> ActivityData -> Maybe String - extractCat cat = fmap (unpack . activityName) . listToMaybe . filter ( (==Just cat) . activityCategory ) +{- + ((extr. snd) `filterWith` + runOnIntervals + (runOnGroups ((==) `on` tlData) +-} - extractTag :: Activity -> ActivityData -> Maybe String - extractTag tag = fmap show . listToMaybe . filter ( (==tag) ) - 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 - +{- +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 opts reportdata = do - let results = doRender opts reportdata - putStr results +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 @@ -302,9 +369,11 @@ 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 @@ -333,6 +402,7 @@ showUtcTime :: UTCTime -> String showUtcTime = formatTime defaultTimeLocale "%x %X" +underline :: String -> String underline str = unlines [ str , map (const '=') str diff --git a/src/TimeLog.hs b/src/TimeLog.hs --- a/src/TimeLog.hs +++ b/src/TimeLog.hs @@ -15,6 +15,7 @@ import System.Directory import Control.Exception import Prelude hiding (catch) +import Control.DeepSeq import qualified Data.ByteString.Lazy as BS import Data.Maybe @@ -86,20 +87,22 @@ ) where strs = maybe [] listOfStrings prev -readTimeLog :: ListOfStringable a => FilePath -> IO (TimeLog a) +readTimeLog :: (NFData a, ListOfStringable a) => FilePath -> IO (TimeLog a) readTimeLog filename = do content <- BS.readFile filename - return $ runGet start content - where start = do - startString <- getLazyByteString (BS.length magic) - if startString == magic - then go Nothing - else error $ + return $ start content + where start input = + let (startString, rest, off) = runGetState (getLazyByteString (BS.length magic)) input 0 + in if startString == magic + then go Nothing rest off + else error $ "Timelog starts with unknown marker " ++ show (map (chr.fromIntegral) (BS.unpack startString)) - go prev = do v <- ls_get strs - m <- isEmpty - if m then return [v] - else (v :) <$> go (Just (tlData v)) + go prev input off = + let (v, rest, off') = runGetState (ls_get strs) input off + in v `deepseq` + if (BS.null rest) + then [v] + else v : go (Just (tlData v)) rest off' where strs = maybe [] listOfStrings prev diff --git a/src/stats-main.hs b/src/stats-main.hs --- a/src/stats-main.hs +++ b/src/stats-main.hs @@ -11,11 +11,13 @@ import Text.Printf import Data.Version (showVersion) import Control.DeepSeq +import Control.Applicative import TimeLog import Categorize import Stats import CommonStartup +import LeftFold import Paths_arbtt (version) @@ -150,22 +152,25 @@ categorizer <- readCategorizer (optCategorizeFile flags) captures <- readTimeLog (optLogFile flags) - captures `deepseq` return () let allTags = categorizer captures + -- allTags `deepseq` return () when (null allTags) $ do putStrLn "Nothing recorded yet" exitFailure let filters = (if optAlsoInactive flags then id else (defaultFilter:)) $ optFilters flags - let tags = applyFilters filters allTags + -- let tags = applyFilters filters allTags let reps = case optReports flags of {[] -> [TotalTime]; reps -> reverse reps } -- These are defined here, but of course only evaluated when any report -- refers to them. Some are needed by more than one report, which is then -- advantageous. - let c = prepareCalculations allTags tags + let opts = optReportOptions flags + let (c,results) = runLeftFold (filterPredicate filters `filterWith` + (pure (,) <*> prepareCalculations <*> processReports opts c reps)) allTags - putReports (optReportOptions flags) c reps + --let results = runLeftFold (filterPredicate filters `filterWith` processReports opts reps) allTags + renderReport opts (MultpleReportResults results) {- import Data.Accessor