1module HpcOverlay where
2
3import HpcFlags
4import HpcParser
5import HpcUtils
6import Trace.Hpc.Tix
7import Trace.Hpc.Mix
8import Trace.Hpc.Util
9import qualified Data.Map as Map
10import Data.Tree
11
12overlay_options :: FlagOptSeq
13overlay_options
14        = srcDirOpt
15        . hpcDirOpt
16        . resetHpcDirsOpt
17        . outputOpt
18        . verbosityOpt
19
20overlay_plugin :: Plugin
21overlay_plugin = Plugin { name = "overlay"
22                       , usage = "[OPTION] .. <OVERLAY_FILE> [<OVERLAY_FILE> [...]]"
23                       , options = overlay_options
24                       , summary = "Generate a .tix file from an overlay file"
25                       , implementation = overlay_main
26                       , init_flags = default_flags
27                       , final_flags = default_final_flags
28                       }
29
30overlay_main :: Flags -> [String] -> IO ()
31overlay_main _     [] = hpcError overlay_plugin $ "no overlay file specified"
32overlay_main flags files = do
33  specs <- mapM hpcParser files
34  let (Spec globals modules) = concatSpec specs
35
36  let modules1 = Map.fromListWith (++) [ (m,info) | (m,info) <- modules ]
37
38  mod_info <-
39     sequence [ do mix@(Mix origFile _ _ _ _) <- readMixWithFlags flags (Left modu)
40                   content <- readFileFromPath (hpcError overlay_plugin) origFile (srcDirs flags)
41                   processModule modu content mix mod_spec globals
42              | (modu, mod_spec) <- Map.toList modules1
43              ]
44
45
46  let tix = Tix $ mod_info
47
48  case outputFile flags of
49    "-" -> putStrLn (show tix)
50    out -> writeFile out (show tix)
51
52
53processModule :: String         -- ^ module name
54              -> String         -- ^ module contents
55              -> Mix            -- ^ mix entry for this module
56              -> [Tick]         -- ^ local ticks
57              -> [ExprTick]     -- ^ global ticks
58              -> IO TixModule
59processModule modName modContents (Mix _ _ hash _ entries) locals globals = do
60
61   let hsMap :: Map.Map Int String
62       hsMap = Map.fromList (zip [1..] $ lines modContents)
63
64   let topLevelFunctions =
65        Map.fromListWith (++)
66                     [ (nm,[pos])
67                     | (pos,TopLevelBox [nm]) <- entries
68                     ]
69
70   let inside :: HpcPos -> String -> Bool
71       inside pos nm =
72                       case Map.lookup nm topLevelFunctions of
73                         Nothing -> False
74                         Just poss -> any (pos `insideHpcPos`) poss
75
76   -- TODO: rename plzTick => plzExprTick, plzTopPick => plzTick
77   let plzTick :: HpcPos -> BoxLabel -> ExprTick -> Bool
78       plzTick pos (ExpBox _) (TickExpression _ match q _)  =
79                     qualifier pos q
80                  && case match of
81                        Nothing -> True
82                        Just str -> str == grabHpcPos hsMap pos
83       plzTick _   _       _ = False
84
85
86       plzTopTick :: HpcPos -> BoxLabel -> Tick -> Bool
87       plzTopTick pos label  (ExprTick ignore)           = plzTick pos label ignore
88       plzTopTick pos _      (TickFunction fn q _)   =
89                    qualifier pos q && pos `inside` fn
90       plzTopTick pos label  (InsideFunction fn igs)   =
91         pos `inside` fn && any (plzTopTick pos label) igs
92
93
94   let tixs = Map.fromList
95              [ (ix,
96                   any (plzTick pos label) globals
97                || any (plzTopTick pos label) locals)
98              | (ix,(pos,label)) <- zip [0..] entries
99              ]
100
101
102   -- let show' (srcspan,stuff) = show (srcspan,stuff,grabHpcPos hsMap span)
103
104   let forest = createMixEntryDom
105              [ (srcspan,ix)
106              | ((srcspan,_),ix) <- zip entries [0..]
107              ]
108
109
110   --
111   let forest2 = addParentToList [] $ forest
112--   putStrLn $ drawForest $ map (fmap show') $ forest2
113
114   let isDomList = Map.fromList
115              [ (ix,filter (/= ix) rng ++ dom)
116              | (_,(rng,dom)) <- concatMap flatten forest2
117              , ix <- rng
118              ]
119
120   -- We do not use laziness here, because the dominator lists
121   -- point to their equivent peers, creating loops.
122
123
124   let isTicked n =
125           case Map.lookup n tixs of
126             Just v -> v
127             Nothing -> error $ "can not find ix # " ++ show n
128
129   let tixs' = [ case Map.lookup n isDomList of
130                   Just vs -> if any isTicked (n : vs) then 1 else 0
131                   Nothing -> error $ "can not find ix in dom list # " ++ show n
132               | n <- [0..(length entries - 1)]
133               ]
134
135   return $ TixModule modName hash (length tixs') tixs'
136
137qualifier :: HpcPos -> Maybe Qualifier -> Bool
138qualifier _   Nothing = True
139qualifier pos (Just (OnLine n)) = n == l1 && n == l2
140  where (l1,_,l2,_) = fromHpcPos pos
141qualifier pos (Just (AtPosition l1' c1' l2' c2'))
142          = (l1', c1', l2', c2') == fromHpcPos pos
143
144concatSpec :: [Spec] -> Spec
145concatSpec = foldr
146               (\ (Spec pre1 body1) (Spec pre2 body2)
147                     -> Spec (pre1 ++ pre2) (body1 ++ body2))
148                (Spec [] [])
149
150
151
152addParentToTree :: [a] -> MixEntryDom [a] -> MixEntryDom ([a],[a])
153addParentToTree path (Node (pos,a) children) =
154                Node (pos,(a,path)) (addParentToList (a ++ path) children)
155
156addParentToList :: [a] -> [MixEntryDom [a]] -> [MixEntryDom ([a],[a])]
157addParentToList path nodes = map (addParentToTree path) nodes
158
159
160