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