Instructions to run on startup in OS X (fixes #3)
[darcs-mirror-arbtt.git] / src / Categorize.hs
1 {-# LANGUAGE Rank2Types, CPP #-}
2 module Categorize where
3
4 import Data
5
6 import qualified Text.Regex.PCRE.Light.Text as RE
7 import qualified Data.Map as M
8 import qualified Data.MyText as T
9 import Data.MyText (Text)
10 import Control.Monad
11 import Control.Monad.Instances
12 import Control.Monad.Trans.Reader
13 import Control.Monad.Trans.Class
14 import Data.Functor.Identity
15
16
17 import Text.Parsec
18 import Text.Parsec.Char
19 import Text.Parsec.Token
20 import Text.Parsec.Combinator
21 import Text.Parsec.Language
22 import Text.Parsec.ExprFail
23 import System.IO
24 import System.Exit
25 import Control.Applicative ((<*>),(<$>))
26 import Control.DeepSeq
27 import Data.List
28 import Data.Maybe
29 import Data.Char
30 import Data.Time.Clock
31 import Data.Time.LocalTime
32 import Data.Time.Calendar (toGregorian, fromGregorian)
33 import Data.Time.Calendar.WeekDate (toWeekDate)
34 import Data.Time.Format (formatTime)
35 #if MIN_VERSION_time(1,5,0)
36 import Data.Time.Format(defaultTimeLocale, iso8601DateFormat)
37 #else
38 import System.Locale (defaultTimeLocale, iso8601DateFormat)
39 #endif
40 import Debug.Trace
41 import Control.Arrow (second)
42 import Text.Printf
43
44 type Categorizer = TimeLog CaptureData -> TimeLog (Ctx, ActivityData)
45 type Rule = Ctx -> ActivityData
46
47 type Parser = ParsecT String () (ReaderT TimeZone Identity)
48
49
50 data Ctx = Ctx
51         { cNow :: TimeLogEntry CaptureData
52         , cCurrentWindow :: Maybe (Bool, Text, Text)
53         , cWindowInScope :: Maybe (Bool, Text, Text)
54         , cSubsts :: [Text]
55         , cCurrentTime :: UTCTime
56         , cTimeZone :: TimeZone
57         }
58   deriving (Show)
59
60 instance NFData Ctx where
61     rnf (Ctx a b c d e f) = a `deepseq` b `deepseq` c `deepseq` e `deepseq` e `deepseq` f `deepseq` ()
62
63 type Cond = CtxFun [Text]
64
65 type CtxFun a = Ctx -> Maybe a
66
67 data CondPrim
68         = CondString (CtxFun Text)
69         | CondRegex (CtxFun RE.Regex)
70         | CondInteger (CtxFun Integer)
71         | CondTime (CtxFun NominalDiffTime)
72         | CondDate (CtxFun UTCTime)
73         | CondCond (CtxFun [Text])
74         | CondStringList (CtxFun [Text])
75         | CondRegexList (CtxFun [RE.Regex])
76
77 newtype Cmp = Cmp (forall a. Ord a => a -> a -> Bool)
78
79 readCategorizer :: FilePath -> IO Categorizer
80 readCategorizer filename = do
81         h <- openFile filename ReadMode
82         hSetEncoding h utf8
83         content <- hGetContents h
84         time <- getCurrentTime
85         tz <- getCurrentTimeZone
86         case flip runReader tz $
87             runParserT (between (return ()) eof parseRules) () filename content of
88           Left err -> do
89                 putStrLn "Parser error:"
90                 print err
91                 exitFailure
92           Right cat -> return $
93                 (map (fmap (mkSecond (postpare . cat))) . prepare time tz)
94
95 applyCond :: String -> TimeZone -> TimeLogEntry (Ctx, ActivityData) -> Bool
96 applyCond s tz = 
97         case flip runReader tz $ runParserT (do {c <- parseCond; eof ; return c}) () "commad line parameter" s of
98           Left err -> error (show err)
99           Right c  -> isJust . c . fst . tlData
100
101 prepare :: UTCTime -> TimeZone -> TimeLog CaptureData -> TimeLog Ctx
102 prepare time tz = map go
103   where go now  = now {tlData = Ctx now (findActive (cWindows (tlData now))) Nothing [] time tz }
104
105 -- | Here, we filter out tags appearing twice, and make sure that only one of
106 --   each category survives
107 postpare :: ActivityData -> ActivityData
108 postpare = nubBy go
109   where go (Activity (Just c1) _) (Activity (Just c2) _) = c1 == c2
110         go a1                     a2                     = a1 == a2
111
112 lang :: GenTokenParser String () (ReaderT TimeZone Identity)
113 lang = makeTokenParser $ LanguageDef
114                 { commentStart   = "{-"
115                 , commentEnd     = "-}"
116                 , commentLine    = "--"
117                 , nestedComments = True
118                 , identStart     = letter
119                 , identLetter    = alphaNum <|> oneOf "_'"
120                 , opStart        = oneOf ":!#$%&*+./<=>?@\\^|-~"
121                 , opLetter       = oneOf ":!#$%&*+./<=>?@\\^|-~"
122                 , reservedOpNames= []
123                 , reservedNames  = []
124                 , caseSensitive  = True
125                 }
126
127 parseRules :: Parser Rule
128 parseRules = do 
129         whiteSpace lang
130         a <- option id (reserved lang "aliases" >> parens lang parseAliasSpecs)
131         rb <- parseRulesBody
132         return (a . rb)
133
134 parseAliasSpecs :: Parser (ActivityData -> ActivityData)
135 parseAliasSpecs = do as <- sepEndBy1 parseAliasSpec (comma lang)
136                      return $ \ad -> foldr doAlias ad as
137
138 doAlias :: (Text, Text) -> ActivityData -> ActivityData
139 doAlias (s1,s2) = map go
140   where go (Activity cat tag) = Activity (if cat == Just s1 then Just s2 else cat)
141                                          (if tag == s1 then s2 else tag)
142
143 parseAliasSpec :: Parser (Text, Text)
144 parseAliasSpec = do s1 <- T.pack <$> stringLiteral lang
145                     reservedOp lang "->"
146                     s2 <- T.pack <$> stringLiteral lang
147                     return (s1,s2)
148
149 parseRulesBody :: Parser Rule
150 parseRulesBody = do 
151         x <- parseRule
152         choice [ do comma lang
153                     xs <- parseRule `sepEndBy1` comma lang
154                     return (matchAny (x:xs))
155                , do semi lang
156                     xs <- parseRule `sepEndBy1` semi lang
157                     return (matchFirst (x:xs))
158                ,    return x
159                ]
160
161 parseRule :: Parser Rule
162 parseRule = choice
163         [    braces lang parseRules
164         , do cond <- parseCond
165              reservedOp lang "==>"
166              rule <- parseRule
167              return (ifThenElse cond rule matchNone)
168         , do reserved lang "if"
169              cond <- parseCond
170              reserved lang "then"
171              rule1 <- parseRule
172              reserved lang "else"
173              rule2 <- parseRule
174              return (ifThenElse cond rule1 rule2)
175         , do reserved lang "tag"
176              parseSetTag
177         ]
178
179 parseCond :: Parser Cond
180 parseCond = do cp <- parseCondExpr
181                case cp of
182                 CondCond c -> return c
183                 cp         -> fail $ printf "Expression of type %s" (cpType cp)
184
185 parseCondExpr :: Parser CondPrim
186 parseCondExpr = buildExpressionParser [
187                 [ Prefix (reservedOp lang "!" >> return checkNot) ],
188                 [ Prefix (reserved lang "day of week" >> return evalDayOfWeek)
189                 , Prefix (reserved lang "day of month" >> return evalDayOfMonth)
190                 , Prefix (reserved lang "month" >> return evalMonth)
191                 , Prefix (reserved lang "year" >> return evalYear)
192                 , Prefix (reserved lang "format" >> return formatDate) ],
193                 [ Infix (reservedOp lang "=~" >> return checkRegex) AssocNone 
194                 , Infix (checkCmp <$> parseCmp) AssocNone
195                 ],
196                 [ Prefix (reserved lang "current window" >> return checkCurrentwindow)
197                 , Prefix (reserved lang "any window" >> return checkAnyWindow)
198                 ],
199                 [ Infix (reservedOp lang "&&" >> return checkAnd) AssocRight ],
200                 [ Infix (reservedOp lang "||" >> return checkOr) AssocRight ]
201             ] parseCondPrim
202
203 cpType :: CondPrim -> String
204 cpType (CondString _) = "String"
205 cpType (CondRegex _) = "Regex"
206 cpType (CondInteger _) = "Integer"
207 cpType (CondTime _) = "Time"
208 cpType (CondDate _) = "Date"
209 cpType (CondCond _) = "Condition"
210 cpType (CondStringList _) = "List of Strings"
211 cpType (CondRegexList _) = "List of regular expressions"
212
213 checkRegex :: CondPrim -> CondPrim -> Erring CondPrim
214 checkRegex (CondString getStr) (CondRegex getRegex) = Right $ CondCond $ \ctx -> do
215         str <- getStr ctx
216         regex <- getRegex ctx
217         tail <$> RE.match regex str [RE.exec_no_utf8_check]
218 checkRegex (CondString getStr) (CondRegexList getRegexList) = Right $ CondCond $ \ctx -> do
219         str <- getStr ctx
220         regexes <- getRegexList ctx
221         tail <$> msum (map (\regex -> RE.match regex str [RE.exec_no_utf8_check]) regexes)
222 checkRegex cp1 cp2 = Left $
223         printf "Cannot apply =~ to an expression of type %s and type %s"
224                (cpType cp1) (cpType cp2)
225
226 checkAnd :: CondPrim-> CondPrim -> Erring CondPrim
227 checkAnd (CondCond c1) (CondCond c2) = Right $ CondCond $ do
228         res1 <- c1
229         res2 <- c2
230         return $ res1 >> res2
231 checkAnd cp1 cp2 = Left $
232         printf "Cannot apply && to an expression of type %s and type %s"
233                (cpType cp1) (cpType cp2)
234
235 checkOr :: CondPrim-> CondPrim -> Erring CondPrim
236 checkOr (CondCond c1) (CondCond c2) = Right $ CondCond $ do
237         res1 <- c1
238         res2 <- c2
239         return $ res1 `mplus` res2
240 checkOr cp1 cp2 = Left $
241         printf "Cannot apply && to an expression of type %s and type %s"
242                (cpType cp1) (cpType cp2)
243
244 checkNot :: CondPrim -> Erring CondPrim
245 checkNot (CondCond getCnd) = Right $ CondCond $ do
246         liftM (maybe (Just []) (const Nothing)) getCnd
247 checkNot cp = Left $
248         printf "Cannot apply ! to an expression of type %s"
249                (cpType cp)
250
251 checkCmp :: Cmp -> CondPrim -> CondPrim -> Erring CondPrim
252 checkCmp (Cmp (?)) (CondInteger getN1) (CondInteger getN2) = Right $ CondCond $ \ctx -> do
253         n1 <- getN1 ctx
254         n2 <- getN2 ctx
255         guard (n1 ? n2)
256         return []
257 checkCmp (Cmp (?)) (CondTime getT1) (CondTime getT2) = Right $ CondCond $ \ctx -> do
258         t1 <- getT1 ctx
259         t2 <- getT2 ctx
260         guard (t1 ? t2)
261         return []
262 checkCmp (Cmp (?)) (CondDate getT1) (CondDate getT2) = Right $ CondCond $ \ctx -> do
263         t1 <- getT1 ctx
264         t2 <- getT2 ctx
265         guard (t1 ? t2)
266         return []
267 checkCmp (Cmp (?)) (CondString getS1) (CondString getS2) = Right $ CondCond $ \ctx -> do
268         s1 <- getS1 ctx
269         s2 <- getS2 ctx
270         guard (s1 ? s2)
271         return []
272 checkCmp (Cmp (?)) (CondString getS1) (CondStringList getS2) = Right $ CondCond $ \ctx -> do
273         s1 <- getS1 ctx
274         sl <- getS2 ctx
275         guard (any (s1 ?) sl)
276         return []
277 checkCmp _ cp1 cp2 = Left $
278         printf "Cannot compare expressions of type %s and type %s"
279                (cpType cp1) (cpType cp2)
280
281 checkCurrentwindow :: CondPrim -> Erring CondPrim
282 checkCurrentwindow (CondCond cond) = Right $ CondCond $ \ctx -> 
283         cond (ctx { cWindowInScope = cCurrentWindow ctx })
284 checkCurrentwindow cp = Left $
285         printf "Cannot apply current window to an expression of type %s"
286                (cpType cp)
287
288 checkAnyWindow :: CondPrim -> Erring CondPrim
289 checkAnyWindow (CondCond cond) = Right $ CondCond $ \ctx ->
290         msum $ map (\w -> cond (ctx { cWindowInScope = Just w }))
291                                      (cWindows (tlData (cNow ctx)))
292 checkAnyWindow cp = Left $
293         printf "Cannot apply current window to an expression of type %s"
294                (cpType cp)
295
296 fst3 (a,_,_) = a
297 snd3 (_,b,_) = b
298 trd3 (_,_,c) = c
299
300 -- Day of week is an integer in [1..7].
301 evalDayOfWeek :: CondPrim -> Erring CondPrim
302 evalDayOfWeek (CondDate df) = Right $ CondInteger $ \ctx ->
303   let tz = cTimeZone ctx in
304   (toInteger . trd3 . toWeekDate . localDay . utcToLocalTime tz) `liftM` df ctx
305 evalDayOfWeek cp = Left $ printf
306   "Cannot apply day of week to an expression of type %s, only to $date."
307   (cpType cp)
308
309 -- Day of month is an integer in [1..31].
310 evalDayOfMonth :: CondPrim -> Erring CondPrim
311 evalDayOfMonth (CondDate df) = Right $ CondInteger $ \ctx ->
312   let tz = cTimeZone ctx in
313   (toInteger . trd3 . toGregorian . localDay . utcToLocalTime tz) `liftM` df ctx
314 evalDayOfMonth cp = Left $ printf
315   "Cannot apply day of month to an expression of type %s, only to $date."
316   (cpType cp)
317
318 -- Month is an integer in [1..12].
319 evalMonth :: CondPrim -> Erring CondPrim
320 evalMonth (CondDate df) = Right $ CondInteger $ \ctx ->
321   let tz = cTimeZone ctx in
322   (toInteger . snd3 . toGregorian . localDay . utcToLocalTime tz) `liftM` df ctx
323 evalMonth cp = Left $ printf
324   "Cannot apply month to an expression of type %s, only to $date."
325   (cpType cp)
326
327 evalYear :: CondPrim -> Erring CondPrim
328 evalYear (CondDate df) = Right $ CondInteger $ \ctx ->
329   let tz = cTimeZone ctx in
330   (fst3 . toGregorian . localDay . utcToLocalTime tz) `liftM` df ctx
331 evalYear cp = Left $ printf
332   "Cannot apply year to an expression of type %s, only to $date."
333   (cpType cp)
334
335 -- format date according to ISO 8601 (YYYY-MM-DD)
336 formatDate :: CondPrim -> Erring CondPrim
337 formatDate (CondDate df) = Right $ CondString $ \ctx ->
338   let tz = cTimeZone ctx
339       local = utcToLocalTime tz `liftM` df ctx
340    in T.pack . formatTime defaultTimeLocale (iso8601DateFormat Nothing) <$> local
341 formatDate cp = Left $ printf
342   "Cannot format an expression of type %s, only $date." (cpType cp)
343
344 parseCmp :: Parser Cmp
345 parseCmp = choice $ map (\(s,o) -> reservedOp lang s >> return o)
346                         [(">=",Cmp (>=)),
347                          (">", Cmp (>)),
348                          ("==",Cmp (==)),
349                          ("=", Cmp (==)),
350                          ("<", Cmp (<)),
351                          ("<=",Cmp (<=))]
352
353 parseCondPrim :: Parser CondPrim
354 parseCondPrim = choice
355         [ parens lang parseCondExpr
356         , brackets lang (choice [
357             (do list <- commaSep1 lang (stringLiteral lang)
358                 return $ CondStringList (const (Just (map T.pack list)))
359             ) <?> "list of strings",
360             (do list <- commaSep1 lang parseRegex
361                 return $ CondRegexList (const (Just list))
362             ) <?> "list of regular expressions"
363             ])
364         , char '$' >> choice 
365              [ do backref <- read <$> many1 digit
366                   return $ CondString (getBackref backref)
367              , do varname <- identifier lang 
368                   choice 
369                       [ do guard $ varname == "title"
370                            return $ CondString (getVar "title")
371                       , do guard $ varname == "program"
372                            return $ CondString (getVar "program")
373                       , do guard $ varname == "active"
374                            return $ CondCond checkActive
375                       , do guard $ varname == "idle"
376                            return $ CondInteger (getNumVar "idle")
377                       , do guard $ varname == "time"
378                            return $ CondTime (getTimeVar "time")
379                       , do guard $ varname == "sampleage"
380                            return $ CondTime (getTimeVar "sampleage")
381                       , do guard $ varname == "date"
382                            return $ CondDate (getDateVar "date")
383                       , do guard $ varname == "desktop"
384                            return $ CondString (getVar "desktop")
385                      ]
386               ] <?> "variable"
387         , do regex <- parseRegex <?> "regular expression"
388              return $ CondRegex (const (Just regex))
389         , do str <- T.pack <$> stringLiteral lang <?> "string"
390              return $ CondString (const (Just str))
391         , try $ do time <- parseTime <?> "time" -- backtrack here, it might have been a number
392                    return $ CondTime (const (Just time))
393         , try $ do date <- parseDate <?> "date" -- backtrack here, it might have been a number
394                    return $ CondDate (const (Just date))
395         , do num <- natural lang <?> "number"
396              return $ CondInteger (const (Just num))
397         ]
398 {-
399                      choice
400                         [ do reservedOp lang "=~"
401                              regex <- parseRegex
402                              return $ checkRegex varname (RE.compile regex [])
403                         , do reservedOp lang "==" <|> reservedOp lang "="
404                              str <- stringLiteral lang
405                              return $ checkEq varname str
406                         , do reservedOp lang "/=" <|> reservedOp lang "!="
407                              str <- stringLiteral lang
408                              return $ checkNot (checkEq varname str)
409                         ]
410                 , do guard $ varname == "idle"
411                      op <- parseCmp
412                      num <- natural lang
413                      return $ checkNumCmp op varname num
414                 , do guard $ varname `elem` ["time","sampleage"]
415                      op <- parseCmp 
416                      time <- parseTime
417                      return $ checkTimeCmp op varname time
418                 , do guard $ varname == "active"
419                      return checkActive
420                 ]
421         , do reserved lang "current window"
422              cond <- parseCond
423              return $ checkCurrentwindow cond
424         , do reserved lang "any window"
425              cond <- parseCond
426              return $ checkAnyWindow cond
427         ]
428 -}
429
430 parseRegex :: Parser RE.Regex
431 parseRegex = fmap (flip RE.compile [] . T.pack) $ lexeme lang $ choice
432         [ between (char '/') (char '/') (many1 (noneOf "/"))
433         , do char 'm'
434              c <- anyChar
435              str <- many1 (noneOf [c])
436              char c
437              return str
438         ]
439              
440 -- | Parses a day-of-time specification (hh:mm)
441 parseTime :: Parser NominalDiffTime
442 parseTime = fmap fromIntegral $ lexeme lang $ do
443                hour <- read <$> many1 digit
444                char ':'
445                minute <- read <$> count 2 digit
446                return $ (hour * 60 + minute) * 60
447
448 parseDate :: Parser UTCTime
449 parseDate = lexeme lang $ do
450     tz <- lift ask
451     year <- read <$> count 4 digit
452     char '-'
453     month <- read <$> count 2 digit
454     char '-'
455     day <- read <$> count 2 digit
456     time <- option 0 parseTime
457     let date = LocalTime (fromGregorian year month day) (TimeOfDay 0 0 0)
458     return $ addUTCTime time $ localTimeToUTC tz date
459
460
461 parseSetTag :: Parser Rule
462 parseSetTag = lexeme lang $ do
463                  firstPart <- parseTagPart 
464                  choice [ do char ':'
465                              secondPart <- parseTagPart
466                              return $ do cat <- firstPart
467                                          tag <- secondPart
468                                          return $ maybeToList $ do
469                                             cat <- cat
470                                             tag <- tag
471                                             return $ Activity (Just cat) tag
472                         ,    return $ do tag <- firstPart
473                                          return $ maybeToList $ do
474                                             tag <- tag
475                                             return $ Activity Nothing tag
476                         ]
477
478 replaceForbidden :: Maybe Text -> Maybe Text
479 replaceForbidden = liftM $ T.map go
480   where
481     go c | isAlphaNum c  = c
482          | c `elem` "-_" = c
483          | otherwise     = '_'
484
485 parseTagPart :: Parser (Ctx -> Maybe Text)
486 parseTagPart = do parts <- many1 (choice
487                         [ do char '$'
488                              (replaceForbidden . ) <$> choice
489                                [ do num <- read <$> many1 digit
490                                     return $ getBackref num
491                                , do varname <- many1 (letter <|> oneOf ".")
492                                     return $ getVar varname
493                                ] <?> "variable"
494                         , do s <- many1 (alphaNum <|> oneOf "-_")
495                              return $ const (Just (T.pack s))
496                         ])
497                   return $ (fmap T.concat . sequence) <$> sequence parts
498
499 ifThenElse :: Cond -> Rule -> Rule -> Rule
500 ifThenElse cond r1 r2 = do res <- cond
501                            case res of 
502                             Just substs -> r1 . setSubsts substs
503                             Nothing -> r2
504   where setSubsts :: [Text] -> Ctx -> Ctx
505         setSubsts substs ctx = ctx { cSubsts = substs }
506         
507
508 matchAny :: [Rule] -> Rule
509 matchAny rules = concat <$> sequence rules
510 matchFirst :: [Rule] -> Rule
511 matchFirst rules = takeFirst <$> sequence rules
512   where takeFirst [] = []
513         takeFirst ([]:xs) = takeFirst xs
514         takeFirst (x:xs) = x
515
516
517 getBackref :: Integer -> CtxFun Text
518 getBackref n ctx = listToMaybe (drop (fromIntegral n-1) (cSubsts ctx))
519
520 getVar :: String -> CtxFun Text
521 getVar v ctx | "current" `isPrefixOf` v = do
522                 let var = drop (length "current.") v
523                 win <- cCurrentWindow ctx
524                 getVar var (ctx { cWindowInScope = Just win })
525 getVar "title"   ctx = do
526                 (_,t,_) <- cWindowInScope ctx
527                 return t
528 getVar "program" ctx = do
529                 (_,_,p) <- cWindowInScope ctx
530                 return p
531 getVar "desktop" ctx = do
532                 return $ cDesktop (tlData (cNow ctx))
533 getVar v ctx = error $ "Unknown variable " ++ v
534
535 getNumVar :: String -> CtxFun Integer
536 getNumVar "idle" ctx = Just $ cLastActivity (tlData (cNow ctx)) `div` 1000
537
538 getTimeVar :: String -> CtxFun NominalDiffTime
539 getTimeVar "time" ctx = Just $
540    let utc = tlTime . cNow $ ctx
541        tz = cTimeZone ctx
542        local = utcToLocalTime tz utc
543        midnightUTC = localTimeToUTC tz $ local { localTimeOfDay = midnight }
544     in utc `diffUTCTime` midnightUTC
545 getTimeVar "sampleage" ctx = Just $ cCurrentTime ctx `diffUTCTime` tlTime (cNow ctx)
546
547 getDateVar :: String -> CtxFun UTCTime
548 getDateVar "date" ctx = Just $ tlTime (cNow ctx)
549
550 findActive :: [(Bool, t, t1)] -> Maybe (Bool, t, t1)
551 findActive = find (\(a,_,_) -> a)                                 
552
553 checkActive :: Cond
554 checkActive ctx = do (a,_,_) <- cWindowInScope ctx
555                      guard a
556                      return []
557
558 matchNone :: Rule
559 matchNone = const []
560
561 justIf :: a -> Bool -> Maybe a
562 justIf x True = Just x
563 justIf x False = Nothing
564
565 mkSecond :: (a -> b) -> a -> (a, b)
566 mkSecond f a = (a, f a)