(partial) Merge branch 'master' into type-nats
[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 qualified Data.Set as Set
10 import qualified Data.Map as Map
11 import HpcUtils
12 import Data.Tree
13
14 ------------------------------------------------------------------------------
15 draft_options :: FlagOptSeq
16 draft_options
17 = excludeOpt
18 . includeOpt
19 . srcDirOpt
20 . hpcDirOpt
21 . outputOpt
22
23 draft_plugin :: Plugin
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 _ [] = error "draft_main: unhandled case: []"
37 draft_main hpcflags (progName:mods) = do
38 let hpcflags1 = hpcflags
39 { includeMods = Set.fromList mods
40 `Set.union`
41 includeMods hpcflags }
42 let prog = getTixFileName $ progName
43 tix <- readTix prog
44 case tix of
45 Just (Tix tickCounts) -> do
46 outs <- sequence
47 [ makeDraft hpcflags1 tixModule
48 | tixModule@(TixModule m _ _ _) <- tickCounts
49 , allowModule hpcflags1 m
50 ]
51 case outputFile hpcflags1 of
52 "-" -> putStrLn (unlines outs)
53 out -> writeFile out (unlines outs)
54 Nothing -> hpcError draft_plugin $ "unable to find tix file for:" ++ progName
55
56
57 makeDraft :: Flags -> TixModule -> IO String
58 makeDraft hpcflags tix = do
59 let modu = tixModuleName tix
60 tixs = tixModuleTixs tix
61
62 (Mix filepath _ _ _ entries) <- readMixWithFlags hpcflags (Right tix)
63
64 let forest = createMixEntryDom
65 [ (srcspan,(box,v > 0))
66 | ((srcspan,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 (hpcError draft_plugin) 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] _ pleases) =
99 spaces d ++ "inside \"" ++ str ++ "\" {\n" ++
100 showPleaseTicks (d + 2) pleases ++
101 spaces d ++ "}"
102
103 showPleaseTick _ (TickInside _ _ _)
104 = error "showPleaseTick: Unhandled case TickInside"
105
106 showPleaseTicks d pleases = unlines (map (showPleaseTick d) pleases)
107
108 spaces d = take d (repeat ' ')
109
110 return $ "module " ++ show (fixPackageSuffix modu) ++ " {\n" ++
111 showPleaseTicks 2 non_ticked ++ "}"
112
113 fixPackageSuffix :: String -> String
114 fixPackageSuffix modu = case span (/= '/') modu of
115 (before,'/':after) -> before ++ ":" ++ after
116 _ -> modu
117
118 data PleaseTick
119 = TickFun [String] HpcPos
120 | TickExp HpcPos
121 | TickInside [String] HpcPos [PleaseTick]
122 deriving Show
123
124 mkTickInside :: [String] -> HpcPos -> [PleaseTick]
125 -> [PleaseTick] -> [PleaseTick]
126 mkTickInside _ _ [] = id
127 mkTickInside nm pos inside = (TickInside nm pos inside :)
128
129 findNotTickedFromTree :: MixEntryDom [(BoxLabel,Bool)] -> [PleaseTick]
130 findNotTickedFromTree (Node (pos,(ExpBox {},False):_) _) = [TickExp pos]
131 findNotTickedFromTree (Node (pos,(TopLevelBox nm,False):_) _)
132 = [ TickFun nm pos ]
133 findNotTickedFromTree (Node (pos,(LocalBox nm,False):_) _)
134 = [ TickFun nm pos ]
135 findNotTickedFromTree (Node (pos,(TopLevelBox nm,True):_) children)
136 = mkTickInside nm pos (findNotTickedFromList children) []
137 findNotTickedFromTree (Node (pos,_:others) children) =
138 findNotTickedFromTree (Node (pos,others) children)
139 findNotTickedFromTree (Node (_, []) children) = findNotTickedFromList children
140
141 findNotTickedFromList :: [MixEntryDom [(BoxLabel,Bool)]] -> [PleaseTick]
142 findNotTickedFromList = concatMap findNotTickedFromTree
143