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