diff --git a/arbtt.cabal b/arbtt.cabal --- a/arbtt.cabal +++ b/arbtt.cabal @@ -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 maintainer: Joachim Breitner -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 diff --git a/categorize.cfg b/categorize.cfg --- a/categorize.cfg +++ b/categorize.cfg @@ -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 diff --git a/doc/arbtt.xml b/doc/arbtt.xml --- a/doc/arbtt.xml +++ b/doc/arbtt.xml @@ -240,15 +240,19 @@ The variable $date referes to the date and time of the - recorded sample. It cannot be compare to anything else directly, but - there are some helper functions to extract calendar information out of it. - All dates are evaluated in local time. + recorded sample. It can be compared with date literals in the form + YYYY-MM-DD (which stand for midnight, so $date == + 2001-01-01 will not do what you want, but + $date >= 2001-01-01 && $date <= 2001-01-02 + would). All dates are evaluated in local time. Expression format $date evaluates to a string with a date formatted according to ISO 8601, i.e. like "YYYY-MM-DD". The 19th of March 2010 is formatted as "2010-03-19". Formatted date can be compared - to strings. Formatted dates may be useful to tag particular date ranges. + 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. Expression month $date evaluates to an integer, from 1 @@ -1023,6 +1027,16 @@ + + Troubleshooting + + arbtt and xmonad + + If you are using the xmonad window manager and arbtt does ont record any windows, ensure that your xmonad configuration includes the EWMH-Hints extensions in the module XMonad.Hooks.EwmhDesktops. + + + + Copyright and Contact @@ -1062,6 +1076,21 @@ The version history with changes relevant for the user are documented here. + + Version 0.7 + + + Make sure that the log file is only readable by the current user. Thanks to Joey Hess for pointing that out. + + + Show a progress bar in arbtt-stats. + + + GHC-7.6 compatibility, thanks to Isaac Dupree. + + + + Version 0.6.4.1 diff --git a/src/Capture/X11.hs b/src/Capture/X11.hs --- a/src/Capture/X11.hs +++ b/src/Capture/X11.hs @@ -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 "" diff --git a/src/Categorize.hs b/src/Categorize.hs --- a/src/Categorize.hs +++ b/src/Categorize.hs @@ -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 diff --git a/src/Data.hs b/src/Data.hs --- a/src/Data.hs +++ b/src/Data.hs @@ -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 diff --git a/src/Data/MyText.hs b/src/Data/MyText.hs --- a/src/Data/MyText.hs +++ b/src/Data/MyText.hs @@ -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` () diff --git a/src/LeftFold.hs b/src/LeftFold.hs --- a/src/LeftFold.hs +++ b/src/LeftFold.hs @@ -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) diff --git a/src/Stats.hs b/src/Stats.hs --- a/src/Stats.hs +++ b/src/Stats.hs @@ -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 diff --git a/src/TermSize.hsc b/src/TermSize.hsc new file mode 100644 --- /dev/null +++ b/src/TermSize.hsc @@ -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 +#include + +-- 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 diff --git a/src/Text/Parsec/ExprFail.hs b/src/Text/Parsec/ExprFail.hs new file mode 100644 --- /dev/null +++ b/src/Text/Parsec/ExprFail.hs @@ -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) diff --git a/src/TimeLog.hs b/src/TimeLog.hs --- a/src/TimeLog.hs +++ b/src/TimeLog.hs @@ -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 diff --git a/src/capture-main.hs b/src/capture-main.hs --- a/src/capture-main.hs +++ b/src/capture-main.hs @@ -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 diff --git a/src/stats-main.hs b/src/stats-main.hs --- a/src/stats-main.hs +++ b/src/stats-main.hs @@ -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) {-