0a5f054bf17fe3cc5f7ac356e3a4793ab0988646
[packages/hpc.git] / Trace / Hpc / Mix.hs
1 {-# LANGUAGE CPP #-}
2 #if __GLASGOW_HASKELL__ >= 709
3 {-# LANGUAGE Safe #-}
4 #elif __GLASGOW_HASKELL__ >= 701
5 {-# LANGUAGE Trustworthy #-}
6 #endif
7 ---------------------------------------------------------------
8 -- Colin Runciman and Andy Gill, June 2006
9 ---------------------------------------------------------------
10
11 -- | Datatypes and file-access routines for the per-module (@.mix@)
12 -- indexes used by Hpc.
13 module Trace.Hpc.Mix
14 ( Mix(..)
15 , MixEntry
16 , BoxLabel(..)
17 , CondBox(..)
18 , mixCreate
19 , readMix
20 , createMixEntryDom
21 , MixEntryDom
22 )
23 where
24
25 import Data.Maybe (catMaybes, fromMaybe)
26 import Data.Time (UTCTime)
27 import Data.Tree
28
29 import System.FilePath
30
31 #if MIN_VERSION_base(4,6,0)
32 import Text.Read (readMaybe)
33 #else
34 readMaybe :: Read a => String -> Maybe a
35 readMaybe s = case reads s of
36 [(x, s')] | all isSpace s' -> Just x
37 _ -> Nothing
38 #endif
39
40 -- a module index records the attributes of each tick-box that has
41 -- been introduced in that module, accessed by tick-number position
42 -- in the list
43
44 import Trace.Hpc.Util (HpcPos, insideHpcPos, Hash, HpcHash(..), catchIO)
45 import Trace.Hpc.Tix
46
47 -- | 'Mix' is the information about a modules static properties, like
48 -- location of Tix's in a file.
49 --
50 -- Tab stops are the size of a tab in the provided /line:column/ values.
51 --
52 -- * In GHC, this is 1 (a tab is just a character)
53 -- * With @hpc-tracer@, this is 8 (a tab represents several spaces).
54 data Mix = Mix
55 FilePath -- location of original file
56 UTCTime -- time of original file's last update
57 Hash -- hash of mix entry + timestamp
58 Int -- tab stop value.
59 [MixEntry] -- entries
60 deriving (Show,Read,Eq)
61
62 type MixEntry = (HpcPos, BoxLabel)
63
64 data BoxLabel = ExpBox Bool -- isAlt
65 | TopLevelBox [String]
66 | LocalBox [String]
67 | BinBox CondBox Bool
68 deriving (Read, Show, Eq, Ord)
69
70 data CondBox = GuardBinBox
71 | CondBinBox
72 | QualBinBox
73 deriving (Read, Show, Eq, Ord)
74
75 instance HpcHash BoxLabel where
76 toHash (ExpBox b) = 0x100 + toHash b
77 toHash (TopLevelBox nm) = 0x200 + toHash nm
78 toHash (LocalBox nm) = 0x300 + toHash nm
79 toHash (BinBox cond b) = 0x400 + toHash (cond,b)
80
81 instance HpcHash CondBox where
82 toHash GuardBinBox = 0x10
83 toHash CondBinBox = 0x20
84 toHash QualBinBox = 0x30
85
86
87 -- | Create is mix file.
88 mixCreate :: String -- ^ Dir Name
89 -> String -- ^ module Name
90 -> Mix -- ^ Mix DataStructure
91 -> IO ()
92 mixCreate dirName modName mix =
93 writeFile (mixName dirName modName) (show mix)
94
95 -- | Read a mix file.
96 readMix :: [String] -- ^ Dir Names
97 -> Either String TixModule -- ^ module wanted
98 -> IO Mix
99 readMix dirNames mod' = do
100 let modName = either id tixModuleName mod'
101 res <- sequence [ (do let mixPath = mixName dirName modName
102 parseError = error ("can not parse " ++ mixPath)
103 parse = fromMaybe parseError . readMaybe
104 mix <- parse `fmap` readFile mixPath
105 case mod' of
106 Left _ -> return $ Just mix -- Bypass hash check
107 Right tix -> return $ checkHash tix mix mixPath)
108 `catchIO` (\ _ -> return $ Nothing)
109 | dirName <- dirNames
110 ]
111 case catMaybes res of
112 xs@(x:_:_) | any (/= x) (tail xs) ->
113 -- Only complain if multiple *different* `Mix` files with the
114 -- same name are found (#9619).
115 error $ "found " ++ show(length xs) ++ " different instances of "
116 ++ modName ++ " in " ++ show dirNames
117 (x:_) -> return x
118 _ -> error $ "can not find " ++ modName ++ " in " ++ show dirNames
119
120 mixName :: FilePath -> String -> String
121 mixName dirName name = dirName </> name <.> "mix"
122
123 -- | Check that hash in .tix and .mix file match.
124 checkHash :: TixModule -> Mix -> FilePath -> Maybe Mix
125 checkHash tix mix@(Mix _ _ mixHash _ _) mixPath
126 | modHash == mixHash = Just mix
127 | otherwise = error $
128 "hash in tix file for module " ++ modName ++ " (" ++ show modHash ++ ")\n"
129 ++ "does not match hash in " ++ mixPath ++ " (" ++ show mixHash ++ ")"
130 where
131 modName = tixModuleName tix
132 modHash = tixModuleHash tix
133
134 ------------------------------------------------------------------------------
135
136 type MixEntryDom a = Tree (HpcPos,a)
137
138 -- A good tree has all its children fully inside its parents HpcPos.
139 -- No child should have the *same* HpcPos.
140 -- There is no ordering to the children
141
142 isGoodNode :: MixEntryDom a -> Bool
143 isGoodNode (Node (pos,_) sub_nodes) =
144 and [ pos' `insideHpcPos` pos | Node(pos',_) _ <- sub_nodes ]
145 && and [ pos' /= pos | Node(pos',_) _ <- sub_nodes ]
146 && isGoodForest sub_nodes
147
148 -- all sub-trees are good trees, and no two HpcPos are inside each other.
149 isGoodForest :: [MixEntryDom a] -> Bool
150 isGoodForest sub_nodes =
151 all isGoodNode sub_nodes
152 && and [ not (pos1 `insideHpcPos` pos2 ||
153 pos2 `insideHpcPos` pos1)
154 | (Node (pos1,_) _,n1) <- zip sub_nodes [0..]
155 , (Node (pos2,_) _,n2) <- zip sub_nodes [0..]
156 , (n1 :: Int) /= n2 ]
157
158 addNodeToTree :: (Show a) => (HpcPos,a) -> MixEntryDom [a] -> MixEntryDom [a]
159 addNodeToTree (new_pos,new_a) (Node (pos,a) children)
160 | pos == new_pos = Node (pos,new_a : a) children
161 | new_pos `insideHpcPos` pos =
162 Node (pos,a) (addNodeToList (new_pos,new_a) children)
163 | pos `insideHpcPos` new_pos =
164 error "precondition not met inside addNodeToNode"
165 | otherwise = error "something impossible happened in addNodeToTree"
166
167 addNodeToList :: Show a => (HpcPos,a) -> [MixEntryDom [a]] -> [MixEntryDom [a]]
168 addNodeToList (new_pos,new_a) entries
169 | otherwise =
170 if length [ ()
171 | (am_inside,am_outside,_) <- entries'
172 , am_inside || am_outside
173 ] == 0
174 -- The case where we have a new HpcPos range
175 then Node (new_pos,[new_a]) [] : entries else
176 if length [ ()
177 | (am_inside,_,_) <- entries'
178 , am_inside
179 ] > 0
180 -- The case where we are recursing into a tree
181 -- Note we can recurse down many branches, in the case of
182 -- overlapping ranges.
183 -- Assumes we have captures the new HpcPos
184 -- (or the above conditional would be true)
185 then [ if i_am_inside -- or the same as
186 then addNodeToTree (new_pos,new_a) node
187 else node
188 | (i_am_inside,_,node) <- entries'
189 ] else
190 -- The case of a super-range.
191 ( Node (new_pos,[new_a])
192 [ node | (_,True,node) <- entries' ] :
193 [ node | (_,False,node) <- entries' ]
194 )
195 where
196 entries' = [ ( new_pos `insideHpcPos` pos
197 , pos `insideHpcPos` new_pos
198 , node)
199 | node@(Node (pos,_) _) <- entries
200 ]
201
202 createMixEntryDom :: (Show a) => [(HpcPos,a)] -> [MixEntryDom [a]]
203 createMixEntryDom entries
204 | isGoodForest forest = forest
205 | otherwise = error "createMixEntryDom: bad forest"
206 where forest = foldr addNodeToList [] entries