0f098ed9d4deae7a8181bdf244d5e545aa2a51db
[packages/hpc.git] / Trace / Hpc / Mix.hs
1 {-# OPTIONS -cpp #-}
2 ---------------------------------------------------------------
3 -- Colin Runciman and Andy Gill, June 2006
4 ---------------------------------------------------------------
5
6 -- |Datatypes and file-access routines for the per-module (.mix)
7 -- indexes used by Hpc.
8 module Trace.Hpc.Mix
9 ( Mix(..)
10 , MixEntry
11 , BoxLabel(..)
12 , CondBox(..)
13 , mixCreate
14 , readMix
15 , Trace.Hpc.Mix.getModificationTime
16 , createMixEntryDom
17 , MixEntryDom
18 )
19 where
20
21 import System.Time (ClockTime(..))
22 import System.Directory (getModificationTime)
23 import System.IO (FilePath)
24 import Data.Maybe (catMaybes)
25 import Data.Tree
26 import Data.Char
27
28 -- a module index records the attributes of each tick-box that has
29 -- been introduced in that module, accessed by tick-number position
30 -- in the list
31
32 import Trace.Hpc.Util (HpcPos, insideHpcPos, Hash, HpcHash(..))
33
34 -- | 'Mix' is the information about a modules static properties, like
35 -- location of Tix's in a file.
36 -- tab stops are the size of a tab in the provided line:colunm values.
37 -- * In GHC, this is 1 (a tab is just a character)
38 -- * With hpc-tracer, this is 8 (a tab represents several spaces).
39
40 data Mix = Mix
41 FilePath -- ^location of original file
42 Integer -- ^time (in seconds) of original file's last update, since 1970.
43 Hash -- ^hash of mix entry + timestamp
44 Int -- ^tab stop value.
45 [MixEntry] -- ^entries
46 deriving (Show,Read)
47
48 -- We would rather use ClockTime in Mix, but ClockTime has no Read instance in 6.4 and before,
49 -- but does in 6.6. Definining the instance for ClockTime here is the Wrong Thing to do,
50 -- because if some other program also defined that instance, we will not be able to compile.
51
52 type MixEntry = (HpcPos, BoxLabel)
53
54 data BoxLabel = ExpBox Bool -- isAlt
55 | TopLevelBox [String]
56 | LocalBox [String]
57 | BinBox CondBox Bool
58 deriving (Read, Show, Eq, Ord)
59
60 data CondBox = GuardBinBox
61 | CondBinBox
62 | QualBinBox
63 deriving (Read, Show, Eq, Ord)
64
65 instance HpcHash BoxLabel where
66 toHash (ExpBox b) = 0x100 + toHash b
67 toHash (TopLevelBox nm) = 0x200 + toHash nm
68 toHash (LocalBox nm) = 0x300 + toHash nm
69 toHash (BinBox cond b) = 0x400 + toHash (cond,b)
70
71 instance HpcHash CondBox where
72 toHash GuardBinBox = 0x10
73 toHash CondBinBox = 0x20
74 toHash QualBinBox = 0x30
75
76
77 -- | Create is mix file.
78 mixCreate :: String -- ^ Dir Name
79 -> String -- ^ module Name
80 -> Mix -- ^ Mix DataStructure
81 -> IO ()
82 mixCreate dirName modName mix =
83 writeFile (mixName dirName modName) (show mix)
84
85 -- | Read a mix file.
86 readMix :: [String] -- ^ Dir Names
87 -> String -- ^ module Name
88 -> IO Mix
89 readMix dirNames modName = do
90 res <- sequence [ (do contents <- readFile (mixName dirName modName)
91 case reads contents of
92 [(r@Mix {},cs)] | all isSpace cs -> return $ Just r
93 _ -> return $ Nothing) `catch` (\ _ -> return $ Nothing)
94 | dirName <- dirNames
95 ]
96 case catMaybes res of
97 [r] -> return r
98 xs@(_:_) -> error $ "found " ++ show(length xs) ++ " for " ++ modName ++ " in " ++ show dirNames
99 _ -> error $ "can not find " ++ modName ++ " in " ++ show dirNames
100
101
102 mixName :: FilePath -> String -> String
103 mixName dirName name = dirName ++ "/" ++ name ++ ".mix"
104
105 -- | Get modification time of a file.
106
107 getModificationTime :: FilePath -> IO Integer
108 getModificationTime file = do
109 (TOD sec _) <- System.Directory.getModificationTime file
110 return $ sec
111
112 ------------------------------------------------------------------------------
113
114 type MixEntryDom a = Tree (HpcPos,a)
115
116 -- A good tree has all its children fully inside its parents HpcPos.
117 -- No child should have the *same* HpcPos.
118 -- There is no ordering to the children
119
120 isGoodNode :: MixEntryDom a -> Bool
121 isGoodNode (Node (pos,_) sub_nodes) =
122 and [ pos' `insideHpcPos` pos | Node(pos',_) _ <- sub_nodes ]
123 && and [ pos' /= pos | Node(pos',_) _ <- sub_nodes ]
124 && isGoodForest sub_nodes
125
126 -- all sub-trees are good trees, and no two HpcPos are inside each other.
127 isGoodForest :: [MixEntryDom a] -> Bool
128 isGoodForest sub_nodes =
129 all isGoodNode sub_nodes
130 && and [ not (pos1 `insideHpcPos` pos2 ||
131 pos2 `insideHpcPos` pos1)
132 | (Node (pos1,_) _,n1) <- zip sub_nodes [0..]
133 , (Node (pos2,_) _,n2) <- zip sub_nodes [0..]
134 , (n1 :: Int) /= n2 ]
135
136 addNodeToTree :: (Show a) => (HpcPos,a) -> MixEntryDom [a] -> MixEntryDom [a]
137 addNodeToTree (new_pos,new_a) (Node (pos,a) children)
138 | pos == new_pos = Node (pos,new_a : a) children
139 | new_pos `insideHpcPos` pos =
140 Node (pos,a) (addNodeToList (new_pos,new_a) children)
141 | pos `insideHpcPos` new_pos =
142 error "precondition not met inside addNodeToNode"
143 | otherwise = error "something impossible happened in addNodeToTree"
144
145 addNodeToList :: Show a => (HpcPos,a) -> [MixEntryDom [a]] -> [MixEntryDom [a]]
146 addNodeToList (new_pos,new_a) entries
147 | otherwise =
148 if length [ ()
149 | (am_inside,am_outside,_) <- entries'
150 , am_inside || am_outside
151 ] == 0
152 -- The case where we have a new HpcPos range
153 then Node (new_pos,[new_a]) [] : entries else
154 if length [ ()
155 | (am_inside,_,_) <- entries'
156 , am_inside
157 ] > 0
158 -- The case where we are recursing into a tree
159 -- Note we can recurse down many branches, in the case of
160 -- overlapping ranges.
161 -- Assumes we have captures the new HpcPos
162 -- (or the above conditional would be true)
163 then [ if i_am_inside -- or the same as
164 then addNodeToTree (new_pos,new_a) node
165 else node
166 | (i_am_inside,_,node) <- entries'
167 ] else
168 -- The case of a super-range.
169 ( Node (new_pos,[new_a])
170 [ node | (_,True,node) <- entries' ] :
171 [ node | (_,False,node) <- entries' ]
172 )
173 where
174 entries' = [ ( new_pos `insideHpcPos` pos
175 , pos `insideHpcPos` new_pos
176 , node)
177 | node@(Node (pos,_) _) <- entries
178 ]
179
180 createMixEntryDom :: (Show a) => [(HpcPos,a)] -> [MixEntryDom [a]]
181 createMixEntryDom entries
182 | isGoodForest forest = forest
183 | otherwise = error "createMixEntryDom: bad forest"
184 where forest = foldr addNodeToList [] entries