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