Fix off-by-one-error :-)
[darcs-mirror-arbtt.git] / src / Data.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 module Data where
3
4 import Data.Time
5 import Text.ParserCombinators.ReadPrec (readP_to_Prec)
6 import Text.ParserCombinators.ReadP hiding (get)
7 import qualified Text.ParserCombinators.ReadP as ReadP
8 import Text.Read (readPrec)
9 import Data.Binary
10 import Data.Binary.Put
11 import Data.Binary.Get
12 import Data.Binary.StringRef
13 import qualified Data.MyText as T
14 import Data.MyText (Text)
15 import Control.Applicative
16 import Control.Monad
17 import Control.DeepSeq
18
19 type TimeLog a = [TimeLogEntry a]
20
21 data TimeLogEntry a = TimeLogEntry
22         { tlTime :: UTCTime
23         , tlRate :: Integer -- ^ in milli-seconds
24         , tlData :: a }
25   deriving (Show, Read)
26
27 instance Functor TimeLogEntry where
28         fmap f tl = tl { tlData = f (tlData tl) }
29
30 instance NFData a => NFData (TimeLogEntry a) where
31     rnf (TimeLogEntry a b c) = a `deepseq` b `deepseq` c `deepseq` ()
32
33 data CaptureData = CaptureData
34         { cWindows :: [ (Bool, Text, Text) ]
35                 -- ^ Active window, window title, programm name
36         , cLastActivity :: Integer -- ^ in milli-seconds
37         , cDesktop :: Text
38                 -- ^ Current desktop name
39         }
40   deriving (Show, Read)
41
42 instance NFData CaptureData where
43     rnf (CaptureData a b c) = a `deepseq` b `deepseq` c `deepseq` ()
44
45 type ActivityData = [Activity]
46
47 data Activity = Activity 
48         { activityCategory :: Maybe Category
49         , activityName :: Text
50         }
51   deriving (Ord, Eq)
52
53 instance NFData Activity where
54     rnf (Activity a b) = a `deepseq` b `deepseq` ()
55
56 -- | An activity with special meaning: ignored by default (i.e. for idle times)
57 inactiveActivity = Activity Nothing "inactive"
58
59 instance Show Activity where
60  show (Activity mbC t) = maybe "" ((++":").T.unpack) mbC ++ (T.unpack t)
61
62 instance Read Activity where
63  readPrec = readP_to_Prec $ \_ ->
64                    (do cat <- munch1 (/= ':')
65                        char ':'
66                        tag <- many1 ReadP.get
67                        return $ Activity (Just (T.pack cat)) (T.pack tag))
68                    <++ (Activity Nothing . T.pack <$> many1 ReadP.get)
69
70 type Category = Text
71
72 isCategory :: Category -> Activity -> Bool
73 isCategory cat (Activity (Just cat') _) = cat == cat'
74 isCategory _   _                        = False
75
76
77 -- Data.Binary instances
78
79 instance StringReferencingBinary a => StringReferencingBinary (TimeLogEntry a) where
80  ls_put strs tle = do
81         -- A version tag
82         putWord8 1
83         put (tlTime tle)
84         put (tlRate tle)
85         ls_put strs (tlData tle)
86  ls_get strs = do
87         v <- getWord8
88         case v of
89          1 -> TimeLogEntry <$> get <*> get <*> ls_get strs
90          _ -> error $ "Unsupported TimeLogEntry version tag " ++ show v
91
92 instance Binary UTCTime where
93  put (UTCTime (ModifiedJulianDay d) t) = do
94         put d
95         put (toRational t)
96  get = do
97         d <- get
98         t <- get
99         return $ UTCTime (ModifiedJulianDay d) ({-# SCC diffTimeFromRational #-} fromRational t)
100
101 instance ListOfStringable CaptureData where
102   listOfStrings = concatMap (\(b,t,p) -> [t,p]) . cWindows
103
104 instance StringReferencingBinary CaptureData where
105 -- Versions:
106 -- 1 First version
107 -- 2 Using ListOfStringable
108  ls_put strs cd = do
109         -- A version tag
110         putWord8 3
111         ls_put strs (cWindows cd)
112         ls_put strs (cLastActivity cd)
113         ls_put strs (cDesktop cd)
114  ls_get strs = do
115         v <- getWord8
116         case v of
117          1 -> CaptureData <$> get <*> get <*> pure ""
118          2 -> CaptureData <$> ls_get strs <*> ls_get strs <*> pure ""
119          3 -> CaptureData <$> ls_get strs <*> ls_get strs <*> ls_get strs
120          _ -> error $ "Unsupported CaptureData version tag " ++ show v
121
122   -- | 'getMany n' get 'n' elements in order, without blowing the stack.
123   --   From Data.Binary
124 getMany :: Binary a => Int -> Get [a]
125 getMany n = go [] n
126  where
127     go xs 0 = return $! reverse xs
128     go xs i = do x <- get
129                  -- we must seq x to avoid stack overflows due to laziness in
130                  -- (>>=)
131                  x `seq` go (x:xs) (i-1)
132 {-# INLINE getMany #-}