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