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