Fixing hpc to allow use of hash function to seperate source files on source path
[ghc.git] / utils / hpc / HpcDraft.hs
1 module HpcDraft (draft_plugin) where
2
3 import Trace.Hpc.Tix
4 import Trace.Hpc.Mix
5 import Trace.Hpc.Util
6
7 import HpcFlags
8
9 import Control.Monad
10 import qualified HpcSet as Set
11 import qualified HpcMap as Map
12 import System.Environment
13 import HpcUtils
14 import Data.Tree
15
16 ------------------------------------------------------------------------------
17 draft_options
18 = excludeOpt
19 . includeOpt
20 . srcDirOpt
21 . hpcDirOpt
22 . outputOpt
23
24 draft_plugin = Plugin { name = "draft"
25 , usage = "[OPTION] .. <TIX_FILE>"
26 , options = draft_options
27 , summary = "Generate draft overlay that provides 100% coverage"
28 , implementation = draft_main
29 , init_flags = default_flags
30 , final_flags = default_final_flags
31 }
32
33 ------------------------------------------------------------------------------
34
35 draft_main :: Flags -> [String] -> IO ()
36 draft_main hpcflags (progName:mods) = do
37 let hpcflags1 = hpcflags
38 { includeMods = Set.fromList mods
39 `Set.union`
40 includeMods hpcflags }
41 let prog = getTixFileName $ progName
42 tix <- readTix prog
43 case tix of
44 Just (Tix tickCounts) -> do
45 outs <- sequence
46 [ makeDraft hpcflags1 tixModule
47 | tixModule@(TixModule m _ _ _) <- tickCounts
48 , allowModule hpcflags1 m
49 ]
50 case outputFile hpcflags1 of
51 "-" -> putStrLn (unlines outs)
52 out -> writeFile out (unlines outs)
53 Nothing -> hpcError draft_plugin $ "unable to find tix file for:" ++ progName
54
55
56 makeDraft :: Flags -> TixModule -> IO String
57 makeDraft hpcflags tix = do
58 let mod = tixModuleName tix
59 hash = tixModuleHash tix
60 tixs = tixModuleTixs tix
61
62 mix@(Mix filepath timestamp hash tabstop entries) <- readMixWithFlags hpcflags tix
63
64 let forest = createMixEntryDom
65 [ (span,(box,v > 0))
66 | ((span,box),v) <- zip entries tixs
67 ]
68
69 -- let show' (span,stuff) = show (span,stuff,grabHpcPos hsMap span)
70 -- putStrLn $ drawForest $ map (fmap show) $ forest
71
72 let non_ticked = findNotTickedFromList forest
73
74 hs <- readFileFromPath filepath (srcDirs hpcflags)
75
76 let hsMap :: Map.Map Int String
77 hsMap = Map.fromList (zip [1..] $ lines hs)
78
79 let quoteString = show
80
81 let firstLine pos = case fromHpcPos pos of
82 (ln,_,_,_) -> ln
83
84
85 let showPleaseTick :: Int -> PleaseTick -> String
86 showPleaseTick d (TickFun str pos) =
87 spaces d ++ "tick function \"" ++ last str ++ "\" "
88 ++ "on line " ++ show (firstLine pos) ++ ";"
89 showPleaseTick d (TickExp pos) =
90 spaces d ++ "tick "
91 ++ if '\n' `elem` txt
92 then "at position " ++ show pos ++ ";"
93 else quoteString txt ++ " " ++ "on line " ++ show (firstLine pos) ++ ";"
94
95 where
96 txt = grabHpcPos hsMap pos
97
98 showPleaseTick d (TickInside [str] pos pleases) =
99 spaces d ++ "inside \"" ++ str ++ "\" {\n" ++
100 showPleaseTicks (d + 2) pleases ++
101 spaces d ++ "}"
102
103 showPleaseTicks d pleases = unlines (map (showPleaseTick d) pleases)
104
105 spaces d = take d (repeat ' ')
106
107 return $ "module " ++ show (fixPackageSuffix mod) ++ " {\n" ++
108 showPleaseTicks 2 non_ticked ++ "}"
109
110 fixPackageSuffix :: String -> String
111 fixPackageSuffix mod = case span (/= '/') mod of
112 (before,'/':after) -> before ++ ":" ++ after
113 _ -> mod
114
115 data PleaseTick
116 = TickFun [String] HpcPos
117 | TickExp HpcPos
118 | TickInside [String] HpcPos [PleaseTick]
119 deriving Show
120
121 mkTickInside _ _ [] = id
122 mkTickInside nm pos inside = (TickInside nm pos inside :)
123
124 findNotTickedFromTree :: MixEntryDom [(BoxLabel,Bool)] -> [PleaseTick]
125 findNotTickedFromTree (Node (pos,(ExpBox {},False):_) _) = [TickExp pos]
126 findNotTickedFromTree (Node (pos,(TopLevelBox nm,False):_) _)
127 = [ TickFun nm pos ]
128 findNotTickedFromTree (Node (pos,(LocalBox nm,False):_) _)
129 = [ TickFun nm pos ]
130 findNotTickedFromTree (Node (pos,(TopLevelBox nm,True):others) children)
131 = mkTickInside nm pos (findNotTickedFromList children) []
132 findNotTickedFromTree (Node (pos,_:others) children) =
133 findNotTickedFromTree (Node (pos,others) children)
134 findNotTickedFromTree (Node (pos,[]) children) = findNotTickedFromList children
135
136 findNotTickedFromList :: [MixEntryDom [(BoxLabel,Bool)]] -> [PleaseTick]
137 findNotTickedFromList = concatMap findNotTickedFromTree
138
139 readFileFromPath :: String -> [String] -> IO String
140 readFileFromPath filename@('/':_) _ = readFile filename
141 readFileFromPath filename path0 = readTheFile path0
142 where
143 readTheFile :: [String] -> IO String
144 readTheFile [] = error $ "could not find " ++ show filename
145 ++ " in path " ++ show path0
146 readTheFile (dir:dirs) =
147 catch (do str <- readFile (dir ++ "/" ++ filename)
148 return str)
149 (\ _ -> readTheFile dirs)