arbtt 0.4.5.1 → 0.5
raw patch · 23 files changed
+1697/−686 lines, 23 filesdep +old-localedep +utf8-stringsetup-changednew-component:exe:arbtt-import
Dependencies added: old-locale, utf8-string
Files
- README +5/−0
- Setup.hs +15/−15
- arbtt.cabal +27/−4
- categorize.cfg +28/−6
- doc/arbtt.xml +362/−129
- src/Capture.hs +3/−3
- src/Capture/Win32.hs +9/−8
- src/Capture/X11.hs +34/−30
- src/Categorize.hs +375/−195
- src/CommonStartup.hs +2/−2
- src/Data.hs +47/−45
- src/Data/Binary/StringRef.hs +28/−23
- src/Data/MyText.hs +40/−0
- src/Stats.hs +174/−109
- src/Text/ParserCombinators/Parsec/ExprFail.hs +127/−0
- src/Text/Regex/PCRE/Light/Text.hs +206/−0
- src/TimeLog.hs +53/−53
- src/UpgradeLog1.hs +11/−10
- src/capture-main.hs +18/−18
- src/dump-main.hs +7/−7
- src/import-main.hs +68/−0
- src/recover-main.hs +12/−12
- src/stats-main.hs +46/−17
README view
@@ -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,
Setup.hs view
@@ -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"
arbtt.cabal view
@@ -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 <mail@joachim-breitner.de> maintainer: Joachim Breitner <mail@joachim-breitner.de>-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
categorize.cfg view
@@ -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,
doc/arbtt.xml view
@@ -15,8 +15,25 @@ <email>mail@joachim-breitner.de</email> <contrib>Main author of arbtt</contrib> </author>+ <author id="sergey">+ <firstname>Sergey</firstname>+ <surname>Astanin</surname>+ <email>s.astanin@gmail.com</email>+ <contrib>Contributor</contrib>+ </author>+ <author id="martin">+ <firstname>Martin</firstname>+ <surname>Kiefel</surname>+ <email>mk@nopw.de</email>+ <contrib>Contributor</contrib>+ </author>+ <author id="muharem">+ <firstname>Muharem</firstname>+ <surname>Hrnjadovic</surname>+ <email>muharem@linux.com</email>+ <contrib>Contributor</contrib>+ </author> </authorgroup>- <pubdate>October 2009</pubdate> </articleinfo> <abstract> <para>@@ -100,34 +117,180 @@ </sect1> <sect1 id="configuration">- <title>Configuring the arbtt categorizer</title>+ <title>Configuring the arbtt categorizer (<command>arbtt-stats</command>)</title> <para>- 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 <command>arbtt-capture</command> 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+ (<command>arbtt-stats</command>) 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! </para> + <sect2>+ <title>Configuration example</title> <para> The configuration file needs to be placed in <filename>~/.arbtt/categorize.cfg</filename>. An- example file is included in the source distribution, and reproduced here as- <xref linkend="catex"/>, which should be more enlightening than this rather- formal description.+ example is included in the source distribution, and it is reproduced here:+ see <xref linkend="catex"/>.+ It should be more enlightening than a formal description. </para> <example id="catex">- <title>A complete <filename>categorize.cfg</filename></title>+ <title><filename>categorize.cfg</filename></title> <programlisting><xi:include href="../categorize.cfg" parse="text" xmlns:xi="http://www.w3.org/2001/XInclude" /></programlisting> </example>+ </sect2> <sect2>+ <title>The semantics (informal)</title>+ <para>+ 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:+ <itemizedlist>+ <listitem><simpara>the window title</simpara></listitem>+ <listitem><simpara>the program name</simpara></listitem>+ <listitem><simpara>whether the window was the active window</simpara></listitem>+ </itemizedlist>+ Based on this information and on the rules in+ <filename>categorize.cfg</filename>, the categorizer+ (<command>arbtt-stats</command>) assigns <emphasis>tags</emphasis> to+ each sample.+ </para>++ <para>+ A simple rule consists of a condition followed by an arrow+ (<literal>==></literal>) and a tag expression+ (<literal>tag</literal> keyword followed by tag name).+ The rule ends with a coma (<literal>,</literal>).+ </para>++ <para>+ The keyword <literal>tag</literal>, usually preceded with a condition,+ assigns a <emphasis>tag</emphasis> to the sample; <literal>tag</literal>+ keyword is followed by a tag name (any sequence of alphanumeric symbols,+ underscores and hyphens). If tag name contains a colon+ (<literal>:</literal>), the first part of the name before the colon, is+ considered to be tag <emphasis>category</emphasis>.+ </para>++ <para>+ For example, this rule+ <programlisting>month $date == 1 ==> tag month:January,</programlisting>+ if it succeeds, assigns a the tag <literal>January</literal> in the+ category <literal>month</literal>.+ </para>++ <para>If the tag has a <emphasis>category</emphasis>, 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 (<literal>$1</literal>,+ <literal>$2</literal>)...). Tags can also reference some+ variables such as window title (<literal>$current.title</literal>) or+ program name (<literal>$current.program</literal>).+ </para>++ <para>+ The variable <literal>$idle</literal> contains the idle time of the user,+ measured in seconds. Usually, it is used to assign the tag+ <literal>inactive</literal>, which is handled specially by+ <command>arbtt-stats</command>, as can be seen in <xref linkend="catex"/>.+ </para>++ <para>+ When applying the rules, the categorizer has a notion of+ the <emphasis>window in scope</emphasis>, and the variables+ <literal>$title</literal>, <literal>$program</literal> and+ <literal>$active</literal> always refer to the window in scope.+ By default, there is no window is in scope. Condition should be prefixed+ with either <literal>current window</literal> or <literal>any+ window</literal>, to define scope of these variables.+ </para>++ <para>+ For <literal>current window</literal>, the currently active window is in+ scope. If there is no such window, the condition is false.+ </para>+ + <para>+ For <literal>any window</literal>, 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 <literal>$1</literal>... are taken from (see more about regular+ expressions below).+ </para>++ <para>+ The variable <literal>$time</literal> refers to the time-of-day of the+ sample (i.e. the time since 00:00 that day, local time), while+ <literal>$sampleage</literal> 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>--filter</option> option of+ <command>arbtt-stats</command>. They can be compared with expressions + like "hh:mm", for example+ <programlisting>$time >= 8:00 && $time < 12:00 ==> tag time-of-day:morning</programlisting>+ </para>++ <para>+ The variable <literal>$date</literal> 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.+ </para>+ <para>+ Expression <literal>format $date</literal> 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.+ </para>+ <para>+ Expression <literal>month $date</literal> evaluates to an integer, from 1+ to 12, corresponding to the month number. Expression <literal>year+ $date</literal> evaluates to an integer which is a year number.+ Expression <literal>day of month $date</literal> evaluates to an integer,+ from 1 to 31, corresponding to the day of month.+ Expression <literal>day of week $date</literal> 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.+ </para>++ <para>+ Expressions can be compared to literal values with <literal>==</literal>+ (equal), <literal>/=</literal> (not equal), <literal><</literal>,+ <literal><=</literal>, <literal>>=</literal>,+ <literal>></literal> operators. String expressions+ (<literal>$program</literal>, <literal>$title</literal>) can be matched+ against regular expressions with <literal>=~</literal> operator.+ </para>++ <para>Regular expressions are written either between slashes+ (<literal>/</literal> regular expression <literal>/</literal>),+ or after a letter <literal>m</literal> followed by any symbol+ (<literal>m</literal> <emphasis>c</emphasis> regular expression <emphasis>c</emphasis>, where <emphasis>c</emphasis> is any symbol).+ The second appearance of that symbol ends the expression.+ You can find both variants in <xref linkend="catex"/>.+ </para>++ <para>Complex conditions may be constructed from the simpler ones,+ using Boolean AND (<literal>&&</literal>), OR+ (<literal>||</literal>), and NOT (<literal>!</literal>) functions and+ parentheses.+ </para>++ </sect2>++ <sect2> <title>The syntax</title> <para>- The file <filename>categorize.cfg</filename> is a plain text file.- Whitespace is insignificant and Haskell-style comments are allowed. A formal- grammar is provided in <xref linkend="grammar"/>.+ <filename>categorize.cfg</filename> is a plain text file.+ Whitespace is insignificant and Haskell-style comments are allowed.+ A formal grammar is provided in <xref linkend="grammar"/>. </para> <figure id="grammar">@@ -183,25 +346,51 @@ <nonterminal def="#g-cond"/> <quote>||</quote> <nonterminal def="#g-cond"/> </rhs>- <rhs> <quote>$</quote> <nonterminal def="#g-svar"/>- <quote>==</quote> String |- <quote>$</quote> <nonterminal def="#g-svar"/>- <quote>/=</quote> String- </rhs>- <rhs> <quote>$</quote> <nonterminal def="#g-svar"/>- <quote>=~</quote> <nonterminal def="#g-regex"/></rhs>- <rhs> <quote>$</quote> <nonterminal def="#g-nvar"/>- <nonterminal def="#g-cmpop"/> Number- </rhs>- <rhs> <quote>$</quote> <nonterminal def="#g-tvar"/>- <nonterminal def="#g-cmpop"/> <nonterminal def="#g-tspec"/>- </rhs>- <rhs> <quote>$</quote> <nonterminal def="#g-bvar"/>- </rhs>+ <rhs> <quote>$active</quote> </rhs>+ <rhs> <nonterminal def="#g-string"/> <nonterminal def="#g-cmpop"/>+ <nonterminal def="#g-string"/> </rhs>+ <rhs> <nonterminal def="#g-string"/> <quote>=~</quote>+ <nonterminal def="#g-regex"/></rhs>+ <rhs> <nonterminal def="#g-number"/> <nonterminal def="#g-cmpop"/>+ <nonterminal def="#g-number"/> </rhs>+ <rhs> <nonterminal def="#g-timediff"/> <nonterminal def="#g-cmpop"/>+ <nonterminal def="#g-timediff"/> </rhs> <rhs> <quote>current window</quote> <nonterminal def="#g-cond"/> </rhs> <rhs> <quote>any window</quote> <nonterminal def="#g-cond"/> </rhs> </production> + <production id="g-string">+ <lhs>String</lhs>+ <rhs> <quote>$title</quote> </rhs>+ <rhs> <quote>$program</quote> </rhs>+ <rhs> <quote>format</quote> <nonterminal def="#g-date" /> </rhs>+ <rhs> <quote>"</quote> string literal <quote>"</quote> </rhs>+ </production>++ <production id="g-number">+ <lhs>Number</lhs>+ <rhs> <quote>$idle</quote> </rhs>+ <rhs> <quote>day of week</quote> <nonterminal def="#g-date" /> </rhs>+ <rhs> <quote>day of month</quote> <nonterminal def="#g-date" /> </rhs>+ <rhs> <quote>month</quote> <nonterminal def="#g-date" /> </rhs>+ <rhs> <quote>year</quote> <nonterminal def="#g-date" /> </rhs>+ <rhs> number literal </rhs>+ </production>++ <production id="g-date">+ <lhs>Date</lhs>+ <rhs> <quote>$date</quote> </rhs>+ <!-- <rhs> <quote>$now</quote> </rhs> -->+ </production>++ <production id="g-timediff">+ <lhs>TimeDiff</lhs>+ <rhs> <quote>$time</quote> </rhs>+ <rhs> <quote>$sampleage</quote> </rhs>+ <!-- <rhs> <nonterminal def="#g-date"/> <quote>-</quote> <nonterminal def="#g-date"/></rhs> -->+ <rhs>[ Digit ] Digit <quote>:</quote> Digit Digit</rhs>+ </production>+ <production id="g-tag"> <lhs>Tag</lhs> <rhs> [ Literal <quote>:</quote> ] Literal </rhs>@@ -222,31 +411,6 @@ | <quote>></quote> | <quote>>=</quote></rhs> </production> - <production id="g-svar">- <lhs>StringVariable</lhs>- <rhs><quote>title</quote> | <quote>program</quote></rhs>- </production>-- <production id="g-nvar">- <lhs>NumericVariable</lhs>- <rhs><quote>idle</quote></rhs>- </production>-- <production id="g-bvar">- <lhs>BooleanVariable</lhs>- <rhs><quote>active</quote></rhs>- </production>-- <production id="g-tvar">- <lhs>TimeVariable</lhs>- <rhs><quote>time</quote> | <quote>sampleage</quote></rhs>- </production>-- <production id="g-tspec">- <lhs>TimeSpecification</lhs>- <rhs>[ Digit ] Digit <quote>:</quote> Digit Digit</rhs>- </production>- </productionset> </figure> <para>@@ -285,74 +449,7 @@ expressions. </para> </sect2>- <sect2>- <title>The semantics</title>- <para>- 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:- <itemizedlist>- <listitem><simpara>the window title</simpara></listitem>- <listitem><simpara>the program name</simpara></listitem>- <listitem><simpara>whether the window was the active window</simpara></listitem>- </itemizedlist>- Base on this information, the categorizer will now assign- <emphasis>tags</emphasis> to each- sample, based on the rules layed out in- <filename>categorizer.cfg</filename>.- </para>-- <para>- The keyword <literal>tag</literal>, usually wrapped in a condition,- assigns the tag to the sample. If the tag also contains a- <emphasis>category</emphasis>, 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.- </para>-- <para>- The variable <literal>$idle</literal> contains the idle time of the user,- measured in seconds. Usually, it is used to assign the tag- <literal>inactive</literal>, which is handled specially by- <command>arbtt-stats</command>, as can be seen in <xref linkend="catex"/>.- </para>-- <para>- While applying the conditions and rules, the categorizer has a notion of- the <emphasis>window in scope</emphasis>, and the variables- <literal>$title</literal>, <literal>$program</literal> and- <literal>$active</literal> always refer to the window in scope. At first,- no window is in scope. Only when evaluating a condition wrapped in- <literal>current window</literal> or <literal>any window</literal>, this- changes.- </para>-- <para>- For <literal>current window</literal>, the currently active window is in- scope. If there is no such window, the condition is false.- </para>- - <para>- For <literal>any window</literal>, 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 <literal>$1</literal>... are take from.- </para>-- <para>- The variable <literal>$time</literal> refers to the time-of-day of the- sample (i.e. the time since 0:00 that day), while- <literal>$sampleage</literal> 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>--filter</option> option of- <command>arbtt-stats</command>.- They can be compared with expressions of the- type "hh:mm", for example- <programlisting>$time >= 8:00 && $time < 12:00 ==> tag time-of-day:morning</programlisting>- </para>- </sect2>+ </sect1> <sect1 id="references">@@ -451,6 +548,14 @@ <term><option>--version</option></term> <listitem><simpara>shows the version number, and exists.</simpara></listitem> </varlistentry>+ <varlistentry>+ <term><option>--logfile</option></term>+ <listitem><simpara>logfile to use instead of <filename>~/.arbtt/capture.log</filename></simpara></listitem>+ </varlistentry>+ <varlistentry>+ <term><option>--categorizefile</option></term>+ <listitem><simpara>categorize file to use instead of <filename>~/.arbtt/categorize.cfg</filename></simpara></listitem>+ </varlistentry> </variablelist> <refsect2><title>Filtering options</title> <variablelist>@@ -488,10 +593,18 @@ <term><option>-m</option> <replaceable>PERCENTAGE</replaceable></term> <term><option>--min-percentage</option> <replaceable>PERCENTAGE</replaceable></term> <listitem><para>- 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%. </para></listitem> </varlistentry>+ <varlistentry>+ <term><option>--output-format</option> <replaceable>FORMAT</replaceable></term>+ <listitem><para>+ Specify the report output format, may be one of: text, csv+ (comma-separated values), tsv (TAB-separated values).+ Default format: text.+ </para></listitem>+ </varlistentry> </variablelist> </refsect2> <refsect2><title>Reports</title>@@ -700,6 +813,70 @@ </refsect1> </refentry> + <refentry>+ <refnamediv>+ <refname>arbtt-import</refname>+ <refpurpose>imports dumped arbtt data samples</refpurpose>+ </refnamediv>+ + <refsynopsisdiv>+ <cmdsynopsis>+ <command>arbtt-import</command>+ <arg rep="repeat">OPTION</arg>+ </cmdsynopsis>+ </refsynopsisdiv>++ <refsect1><title>Description</title>+ <para>+ <command>arbtt-import</command> expects the output of+ <command>arbtt-dump</command> on the standard input and saves them as the+ logfile or the specified file.+ </para>+ <para>+ 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+ <command>arbtt-import</command>.+ </para>+ </refsect1>++ <refsect1><title>Options</title>+ <variablelist>+ <varlistentry>+ <term><option>-h</option></term>+ <term><option>-?</option></term>+ <term><option>--help</option></term>+ <listitem><simpara>shows a short summary of the available+ options, and exists.</simpara></listitem>+ </varlistentry>+ <varlistentry>+ <term><option>-V</option></term>+ <term><option>--version</option></term>+ <listitem><simpara>shows the version number, and exists.</simpara></listitem>+ </varlistentry>+ <varlistentry>+ <term><option>-f</option></term>+ <term><option>--logfile</option></term>+ <listitem><simpara>logfile to use instead of <filename>~/.arbtt/capture.log</filename></simpara></listitem>+ </varlistentry>+ </variablelist>+ </refsect1>+ <refsect1><title>Files</title>+ <variablelist>+ <varlistentry>+ <term><filename>~/.arbtt/capture.log</filename></term>+ <listitem><para>binary file, storing the arbtt data samples</para></listitem>+ </varlistentry>+ </variablelist>+ </refsect1>++ <refsect1><title>See also</title>+ <para>See the arbtt manual for more information and the <ulink+ url="http://www.hackage.org/package/arbtt">arbtt hackage page</ulink> for+ newer versions of arbtt.</para>+ </refsect1>+ </refentry>+ <refentry id="arbtt-recover"> <refmeta> <refentrytitle>arbtt-recover</refentrytitle>@@ -722,8 +899,11 @@ <refsect1><title>Description</title> <para> <command>arbtt-recover</command> tries to readsthe data samples recorded- by <xref linkend="arbtt-capture"/>, skipping over possible broken entries. A fixed log file is written to <file>~/.arbtt/capture.log.recovered</file>.+ by <xref linkend="arbtt-capture"/>, skipping over possible broken entries. A fixed log file is written to <file>~/.arbtt/capture.log.recovered</file>. If the recovery was successful, you should stop <command>arbtt-capture</command> and move the file to <file>~/.arbtt/capture.log</file>. </para>+ <para>+ As a sid effect, <command>arbtt-recover</command> 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 <command>arbtt-recover</command> is recommended.+ </para> </refsect1> <refsect1><title>Options</title>@@ -776,14 +956,12 @@ <sect1 id="copyright"> <title>Copyright and Contact</title> <para>- arbtt is Copyright © 2009 Joachim Breitner+ arbtt is Copyright © 2009-2010 Joachim Breitner </para> <para>- 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- <ulink- url="mailto:mail@joachim-breitner.de">mail@joachim-breitner.de</ulink>.+ 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 <ulink url="mailto:arbtt@lists.nomeata.de">arbtt@lists.nomeata.de</ulink>, which you can subscribe at <ulink url="http://lists.nomeata.de/mailman/listinfo/arbtt">http://lists.nomeata.de/mailman/listinfo/arbtt</ulink>. </para> <sect2>@@ -813,6 +991,61 @@ <para> The version history with changes relevant for the user are documented here. </para>++ <sect2>+ <title>Version 0.5 (The ZuriHac-Release)</title>+ <itemizedlist>+ <listitem>+ <para>New command <command>arbtt-import</command>, which imports the output from <command>arbtt-dump</command>.+ </para>+ </listitem>+ <listitem>+ <para>The command <command>arbtt-stats</command> now supports the+ <option>--logfile</option> and <option>--categorizefile</option> as well.+ (<xref linkend="martin"/>)+ </para>+ </listitem>+ <listitem>+ <para>+ The command <command>arbtt-stats</command> now supports the csv+ (comma-separated values) and tsv (TAB-separated values) report output+ formats in addition to text.+ (<xref linkend="muharem"/>)+ </para>+ </listitem>+ <listitem>+ <para>+ Unicode is handled correctly in regular expressions.+ </para>+ </listitem>+ <listitem>+ <para>+ Improved date-handling functions for <filename>categorize.cfg</filename>.+ (<xref linkend="sergey"/>)+ </para>+ </listitem>+ </itemizedlist>+ </sect2>++ <sect2>+ <title>Version 0.4.5.1</title>+ <itemizedlist>+ <listitem>+ <para>Bugfix: Added missing modules to the cabal file.+ </para>+ </listitem>+ </itemizedlist>+ </sect2>++ <sect2>+ <title>Version 0.4.5</title>+ <itemizedlist>+ <listitem>+ <para>Implement a custom compression method greatly reduce the file size of the log file. Run <command>arbtt-capture</command> to compress the previous samples as well.+ </para>+ </listitem>+ </itemizedlist>+ </sect2> <sect2> <title>Version 0.4.4</title>
src/Capture.hs view
@@ -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
src/Capture/Win32.hs view
@@ -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
src/Capture/X11.hs view
@@ -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 ""
src/Categorize.hs view
@@ -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 []
src/CommonStartup.hs view
@@ -9,6 +9,6 @@ commonStartup :: IO () commonStartup = do #ifndef WIN32- setLocale LC_ALL (Just "") + setLocale LC_ALL (Just "") #endif- return ()+ return ()
src/Data.hs view
@@ -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 #-}-
src/Data/Binary/StringRef.hs view
@@ -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)
+ src/Data/MyText.hs view
@@ -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
src/Stats.hs view
@@ -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+ ]
+ src/Text/ParserCombinators/Parsec/ExprFail.hs view
@@ -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)+
+ src/Text/Regex/PCRE/Light/Text.hs view
@@ -0,0 +1,206 @@+--------------------------------------------------------------------+-- |+-- Module : Text.Regex.PCRE.Light.Text+-- Copyright: Copyright (c) 2007-2008, Don Stewart+-- License : BSD3+--+-- Maintainer: Don Stewart <dons@galois.com>+-- 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 #-}
src/TimeLog.hs view
@@ -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
src/UpgradeLog1.hs view
@@ -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
src/capture-main.hs view
@@ -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
src/dump-main.hs view
@@ -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
+ src/import-main.hs view
@@ -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
src/recover-main.hs view
@@ -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
src/stats-main.hs view
@@ -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