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