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