arbtt 0.6.2 → 0.6.4
raw patch · 8 files changed
+307/−138 lines, 8 filesdep +strictdep ~time
Dependencies added: strict
Dependency ranges changed: time
Files
- arbtt.cabal +3/−3
- categorize.cfg +6/−6
- doc/arbtt.xml +70/−1
- src/Categorize.hs +28/−9
- src/Data.hs +3/−0
- src/Stats.hs +174/−104
- src/TimeLog.hs +14/−11
- src/stats-main.hs +9/−4
arbtt.cabal view
@@ -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
categorize.cfg view
@@ -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,
doc/arbtt.xml view
@@ -267,7 +267,11 @@ <literal><=</literal>, <literal>>=</literal>, <literal>></literal> operators. String expressions (<literal>$program</literal>, <literal>$title</literal>) can be matched- against regular expressions with <literal>=~</literal> operator.+ against regular expressions with <literal>=~</literal> operator. With these+ operatorions, the right hand side can be a comma-separated list of+ literals enclosed in square brackets (<literal>[</literal>+ <emphasis>...</emphasis>, <emphasis>...</emphasis>, <literal>]</literal>), which+ succeeds if any of them succeeds. </para> <para>Regular expressions are written either between slashes@@ -350,8 +354,16 @@ <rhs> <quote>$active</quote> </rhs> <rhs> <nonterminal def="#g-string"/> <nonterminal def="#g-cmpop"/> <nonterminal def="#g-string"/> </rhs>+ <rhs> <nonterminal def="#g-string"/> <nonterminal def="#g-cmpop"/>+ <quote>[</quote> <nonterminal def="#g-listofstring"/> + <quote>]</quote>+ </rhs> <rhs> <nonterminal def="#g-string"/> <quote>=~</quote> <nonterminal def="#g-regex"/></rhs>+ <rhs> <nonterminal def="#g-string"/> <quote>=~</quote>+ <quote>[</quote> <nonterminal def="#g-listofregex"/> + <quote>]</quote>+ </rhs> <rhs> <nonterminal def="#g-number"/> <nonterminal def="#g-cmpop"/> <nonterminal def="#g-number"/> </rhs> <rhs> <nonterminal def="#g-timediff"/> <nonterminal def="#g-cmpop"/>@@ -368,6 +380,12 @@ <rhs> <quote>"</quote> string literal <quote>"</quote> </rhs> </production> + <production id="g-listofstring">+ <lhs>ListOfString</lhs>+ <rhs> <quote>"</quote> string literal <quote>"</quote> </rhs>+ <rhs> <quote>"</quote> string literal <quote>"</quote> , <nonterminal def="#g-listofstring"/> </rhs>+ </production>+ <production id="g-number"> <lhs>Number</lhs> <rhs> <quote>$idle</quote> </rhs>@@ -406,6 +424,12 @@ character.</lineannotation> </rhs> </production> + <production id="g-listofregex">+ <lhs>ListOfRegex</lhs>+ <rhs> <quote>"</quote> <nonterminal def="#g-regex"/> <quote>"</quote> </rhs>+ <rhs> <quote>"</quote> <nonterminal def="#g-regex"/> <quote>"</quote> , <nonterminal def="#g-listofregex"/> </rhs>+ </production>+ <production id="g-cmpop"> <lhs>CmpOp</lhs> <rhs><quote><=</quote> | <quote><</quote> | <quote>==</quote>@@ -1038,6 +1062,51 @@ The version history with changes relevant for the user are documented here. </para> + <sect2>+ <title>Version 0.6.4</title>+ <itemizedlist>+ <listitem>+ <para>Massive memory footprint reduction, due to processing the data in one run. See <ulink url="http://www.joachim-breitner.de/blog/archives/560-The-might-applicative-left-fold.html">my blog post for technical information</ulink>.</para>+ </listitem>+ </itemizedlist>+ </sect2>++ <sect2>+ <title>Version 0.6.3</title>+ <itemizedlist>+ <listitem>+ <para>Performance improvements.</para>+ </listitem>+ <listitem>+ <para>Support comparing a string to a list of strings, or matching it against a list ofregular expressions.</para>+ </listitem>+ </itemizedlist>+ </sect2>++ <sect2>+ <title>Version 0.6.2</title>+ <itemizedlist>+ <listitem>+ <para>Add a warning whtn the system locale is not supported.</para>+ </listitem>+ <listitem>+ <para>Allwo RTS options to be passed to the arbtt binaries.</para>+ </listitem>+ <listitem>+ <para>GHC 7.4 compatibility.</para>+ </listitem>+ </itemizedlist>+ </sect2>++ <sect2>+ <title>Version 0.6.1</title>+ <itemizedlist>+ <listitem>+ <para>Performance improvements.</para>+ </listitem>+ </itemizedlist>+ </sect2>+ <sect2> <title>Version 0.6</title> <itemizedlist>
src/Categorize.hs view
@@ -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)
src/Data.hs view
@@ -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"
src/Stats.hs view
@@ -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
src/TimeLog.hs view
@@ -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
src/stats-main.hs view
@@ -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