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 Control.Monad
import qualified HpcSet as Set
import qualified HpcMap as Map
import System.Environment
import HpcUtils
import Data.Tree
------------------------------------------------------------------------------
draft_options =
[ excludeOpt,includeOpt,hpcDirOpt,hsDirOpt,outputOpt ]
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 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 mod = tixModuleName tix
hash = tixModuleHash tix
tixs = tixModuleTixs tix
mix@(Mix filepath timestamp hash tabstop entries) <- readMix (hpcDirs hpcflags) mod
let forest = createMixEntryDom
[ (span,(box,v > 0))
| ((span,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 filepath (hsDirs 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 \"" ++ head str ++ "\" "
++ "on line " ++ show (firstLine pos) ++ ";"
showPleaseTick d (TickExp pos) =
spaces d ++ "tick expression "
++ 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] pos pleases) =
spaces d ++ "function \"" ++ str ++ "\" {\n" ++
showPleaseTicks (d + 2) pleases ++
spaces d ++ "}"
showPleaseTicks d pleases = unlines (map (showPleaseTick d) pleases)
spaces d = take d (repeat ' ')
return $ "module " ++ show (fixPackageSuffix mod) ++ " {\n" ++
showPleaseTicks 2 non_ticked ++ "}"
fixPackageSuffix :: String -> String
fixPackageSuffix mod = case span (/= '/') mod of
(before,'/':after) -> before ++ ":" ++ after
_ -> mod
data PleaseTick
= TickFun [String] HpcPos
| TickExp HpcPos
| TickInside [String] HpcPos [PleaseTick]
deriving Show
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):others) children)
= mkTickInside nm pos (findNotTickedFromList children) []
findNotTickedFromTree (Node (pos,_:others) children) =
findNotTickedFromTree (Node (pos,others) children)
findNotTickedFromTree (Node (pos,[]) children) = findNotTickedFromList children
findNotTickedFromList :: [MixEntryDom [(BoxLabel,Bool)]] -> [PleaseTick]
findNotTickedFromList = concatMap findNotTickedFromTree
readFileFromPath :: String -> [String] -> IO String
readFileFromPath filename@('/':_) _ = readFile filename
readFileFromPath filename path0 = readTheFile path0
where
readTheFile :: [String] -> IO String
readTheFile [] = error $ "could not find " ++ show filename
++ " in path " ++ show path0
readTheFile (dir:dirs) =
catch (do str <- readFile (dir ++ "/" ++ filename)
return str)
(\ _ -> readTheFile dirs)
|
