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