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