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