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