Make some utils -Wall clean
[ghc.git] / utils / hpc / HpcCombine.hs
1 ---------------------------------------------------------
2 -- The main program for the hpc-add tool, part of HPC.
3 -- Andy Gill, Oct 2006
4 ---------------------------------------------------------
5
6 module HpcCombine (sum_plugin,combine_plugin,map_plugin) where
7
8 import Trace.Hpc.Tix
9 import Trace.Hpc.Util
10
11 import HpcFlags
12
13 import Control.Monad
14 import qualified HpcSet as Set
15 import qualified HpcMap as Map
16
17 ------------------------------------------------------------------------------
18 sum_options :: FlagOptSeq
19 sum_options
20 = excludeOpt
21 . includeOpt
22 . outputOpt
23 . unionModuleOpt
24
25 sum_plugin :: Plugin
26 sum_plugin = Plugin { name = "sum"
27 , usage = "[OPTION] .. <TIX_FILE> [<TIX_FILE> [<TIX_FILE> ..]]"
28 , options = sum_options
29 , summary = "Sum multiple .tix files in a single .tix file"
30 , implementation = sum_main
31 , init_flags = default_flags
32 , final_flags = default_final_flags
33 }
34
35 combine_options :: FlagOptSeq
36 combine_options
37 = excludeOpt
38 . includeOpt
39 . outputOpt
40 . combineFunOpt
41 . combineFunOptInfo
42 . unionModuleOpt
43
44 combine_plugin :: Plugin
45 combine_plugin = Plugin { name = "combine"
46 , usage = "[OPTION] .. <TIX_FILE> <TIX_FILE>"
47 , options = combine_options
48 , summary = "Combine two .tix files in a single .tix file"
49 , implementation = combine_main
50 , init_flags = default_flags
51 , final_flags = default_final_flags
52 }
53
54 map_options :: FlagOptSeq
55 map_options
56 = excludeOpt
57 . includeOpt
58 . outputOpt
59 . mapFunOpt
60 . mapFunOptInfo
61 . unionModuleOpt
62
63 map_plugin :: Plugin
64 map_plugin = Plugin { name = "map"
65 , usage = "[OPTION] .. <TIX_FILE> "
66 , options = map_options
67 , summary = "Map a function over a single .tix file"
68 , implementation = map_main
69 , init_flags = default_flags
70 , final_flags = default_final_flags
71 }
72
73 ------------------------------------------------------------------------------
74
75 sum_main :: Flags -> [String] -> IO ()
76 sum_main _ [] = hpcError sum_plugin $ "no .tix file specified"
77 sum_main flags (first_file:more_files) = do
78 Just tix <- readTix first_file
79
80 tix' <- foldM (mergeTixFile flags (+))
81 (filterTix flags tix)
82 more_files
83
84 case outputFile flags of
85 "-" -> putStrLn (show tix')
86 out -> writeTix out tix'
87
88 combine_main :: Flags -> [String] -> IO ()
89 combine_main flags [first_file,second_file] = do
90 let f = theCombineFun (combineFun flags)
91
92 Just tix1 <- readTix first_file
93 Just tix2 <- readTix second_file
94
95 let tix = mergeTix (mergeModule flags)
96 f
97 (filterTix flags tix1)
98 (filterTix flags tix2)
99
100 case outputFile flags of
101 "-" -> putStrLn (show tix)
102 out -> writeTix out tix
103 combine_main _ _ = hpcError combine_plugin $ "need exactly two .tix files to combine"
104
105 map_main :: Flags -> [String] -> IO ()
106 map_main flags [first_file] = do
107 let f = thePostFun (postFun flags)
108
109 Just tix <- readTix first_file
110
111 let (Tix inside_tix) = filterTix flags tix
112 let tix' = Tix [ TixModule m p i (map f t)
113 | TixModule m p i t <- inside_tix
114 ]
115
116 case outputFile flags of
117 "-" -> putStrLn (show tix')
118 out -> writeTix out tix'
119 map_main _ [] = hpcError map_plugin $ "no .tix file specified"
120 map_main _ _ = hpcError map_plugin $ "to many .tix files specified"
121
122 mergeTixFile :: Flags -> (Integer -> Integer -> Integer) -> Tix -> String -> IO Tix
123 mergeTixFile flags fn tix file_name = do
124 Just new_tix <- readTix file_name
125 return $! strict $ mergeTix (mergeModule flags) fn tix (filterTix flags new_tix)
126
127 -- could allow different numbering on the module info,
128 -- as long as the total is the same; will require normalization.
129
130 mergeTix :: MergeFun
131 -> (Integer -> Integer -> Integer) -> Tix -> Tix -> Tix
132 mergeTix modComb f
133 (Tix t1)
134 (Tix t2) = Tix
135 [ case (Map.lookup m fm1,Map.lookup m fm2) of
136 -- todo, revisit the semantics of this combination
137 (Just (TixModule _ hash1 len1 tix1),Just (TixModule _ hash2 len2 tix2))
138 | hash1 /= hash2
139 || length tix1 /= length tix2
140 || len1 /= length tix1
141 || len2 /= length tix2
142 -> error $ "mismatched in module " ++ m
143 | otherwise ->
144 TixModule m hash1 len1 (zipWith f tix1 tix2)
145 (Just m1,Nothing) ->
146 m1
147 (Nothing,Just m2) ->
148 m2
149 _ -> error "impossible"
150 | m <- Set.toList (theMergeFun modComb m1s m2s)
151 ]
152 where
153 m1s = Set.fromList $ map tixModuleName t1
154 m2s = Set.fromList $ map tixModuleName t2
155
156 fm1 = Map.fromList [ (tixModuleName tix,tix)
157 | tix <- t1
158 ]
159 fm2 = Map.fromList [ (tixModuleName tix,tix)
160 | tix <- t2
161 ]
162
163
164 -- What I would give for a hyperstrict :-)
165 -- This makes things about 100 times faster.
166 class Strict a where
167 strict :: a -> a
168
169 instance Strict Integer where
170 strict i = i
171
172 instance Strict Int where
173 strict i = i
174
175 instance Strict Hash where -- should be fine, because Hash is a newtype round an Int
176 strict i = i
177
178 instance Strict Char where
179 strict i = i
180
181 instance Strict a => Strict [a] where
182 strict (a:as) = (((:) $! strict a) $! strict as)
183 strict [] = []
184
185 instance (Strict a, Strict b) => Strict (a,b) where
186 strict (a,b) = (((,) $! strict a) $! strict b)
187
188 instance Strict Tix where
189 strict (Tix t1) =
190 Tix $! strict t1
191
192 instance Strict TixModule where
193 strict (TixModule m1 p1 i1 t1) =
194 ((((TixModule $! strict m1) $! strict p1) $! strict i1) $! strict t1)
195