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