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