diff --git a/README b/README --- a/README +++ b/README @@ -69,6 +69,11 @@ latest source at the darcs repository at http://darcs.nomeata.de/arbtt +User and Developer discussion happens on the arbtt mailing list: + arbtt@lists.nomeata.de +To subscribe to the list, visit: + http://lists.nomeata.de/mailman/listinfo/arbtt + Some of my plans or ideas include: * A graphical viewer that allows you to expore the tags in an appealing, diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -11,23 +11,23 @@ import System.Directory main = defaultMainWithHooks simpleUserHooks - { hookedPrograms = [isccProgram] - , postBuild = myPostBuild - } + { hookedPrograms = [isccProgram] + , postBuild = myPostBuild + } isccProgram = simpleProgram "ISCC" myPostBuild _ flags pd lbi = do - case lookupProgram isccProgram (withPrograms lbi) of - Nothing -> warn verb $ "The INNO Setup compile ISCC was not found, skipping the " ++ - "creation of the windows setup executable." - Just configuredProg -> do - writeFile includeFilename $ "AppVerName=" ++ display (package pd) ++ "\n" - rawSystemProgram verb configuredProg - ["/Odist","/F"++setupFilename,"setup.iss"] - removeFile includeFilename + case lookupProgram isccProgram (withPrograms lbi) of + Nothing -> warn verb $ "The INNO Setup compile ISCC was not found, skipping the " ++ + "creation of the windows setup executable." + Just configuredProg -> do + writeFile includeFilename $ "AppVerName=" ++ display (package pd) ++ "\n" + rawSystemProgram verb configuredProg + ["/Odist","/F"++setupFilename,"setup.iss"] + removeFile includeFilename where verb = fromFlag (buildVerbosity flags) - setupFilename = display (pkgName (package pd)) ++ - "-setup-" ++ - display (pkgVersion (package pd)) - includeFilename = "dist" "setup-app-ver-name.iss" + setupFilename = display (pkgName (package pd)) ++ + "-setup-" ++ + display (pkgVersion (package pd)) + includeFilename = "dist" "setup-app-ver-name.iss" diff --git a/arbtt.cabal b/arbtt.cabal --- a/arbtt.cabal +++ b/arbtt.cabal @@ -1,5 +1,5 @@ name: arbtt -version: 0.4.5.1 +version: 0.5 license: GPL license-file: LICENSE category: Desktop @@ -7,7 +7,7 @@ build-type: Simple author: Joachim Breitner maintainer: Joachim Breitner -copyright: Joachim Breitner 2009 +copyright: Joachim Breitner 2009-2010 synopsis: Automatic Rule-Based Time Tracker description: arbtt is a background daemon that stores which windows are open, which one @@ -30,10 +30,11 @@ main-is: capture-main.hs hs-source-dirs: src build-depends: - base == 4.*, filepath, directory, mtl, time, + base == 4.*, filepath, directory, mtl, time, utf8-string, bytestring, binary other-modules: Data + Data.MyText Data.Binary.StringRef CommonStartup Capture @@ -63,14 +64,17 @@ main-is: stats-main.hs hs-source-dirs: src build-depends: - base == 4.*, parsec == 2.*, containers, pcre-light + base == 4.*, parsec == 2.*, containers, pcre-light, old-locale other-modules: Data + Data.MyText Data.Binary.StringRef CommonStartup Categorize TimeLog Stats + Text.ParserCombinators.Parsec.ExprFail + Text.Regex.PCRE.Light.Text if os(windows) cpp-options: -DWIN32 else @@ -84,6 +88,7 @@ base == 4.*, parsec == 2.*, containers other-modules: Data + Data.MyText Data.Binary.StringRef CommonStartup TimeLog @@ -93,6 +98,23 @@ other-modules: System.Locale.SetLocale +executable arbtt-import + main-is: import-main.hs + hs-source-dirs: src + build-depends: + base == 4.*, parsec == 2.*, containers + other-modules: + Data + Data.MyText + Data.Binary.StringRef + CommonStartup + TimeLog + if os(windows) + cpp-options: -DWIN32 + else + other-modules: + System.Locale.SetLocale + executable arbtt-recover main-is: recover-main.hs hs-source-dirs: src @@ -100,6 +122,7 @@ base == 4.*, parsec == 2.*, containers other-modules: Data + Data.MyText Data.Binary.StringRef CommonStartup TimeLog diff --git a/categorize.cfg b/categorize.cfg --- a/categorize.cfg +++ b/categorize.cfg @@ -13,15 +13,16 @@ -- Simple rule that just tags the current program tag Program:$current.program, --- I'd like to know what evolution folders I'm working in. But when sending a mail, --- the window title only contains the (not very helpful) subject. So I do not tag --- necessarily by the active window title, but the title that contains the folder +-- I'd like to know what evolution folders I'm working in. But when sending a +-- mail, the window title only contains the (not very helpful) subject. So I do +-- not tag necessarily by the active window title, but the title that contains +-- the folder current window $program == "evolution" && any window ($program == "evolution" && $title =~ /^(.*) \([0-9]+/) ==> tag Evo-Folder:$1, --- A general rule that works well with gvim and gnome-terminal and tells me what --- project I'm currently working on +-- A general rule that works well with gvim and gnome-terminal and tells me +-- what project I'm currently working on current window $title =~ m!(?:~|home/jojo)/projekte/(?:programming/(?:haskell/)?)?([^/)]*)! ==> tag Project:$1, current window $title =~ m!(?:~|home/jojo)/debian! @@ -39,7 +40,8 @@ current window ($program == "gvim" && $title =~ /^[^ ]+\.hs \(/ ) ==> tag Editing-Haskell, --- To be able to match on the time of day, I introduce tags for that as well +-- To be able to match on the time of day, I introduce tags for that as well. +-- $time evaluates to local time. $time >= 2:00 && $time < 8:00 ==> tag time-of-day:night, $time >= 8:00 && $time < 12:00 ==> tag time-of-day:morning, $time >= 12:00 && $time < 14:00 ==> tag time-of-day:lunchtime, @@ -49,3 +51,23 @@ -- This tag always refers to the last 24h $sampleage <= 24:00 ==> tag last-day, + +-- To categorize by calendar periods (months, weeks, or arbitrary periods), +-- I use $date variable, and some auxiliary functions. All these functions +-- evaluate dates in local time. Set TZ environment variable if you need +-- statistics in a different time zone. + +-- “format $date” produces a string with the date in ISO 8601 format +-- (YYYY-MM-DD), it may be compared with strings. For example, to match +-- everything on and after a particular date I can use +format $date >= "2010-03-19" ==> tag period:after_a_special_day, + +-- “day of month $date” gives the day of month (1..31), +-- “day of week $date” gives a sequence number of the day of week +-- (1..7, Monday is 1): +(day of month $date == 13) && (day of week $date == 5) ==> tag day:friday_13, + +-- “month $date” gives a month number (1..12), “year $date” gives a year: +month $date == 1 ==> tag month:January, +month $date == 2 ==> tag month:February, +year $date == 2010 ==> tag year:2010, diff --git a/doc/arbtt.xml b/doc/arbtt.xml --- a/doc/arbtt.xml +++ b/doc/arbtt.xml @@ -15,8 +15,25 @@ mail@joachim-breitner.de Main author of arbtt + + Sergey + Astanin + s.astanin@gmail.com + Contributor + + + Martin + Kiefel + mk@nopw.de + Contributor + + + Muharem + Hrnjadovic + muharem@linux.com + Contributor + - October 2009 @@ -100,34 +117,180 @@ - Configuring the arbtt categorizer + Configuring the arbtt categorizer (<command>arbtt-stats</command>) - Once arbtt-capture is running, it will start recording, without further - configuration. The configuration is only needed to do an analysis of the - recorded data. Thus, if you improve your categorization later, it will apply - even to previous data samples! + Once arbtt-capture is running, it will record data without + any configuration. And only to analyze the recorded data, one needs to + configure the categorizer. Everytime the categorizer + (arbtt-stats) runs, it applies categorization rules to all + recorded data and tags it accordingly. Thus, if you improve your + categorization rules later, they will apply also to all previous data + samples! + + Configuration example The configuration file needs to be placed in ~/.arbtt/categorize.cfg. An - example file is included in the source distribution, and reproduced here as - , which should be more enlightening than this rather - formal description. + example is included in the source distribution, and it is reproduced here: + see . + It should be more enlightening than a formal description. - A complete <filename>categorize.cfg</filename> + <filename>categorize.cfg</filename> + + The semantics (informal) + + A data sample consists of the time of recording, the time passed since the + user’s last action and the list of windows. For each window this + information is available: + + the window title + the program name + whether the window was the active window + + Based on this information and on the rules in + categorize.cfg, the categorizer + (arbtt-stats) assigns tags to + each sample. + + + + A simple rule consists of a condition followed by an arrow + (==>) and a tag expression + (tag keyword followed by tag name). + The rule ends with a coma (,). + + + + The keyword tag, usually preceded with a condition, + assigns a tag to the sample; tag + keyword is followed by a tag name (any sequence of alphanumeric symbols, + underscores and hyphens). If tag name contains a colon + (:), the first part of the name before the colon, is + considered to be tag category. + + + + For example, this rule + month $date == 1 ==> tag month:January, + if it succeeds, assigns a the tag January in the + category month. + + + If the tag has a category, it will only be + assigned if no other tag of that category has been assigned. This means + that for each sample and each category, there can be at most only one tag + in that category. Tags can contain references to group matches in the + regular expressions used in conditions ($1, + $2)...). Tags can also reference some + variables such as window title ($current.title) or + program name ($current.program). + + + + The variable $idle contains the idle time of the user, + measured in seconds. Usually, it is used to assign the tag + inactive, which is handled specially by + arbtt-stats, as can be seen in . + + + + When applying the rules, the categorizer has a notion of + the window in scope, and the variables + $title, $program and + $active always refer to the window in scope. + By default, there is no window is in scope. Condition should be prefixed + with either current window or any + window, to define scope of these variables. + + + + For current window, the currently active window is in + scope. If there is no such window, the condition is false. + + + + For any window, the condition is applied to each + window, in turn, and if any of the windows matches, the result is true. If + more than one window matches it is not defined from which match the + variables $1... are taken from (see more about regular + expressions below). + + + + The variable $time refers to the time-of-day of the + sample (i.e. the time since 00:00 that day, local time), while + $sampleage refers to the + time span from when the sample was recored until now, the time of + evaluating the statistics. The latter variable is especially useful when + passed to the option of + arbtt-stats. They can be compared with expressions + like "hh:mm", for example + $time >= 8:00 && $time < 12:00 ==> tag time-of-day:morning + + + + The variable $date referes to the date and time of the + recorded sample. It cannot be compare to anything else directly, but + there are some helper functions to extract calendar information out of it. + All dates are evaluated in local time. + + + Expression format $date evaluates to a string with + a date formatted according to ISO 8601, i.e. like "YYYY-MM-DD". The 19th + of March 2010 is formatted as "2010-03-19". Formatted date can be compared + to strings. Formatted dates may be useful to tag particular date ranges. + + + Expression month $date evaluates to an integer, from 1 + to 12, corresponding to the month number. Expression year + $date evaluates to an integer which is a year number. + Expression day of month $date evaluates to an integer, + from 1 to 31, corresponding to the day of month. + Expression day of week $date evaluates to an integer, + from 1 to 7, corresponding to the day of week, Monday is 1, Sunday is 7. + These expressions can be compared to integers. + + + + Expressions can be compared to literal values with == + (equal), /= (not equal), <, + <=, >=, + > operators. String expressions + ($program, $title) can be matched + against regular expressions with =~ operator. + + + Regular expressions are written either between slashes + (/ regular expression /), + or after a letter m followed by any symbol + (m c regular expression c, where c is any symbol). + The second appearance of that symbol ends the expression. + You can find both variants in . + + + Complex conditions may be constructed from the simpler ones, + using Boolean AND (&&), OR + (||), and NOT (!) functions and + parentheses. + + + + + The syntax - The file categorize.cfg is a plain text file. - Whitespace is insignificant and Haskell-style comments are allowed. A formal - grammar is provided in . + categorize.cfg is a plain text file. + Whitespace is insignificant and Haskell-style comments are allowed. + A formal grammar is provided in .
@@ -183,25 +346,51 @@ || - $ - == String | - $ - /= String - - $ - =~ - $ - Number - - $ - - - $ - + $active + + + =~ + + + + + current window any window + + String + $title + $program + format + " string literal " + + + + Number + $idle + day of week + day of month + month + year + number literal + + + + Date + $date + + + + + TimeDiff + $time + $sampleage + + [ Digit ] Digit : Digit Digit + + Tag [ Literal : ] Literal @@ -222,31 +411,6 @@ | > | >= - - StringVariable - title | program - - - - NumericVariable - idle - - - - BooleanVariable - active - - - - TimeVariable - time | sampleage - - - - TimeSpecification - [ Digit ] Digit : Digit Digit - -
@@ -285,74 +449,7 @@ expressions. - - The semantics - - A data sample consists of the time of recording, the time passed since the - user’s last action and the list of windows. Per window, the following - information is available: - - the window title - the program name - whether the window was the active window - - Base on this information, the categorizer will now assign - tags to each - sample, based on the rules layed out in - categorizer.cfg. - - - - The keyword tag, usually wrapped in a condition, - assigns the tag to the sample. If the tag also contains a - category, it will only be assigned if no other tag of that - category is present. This means that for each sample and each category, - there can only be one tag of that category. Tags can contain references to - matches done of regular expressions in conditions. - - - - The variable $idle contains the idle time of the user, - measured in seconds. Usually, it is used to assign the tag - inactive, which is handled specially by - arbtt-stats, as can be seen in . - - - - While applying the conditions and rules, the categorizer has a notion of - the window in scope, and the variables - $title, $program and - $active always refer to the window in scope. At first, - no window is in scope. Only when evaluating a condition wrapped in - current window or any window, this - changes. - - - - For current window, the currently active window is in - scope. If there is no such window, the condition is false. - - - - For any window, the condition is applied to each - window, in turn, and if any of the windows matches, the result is true. If - more than one window matches it is not defined from which match the - variables $1... are take from. - - - - The variable $time refers to the time-of-day of the - sample (i.e. the time since 0:00 that day), while - $sampleage refers to the - time span from when the sample was created until now, the time of - evaluating the statistics. The latter variable is especially useful when - passed to the option of - arbtt-stats. - They can be compared with expressions of the - type "hh:mm", for example - $time >= 8:00 && $time < 12:00 ==> tag time-of-day:morning - - + @@ -451,6 +548,14 @@ shows the version number, and exists. + + + logfile to use instead of ~/.arbtt/capture.log + + + + categorize file to use instead of ~/.arbtt/categorize.cfg + Filtering options @@ -488,10 +593,18 @@ PERCENTAGE PERCENTAGE - In the reports, any tag which occurs rarer than the given - percentage is ignored. The default value is 1. + Ignore tags whose percentage is less than the value specified + here. Default percentage: 1%. + + FORMAT + + Specify the report output format, may be one of: text, csv + (comma-separated values), tsv (TAB-separated values). + Default format: text. + + Reports @@ -700,6 +813,70 @@ + + + arbtt-import + imports dumped arbtt data samples + + + + + arbtt-import + OPTION + + + + Description + + arbtt-import expects the output of + arbtt-dump on the standard input and saves them as the + logfile or the specified file. + + + This program would completely override the existing file, therefore it + will refuse to work if the log file already exists. If you want to + overwrite a file, please delete it before running + arbtt-import. + + + + Options + + + + + + shows a short summary of the available + options, and exists. + + + + + shows the version number, and exists. + + + + + logfile to use instead of ~/.arbtt/capture.log + + + + Files + + + ~/.arbtt/capture.log + binary file, storing the arbtt data samples + + + + + See also + See the arbtt manual for more information and the arbtt hackage page for + newer versions of arbtt. + + + arbtt-recover @@ -722,8 +899,11 @@ Description arbtt-recover tries to readsthe data samples recorded - by , skipping over possible broken entries. A fixed log file is written to ~/.arbtt/capture.log.recovered. + by , skipping over possible broken entries. A fixed log file is written to ~/.arbtt/capture.log.recovered. If the recovery was successful, you should stop arbtt-capture and move the file to ~/.arbtt/capture.log. + + As a sid effect, arbtt-recover applies the log compression method implemented in version 0.4.5 to the samples created by an earlier version. If you have a large logfile written by older versions, running arbtt-recover is recommended. + Options @@ -776,14 +956,12 @@ Copyright and Contact - arbtt is Copyright © 2009 Joachim Breitner + arbtt is Copyright © 2009-2010 Joachim Breitner - arbtt does not have a bug tracker or other project infrastructure yet. If - you have bug reports, suggestions or questions, please send an email to - mail@joachim-breitner.de. + arbtt does not have a bug tracker yet. If you have bug reports, suggestions + or questions, please send an email to the arbtt mailing list at arbtt@lists.nomeata.de, which you can subscribe at http://lists.nomeata.de/mailman/listinfo/arbtt. @@ -813,6 +991,61 @@ The version history with changes relevant for the user are documented here. + + + Version 0.5 (The ZuriHac-Release) + + + New command arbtt-import, which imports the output from arbtt-dump. + + + + The command arbtt-stats now supports the + and as well. + () + + + + + The command arbtt-stats now supports the csv + (comma-separated values) and tsv (TAB-separated values) report output + formats in addition to text. + () + + + + + Unicode is handled correctly in regular expressions. + + + + + Improved date-handling functions for categorize.cfg. + () + + + + + + + Version 0.4.5.1 + + + Bugfix: Added missing modules to the cabal file. + + + + + + + Version 0.4.5 + + + Implement a custom compression method greatly reduce the file size of the log file. Run arbtt-capture to compress the previous samples as well. + + + + Version 0.4.4 diff --git a/src/Capture.hs b/src/Capture.hs --- a/src/Capture.hs +++ b/src/Capture.hs @@ -2,11 +2,11 @@ module Capture ( #ifdef WIN32 - module Capture.Win32 + module Capture.Win32 #else - module Capture.X11 + module Capture.X11 #endif - ) where + ) where #ifdef WIN32 import Capture.Win32 diff --git a/src/Capture/Win32.hs b/src/Capture/Win32.hs --- a/src/Capture/Win32.hs +++ b/src/Capture/Win32.hs @@ -1,6 +1,7 @@ module Capture.Win32 where import Data +import qualified Data.MyText as T import Control.Monad import Control.Exception (bracket) import Control.Applicative @@ -12,17 +13,17 @@ setupCapture :: IO () setupCapture = do - return () + return () captureData :: IO CaptureData captureData = do - titles <- fetchWindowTitles - foreground <- getForegroundWindow + titles <- fetchWindowTitles + foreground <- getForegroundWindow - let winData = map ( - \(h,t,p) -> (h == foreground, t, p) - ) titles + let winData = map ( + \(h,t,p) -> (h == foreground, T.pack t, T.pack p) + ) titles - it <- fromIntegral `fmap` getIdleTime + it <- fromIntegral `fmap` getIdleTime - return $ CaptureData winData it + return $ CaptureData winData it diff --git a/src/Capture/X11.hs b/src/Capture/X11.hs --- a/src/Capture/X11.hs +++ b/src/Capture/X11.hs @@ -9,6 +9,7 @@ import Data.Maybe import Data.Time.Clock import System.IO +import qualified Data.MyText as T import System.Locale.SetLocale import Graphics.X11.XScreenSaver (getXIdleTime, compiledWithXScreenSaver) @@ -16,38 +17,41 @@ setupCapture :: IO () setupCapture = do unless compiledWithXScreenSaver $ - hPutStrLn stderr "arbtt [Warning]: X11 was compiled without support for XScreenSaver" - dpy <- openDisplay "" + hPutStrLn stderr "arbtt [Warning]: X11 was compiled without support for XScreenSaver" + dpy <- openDisplay "" xSetErrorHandler - let rwin = defaultRootWindow dpy - a <- internAtom dpy "_NET_CLIENT_LIST" False - p <- getWindowProperty32 dpy a rwin - when (isNothing p) $ do - hPutStrLn stderr "arbtt: ERROR: No _NET_CLIENT_LIST set for the root window" - closeDisplay dpy + let rwin = defaultRootWindow dpy + a <- internAtom dpy "_NET_CLIENT_LIST" False + p <- getWindowProperty32 dpy a rwin + when (isNothing p) $ do + hPutStrLn stderr "arbtt: ERROR: No _NET_CLIENT_LIST set for the root window" + closeDisplay dpy captureData :: IO CaptureData captureData = do - dpy <- openDisplay "" + dpy <- openDisplay "" xSetErrorHandler - let rwin = defaultRootWindow dpy + let rwin = defaultRootWindow dpy - a <- internAtom dpy "_NET_CLIENT_LIST" False - p <- getWindowProperty32 dpy a rwin + a <- internAtom dpy "_NET_CLIENT_LIST" False + p <- getWindowProperty32 dpy a rwin - wins <- case p of - Just wins -> return (map fromIntegral wins) - Nothing -> return [] + wins <- case p of + Just wins -> return (map fromIntegral wins) + Nothing -> return [] - (fsubwin,_) <- getInputFocus dpy - fwin <- followTreeUntil dpy (`elem` wins) fsubwin + (fsubwin,_) <- getInputFocus dpy + fwin <- followTreeUntil dpy (`elem` wins) fsubwin - winData <- mapM (\w -> (,,) (w == fwin) <$> getWindowTitle dpy w <*> getProgramName dpy w) wins + winData <- forM wins $ \w -> (,,) + (w == fwin) <$> + (T.pack <$> getWindowTitle dpy w) <*> + (T.pack <$> getProgramName dpy w) - it <- fromIntegral `fmap` getXIdleTime dpy + it <- fromIntegral `fmap` getXIdleTime dpy - closeDisplay dpy - return $ CaptureData winData it + closeDisplay dpy + return $ CaptureData winData it getWindowTitle :: Display -> Window -> IO String getWindowTitle dpy = myFetchName dpy @@ -61,21 +65,21 @@ followTreeUntil dpy cond = go where go w | cond w = return w | otherwise = do (r,p,_) <- queryTree dpy w - if p == 0 then return w - else go p + if p == 0 then return w + else go p -- | better than fetchName from X11, as it supports _NET_WM_NAME and unicode -- -- Code taken from XMonad.Managehook.title myFetchName :: Display -> Window -> IO String myFetchName d w = do - let getProp = - (internAtom d "_NET_WM_NAME" False >>= getTextProperty d w) - `catch` - (\_ -> getTextProperty d w wM_NAME) + let getProp = + (internAtom d "_NET_WM_NAME" False >>= getTextProperty d w) + `catch` + (\_ -> getTextProperty d w wM_NAME) - extract prop = do l <- wcTextPropertyToTextList d prop - return $ if null l then "" else head l + extract prop = do l <- wcTextPropertyToTextList d prop + return $ if null l then "" else head l - bracket getProp (xFree . tp_value) extract `catch` \_ -> return "" + bracket getProp (xFree . tp_value) extract `catch` \_ -> return "" diff --git a/src/Categorize.hs b/src/Categorize.hs --- a/src/Categorize.hs +++ b/src/Categorize.hs @@ -1,24 +1,33 @@ +{-# LANGUAGE Rank2Types #-} module Categorize where import Data -import qualified Text.Regex.PCRE.Light.Char8 as RE +import qualified Text.Regex.PCRE.Light.Text as RE import qualified Data.Map as M +import qualified Data.MyText as T +import Data.MyText (Text) import Control.Monad import Control.Monad.Instances import Text.ParserCombinators.Parsec hiding (Parser) import Text.ParserCombinators.Parsec.Token import Text.ParserCombinators.Parsec.Language -import Text.ParserCombinators.Parsec.Expr +import Text.ParserCombinators.Parsec.ExprFail import System.Exit import Control.Applicative ((<*>),(<$>)) import Data.List import Data.Maybe import Data.Char import Data.Time.Clock +import Data.Time.LocalTime +import Data.Time.Calendar (toGregorian) +import Data.Time.Calendar.WeekDate (toWeekDate) +import Data.Time.Format (formatTime) +import System.Locale (defaultTimeLocale, iso8601DateFormat) import Debug.Trace import Control.Arrow (second) +import Text.Printf type Categorizer = TimeLog CaptureData -> TimeLog (Ctx, ActivityData) type Rule = Ctx -> ActivityData @@ -26,41 +35,56 @@ type Parser a = CharParser () a data Ctx = Ctx - { cNow :: TimeLogEntry CaptureData - , cPast :: [TimeLogEntry CaptureData] - , cFuture :: [TimeLogEntry CaptureData] - , cWindowInScope :: Maybe (Bool, String, String) - , cSubsts :: [String] - , cCurrentTime :: UTCTime - } + { cNow :: TimeLogEntry CaptureData + , cPast :: [TimeLogEntry CaptureData] + , cFuture :: [TimeLogEntry CaptureData] + , cWindowInScope :: Maybe (Bool, Text, Text) + , cSubsts :: [Text] + , cCurrentTime :: UTCTime + , cTimeZone :: TimeZone + } deriving (Show) -type Cond = Ctx -> Maybe [String] +type Cond = CtxFun [Text] +type CtxFun a = Ctx -> Maybe a + +data CondPrim + = CondString (CtxFun Text) + | CondRegex (CtxFun RE.Regex) + | CondInteger (CtxFun Integer) + | CondTime (CtxFun NominalDiffTime) + | CondDate (CtxFun UTCTime) + | CondCond (CtxFun [Text]) + +newtype Cmp = Cmp (forall a. Ord a => a -> a -> Bool) + readCategorizer :: FilePath -> IO Categorizer readCategorizer filename = do - content <- readFile filename - time <- getCurrentTime - case parse (do {r <- parseRules; eof ; return r}) filename content of - Left err -> do - putStrLn "Parser error:" - print err - exitFailure - Right cat -> return ((fmap . fmap) (mkSecond (postpare . cat)) . prepare time) + content <- readFile filename + time <- getCurrentTime + tz <- getCurrentTimeZone + case parse (do {r <- parseRules; eof ; return r}) filename content of + Left err -> do + putStrLn "Parser error:" + print err + exitFailure + Right cat -> return $ + ((fmap . fmap) (mkSecond (postpare . cat)) . prepare time tz) applyCond :: String -> TimeLog (Ctx, ActivityData) -> TimeLog (Ctx, ActivityData) applyCond s = - case parse (do {c <- parseCond; eof ; return c}) "commad line parameter" s of - Left err -> error (show err) - Right c -> filter (isJust . c . fst . tlData) + case parse (do {c <- parseCond; eof ; return c}) "commad line parameter" s of + Left err -> error (show err) + Right c -> filter (isJust . c . fst . tlData) -prepare :: UTCTime -> TimeLog CaptureData -> TimeLog Ctx -prepare time tl = go' [] tl tl +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 } : - go' (this:past) future rest + = now {tlData = Ctx now past future Nothing [] time tz } : + go' (this:past) future rest -- | Here, we filter out tags appearing twice, and make sure that only one of -- each category survives @@ -74,180 +98,346 @@ parseRules :: Parser Rule parseRules = do - whiteSpace lang - a <- option id (reserved lang "aliases" >> parens lang parseAliasSpecs) - rb <- parseRulesBody - return (a . rb) + whiteSpace lang + a <- option id (reserved lang "aliases" >> parens lang parseAliasSpecs) + rb <- parseRulesBody + return (a . rb) parseAliasSpecs :: Parser (ActivityData -> ActivityData) parseAliasSpecs = do as <- sepEndBy1 parseAliasSpec (comma lang) - return $ \ad -> foldr doAlias ad as + return $ \ad -> foldr doAlias ad as -doAlias :: (String, String) -> ActivityData -> ActivityData +doAlias :: (Text, Text) -> ActivityData -> ActivityData doAlias (s1,s2) = map go where go (Activity cat tag) = Activity (if cat == Just s1 then Just s2 else cat) (if tag == s1 then s2 else tag) -parseAliasSpec :: Parser (String, String) -parseAliasSpec = do s1 <- stringLiteral lang +parseAliasSpec :: Parser (Text, Text) +parseAliasSpec = do s1 <- T.pack <$> stringLiteral lang reservedOp lang "->" - s2 <- stringLiteral lang - return (s1,s2) + s2 <- T.pack <$> stringLiteral lang + return (s1,s2) parseRulesBody :: Parser Rule parseRulesBody = do - x <- parseRule - choice [ do comma lang - xs <- sepEndBy1 parseRule (comma lang) - return (matchAny (x:xs)) - , do semi lang - xs <- many1 (semi lang >> parseRule) - return (matchFirst (x:xs)) - , return x - ] + x <- parseRule + choice [ do comma lang + xs <- sepEndBy1 parseRule (comma lang) + return (matchAny (x:xs)) + , do semi lang + xs <- many1 (semi lang >> parseRule) + return (matchFirst (x:xs)) + , return x + ] parseRule :: Parser Rule parseRule = choice - [ braces lang parseRules - , do cond <- parseCond - reservedOp lang "==>" - rule <- parseRule - return (ifThenElse cond rule matchNone) - , do reserved lang "if" - cond <- parseCond - reserved lang "then" - rule1 <- parseRule - reserved lang "else" - rule2 <- parseRule - return (ifThenElse cond rule1 rule2) - , do reserved lang "tag" - parseSetTag - ] + [ braces lang parseRules + , do cond <- parseCond + reservedOp lang "==>" + rule <- parseRule + return (ifThenElse cond rule matchNone) + , do reserved lang "if" + cond <- parseCond + reserved lang "then" + rule1 <- parseRule + reserved lang "else" + rule2 <- parseRule + return (ifThenElse cond rule1 rule2) + , do reserved lang "tag" + parseSetTag + ] parseCond :: Parser Cond -parseCond = buildExpressionParser [ - [ Prefix (reservedOp lang "!" >> return checkNot) ], - [ Infix (reservedOp lang "&&" >> return checkAnd) AssocLeft ], - [ Infix (reservedOp lang "||" >> return checkOr) AssocLeft ] - ] parseCondPrim +parseCond = do cp <- parseCondExpr + case cp of + CondCond c -> return c + cp -> fail $ printf "Expression of type %s" (cpType cp) -checkAnd :: Cond -> Cond -> Cond -checkAnd c1 c2 = do res1 <- c1 - res2 <- c2 - return $ res1 >> res2 +parseCondExpr :: Parser CondPrim +parseCondExpr = buildExpressionParser [ + [ Prefix (reservedOp lang "!" >> return checkNot) ], + [ Prefix (reserved lang "day of week" >> return evalDayOfWeek) + , Prefix (reserved lang "day of month" >> return evalDayOfMonth) + , Prefix (reserved lang "month" >> return evalMonth) + , Prefix (reserved lang "year" >> return evalYear) + , Prefix (reserved lang "format" >> return formatDate) ], + [ Infix (reservedOp lang "=~" >> return checkRegex) AssocNone + , Infix (checkCmp <$> parseCmp) AssocNone + ], + [ Prefix (reserved lang "current window" >> return checkCurrentwindow) + , Prefix (reserved lang "any window" >> return checkAnyWindow) + ], + [ Infix (reservedOp lang "&&" >> return checkAnd) AssocRight ], + [ Infix (reservedOp lang "||" >> return checkOr) AssocRight ] + ] parseCondPrim +cpType :: CondPrim -> String +cpType (CondString _) = "String" +cpType (CondRegex _) = "Regex" +cpType (CondInteger _) = "Integer" +cpType (CondTime _) = "Time" +cpType (CondDate _) = "Date" +cpType (CondCond _) = "Condition" -checkOr :: Cond -> Cond -> Cond -checkOr c1 c2 = do res1 <- c1 - res2 <- c2 - return $ res1 `mplus` res2 +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 [] +checkRegex cp1 cp2 = Left $ + printf "Cannot apply =~ to an expression of type %s and type %s" + (cpType cp1) (cpType cp2) -checkNot :: Cond -> Cond -checkNot = liftM (maybe (Just []) (const Nothing)) +checkAnd :: CondPrim-> CondPrim -> Erring CondPrim +checkAnd (CondCond c1) (CondCond c2) = Right $ CondCond $ do + res1 <- c1 + res2 <- c2 + return $ res1 >> res2 +checkAnd cp1 cp2 = Left $ + printf "Cannot apply && to an expression of type %s and type %s" + (cpType cp1) (cpType cp2) -parseCmp :: Ord a => Parser (a -> a -> Bool) -parseCmp = choice $ map (\(s,o) -> reservedOp lang s >> return o) - [(">=",(>=)), - (">", (>)), - ("=", (==)), - ("==",(==)), - ("<",(<)), - ("<=",(<=))] +checkOr :: CondPrim-> CondPrim -> Erring CondPrim +checkOr (CondCond c1) (CondCond c2) = Right $ CondCond $ do + res1 <- c1 + res2 <- c2 + return $ res1 `mplus` res2 +checkOr cp1 cp2 = Left $ + printf "Cannot apply && to an expression of type %s and type %s" + (cpType cp1) (cpType cp2) +checkNot :: CondPrim -> Erring CondPrim +checkNot (CondCond getCnd) = Right $ CondCond $ do + liftM (maybe (Just []) (const Nothing)) getCnd +checkNot cp = Left $ + printf "Cannot apply ! to an expression of type %s" + (cpType cp) -parseCondPrim :: Parser Cond +checkCmp :: Cmp -> CondPrim -> CondPrim -> Erring CondPrim +checkCmp (Cmp (?)) (CondInteger getN1) (CondInteger getN2) = Right $ CondCond $ \ctx -> do + n1 <- getN1 ctx + n2 <- getN2 ctx + guard (n1 ? n2) + return [] +checkCmp (Cmp (?)) (CondTime getT1) (CondTime getT2) = Right $ CondCond $ \ctx -> do + t1 <- getT1 ctx + t2 <- getT2 ctx + guard (t1 ? t2) + return [] +checkCmp (Cmp (?)) (CondString getS1) (CondString getS2) = Right $ CondCond $ \ctx -> do + s1 <- getS1 ctx + s2 <- getS2 ctx + guard (s1 ? s2) + return [] +checkCmp _ cp1 cp2 = Left $ + printf "Cannot compare expressions of type %s and type %s" + (cpType cp1) (cpType cp2) + +checkCurrentwindow :: CondPrim -> Erring CondPrim +checkCurrentwindow (CondCond cond) = Right $ CondCond $ \ctx -> + cond (ctx { cWindowInScope = findActive (cWindows (tlData (cNow ctx))) }) +checkCurrentwindow cp = Left $ + printf "Cannot apply current window to an expression of type %s" + (cpType cp) + +checkAnyWindow :: CondPrim -> Erring CondPrim +checkAnyWindow (CondCond cond) = Right $ CondCond $ \ctx -> + msum $ map (\w -> cond (ctx { cWindowInScope = Just w })) + (cWindows (tlData (cNow ctx))) +checkAnyWindow cp = Left $ + printf "Cannot apply current window to an expression of type %s" + (cpType cp) + +fst3 (a,_,_) = a +snd3 (_,b,_) = b +trd3 (_,_,c) = c + +-- Day of week is an integer in [1..7]. +evalDayOfWeek :: CondPrim -> Erring CondPrim +evalDayOfWeek (CondDate df) = Right $ CondInteger $ \ctx -> + let tz = cTimeZone ctx in + (toInteger . trd3 . toWeekDate . localDay . utcToLocalTime tz) `liftM` df ctx +evalDayOfWeek cp = Left $ printf + "Cannot apply day of week to an expression of type %s, only to $date." + (cpType cp) + +-- Day of month is an integer in [1..31]. +evalDayOfMonth :: CondPrim -> Erring CondPrim +evalDayOfMonth (CondDate df) = Right $ CondInteger $ \ctx -> + let tz = cTimeZone ctx in + (toInteger . trd3 . toGregorian . localDay . utcToLocalTime tz) `liftM` df ctx +evalDayOfMonth cp = Left $ printf + "Cannot apply day of month to an expression of type %s, only to $date." + (cpType cp) + +-- Month is an integer in [1..12]. +evalMonth :: CondPrim -> Erring CondPrim +evalMonth (CondDate df) = Right $ CondInteger $ \ctx -> + let tz = cTimeZone ctx in + (toInteger . snd3 . toGregorian . localDay . utcToLocalTime tz) `liftM` df ctx +evalMonth cp = Left $ printf + "Cannot apply month to an expression of type %s, only to $date." + (cpType cp) + +evalYear :: CondPrim -> Erring CondPrim +evalYear (CondDate df) = Right $ CondInteger $ \ctx -> + let tz = cTimeZone ctx in + (fst3 . toGregorian . localDay . utcToLocalTime tz) `liftM` df ctx +evalYear cp = Left $ printf + "Cannot apply year to an expression of type %s, only to $date." + (cpType cp) + +-- format date according to ISO 8601 (YYYY-MM-DD) +formatDate :: CondPrim -> Erring CondPrim +formatDate (CondDate df) = Right $ CondString $ \ctx -> + let tz = cTimeZone ctx + local = utcToLocalTime tz `liftM` df ctx + in T.pack . formatTime defaultTimeLocale (iso8601DateFormat Nothing) <$> local +formatDate cp = Left $ printf + "Cannot format an expression of type %s, only $date." (cpType cp) + +parseCmp :: Parser Cmp +parseCmp = choice $ map (\(s,o) -> reservedOp lang s >> return o) + [(">=",Cmp (>=)), + (">", Cmp (>)), + ("==",Cmp (==)), + ("=", Cmp (==)), + ("<", Cmp (<)), + ("<=",Cmp (<=))] + +parseCondPrim :: Parser CondPrim parseCondPrim = choice - [ parens lang parseCond - , do char '$' - varname <- show `liftM` natural lang <|> identifier lang - choice - [ do guard $ varname `elem` ["title","program"] - choice - [ do reservedOp lang "=~" - regex <- parseRegex - return $ checkRegex varname (RE.compile regex []) - , do reservedOp lang "==" <|> reservedOp lang "=" - str <- stringLiteral lang - return $ checkEq varname str - , do reservedOp lang "/=" <|> reservedOp lang "!=" - str <- stringLiteral lang - return $ checkNot (checkEq varname str) - ] - , do guard $ varname == "idle" - op <- parseCmp - num <- natural lang - return $ checkNumCmp op varname num - , do guard $ varname `elem` ["time","sampleage"] - op <- parseCmp - time <- parseTime - return $ checkTimeCmp op varname time - , do guard $ varname == "active" - return checkActive - ] - , do reserved lang "current window" - cond <- parseCond - return $ checkCurrentwindow cond - , do reserved lang "any window" - cond <- parseCond - return $ checkAnyWindow cond - ] + [ parens lang parseCondExpr + , char '$' >> choice + [ do backref <- natural lang + return $ CondString (getBackref backref) + , do varname <- identifier lang + choice + [ do guard $ varname == "title" + return $ CondString (getVar "title") + , do guard $ varname == "program" + return $ CondString (getVar "program") + , do guard $ varname == "active" + return $ CondCond checkActive + , do guard $ varname == "idle" + return $ CondInteger (getNumVar "idle") + , do guard $ varname == "time" + return $ CondTime (getTimeVar "time") + , do guard $ varname == "sampleage" + return $ CondTime (getTimeVar "sampleage") + , do guard $ varname == "date" + return $ CondDate (getDateVar "date") + ] + ] "variable" + , do regex <- parseRegex "regular expression" + return $ CondRegex (const (Just regex)) + , do str <- T.pack <$> stringLiteral lang "string" + return $ CondString (const (Just str)) + , try $ do time <- parseTime "time" -- backtrack here, it might have been a number + return $ CondTime (const (Just time)) + , do num <- natural lang "number" + return $ CondInteger (const (Just num)) + ] +{- + choice + [ do reservedOp lang "=~" + regex <- parseRegex + return $ checkRegex varname (RE.compile regex []) + , do reservedOp lang "==" <|> reservedOp lang "=" + str <- stringLiteral lang + return $ checkEq varname str + , do reservedOp lang "/=" <|> reservedOp lang "!=" + str <- stringLiteral lang + return $ checkNot (checkEq varname str) + ] + , do guard $ varname == "idle" + op <- parseCmp + num <- natural lang + return $ checkNumCmp op varname num + , do guard $ varname `elem` ["time","sampleage"] + op <- parseCmp + time <- parseTime + return $ checkTimeCmp op varname time + , do guard $ varname == "active" + return checkActive + ] + , do reserved lang "current window" + cond <- parseCond + return $ checkCurrentwindow cond + , do reserved lang "any window" + cond <- parseCond + return $ checkAnyWindow cond + ] +-} -parseRegex :: Parser String -parseRegex = lexeme lang $ choice - [ between (char '/') (char '/') (many1 (noneOf "/")) - , do char 'm' - c <- anyChar - str <- many1 (noneOf [c]) - char c - return str - ] - +parseRegex :: Parser RE.Regex +parseRegex = fmap (flip RE.compile [] . T.pack) $ lexeme lang $ choice + [ between (char '/') (char '/') (many1 (noneOf "/")) + , do char 'm' + c <- anyChar + str <- many1 (noneOf [c]) + char c + return str + ] + -- | Parses a day-of-time specification (hh:mm) parseTime :: Parser NominalDiffTime parseTime = fmap fromIntegral $ lexeme lang $ do h <- digitToInt <$> digit - mh <- optionMaybe (digitToInt <$> digit) - char ':' + mh <- optionMaybe (digitToInt <$> digit) + char ':' m1 <- digitToInt <$> digit m2 <- digitToInt <$> digit - let hour = maybe h ((10*h)+) mh - return $ (hour * 60 + m1 * 10 + m2) * 60 + let hour = maybe h ((10*h)+) mh + return $ (hour * 60 + m1 * 10 + m2) * 60 parseSetTag :: Parser Rule parseSetTag = lexeme lang $ do firstPart <- parseTagPart - choice [ do char ':' - secondPart <- parseTagPart - return $ do cat <- firstPart - tag <- secondPart - return $ maybeToList $ do - cat <- cat - tag <- tag - return $ Activity (Just cat) tag - , return $ do tag <- firstPart - return $ maybeToList $ do - tag <- tag - return $ Activity Nothing tag - ] + choice [ do char ':' + secondPart <- parseTagPart + return $ do cat <- firstPart + tag <- secondPart + return $ maybeToList $ do + cat <- cat + tag <- tag + return $ Activity (Just cat) tag + , return $ do tag <- firstPart + return $ maybeToList $ do + tag <- tag + return $ Activity Nothing tag + ] -parseTagPart :: Parser (Ctx -> Maybe String) -parseTagPart = do parts <- many1 (choice - [ do char '$' - varname <- many1 (letter <|> oneOf ".") <|> many1 digit - return $ getVar varname - , do s <- many1 (letter <|> oneOf "-_") - return $ const (Just s) - ]) - return $ (fmap concat . sequence) <$> sequence parts +replaceForbidden :: Maybe Text -> Maybe Text +replaceForbidden = liftM $ T.map go + where + go c | isLetter c = c + | c `elem` "-_" = c + | otherwise = '_' +parseTagPart :: Parser (Ctx -> Maybe Text) +parseTagPart = do parts <- many1 (choice + [ do char '$' + choice + [ do num <- natural lang + return $ replaceForbidden . getBackref num + , do varname <- many1 (letter <|> oneOf ".") + return $ getVar varname + ] "variable" + , do s <- many1 (alphaNum <|> oneOf "-_") + return $ const (Just (T.pack s)) + ]) + return $ (fmap T.concat . sequence) <$> sequence parts + ifThenElse :: Cond -> Rule -> Rule -> Rule ifThenElse cond r1 r2 = do res <- cond case res of - Just substs -> r1 . setSubsts substs - Nothing -> r2 - where setSubsts :: [String] -> Ctx -> Ctx + Just substs -> r1 . setSubsts substs + Nothing -> r2 + where setSubsts :: [Text] -> Ctx -> Ctx setSubsts substs ctx = ctx { cSubsts = substs } - + matchAny :: [Rule] -> Rule matchAny rules = concat <$> sequence rules @@ -255,57 +445,47 @@ matchFirst rules = takeFirst <$> sequence rules where takeFirst [] = [] takeFirst ([]:xs) = takeFirst xs - takeFirst (x:xs) = x + takeFirst (x:xs) = x -getVar :: String -> Ctx -> Maybe String -getVar v ctx | all isNumber v = - let n = read v in - listToMaybe (drop (n-1) (cSubsts ctx)) + +getBackref :: Integer -> CtxFun Text +getBackref n ctx = listToMaybe (drop (fromIntegral n-1) (cSubsts ctx)) + +getVar :: String -> CtxFun Text getVar v ctx | "current" `isPrefixOf` v = do - let var = drop (length "current.") v - win <- findActive $ cWindows (tlData (cNow ctx)) - getVar var (ctx { cWindowInScope = Just win }) + let var = drop (length "current.") v + win <- findActive $ cWindows (tlData (cNow ctx)) + getVar var (ctx { cWindowInScope = Just win }) getVar "title" ctx = do - (_,t,_) <- cWindowInScope ctx + (_,t,_) <- cWindowInScope ctx return t getVar "program" ctx = do - (_,_,p) <- cWindowInScope ctx + (_,_,p) <- cWindowInScope ctx return p - -checkRegex :: String -> RE.Regex -> Cond -checkRegex varname regex ctx = do s <- getVar varname ctx - matches <- RE.match regex s [] - return (tail matches) +getVar v ctx = error $ "Unknown variable " ++ v -checkEq :: String -> String -> Cond -checkEq varname str ctx = do s <- getVar varname ctx - [] `justIf` (s == str) +getNumVar :: String -> CtxFun Integer +getNumVar "idle" ctx = Just $ cLastActivity (tlData (cNow ctx)) `div` 1000 -findActive :: [(Bool, t, t1)] -> Maybe (Bool, t, t1) -findActive = find (\(a,_,_) -> a) +getTimeVar :: String -> CtxFun NominalDiffTime +getTimeVar "time" ctx = Just $ + let utc = tlTime . cNow $ ctx + tz = cTimeZone ctx + local = utcToLocalTime tz utc + midnightUTC = localTimeToUTC tz $ local { localTimeOfDay = midnight } + in utc `diffUTCTime` midnightUTC +getTimeVar "sampleage" ctx = Just $ cCurrentTime ctx `diffUTCTime` tlTime (cNow ctx) -checkCurrentwindow :: Cond -> Cond -checkCurrentwindow cond ctx = cond (ctx { cWindowInScope = findActive (cWindows (tlData (cNow ctx))) }) +getDateVar :: String -> CtxFun UTCTime +getDateVar "date" ctx = Just $ tlTime (cNow ctx) -checkAnyWindow :: Cond -> Cond -checkAnyWindow cond ctx = msum $ map (\w -> cond (ctx { cWindowInScope = Just w })) - (cWindows (tlData (cNow ctx))) +findActive :: [(Bool, t, t1)] -> Maybe (Bool, t, t1) +findActive = find (\(a,_,_) -> a) checkActive :: Cond checkActive ctx = do (a,_,_) <- cWindowInScope ctx guard a - return [] - -checkNumCmp :: (Integer -> Integer -> Bool) -> String -> Integer -> Cond -checkNumCmp () "idle" num ctx = [] `justIf` (cLastActivity (tlData (cNow ctx)) (num*1000)) - -checkTimeCmp :: (NominalDiffTime -> NominalDiffTime -> Bool) -> String -> NominalDiffTime -> Cond -checkTimeCmp () "time" num ctx = - let time = tlTime (cNow ctx) `diffUTCTime` (tlTime (cNow ctx)) { utctDayTime = fromIntegral 0} - in [] `justIf` (time num) -checkTimeCmp () "sampleage" num ctx = - let age = cCurrentTime ctx `diffUTCTime` tlTime (cNow ctx) - in [] `justIf` (age num) + return [] matchNone :: Rule matchNone = const [] diff --git a/src/CommonStartup.hs b/src/CommonStartup.hs --- a/src/CommonStartup.hs +++ b/src/CommonStartup.hs @@ -9,6 +9,6 @@ commonStartup :: IO () commonStartup = do #ifndef WIN32 - setLocale LC_ALL (Just "") + setLocale LC_ALL (Just "") #endif - return () + return () diff --git a/src/Data.hs b/src/Data.hs --- a/src/Data.hs +++ b/src/Data.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Data where import Data.Time @@ -9,50 +10,52 @@ import Data.Binary.Put import Data.Binary.Get import Data.Binary.StringRef +import qualified Data.MyText as T +import Data.MyText (Text) import Control.Applicative import Control.Monad type TimeLog a = [TimeLogEntry a] data TimeLogEntry a = TimeLogEntry - { tlTime :: UTCTime - , tlRate :: Integer -- ^ in milli-seconds - , tlData :: a } - deriving (Show) + { tlTime :: UTCTime + , tlRate :: Integer -- ^ in milli-seconds + , tlData :: a } + deriving (Show, Read) instance Functor TimeLogEntry where - fmap f tl = tl { tlData = f (tlData tl) } - + fmap f tl = tl { tlData = f (tlData tl) } + data CaptureData = CaptureData - { cWindows :: [ (Bool, String, String) ] - -- ^ Active window, window title, programm name - , cLastActivity :: Integer -- ^ in milli-seconds - } - deriving (Show) + { cWindows :: [ (Bool, Text, Text) ] + -- ^ Active window, window title, programm name + , cLastActivity :: Integer -- ^ in milli-seconds + } + deriving (Show, Read) type ActivityData = [Activity] data Activity = Activity - { activityCategory :: Maybe Category - , activityName :: String - } + { activityCategory :: Maybe Category + , activityName :: Text + } deriving (Ord, Eq) -- | An activity with special meaning: ignored by default (i.e. for idle times) inactiveActivity = Activity Nothing "inactive" instance Show Activity where - show (Activity mbC t) = maybe "" (++":") mbC ++ t + show (Activity mbC t) = maybe "" ((++":").T.unpack) mbC ++ (T.unpack t) instance Read Activity where readPrec = readP_to_Prec $ \_ -> - (do cat <- munch1 (/= ':') - char ':' - tag <- many1 ReadP.get - return $ Activity (Just cat) tag) - <++ (Activity Nothing `fmap` many1 ReadP.get) + (do cat <- munch1 (/= ':') + char ':' + tag <- many1 ReadP.get + return $ Activity (Just (T.pack cat)) (T.pack tag)) + <++ (Activity Nothing . T.pack <$> many1 ReadP.get) -type Category = String +type Category = Text isCategory :: Category -> Activity -> Bool isCategory cat (Activity (Just cat') _) = cat == cat' @@ -63,25 +66,25 @@ instance StringReferencingBinary a => StringReferencingBinary (TimeLogEntry a) where ls_put strs tle = do - -- A version tag - putWord8 1 - put (tlTime tle) - put (tlRate tle) - ls_put strs (tlData tle) + -- A version tag + putWord8 1 + put (tlTime tle) + put (tlRate tle) + ls_put strs (tlData tle) ls_get strs = do - v <- getWord8 - case v of - 1 -> TimeLogEntry <$> get <*> get <*> ls_get strs - _ -> error $ "Unsupported TimeLogEntry version tag " ++ show v + v <- getWord8 + case v of + 1 -> TimeLogEntry <$> get <*> get <*> ls_get strs + _ -> error $ "Unsupported TimeLogEntry version tag " ++ show v instance Binary UTCTime where put (UTCTime (ModifiedJulianDay d) t) = do - put d - put (toRational t) + put d + put (toRational t) get = do - d <- get - t <- get - return $ UTCTime (ModifiedJulianDay d) (fromRational t) + d <- get + t <- get + return $ UTCTime (ModifiedJulianDay d) (fromRational t) instance ListOfStringable CaptureData where listOfStrings = concatMap (\(b,t,p) -> [t,p]) . cWindows @@ -91,16 +94,16 @@ -- 1 First version -- 2 Using ListOfStringable ls_put strs cd = do - -- A version tag - putWord8 2 - ls_put strs (cWindows cd) - ls_put strs (cLastActivity cd) + -- A version tag + putWord8 2 + ls_put strs (cWindows cd) + ls_put strs (cLastActivity cd) ls_get strs = do - v <- getWord8 - case v of - 1 -> CaptureData <$> get <*> get - 2 -> CaptureData <$> ls_get strs <*> ls_get strs - _ -> error $ "Unsupported CaptureData version tag " ++ show v + v <- getWord8 + case v of + 1 -> CaptureData <$> get <*> get + 2 -> CaptureData <$> ls_get strs <*> ls_get strs + _ -> error $ "Unsupported CaptureData version tag " ++ show v -- | 'getMany n' get 'n' elements in order, without blowing the stack. -- From Data.Binary @@ -113,4 +116,3 @@ -- (>>=) x `seq` go (x:xs) (i-1) {-# INLINE getMany #-} - diff --git a/src/Data/Binary/StringRef.hs b/src/Data/Binary/StringRef.hs --- a/src/Data/Binary/StringRef.hs +++ b/src/Data/Binary/StringRef.hs @@ -1,27 +1,31 @@ {-# LANGUAGE FlexibleInstances, UndecidableInstances, TypeSynonymInstances, OverlappingInstances#-} module Data.Binary.StringRef - ( ListOfStringable(..) - , StringReferencingBinary(..) - , ls_encode - , ls_decode - ) where + ( ListOfStringable(..) + , StringReferencingBinary(..) + , ls_encode + , ls_decode + ) where import Data.Binary import Data.Binary.Put import Data.Binary.Get import Control.Monad +import Control.Applicative ((<$>)) import Data.List import Data.ByteString.Lazy (ByteString) +import qualified Data.MyText as T +import Data.MyText (Text, decodeUtf8, encodeUtf8) +import Debug.Trace class StringReferencingBinary a => ListOfStringable a where - listOfStrings :: a -> [String] + listOfStrings :: a -> [Text] -- | An extended version of Binary that passes the list of strings of the -- previous sample class StringReferencingBinary a where - ls_put :: [String] -> a -> Put - ls_get :: [String] -> Get a + ls_put :: [Text] -> a -> Put + ls_get :: [Text] -> Get a ------------------------------------------------------------------------ -- Instances for the first few tuples @@ -49,7 +53,7 @@ ls_getMany strs n -- | 'ls_get strsMany n' ls_get strs 'n' elements in order, without blowing the stack. -ls_getMany :: StringReferencingBinary a => [String] -> Int -> Get [a] +ls_getMany :: StringReferencingBinary a => [Text] -> Int -> Get [a] ls_getMany strs n = go [] n where go xs 0 = return $! reverse xs @@ -59,21 +63,22 @@ x `seq` go (x:xs) (i-1) {-# INLINE ls_getMany #-} -instance StringReferencingBinary String where - ls_put strs s = case elemIndex s strs of - Just i | 0 <= i && i < 255 - 2 -> - put (fromIntegral (succ i) :: Word8) - _ -> put (0 :: Word8) >> put s - ls_get strs = do - tag <- get - case tag :: Word8 of - 0 -> get - i -> return $! strs !! fromIntegral (pred i) +instance StringReferencingBinary Text where + ls_put strs s = case elemIndex s strs of + Just i | 0 <= i && i < 255 - 2 -> + put (fromIntegral (succ i) :: Word8) + _ -> put (0 :: Word8) >> put s + ls_get strs = do + tag <- get + case tag :: Word8 of + 0 -> get + i -> return $! strs !! fromIntegral (pred i) + {- instance Binary a => StringReferencingBinary a where - ls_put _ = put - ls_get _ = get + ls_put _ = put + ls_get _ = get -} instance StringReferencingBinary Char where { ls_put _ = put; ls_get _ = get } @@ -81,13 +86,13 @@ instance StringReferencingBinary Integer where { ls_put _ = put; ls_get _ = get } instance StringReferencingBinary Bool where { ls_put _ = put; ls_get _ = get } -ls_encode :: StringReferencingBinary a => [String] -> a -> ByteString +ls_encode :: StringReferencingBinary a => [Text] -> a -> ByteString ls_encode strs = runPut . ls_put strs {-# INLINE ls_encode #-} -- | Decode a value from a lazy ByteString, reconstructing the original structure. -- -ls_decode :: StringReferencingBinary a => [String] -> ByteString -> a +ls_decode :: StringReferencingBinary a => [Text] -> ByteString -> a ls_decode strs = runGet (ls_get strs) diff --git a/src/Data/MyText.hs b/src/Data/MyText.hs new file mode 100644 --- /dev/null +++ b/src/Data/MyText.hs @@ -0,0 +1,40 @@ +module Data.MyText where + +import qualified Data.ByteString.UTF8 as BSU +import qualified Data.ByteString as BS +import Data.Binary +import Control.Applicative ((<$>)) +import Prelude hiding (length, map) +import qualified Prelude +import GHC.Exts( IsString(..) ) + +newtype Text = Text { toBytestring :: BSU.ByteString } deriving (Eq, Ord, Show, Read) + +instance IsString Text where + fromString = pack + +-- Binary instance compatible with Binary String +instance Binary Text where + put = put . unpack + get = pack <$> get + +length :: Text -> Int +length (Text bs) = BSU.length bs + +decodeUtf8 :: BS.ByteString -> Text +decodeUtf8 = Text + +encodeUtf8 :: Text -> BS.ByteString +encodeUtf8 = toBytestring + +unpack :: Text -> String +unpack = BSU.toString . toBytestring + +pack :: String -> Text +pack = Text . BSU.fromString + +map :: (Char -> Char) -> Text -> Text +map f = pack . Prelude.map f . unpack + +concat :: [Text] -> Text +concat = Text . BS.concat . Prelude.map toBytestring diff --git a/src/Stats.hs b/src/Stats.hs --- a/src/Stats.hs +++ b/src/Stats.hs @@ -8,26 +8,32 @@ import Text.Printf import qualified Data.Map as M import qualified Data.Set as S +import Data.MyText (Text) import Data import Categorize -data Report = GeneralInfos | TotalTime | Category String | EachCategory +data Report = GeneralInfos | TotalTime | Category Text | EachCategory deriving (Show, Eq) data Filter = Exclude Activity | Only Activity | AlsoInactive | GeneralCond String deriving (Show, Eq) -data ReportOption = MinPercentage Double +-- Supported report output formats: text, comma-separated values and +-- tab-separated values +data ReportFormat = RFText | RFCSV | RFTSV deriving (Show, Eq) +data ReportOption = MinPercentage Double | OutputFormat ReportFormat + deriving (Show, Eq) + -- Data format semantically representing the result of a report, including the -- title data ReportResults = - ListOfFields String [(String, String)] - | ListOfTimePercValues String [(String, String, Double)] - | PieChartOfTimePercValues String [(String, String, Double)] + ListOfFields String [(String, String)] + | ListOfTimePercValues String [(String, String, Double)] + | PieChartOfTimePercValues String [(String, String, Double)] applyFilters :: [Filter] -> TimeLog (Ctx, ActivityData) -> TimeLog (Ctx, ActivityData) @@ -36,7 +42,7 @@ Exclude act -> excludeTag act Only act -> onlyTag act AlsoInactive -> id - GeneralCond s-> applyCond s + GeneralCond s-> applyCond s ) (if AlsoInactive `elem` filters then tle else defaultFilter tle) filters @@ -47,34 +53,34 @@ -- | 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 :: TimeLog (Ctx, ActivityData) - } + { 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 :: 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 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 tags - , allTags - , tags - } in c + { 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 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 tags + , allTags + , tags + } in c -- | Sums up each occurence of an 'Activity', weighted by the sampling rate sumUp :: TimeLog (Ctx, ActivityData) -> M.Map Activity NominalDiffTime @@ -87,99 +93,157 @@ 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 + go' _ = id putReports :: [ReportOption] -> Calculations -> [Report] -> IO () putReports opts c = sequence_ . intersperse (putStrLn "") . map (putReport opts c) putReport :: [ReportOption] -> Calculations -> Report -> IO () putReport opts c EachCategory = putReports opts c (map Category (listCategories (tags c))) -putReport opts c r = renderReport $ reportToTable opts c r +putReport opts c r = renderReport opts $ reportToTable opts c r reportToTable :: [ReportOption] -> 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)) - ] + 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)) + ] - TotalTime -> ListOfTimePercValues "Total time per tag" $ - mapMaybe (\(tag,time) -> - let perc = realToFrac time/realToFrac totalTimeSel in - if perc*100 >= minPercentage - then Just $ ( show tag - , showTimeDiff time - , perc) - else Nothing - ) $ - reverse $ - sortBy (comparing snd) $ - M.toList sums - - Category cat -> PieChartOfTimePercValues ("Statistics for category " ++ 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 < minPercentage) filteredSums - tooSmallTimes = M.fold (+) 0 tooSmallSums - in + TotalTime -> ListOfTimePercValues "Total time per tag" $ + mapMaybe (\(tag,time) -> + let perc = realToFrac time/realToFrac totalTimeSel in + if perc*100 >= minPercentage + then Just $ ( show tag + , showTimeDiff time + , perc) + else Nothing + ) $ + reverse $ + sortBy (comparing snd) $ + M.toList sums + + Category 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 < minPercentage) filteredSums + tooSmallTimes = M.fold (+) 0 tooSmallSums + in - mapMaybe (\(tag,time) -> - let perc = realToFrac time/realToFrac totalTimeSel in - if perc*100 >= minPercentage - 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)" + mapMaybe (\(tag,time) -> + let perc = realToFrac time/realToFrac totalTimeSel in + if perc*100 >= minPercentage + 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 [] - ) + )] + else [] + ) + where + minPercentage = + case pvalues of + [] -> 1 + _ -> last pvalues + pvalues = mapMaybe pickPercentage opts + pickPercentage o = case o of + MinPercentage m -> Just m + _ -> Nothing - where minPercentage = last $ mapMaybe (\f -> case f of {MinPercentage m -> Just m {- ; _ -> Nothing -} }) opts +renderReport opts reportdata = do + let results = doRender opts reportdata + putStr results +doRender opts reportdata = results + where + results = + case outputformat of + RFText -> renderReportText reportdata + RFCSV -> renderReportCSV reportdata + RFTSV -> renderReportTSV reportdata + outputformat = + case formats of + [] -> RFText + _ -> last formats + formats = mapMaybe pickFormats opts + pickFormats o = case o of + OutputFormat f -> Just f + _ -> Nothing -renderReport (ListOfFields title dats) = do - putStrLnUnderlined title - putStr $ tabulate False $ map (\(f,v) -> [f,v]) dats +renderReportText (ListOfFields title dats) = + underline title ++ + (tabulate False $ map (\(f,v) -> [f,v]) dats) -renderReport (ListOfTimePercValues title dats) = do - putStrLnUnderlined title - putStr $ tabulate True $ ["Tag","Time","Percentage"] : map (\(f,t,p) -> [f,t,printf "%.2f" (p*100)]) dats +renderReportText (ListOfTimePercValues title dats) = + underline title ++ (tabulate True $ listOfValues dats) -renderReport (PieChartOfTimePercValues title dats) = do - putStrLnUnderlined title - putStr $ tabulate True $ ["Tag","Time","Percentage"] : map (\(f,t,p) -> [f,t,printf "%.2f" (p*100)]) dats +renderReportText (PieChartOfTimePercValues title dats) = + underline title ++ (tabulate True $ piechartOfValues 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 + +-- 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) + +-- 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) + +renderWithDelimiter delim datasource = + unlines $ map (injectDelimiter delim) datasource + +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 + 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"] @@ -187,14 +251,15 @@ 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 + 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 -putStrLnUnderlined str = do - putStrLn str - putStrLn $ map (const '=') str +underline str = unlines + [ str + , map (const '=') str + ] diff --git a/src/Text/ParserCombinators/Parsec/ExprFail.hs b/src/Text/ParserCombinators/Parsec/ExprFail.hs new file mode 100644 --- /dev/null +++ b/src/Text/ParserCombinators/Parsec/ExprFail.hs @@ -0,0 +1,127 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Text.ParserCombinators.Parsec.Expr +-- Copyright : (c) Daan Leijen 1999-2001 +-- License : BSD-style (see the file libraries/parsec/LICENSE) +-- +-- Maintainer : daan@cs.uu.nl +-- Stability : provisional +-- Portability : portable +-- +-- A helper module to parse \"expressions\". +-- Builds a parser given a table of operators and associativities. +-- +----------------------------------------------------------------------------- + +module Text.ParserCombinators.Parsec.ExprFail + ( Erring + , Assoc(..), Operator(..), OperatorTable + , buildExpressionParser + ) where + +import Text.ParserCombinators.Parsec.Prim +import Text.ParserCombinators.Parsec.Combinator +import Control.Applicative ((<*>),(<$>)) + +type Erring a = Either String a + +----------------------------------------------------------- +-- Assoc and OperatorTable +----------------------------------------------------------- +data Assoc = AssocNone + | AssocLeft + | AssocRight + +data Operator t st a = Infix (GenParser t st (a -> a -> Erring a)) Assoc + | Prefix (GenParser t st (a -> Erring a)) + | Postfix (GenParser t st (a -> Erring a)) + +type OperatorTable t st a = [[Operator t st a]] + +erringToParsec :: Erring a -> GenParser t st a +erringToParsec = either fail return + +----------------------------------------------------------- +-- Convert an OperatorTable and basic term parser into +-- a full fledged expression parser +----------------------------------------------------------- +buildExpressionParser :: OperatorTable tok st a -> GenParser tok st a -> GenParser tok st a +buildExpressionParser operators simpleExpr + = foldl (makeParser) simpleExpr operators + where + makeParser term ops + = let (rassoc,lassoc,nassoc + ,prefix,postfix) = foldr splitOp ([],[],[],[],[]) ops + + rassocOp = choice rassoc + lassocOp = choice lassoc + nassocOp = choice nassoc + prefixOp = choice prefix "" + postfixOp = choice postfix "" + + ambigious assoc op= try $ + do{ op; fail ("ambiguous use of a " ++ assoc + ++ " associative operator") + } + + ambigiousRight = ambigious "right" rassocOp + ambigiousLeft = ambigious "left" lassocOp + ambigiousNon = ambigious "non" nassocOp + + termP = do{ pre <- prefixP + ; x <- term + ; post <- postfixP + ; erringToParsec (pre x) >>= erringToParsec . post + } + + postfixP = postfixOp <|> return Right + + prefixP = prefixOp <|> return Right + + rassocP x = do{ f <- rassocOp + ; y <- do{ z <- termP; rassocP1 z } + ; erringToParsec (f x y) + } + <|> ambigiousLeft + <|> ambigiousNon + -- <|> return x + + rassocP1 x = rassocP x <|> return x + + lassocP x = do{ f <- lassocOp + ; y <- termP + ; erringToParsec (f x y) >>= rassocP1 + } + <|> ambigiousRight + <|> ambigiousNon + -- <|> return x + + lassocP1 x = lassocP x <|> return x + + nassocP x = do{ f <- nassocOp + ; y <- termP + ; ambigiousRight + <|> ambigiousLeft + <|> ambigiousNon + <|> erringToParsec (f x y) + } + -- <|> return x + + in do{ x <- termP + ; rassocP x <|> lassocP x <|> nassocP x <|> return x + "operator" + } + + + splitOp (Infix op assoc) (rassoc,lassoc,nassoc,prefix,postfix) + = case assoc of + AssocNone -> (rassoc,lassoc,op:nassoc,prefix,postfix) + AssocLeft -> (rassoc,op:lassoc,nassoc,prefix,postfix) + AssocRight -> (op:rassoc,lassoc,nassoc,prefix,postfix) + + splitOp (Prefix op) (rassoc,lassoc,nassoc,prefix,postfix) + = (rassoc,lassoc,nassoc,op:prefix,postfix) + + splitOp (Postfix op) (rassoc,lassoc,nassoc,prefix,postfix) + = (rassoc,lassoc,nassoc,prefix,op:postfix) + diff --git a/src/Text/Regex/PCRE/Light/Text.hs b/src/Text/Regex/PCRE/Light/Text.hs new file mode 100644 --- /dev/null +++ b/src/Text/Regex/PCRE/Light/Text.hs @@ -0,0 +1,206 @@ +-------------------------------------------------------------------- +-- | +-- Module : Text.Regex.PCRE.Light.Text +-- Copyright: Copyright (c) 2007-2008, Don Stewart +-- License : BSD3 +-- +-- Maintainer: Don Stewart +-- Stability : experimental +-- Portability: H98 + FFI +-- +-------------------------------------------------------------------- +-- +-- A simple, portable binding to perl-compatible regular expressions +-- (PCRE) via 8-bit latin1 Strings. +-- + +module Text.Regex.PCRE.Light.Text ( + + -- * The abstract PCRE Regex type + Regex + + -- * String interface + , compile, compileM + , match + + -- * Regex types and constructors externally visible + + -- ** PCRE compile-time bit flags + , PCREOption + + , anchored + , auto_callout + {-, bsr_anycrlf-} + {-, bsr_unicode-} + , caseless + , dollar_endonly + , dotall + , dupnames + , extended + , extra + , firstline + , multiline + {-, newline_any-} + {-, newline_anycrlf-} + , newline_cr + , newline_crlf + , newline_lf + , no_auto_capture + , ungreedy + , utf8 + , no_utf8_check + + -- ** PCRE exec-time bit flags + , PCREExecOption + + , exec_anchored + {-, exec_newline_any -} + {-, exec_newline_anycrlf -} + , exec_newline_cr + , exec_newline_crlf + , exec_newline_lf + , exec_notbol + , exec_noteol + , exec_notempty + , exec_no_utf8_check + , exec_partial + + ) where + +import qualified Data.MyText as T +import Data.MyText (Text, decodeUtf8, encodeUtf8) +import qualified Text.Regex.PCRE.Light as S +import Text.Regex.PCRE.Light hiding (match, compile, compileM) + +-- | 'compile' +-- +-- Compile a perl-compatible regular expression, in a strict bytestring. +-- The arguments are: +-- +-- * 'pat': A ByteString, which may or may not be zero-terminated, +-- containing the regular expression to be compiled. +-- +-- * 'flags', optional bit flags. If 'Nothing' is provided, defaults are used. +-- +-- Valid compile-time flags are: +-- +-- * 'anchored' - Force pattern anchoring +-- +-- * 'auto_callout' - Compile automatic callouts +-- +-- * 'bsr_anycrlf' - \\R matches only CR, LF, or CRLF +-- +-- * 'bsr_unicode' - \\R matches all Unicode line endings +-- +-- * 'caseless' - Do caseless matching +-- +-- * 'dollar_endonly' - '$' not to match newline at end +-- +-- * 'dotall' - matches anything including NL +-- +-- * 'dupnames' - Allow duplicate names for subpatterns +-- +-- * 'extended' - Ignore whitespace and # comments +-- +-- * 'extra' - PCRE extra features (not much use currently) +-- +-- * 'firstline' - Force matching to be before newline +-- +-- * 'multiline' - '^' and '$' match newlines within data +-- +-- * 'newline_any' - Recognize any Unicode newline sequence +-- +-- * 'newline_anycrlf' - Recognize CR, LF, and CRLF as newline sequences +-- +-- * 'newline_cr' - Set CR as the newline sequence +-- +-- * 'newline_crlf' - Set CRLF as the newline sequence +-- +-- * 'newline_lf' - Set LF as the newline sequence +-- +-- * 'no_auto_capture' - Disable numbered capturing parentheses (named ones available) +-- +-- * 'ungreedy' - Invert greediness of quantifiers +-- +-- * 'utf8' - Run in UTF-8 mode (always enabled in this module) +-- +-- * 'no_utf8_check' - Do not check the pattern for UTF-8 validity (always enabled in this module) +-- +-- If compilation of the pattern fails, the 'Left' constructor is +-- returned with the error string. Otherwise an abstract type +-- representing the compiled regular expression is returned. +-- The regex is allocated via malloc on the C side, and will be +-- deallocated by the runtime when the Haskell value representing it +-- goes out of scope. +-- +-- As regexes are often defined statically, GHC will compile them +-- to null-terminated, strict C strings, enabling compilation of the +-- pattern without copying. This may be useful for very large patterns. +-- +-- See man pcreapi for more details. +-- +compile :: Text -> [PCREOption] -> Regex +compile str os = S.compile (encodeUtf8 str) (no_utf8_check:utf8:os) +{-# INLINE compile #-} + +-- | 'compileM' +-- A safe version of 'compile' with failure lifted into an Either +compileM :: Text -> [PCREOption] -> Either String Regex +compileM str os = S.compileM (encodeUtf8 str) (no_utf8_check:utf8:os) +{-# INLINE compileM #-} + + +-- | 'match' +-- +-- Matches a compiled regular expression against a given subject string, +-- using a matching algorithm that is similar to Perl's. If the subject +-- string doesn't match the regular expression, 'Nothing' is returned, +-- otherwise the portion of the string that matched is returned, along +-- with any captured subpatterns. +-- +-- The arguments are: +-- +-- * 'regex', a PCRE regular expression value produced by compile +-- +-- * 'subject', the subject string to match against +-- +-- * 'options', an optional set of exec-time flags to exec. +-- +-- Available runtime options are: +-- +-- * 'anchored' - Match only at the first position +-- +-- * 'bsr_anycrlf' - '\\R' matches only CR, LF, or CRLF +-- +-- * 'bsr_unicode' - '\\R' matches all Unicode line endings +-- +-- * 'newline_any' - Recognize any Unicode newline sequence +-- +-- * 'newline_anycrlf' - Recognize CR, LF, and CRLF as newline sequences +-- +-- * 'newline_cr' - Set CR as the newline sequence +-- +-- * 'newline_crlf' - Set CRLF as the newline sequence +-- +-- * 'newline_lf' - Set LF as the newline sequence +-- +-- * 'notbol' - Subject is not the beginning of a line +-- +-- * 'noteol' - Subject is not the end of a line +-- +-- * 'notempty' - An empty string is not a valid match +-- +-- * 'no_utf8_check' - Do not check the subject for UTF-8 +-- +-- * 'partial' - Return PCRE_ERROR_PARTIAL for a partial match +-- +-- The result value, and any captured subpatterns, are returned. +-- If the regex is invalid, or the subject string is empty, Nothing +-- is returned. +-- +match :: Regex -> Text -> [PCREExecOption] -> Maybe [Text] +match r subject os = + case S.match r (encodeUtf8 subject) os of + Nothing -> Nothing + Just x -> Just (map decodeUtf8 x) +{-# INLINE match #-} diff --git a/src/TimeLog.hs b/src/TimeLog.hs --- a/src/TimeLog.hs +++ b/src/TimeLog.hs @@ -25,18 +25,18 @@ -- given file. runLogger :: ListOfStringable a => FilePath -> Integer -> IO a -> IO () runLogger filename delay action = flip fix Nothing $ \loop prev -> do - entry <- action - date <- getCurrentTime - createTimeLog False filename - appendTimeLog filename prev (TimeLogEntry date delay entry) - threadDelay (fromIntegral delay * 1000) - loop (Just entry) + entry <- action + date <- getCurrentTime + createTimeLog False filename + appendTimeLog filename prev (TimeLogEntry date delay entry) + threadDelay (fromIntegral delay * 1000) + loop (Just entry) - + createTimeLog :: Bool -> FilePath -> IO () createTimeLog force filename = do - ex <- doesFileExist filename - when (not ex || force) $ BS.writeFile filename magic + ex <- doesFileExist filename + when (not ex || force) $ BS.writeFile filename magic appendTimeLog :: ListOfStringable a => FilePath -> Maybe a -> TimeLogEntry a -> IO () appendTimeLog filename prev = BS.appendFile filename . ls_encode strs @@ -44,62 +44,62 @@ writeTimeLog :: ListOfStringable a => FilePath -> TimeLog a -> IO () writeTimeLog filename tl = do - createTimeLog True filename - foldM_ go Nothing tl + createTimeLog True filename + foldM_ go Nothing tl where go prev v = do appendTimeLog filename prev v - return (Just (tlData v)) + return (Just (tlData v)) -- | This might be very bad style, and it hogs memory, but it might help in some situations... recoverTimeLog :: ListOfStringable a => FilePath -> IO (TimeLog a) recoverTimeLog filename = do - content <- BS.readFile filename + content <- BS.readFile filename start content where start content = do - let (startString, rest, off) = runGetState (getLazyByteString (BS.length magic)) content 0 - if startString /= magic - then do putStrLn $ "WARNING: Timelog starts with unknown marker " ++ - show (map (chr.fromIntegral) (BS.unpack startString)) - else do putStrLn $ "Found header, continuing... (" ++ show (BS.length rest) ++ " bytes to go)" - go Nothing rest off + let (startString, rest, off) = runGetState (getLazyByteString (BS.length magic)) content 0 + if startString /= magic + then do putStrLn $ "WARNING: Timelog starts with unknown marker " ++ + show (map (chr.fromIntegral) (BS.unpack startString)) + else do putStrLn $ "Found header, continuing... (" ++ show (BS.length rest) ++ " bytes to go)" + go Nothing rest off go prev input off = do - mb <- tryGet prev False input off - flip (maybe (return [])) mb $ \(v,rest,off') -> - if BS.null rest - then return [v] - else (v :) <$> go (Just (tlData v)) rest off' - tryGet prev retrying input off = catch ( - do -- putStrLn $ "Trying value at offset " ++ show off - let (v,rest,off') = runGetState (ls_get strs) input off - evaluate rest - when retrying $ - putStrLn $ "Succesfully read value at position " ++ show off - return (Just (v,rest,off')) - ) ( - \e -> do - putStrLn $ "Failed to read value at position " ++ show off ++ ":" - putStrLn $ " " ++ show (e :: SomeException) - if BS.length input <= 1 - then do putStrLn $ "End of file reached" - return Nothing - else do putStrLn $ "Trying at position " ++ show (off+1) ++ "." - tryGet prev True (BS.tail input) (off+1) - ) - where strs = maybe [] listOfStrings prev + mb <- tryGet prev False input off + flip (maybe (return [])) mb $ \(v,rest,off') -> + if BS.null rest + then return [v] + else (v :) <$> go (Just (tlData v)) rest off' + tryGet prev retrying input off = catch ( + do -- putStrLn $ "Trying value at offset " ++ show off + let (v,rest,off') = runGetState (ls_get strs) input off + evaluate rest + when retrying $ + putStrLn $ "Succesfully read value at position " ++ show off + return (Just (v,rest,off')) + ) ( + \e -> do + putStrLn $ "Failed to read value at position " ++ show off ++ ":" + putStrLn $ " " ++ show (e :: SomeException) + if BS.length input <= 1 + then do putStrLn $ "End of file reached" + return Nothing + else do putStrLn $ "Trying at position " ++ show (off+1) ++ "." + tryGet prev True (BS.tail input) (off+1) + ) + where strs = maybe [] listOfStrings prev readTimeLog :: ListOfStringable a => FilePath -> IO (TimeLog a) readTimeLog filename = do - content <- BS.readFile filename + content <- BS.readFile filename return $ runGet start content where start = do - startString <- getLazyByteString (BS.length magic) - if startString == magic - then go Nothing - else error $ - "Timelog starts with unknown marker " ++ - show (map (chr.fromIntegral) (BS.unpack startString)) + startString <- getLazyByteString (BS.length magic) + if startString == magic + then go Nothing + 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)) - where strs = maybe [] listOfStrings prev + m <- isEmpty + if m then return [v] + else (v :) <$> go (Just (tlData v)) + where strs = maybe [] listOfStrings prev diff --git a/src/UpgradeLog1.hs b/src/UpgradeLog1.hs --- a/src/UpgradeLog1.hs +++ b/src/UpgradeLog1.hs @@ -6,6 +6,7 @@ import Control.Applicative import Control.Monad import System.Directory +import qualified Data.MyText as T import TimeLog (writeTimeLog) import qualified Data as D @@ -16,19 +17,19 @@ type TimeLog a = [TimeLogEntry a] data TimeLogEntry a = TimeLogEntry - { tlTime :: UTCTime - , tlRate :: Integer -- ^ in milli-seconds - , tlData :: a } + { tlTime :: UTCTime + , tlRate :: Integer -- ^ in milli-seconds + , tlData :: a } deriving (Show, Read) instance Functor TimeLogEntry where - fmap f tl = tl { tlData = f (tlData tl) } + fmap f tl = tl { tlData = f (tlData tl) } data CaptureData = CaptureData - { cWindows :: [ (Bool, String, String) ] - -- ^ Active window, window title, programm name - , cLastActivity :: Integer -- ^ in milli-seconds - } + { cWindows :: [ (Bool, String, String) ] + -- ^ Active window, window title, programm name + , cLastActivity :: Integer -- ^ in milli-seconds + } deriving (Show, Read) readTimeLog :: Read a => FilePath -> IO (TimeLog a) @@ -39,7 +40,7 @@ upgradeLogFile1 captureFile = do ex <- doesFileExist captureFile when ex $ do - h <- openFile captureFile ReadMode + h <- openFile captureFile ReadMode start <- BS.hGet h (BS.length magicStart) hClose h when (start == magicStart) $ do @@ -56,6 +57,6 @@ upgrade = map $ \(TimeLogEntry a b c) -> D.TimeLogEntry a b (upgradeCD c) upgradeCD :: CaptureData -> D.CaptureData -upgradeCD (CaptureData a b) = D.CaptureData a b +upgradeCD (CaptureData a b) = D.CaptureData (map (\(b,s1,s2) -> (b, T.pack s1, T.pack s2)) a) b diff --git a/src/capture-main.hs b/src/capture-main.hs --- a/src/capture-main.hs +++ b/src/capture-main.hs @@ -27,12 +27,12 @@ data Conf = Conf { - cSampleRate :: Integer - } + cSampleRate :: Integer + } defaultConf = Conf 60 data Opts = Help | Version | SetRate Integer - deriving Eq + deriving Eq versionStr = "arbtt-capture " ++ showVersion version header = "Usage: arbtt-capture [OPTIONS...]" @@ -41,22 +41,22 @@ options = [ Option "h?" ["help"] (NoArg Help) - "show this help" + "show this help" , Option "V" ["version"] (NoArg Version) - "show the version number" + "show the version number" , Option "r" ["sample-rate"] - (ReqArg (SetRate . read) "RATE") - "set the sample rate in seconds (default: 60)" - ] + (ReqArg (SetRate . read) "RATE") + "set the sample rate in seconds (default: 60)" + ] -- | This is very raw, someone ought to improve this lockFile filename = do #ifdef WIN32 success <- claimMutex filename unless success $ do - hPutStrLn stderr ("arbtt [Error]: Could not aquire lock for " ++ filename ++"!") - exitFailure + hPutStrLn stderr ("arbtt [Error]: Could not aquire lock for " ++ filename ++"!") + exitFailure #else flip catch (\e -> hPutStrLn stderr ("arbtt [Error]: Could not aquire lock for " ++ filename ++"!") >> exitFailure) $ do fd <- openFd (filename ++ ".lck") WriteOnly (Just 0o644) defaultFileFlags @@ -68,20 +68,20 @@ args <- getArgs flags <- case getOpt Permute options args of - (o, [], []) | Help `notElem` o && Version `notElem` o -> return o - (o, _, _) | Version `elem` o -> do - hPutStrLn stderr versionStr - exitSuccess - (o, _, _) | Help `elem` o -> do + (o, [], []) | Help `notElem` o && Version `notElem` o -> return o + (o, _, _) | Version `elem` o -> do + hPutStrLn stderr versionStr + exitSuccess + (o, _, _) | Help `elem` o -> do hPutStr stderr (usageInfo header options) - exitSuccess - (_,_,errs) -> do + exitSuccess + (_,_,errs) -> do hPutStr stderr (concat errs ++ usageInfo header options) exitFailure let sampleRate = foldr (.) id (map (\f -> case f of {SetRate r -> const r; _ -> id}) flags) - 60 + 60 dir <- getAppUserDataDirectory "arbtt" createDirectoryIfMissing False dir diff --git a/src/dump-main.hs b/src/dump-main.hs --- a/src/dump-main.hs +++ b/src/dump-main.hs @@ -26,13 +26,13 @@ options = [ Option "h?" ["help"] (NoArg Help) - "show this help" + "show this help" , Option "V" ["version"] (NoArg Version) - "show the version number" + "show the version number" , Option "f" ["logfile"] - (ReqArg LogFile "FILE") - "use this file instead of ~/.arbtt/capture.log" + (ReqArg LogFile "FILE") + "use this file instead of ~/.arbtt/capture.log" ] @@ -54,8 +54,8 @@ dir <- getAppUserDataDirectory "arbtt" let captureFilename = - fromMaybe (dir "capture.log") $ listToMaybe $ - mapMaybe (\f -> case f of { LogFile f -> Just f; _ -> Nothing}) $ - flags + fromMaybe (dir "capture.log") $ listToMaybe $ + mapMaybe (\f -> case f of { LogFile f -> Just f; _ -> Nothing}) $ + flags captures <- readTimeLog captureFilename :: IO (TimeLog CaptureData) mapM_ print captures diff --git a/src/import-main.hs b/src/import-main.hs new file mode 100644 --- /dev/null +++ b/src/import-main.hs @@ -0,0 +1,68 @@ +module Main where +import System.Directory +import System.FilePath +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO +import qualified Data.Map as M +import Data.Version (showVersion) +import Data.Maybe +import Control.Monad +import Control.Applicative + +import TimeLog +import Data +import CommonStartup + +import Paths_arbtt (version) + +data Flag = Help | Version | LogFile String + deriving Eq + +versionStr = "arbtt-import " ++ showVersion version +header = "Usage: arbtt-import [OPTIONS...]" + +options :: [OptDescr Flag] +options = + [ Option "h?" ["help"] + (NoArg Help) + "show this help" + , Option "V" ["version"] + (NoArg Version) + "show the version number" + , Option "f" ["logfile"] + (ReqArg LogFile "FILE") + "use this file instead of ~/.arbtt/capture.log" + ] + + +main = do + commonStartup + args <- getArgs + flags <- case getOpt Permute options args of + (o,[],[]) | Help `notElem` o && Version `notElem` o -> return o + (o,_,_) | Version `elem` o -> do + hPutStrLn stderr versionStr + exitSuccess + (o,_,_) | Help `elem` o -> do + hPutStr stderr (usageInfo header options) + exitSuccess + (_,_,errs) -> do + hPutStr stderr (concat errs ++ usageInfo header options) + exitFailure + + dir <- getAppUserDataDirectory "arbtt" + + let captureFilename = + fromMaybe (dir "capture.log") $ listToMaybe $ + mapMaybe (\f -> case f of { LogFile f -> Just f; _ -> Nothing}) $ + flags + ex <- doesFileExist captureFilename + if ex + then do + putStrLn $ "File at " ++ captureFilename ++ " does already exist. Please delete this file" + putStrLn $ "before running arbtt-import." + else do + captures <- map read . lines <$> getContents :: IO (TimeLog CaptureData) + writeTimeLog captureFilename captures diff --git a/src/recover-main.hs b/src/recover-main.hs --- a/src/recover-main.hs +++ b/src/recover-main.hs @@ -26,16 +26,16 @@ options = [ Option "h?" ["help"] (NoArg Help) - "show this help" + "show this help" , Option "V" ["version"] (NoArg Version) - "show the version number" + "show the version number" , Option "i" ["infile"] - (ReqArg InFile "FILE") - "read from this file instead of ~/.arbtt/capture.log" + (ReqArg InFile "FILE") + "read from this file instead of ~/.arbtt/capture.log" , Option "o" ["outfile"] - (ReqArg OutFile "FILE") - "write to this file instead of ~/.arbtt/capture.log.recovered" + (ReqArg OutFile "FILE") + "write to this file instead of ~/.arbtt/capture.log.recovered" ] @@ -57,13 +57,13 @@ dir <- getAppUserDataDirectory "arbtt" let captureFilename = - fromMaybe (dir "capture.log") $ listToMaybe $ - mapMaybe (\f -> case f of { InFile f -> Just f; _ -> Nothing}) $ - flags + fromMaybe (dir "capture.log") $ listToMaybe $ + mapMaybe (\f -> case f of { InFile f -> Just f; _ -> Nothing}) $ + flags let saveFilename = - fromMaybe (dir "capture.log.recovered") $ listToMaybe $ - mapMaybe (\f -> case f of { OutFile f -> Just f; _ -> Nothing}) $ - flags + fromMaybe (dir "capture.log.recovered") $ listToMaybe $ + mapMaybe (\f -> case f of { OutFile f -> Just f; _ -> Nothing}) $ + flags captures <- recoverTimeLog captureFilename :: IO (TimeLog CaptureData) writeTimeLog saveFilename captures diff --git a/src/stats-main.hs b/src/stats-main.hs --- a/src/stats-main.hs +++ b/src/stats-main.hs @@ -7,6 +7,8 @@ import System.IO import Control.Monad import qualified Data.Map as M +import qualified Data.MyText as T +import Data.Char (toLower) import Data.List import Data.Ord import Data.Time @@ -25,7 +27,9 @@ data Flag = Help | Version | Report Report | Filter Filter | - ReportOption ReportOption + ReportOption ReportOption | + LogFile String | + CategorizeFile String deriving Eq getReports = mapMaybe (\f -> case f of {Report r -> Just r; _ -> Nothing}) @@ -39,40 +43,57 @@ options = [ Option "h?" ["help"] (NoArg Help) - "show this help" + "show this help" , Option "V" ["version"] (NoArg Version) - "show the version number" + "show the version number" -- , Option ['g'] ["graphical"] (NoArg Graphical) "render the reports as graphical charts" + , Option "" ["logfile"] + (ReqArg LogFile "FILE") + "use this file instead of ~/.arbtt/capture.log" + , Option "" ["categorizefile"] + (ReqArg CategorizeFile "FILE") + "use this file instead of ~/.arbtt/categorize.cfg" , Option "x" ["exclude"] (ReqArg (Filter . Exclude . read) "TAG") - "ignore samples containing this tag" + "ignore samples containing this tag" , Option "o" ["only"] (ReqArg (Filter . Only . read) "TAG") - "only consider samples containing this tag" + "only consider samples containing this tag" , Option "" ["also-inactive"] (NoArg (Filter AlsoInactive)) - "include samples with the tag \"inactive\"" + "include samples with the tag \"inactive\"" , Option "f" ["filter"] (ReqArg (Filter . GeneralCond) "COND") - "only consider samples matching the condition" + "only consider samples matching the condition" , Option "m" ["min-percentage"] (ReqArg (ReportOption . MinPercentage . read) "PERC") - "do not show tags with a percentage lower than PERC% (default: 1)" + "do not show tags with a percentage lower than PERC% (default: 1)" , Option "i" ["information"] (NoArg (Report GeneralInfos)) - "show general statistics about the data" + "show general statistics about the data" , Option "t" ["total-time"] (NoArg (Report TotalTime)) - "show total time for each tag" + "show total time for each tag" , Option "c" ["category"] - (ReqArg (Report . Category) "CATEGORY") - "show statistics about category CATEGORY" + (ReqArg (Report . Category . T.pack) "CATEGORY") + "show statistics about category CATEGORY" , Option "" ["each-category"] (NoArg (Report EachCategory)) - "show statistics about each category found" + "show statistics about each category found" + , Option "" ["output-format"] + (ReqArg (ReportOption . OutputFormat . readReportFormat) "FORMAT") + "one of: text, csv (comma-separated values), tsv (TAB-separated values) (default: Text)" ] +readReportFormat arg = + case (tolower arg) of + "text" -> RFText + "csv" -> RFCSV + "tsv" -> RFTSV + _ -> error ("Unsupported report output format: '" ++ arg ++ "'") + where + tolower = map toLower main = do commonStartup @@ -91,7 +112,17 @@ dir <- getAppUserDataDirectory "arbtt" - let categorizeFilename = dir "categorize.cfg" + let captureFilename = + fromMaybe (dir "capture.log") $ listToMaybe $ + mapMaybe (\f -> case f of { LogFile f -> Just f; _ -> Nothing}) $ + flags + + let categorizeFilename = + fromMaybe (dir "categorize.cfg") $ listToMaybe $ + mapMaybe + (\f -> case f of { CategorizeFile f -> Just f; _ -> Nothing}) $ + flags + fileEx <- doesFileExist categorizeFilename unless fileEx $ do putStrLn $ printf "Configuration file %s does not exist." categorizeFilename @@ -99,7 +130,6 @@ exitFailure categorizer <- readCategorizer categorizeFilename - let captureFilename = dir "capture.log" captures <- readTimeLog captureFilename let allTags = categorizer captures when (null allTags) $ do @@ -107,7 +137,6 @@ exitFailure let tags = applyFilters (getFilters flags) allTags - let opts = case getRepOpts flags of {[] -> [MinPercentage 1]; ropts -> ropts } let reps = case getReports flags of {[] -> [TotalTime]; reps -> reps } -- These are defined here, but of course only evaluated when any report @@ -115,7 +144,7 @@ -- advantageous. let c = prepareCalculations allTags tags - putReports opts c reps + putReports (getRepOpts flags) c reps {- import Data.Accessor