arbtt 0.6.4.1 → 0.7
raw patch · 14 files changed
+445/−84 lines, 14 filesdep +bytestring-progressdep +terminal-progress-bardep +transformersdep −mtldep ~base
Dependencies added: bytestring-progress, terminal-progress-bar, transformers
Dependencies removed: mtl
Dependency ranges changed: base
Files
- arbtt.cabal +9/−4
- categorize.cfg +9/−3
- doc/arbtt.xml +33/−4
- src/Capture/X11.hs +4/−2
- src/Categorize.hs +59/−18
- src/Data.hs +1/−1
- src/Data/MyText.hs +30/−1
- src/LeftFold.hs +30/−30
- src/Stats.hs +1/−1
- src/TermSize.hsc +50/−0
- src/Text/Parsec/ExprFail.hs +174/−0
- src/TimeLog.hs +20/−15
- src/capture-main.hs +1/−1
- src/stats-main.hs +24/−4
arbtt.cabal view
@@ -1,5 +1,5 @@ name: arbtt-version: 0.6.4.1+version: 0.7 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-2010+copyright: Joachim Breitner 2009-2013 synopsis: Automatic Rule-Based Time Tracker description: arbtt is a background daemon that stores which windows are open, which one@@ -30,8 +30,11 @@ main-is: capture-main.hs hs-source-dirs: src build-depends:- base == 4.5.*, filepath, directory, mtl, time >= 1.4, utf8-string, - bytestring, binary, deepseq, strict+ base == 4.5.* || == 4.6.*,+ filepath, directory, transformers, time >= 1.4, utf8-string,+ bytestring, binary, deepseq, strict,+ terminal-progress-bar,+ bytestring-progress other-modules: Data Data.MyText@@ -76,8 +79,10 @@ Categorize TimeLog Stats+ Text.Parsec.ExprFail Text.ParserCombinators.Parsec.ExprFail Text.Regex.PCRE.Light.Text+ TermSize ghc-options: -rtsopts if os(windows) cpp-options: -DWIN32
categorize.cfg view
@@ -57,8 +57,8 @@ current window $title =~ m!TDM! ==> tag Project:TDM, -( format $date >= "2010-08-01" &&- format $date <= "2010-12-01" &&+( $date >= 2010-08-01 &&+ $date <= 2010-12-01 && ( current window $program == "sun-awt-X11-XFramePeer" && current window $title == "I3P" || current window $program == "sun-awt-X11-XDialogPeer" &&@@ -97,10 +97,16 @@ -- evaluate dates in local time. Set TZ environment variable if you need -- statistics in a different time zone. +-- You can compare dates:+$date >= 2001-01-01 ==> tag this_century,+-- You have to write them in YYYY-MM-DD format, else they will not be recognized. + -- “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,+format $date =~ ".*-03-19" ==> tag period:on_a_special_day,+-- but note that this is a rather expensive operation and will slow down your+-- data processing considerably. -- “day of month $date” gives the day of month (1..31), -- “day of week $date” gives a sequence number of the day of week
doc/arbtt.xml view
@@ -240,15 +240,19 @@ <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.+ recorded sample. It can be compared with date literals in the form+ YYYY-MM-DD (which stand for midnight, so <programlisting>$date ==+ 2001-01-01</programlisting> will not do what you want, but+ <programlisting>$date >= 2001-01-01 && $date <= 2001-01-02</programlisting>+ would). 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.+ to strings. Formatted dates may be useful to tag particular date ranges. But+ also note that this is a rather expensive operation that can slow down your+ data processing. </para> <para> Expression <literal>month $date</literal> evaluates to an integer, from 1@@ -1023,6 +1027,16 @@ </refentry> </sect1> +<sect1 id="troubleshooting">+ <title>Troubleshooting</title>+ <sect2>+ <title>arbtt and xmonad</title>+ <para>+ If you are using the <ulink url="http://xmonad.org">xmonad</ulink> window manager and arbtt does ont record any windows, ensure that your xmonad configuration includes the EWMH-Hints extensions in the module <ulink url="http://hackage.haskell.org/packages/archive/xmonad-contrib/latest/doc/html/XMonad-Hooks-EwmhDesktops.html">XMonad.Hooks.EwmhDesktops</ulink>.+ </para>+ </sect2>+</sect1>+ <sect1 id="copyright"> <title>Copyright and Contact</title> <para>@@ -1062,6 +1076,21 @@ The version history with changes relevant for the user are documented here. </para> + <sect2>+ <title>Version 0.7</title>+ <itemizedlist>+ <listitem>+ <para>Make sure that the log file is only readable by the current user. Thanks to Joey Hess for pointing that out.</para>+ </listitem>+ <listitem>+ <para>Show a progress bar in <command>arbtt-stats</command>.</para>+ </listitem>+ <listitem>+ <para>GHC-7.6 compatibility, thanks to Isaac Dupree.</para>+ </listitem>+ </itemizedlist>+ </sect2>+ <sect2> <title>Version 0.6.4.1</title> <itemizedlist>
src/Capture/X11.hs view
@@ -5,6 +5,7 @@ import Graphics.X11.Xlib.Extras import Control.Monad import Control.Exception (bracket)+import System.IO.Error (catchIOError) import Control.Applicative import Data.Maybe import Data.Time.Clock@@ -77,11 +78,12 @@ myFetchName d w = do let getProp = (internAtom d "_NET_WM_NAME" False >>= getTextProperty d w)- `catch`+ `catchIOError` (\_ -> getTextProperty d w wM_NAME) 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+ `catchIOError` \_ -> return ""
src/Categorize.hs view
@@ -9,11 +9,17 @@ import Data.MyText (Text) import Control.Monad import Control.Monad.Instances+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class+import Data.Functor.Identity -import Text.ParserCombinators.Parsec hiding (Parser)-import Text.ParserCombinators.Parsec.Token-import Text.ParserCombinators.Parsec.Language-import Text.ParserCombinators.Parsec.ExprFail++import Text.Parsec+import Text.Parsec.Char+import Text.Parsec.Token+import Text.Parsec.Combinator+import Text.Parsec.Language+import Text.Parsec.ExprFail import System.Exit import Control.Applicative ((<*>),(<$>)) import Control.DeepSeq@@ -22,7 +28,7 @@ import Data.Char import Data.Time.Clock import Data.Time.LocalTime-import Data.Time.Calendar (toGregorian)+import Data.Time.Calendar (toGregorian, fromGregorian) import Data.Time.Calendar.WeekDate (toWeekDate) import Data.Time.Format (formatTime) import System.Locale (defaultTimeLocale, iso8601DateFormat)@@ -33,10 +39,12 @@ type Categorizer = TimeLog CaptureData -> TimeLog (Ctx, ActivityData) type Rule = Ctx -> ActivityData -type Parser a = CharParser () a+type Parser = ParsecT String () (ReaderT TimeZone Identity) + data Ctx = Ctx { cNow :: TimeLogEntry CaptureData+ , cCurrentWindow :: Maybe (Bool, Text, Text) , cWindowInScope :: Maybe (Bool, Text, Text) , cSubsts :: [Text] , cCurrentTime :: UTCTime@@ -45,7 +53,7 @@ deriving (Show) instance NFData Ctx where- rnf (Ctx a b c d e) = a `deepseq` b `deepseq` c `deepseq` e `deepseq` e `deepseq` ()+ rnf (Ctx a b c d e f) = a `deepseq` b `deepseq` c `deepseq` e `deepseq` e `deepseq` f `deepseq` () type Cond = CtxFun [Text] @@ -68,7 +76,8 @@ content <- readFile filename time <- getCurrentTime tz <- getCurrentTimeZone- case parse (between (return ()) eof parseRules) filename content of+ case flip runReader tz $+ runParserT (between (return ()) eof parseRules) () filename content of Left err -> do putStrLn "Parser error:" print err@@ -76,15 +85,15 @@ Right cat -> return $ (map (fmap (mkSecond (postpare . cat))) . prepare time tz) -applyCond :: String -> TimeLogEntry (Ctx, ActivityData) -> Bool-applyCond s = - case parse (do {c <- parseCond; eof ; return c}) "commad line parameter" s of+applyCond :: String -> TimeZone -> TimeLogEntry (Ctx, ActivityData) -> Bool+applyCond s tz = + case flip runReader tz $ runParserT (do {c <- parseCond; eof ; return c}) () "commad line parameter" s of Left err -> error (show err)- Right c -> isJust . c . fst . tlData+ Right c -> isJust . c . fst . tlData prepare :: UTCTime -> TimeZone -> TimeLog CaptureData -> TimeLog Ctx prepare time tz = map go- where go now = now {tlData = Ctx now Nothing [] time tz }+ where go now = now {tlData = Ctx now (findActive (cWindows (tlData now))) Nothing [] time tz } -- | Here, we filter out tags appearing twice, and make sure that only one of -- each category survives@@ -93,8 +102,20 @@ where go (Activity (Just c1) _) (Activity (Just c2) _) = c1 == c2 go a1 a2 = a1 == a2 -lang :: TokenParser ()-lang = haskell+lang :: GenTokenParser String () (ReaderT TimeZone Identity)+lang = makeTokenParser $ LanguageDef+ { commentStart = "{-"+ , commentEnd = "-}"+ , commentLine = "--"+ , nestedComments = True+ , identStart = letter+ , identLetter = alphaNum <|> oneOf "_'"+ , opStart = oneOf ":!#$%&*+./<=>?@\\^|-~"+ , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"+ , reservedOpNames= []+ , reservedNames = []+ , caseSensitive = True+ } parseRules :: Parser Rule parseRules = do @@ -155,7 +176,7 @@ cp -> fail $ printf "Expression of type %s" (cpType cp) parseCondExpr :: Parser CondPrim-parseCondExpr = buildExpressionParser [+parseCondExpr = buildExpressionParser [ [ Prefix (reservedOp lang "!" >> return checkNot) ], [ Prefix (reserved lang "day of week" >> return evalDayOfWeek) , Prefix (reserved lang "day of month" >> return evalDayOfMonth)@@ -231,6 +252,11 @@ t2 <- getT2 ctx guard (t1 ? t2) return []+checkCmp (Cmp (?)) (CondDate getT1) (CondDate 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@@ -247,7 +273,7 @@ checkCurrentwindow :: CondPrim -> Erring CondPrim checkCurrentwindow (CondCond cond) = Right $ CondCond $ \ctx -> - cond (ctx { cWindowInScope = findActive (cWindows (tlData (cNow ctx))) })+ cond (ctx { cWindowInScope = cCurrentWindow ctx }) checkCurrentwindow cp = Left $ printf "Cannot apply current window to an expression of type %s" (cpType cp)@@ -355,6 +381,8 @@ return $ CondString (const (Just str)) , try $ do time <- parseTime <?> "time" -- backtrack here, it might have been a number return $ CondTime (const (Just time))+ , try $ do date <- parseDate <?> "date" -- backtrack here, it might have been a number+ return $ CondDate (const (Just date)) , do num <- natural lang <?> "number" return $ CondInteger (const (Just num)) ]@@ -411,6 +439,19 @@ let hour = maybe h ((10*h)+) mh return $ (hour * 60 + m1 * 10 + m2) * 60 +parseDate :: Parser UTCTime+parseDate = lexeme lang $ do+ tz <- lift ask+ year <- read <$> count 4 digit+ char '-'+ month <- read <$> count 2 digit+ char '-'+ day <- read <$> count 2 digit+ time <- option 0 parseTime+ let date = LocalTime (fromGregorian year month day) (TimeOfDay 0 0 0)+ return $ addUTCTime time $ localTimeToUTC tz date++ parseSetTag :: Parser Rule parseSetTag = lexeme lang $ do firstPart <- parseTagPart @@ -473,7 +514,7 @@ getVar :: String -> CtxFun Text getVar v ctx | "current" `isPrefixOf` v = do let var = drop (length "current.") v- win <- findActive $ cWindows (tlData (cNow ctx))+ win <- cCurrentWindow ctx getVar var (ctx { cWindowInScope = Just win }) getVar "title" ctx = do (_,t,_) <- cWindowInScope ctx
src/Data.hs view
@@ -94,7 +94,7 @@ get = do d <- get t <- get- return $ UTCTime (ModifiedJulianDay d) (fromRational t)+ return $ UTCTime (ModifiedJulianDay d) ({-# SCC diffTimeFromRational #-} fromRational t) instance ListOfStringable CaptureData where listOfStrings = concatMap (\(b,t,p) -> [t,p]) . cWindows
src/Data/MyText.hs view
@@ -1,7 +1,9 @@ module Data.MyText where import qualified Data.ByteString.UTF8 as BSU+import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString as BS+import Data.Binary.Get import Data.Binary import Control.Applicative ((<$>)) import Control.Arrow (first)@@ -9,6 +11,7 @@ import qualified Prelude import GHC.Exts( IsString(..) ) import Control.DeepSeq+import Control.Monad newtype Text = Text { toBytestring :: BSU.ByteString } deriving (Eq, Ord) @@ -24,7 +27,33 @@ -- Binary instance compatible with Binary String instance Binary Text where put = put . unpack- get = pack <$> get+ -- The following code exploits that the Binary Char instance uses UTF8 as well+ -- The downside is that it quietly suceeds for broken input+ get = do+ n <- get :: Get Int+ lbs <- lookAhead (getLazyByteString (4*fromIntegral n)) -- safe approximation+ let bs = BS.concat $ LBS.toChunks $ lbs+ let utf8bs = BSU.take n bs+ unless (BSU.length utf8bs == n) $+ fail $ "Coult not parse the expected " ++ show n ++ " utf8 characters."+ skip (BS.length utf8bs)+ return $ Text utf8bs++{- Possible speedup with a version of binary that provides access to the+ internals, as the Char instance is actually UTF8, but the length bit is+ chars, not bytes.+instance Binary Text where+ put = put . unpack+ get = do+ n <- get :: Get Int+ let go = do+ s <- GI.get + let utf8s = BSU.take n s+ if BSU.length utf8s == n+ then GI.skip (B.length utf8s) >> return utf8s+ else GI.demandInput >> go+ go+-} instance NFData Text where rnf (Text a) = a `seq` ()
src/LeftFold.hs view
@@ -45,7 +45,7 @@ mapElems :: LeftFold y a -> (x -> y) -> LeftFold x a mapElems (Pure x) _ = (Pure x)-mapElems (LeftFold s p f) t = LeftFold s (\s x -> p s (t x)) f+mapElems (LeftFold s p f) t = LeftFold s (\s x -> p s $! t x) f filterWith :: (x -> Bool) -> LeftFold (Bool :!: x) a -> LeftFold x a filterWith p f = f `mapElems` (\x -> (p x :!: x))@@ -64,41 +64,41 @@ runOnGroups :: (x -> x -> Bool) -> LeftFold x y -> LeftFold y z -> LeftFold x z runOnGroups eq _ (Pure ox) = Pure ox-runOnGroups eq (Pure ix) (LeftFold sto po fo) = LeftFold (Nothing :!: sto) go finish - where go (Nothing :!: so) x = (Just x :!: so)- go (Just x' :!: so) x | x `eq` x' = (Just x :!: so)- | otherwise = (Just x :!: po so ix)- finish (Nothing :!: so) = fo so- finish (Just _ :!: so) = fo (po so ix)-runOnGroups eq (LeftFold sti pi fi) (LeftFold sto po fo) = LeftFold (Nothing :!: sti :!: sto) go finish - where go (Nothing :!: si :!: so) x = (Just x :!: pi si x :!: so)- go (Just x' :!: si :!: so) x | x `eq` x' = (Just x :!: pi si x :!: so)- | otherwise = (Just x :!: pi sti x :!: po so (fi si))- finish (Nothing :!: si :!: so) = fo so- finish (Just _ :!: si :!: so) = fo (po so (fi si))+runOnGroups eq (Pure ix) (LeftFold sto po fo) = LeftFold (S.Nothing :!: sto) go finish + where go (S.Nothing :!: so) x = (S.Just x :!: so)+ go (S.Just x' :!: so) x | x `eq` x' = (S.Just x :!: so)+ | otherwise = (S.Just x :!: po so ix)+ finish (S.Nothing :!: so) = fo so+ finish (S.Just _ :!: so) = fo (po so ix)+runOnGroups eq (LeftFold sti pi fi) (LeftFold sto po fo) = LeftFold (S.Nothing :!: sti :!: sto) go finish + where go (S.Nothing :!: si :!: so) x = (S.Just x :!: pi si x :!: so)+ go (S.Just x' :!: si :!: so) x | x `eq` x' = (S.Just x :!: pi si x :!: so)+ | otherwise = (S.Just x :!: pi sti x :!: po so (fi si))+ finish (S.Nothing :!: si :!: so) = fo so+ finish (S.Just _ :!: si :!: so) = fo (po so (fi si)) runOnIntervals :: LeftFold x y -> LeftFold y z -> LeftFold (Bool :!: x) z runOnIntervals _ (Pure ox) = (Pure ox)-runOnIntervals (Pure ix) (LeftFold so po fo) = LeftFold (False :!: Nothing) go finish +runOnIntervals (Pure ix) (LeftFold so po fo) = LeftFold (False :!: S.Nothing) go finish where go (True :!: so) (True :!: x) = (True :!: so)- go (True :!: Just so) (False :!: x) = (False :!: Just (po so ix))- go (True :!: Nothing) (False :!: x) = (False :!: Just (po so ix))+ go (True :!: S.Just so) (False :!: x) = (False :!: S.Just (po so ix))+ go (True :!: S.Nothing) (False :!: x) = (False :!: S.Just (po so ix)) go (False :!: so) (True :!: x) = (True :!: so) go (False :!: so) (False :!: x) = (False :!: so)- finish (False :!: Just so) = fo so- finish (False :!: Nothing) = fo so- finish (True :!: Just so) = fo (po so ix)- finish (True :!: Nothing) = fo (po so ix)-runOnIntervals (LeftFold si pi fi) (LeftFold so po fo) = LeftFold (Nothing :!: Nothing) go finish - where go (Just si :!: so) (True :!: x) = (Just (pi si x) :!: so)- go (Just si :!: Just so) (False :!: x) = (Nothing :!: Just (po so (fi si)))- go (Just si :!: Nothing) (False :!: x) = (Nothing :!: Just (po so (fi si)))- go (Nothing :!: so) (True :!: x) = (Just (pi si x) :!: so)- go (Nothing :!: so) (False :!: x) = (Nothing :!: so)- finish (Nothing :!: Just so) = fo so- finish (Nothing :!: Nothing) = fo so- finish (Just si :!: Just so) = fo (po so (fi si))- finish (Just si :!: Nothing) = fo (po so (fi si))+ finish (False :!: S.Just so) = fo so+ finish (False :!: S.Nothing) = fo so+ finish (True :!: S.Just so) = fo (po so ix)+ finish (True :!: S.Nothing) = fo (po so ix)+runOnIntervals (LeftFold si pi fi) (LeftFold so po fo) = LeftFold (S.Nothing :!: S.Nothing) go finish + where go (S.Just si :!: so) (True :!: x) = (S.Just (pi si x) :!: so)+ go (S.Just si :!: S.Just so) (False :!: x) = (S.Nothing :!: S.Just (po so $! fi si))+ go (S.Just si :!: S.Nothing) (False :!: x) = (S.Nothing :!: S.Just (po so $! fi si))+ go (S.Nothing :!: so) (True :!: x) = (S.Just (pi si x) :!: so)+ go (S.Nothing :!: so) (False :!: x) = (S.Nothing :!: so)+ finish (S.Nothing :!: S.Just so) = fo so+ finish (S.Nothing :!: S.Nothing) = fo so+ finish (S.Just si :!: S.Just so) = fo (po so (fi si))+ finish (S.Just si :!: S.Nothing) = fo (po so (fi si)) lfLength :: LeftFold x Int lfLength = leftFold 0 (\c _ -> c + 1)
src/Stats.hs view
@@ -86,7 +86,7 @@ all (\flag -> case flag of Exclude act -> excludeTag act tl Only act -> onlyTag act tl- GeneralCond s-> applyCond s tl) filters+ GeneralCond s-> applyCond s (cTimeZone (fst (tlData tl))) tl) filters applyActivityFilter :: [ActivityFilter] -> Activity -> Bool applyActivityFilter fs act = all go fs
+ src/TermSize.hsc view
@@ -0,0 +1,50 @@+{-# LANGUAGE ForeignFunctionInterface #-}++{-+By hammar on http://stackoverflow.com/a/12807521/946226+-}++module TermSize (getTermSize) where++#ifdef WIN32+getTermSize :: IO (Int, Int)+getTermSize = return (25,80)+#else++import Foreign+import Foreign.C.Error+import Foreign.C.Types++#include <sys/ioctl.h>+#include <unistd.h>++-- Trick for calculating alignment of a type, taken from+-- http://www.haskell.org/haskellwiki/FFICookBook#Working_with_structs+#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)++-- The ws_xpixel and ws_ypixel fields are unused, so I've omitted them here.+data WinSize = WinSize { wsRow, wsCol :: CUShort }++instance Storable WinSize where+ sizeOf _ = (#size struct winsize)+ alignment _ = (#alignment struct winsize) + peek ptr = do+ row <- (#peek struct winsize, ws_row) ptr+ col <- (#peek struct winsize, ws_col) ptr+ return $ WinSize row col+ poke ptr (WinSize row col) = do+ (#poke struct winsize, ws_row) ptr row+ (#poke struct winsize, ws_col) ptr col++foreign import ccall "sys/ioctl.h ioctl"+ ioctl :: CInt -> CInt -> Ptr WinSize -> IO CInt++-- | Return current number of (rows, columns) of the terminal.+getTermSize :: IO (Int, Int)+getTermSize = + with (WinSize 0 0) $ \ws -> do+ throwErrnoIfMinus1 "ioctl" $+ ioctl (#const STDOUT_FILENO) (#const TIOCGWINSZ) ws+ WinSize row col <- peek ws+ return (fromIntegral row, fromIntegral col)+#endif
+ src/Text/Parsec/ExprFail.hs view
@@ -0,0 +1,174 @@+-----------------------------------------------------------------------------+-- |+-- Module : Text.Parsec.Expr+-- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007+-- License : BSD-style (see the LICENSE file)+-- +-- Maintainer : derek.a.elkins@gmail.com+-- Stability : provisional+-- Portability : non-portable+-- +-- A helper module to parse \"expressions\".+-- Builds a parser given a table of operators and associativities.+-- +-----------------------------------------------------------------------------++module Text.Parsec.ExprFail+ ( Assoc(..), Operator(..), OperatorTable+ , Erring+ , buildExpressionParser+ ) where++import Text.Parsec.Prim+import Text.Parsec.Combinator+import Control.Applicative ((<*>),(<$>))+++-----------------------------------------------------------+-- Assoc and OperatorTable+-----------------------------------------------------------++-- | This data type specifies the associativity of operators: left, right+-- or none.++data Assoc = AssocNone+ | AssocLeft+ | AssocRight++type Erring a = Either String a++-- | This data type specifies operators that work on values of type @a@.+-- An operator is either binary infix or unary prefix or postfix. A+-- binary operator has also an associated associativity.++data Operator s u m a = Infix (ParsecT s u m (a -> a -> Erring a)) Assoc+ | Prefix (ParsecT s u m (a -> Erring a))+ | Postfix (ParsecT s u m (a -> Erring a))++erringToParsec :: Erring a -> ParsecT s u m a+erringToParsec = either fail return++-- | An @OperatorTable s u m a@ is a list of @Operator s u m a@+-- lists. The list is ordered in descending+-- precedence. All operators in one list have the same precedence (but+-- may have a different associativity).++type OperatorTable s u m a = [[Operator s u m a]]++-----------------------------------------------------------+-- Convert an OperatorTable and basic term parser into+-- a full fledged expression parser+-----------------------------------------------------------++-- | @buildExpressionParser table term@ builds an expression parser for+-- terms @term@ with operators from @table@, taking the associativity+-- and precedence specified in @table@ into account. Prefix and postfix+-- operators of the same precedence can only occur once (i.e. @--2@ is+-- not allowed if @-@ is prefix negate). Prefix and postfix operators+-- of the same precedence associate to the left (i.e. if @++@ is+-- postfix increment, than @-2++@ equals @-1@, not @-3@).+--+-- The @buildExpressionParser@ takes care of all the complexity+-- involved in building expression parser. Here is an example of an+-- expression parser that handles prefix signs, postfix increment and+-- basic arithmetic.+--+-- > expr = buildExpressionParser table term+-- > <?> "expression"+-- >+-- > term = parens expr +-- > <|> natural+-- > <?> "simple expression"+-- >+-- > table = [ [prefix "-" negate, prefix "+" id ]+-- > , [postfix "++" (+1)]+-- > , [binary "*" (*) AssocLeft, binary "/" (div) AssocLeft ]+-- > , [binary "+" (+) AssocLeft, binary "-" (-) AssocLeft ]+-- > ]+-- > +-- > binary name fun assoc = Infix (do{ reservedOp name; return fun }) assoc+-- > prefix name fun = Prefix (do{ reservedOp name; return fun })+-- > postfix name fun = Postfix (do{ reservedOp name; return fun })++buildExpressionParser :: (Stream s m t)+ => OperatorTable s u m a+ -> ParsecT s u m a+ -> ParsecT s u m 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) >>= lassocP1+ }+ <|> 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/TimeLog.hs view
@@ -16,6 +16,7 @@ import Control.Exception import Prelude hiding (catch) import Control.DeepSeq+import System.Posix.Files import qualified Data.ByteString.Lazy as BS import Data.Maybe@@ -29,6 +30,7 @@ entry <- action date <- getCurrentTime createTimeLog False filename+ setFileMode filename (ownerReadMode `unionFileModes` ownerWriteMode) appendTimeLog filename prev (TimeLogEntry date delay entry) threadDelay (fromIntegral delay * 1000) loop (Just entry)@@ -90,19 +92,22 @@ readTimeLog :: (NFData a, ListOfStringable a) => FilePath -> IO (TimeLog a) readTimeLog filename = do content <- BS.readFile filename- return $ start content- where start input =- let (startString, rest, off) = runGetState (getLazyByteString (BS.length magic)) input 0- in if startString == magic- then go Nothing rest off- else error $- "Timelog starts with unknown marker " ++- show (map (chr.fromIntegral) (BS.unpack startString))- go prev input off =- let (v, rest, off') = runGetState (ls_get strs) input off- in v `deepseq`- if (BS.null rest)- then [v]- else v : go (Just (tlData v)) rest off'- where strs = maybe [] listOfStrings prev+ return $ parseTimeLog content++parseTimeLog :: (NFData a, ListOfStringable a) => BS.ByteString -> TimeLog a+parseTimeLog input = + if startString == magic+ then go Nothing rest off+ else error $+ "Timelog starts with unknown marker " +++ show (map (chr.fromIntegral) (BS.unpack startString))+ where + (startString, rest, off) = runGetState (getLazyByteString (BS.length magic)) input 0+ go prev input off =+ let (v, rest, off') = runGetState (ls_get strs) input off+ in v `deepseq`+ if (BS.null rest)+ then [v]+ else v : go (Just (tlData v)) rest off'+ where strs = maybe [] listOfStrings prev
src/capture-main.hs view
@@ -70,7 +70,7 @@ 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+ flip catchIOError (\e -> hPutStrLn stderr ("arbtt [Error]: Could not aquire lock for " ++ filename ++"!") >> exitFailure) $ do fd <- openFd (filename ++ ".lck") WriteOnly (Just 0o644) defaultFileFlags setLock fd (WriteLock, AbsoluteSeek, 0, 0) #endif
src/stats-main.hs view
@@ -12,6 +12,11 @@ import Data.Version (showVersion) import Control.DeepSeq import Control.Applicative+import qualified Data.ByteString.Lazy as BS+import Data.ByteString.Lazy.Progress+import System.Posix.Files+import System.ProgressBar+import TermSize import TimeLog import Categorize@@ -151,15 +156,28 @@ exitFailure categorizer <- readCategorizer (optCategorizeFile flags) - captures <- readTimeLog (optLogFile flags)+ timelog <- BS.readFile (optLogFile flags)+ size <- fileSize <$> getFileStatus (optLogFile flags)++ hSetBuffering stderr NoBuffering+ trackedTimelog <- trackProgressWithChunkSize (fromIntegral size `div` 100) (\_ b -> do+ (_height, width) <- getTermSize+ hPutChar stderr '\r'+ hPutStr stderr $+ mkProgressBar (msg "Processing data") percentage (fromIntegral width) (fromIntegral b) (fromIntegral size)+ when (fromIntegral b >= fromIntegral size) $ do+ hPutChar stderr '\r'+ hPutStr stderr (replicate width ' ')+ hPutChar stderr '\r'+ ) timelog++ let captures = parseTimeLog trackedTimelog let allTags = categorizer captures- -- allTags `deepseq` return () when (null allTags) $ do putStrLn "Nothing recorded yet" exitFailure let filters = (if optAlsoInactive flags then id else (defaultFilter:)) $ optFilters flags- -- let tags = applyFilters filters allTags let reps = case optReports flags of {[] -> [TotalTime]; reps -> reverse reps } -- These are defined here, but of course only evaluated when any report@@ -168,8 +186,10 @@ let opts = optReportOptions flags let (c,results) = runLeftFold (filterPredicate filters `filterWith` (pure (,) <*> prepareCalculations <*> processReports opts c reps)) allTags++ -- Force the results a bit, to ensure the progress bar to be shown before the titel+ c `seq` return () - --let results = runLeftFold (filterPredicate filters `filterWith` processReports opts reps) allTags renderReport opts (MultpleReportResults results) {-