Adding draft and show to hpc

we now have

  hpc draft <TIX_FILE>

This drafts up a candidate overlay for 100% coverage.

and

  hpc show  <TIX_FILE>

This show verbose details about a tix file; mainly for debugging.

diff --git a/utils/hpc/Hpc.hs b/utils/hpc/Hpc.hs
index d567a0f..5db2b30 100644 (file)
--- a/utils/hpc/Hpc.hs
+++ b/utils/hpc/Hpc.hs
@@ -10,6 +10,8 @@ import System.Console.GetOpt
 import HpcReport
 import HpcMarkup
 import HpcCombine
+import HpcShowTix
+import HpcDraft
 
 helpList :: IO ()
 helpList =
@@ -18,16 +20,18 @@ helpList =
           section "Commands" help ++
           section "Reporting Coverage" reporting ++
           section "Processing Coverage files" processing ++
+          section "Coverage Overlays" overlays ++
           section "Others" other ++
           ""
   where 
     help       = ["help"]
     reporting  = ["report","markup"]
+    overlays   = ["overlay","draft"]
     processing = ["combine"]
     other     = [ name hook
                | hook <- hooks
                , name hook `notElem` 
-                    (concat [help,reporting,processing])
+                    (concat [help,reporting,processing,overlays])
                ]
 
 section :: String -> [String] -> String
@@ -72,6 +76,8 @@ hooks = [ help_plugin
         , report_plugin 
        , markup_plugin
        , combine_plugin
+       , showtix_plugin
+       , draft_plugin
        , version_plugin
         ]
 
@@ -116,4 +122,4 @@ version_plugin = Plugin { name = "version"
 version_main _ _ = putStrLn $ "hpc tools, version 0.5-dev"
 
 
-------------------------------------------------------------------------------
+------------------------------------------------------------------------------
\ No newline at end of file

diff --git a/utils/hpc/HpcDraft.hs b/utils/hpc/HpcDraft.hs
new file mode 100644 (file)
index 0000000..bf67213
--- /dev/null
+++ b/utils/hpc/HpcDraft.hs
@@ -0,0 +1,145 @@
+module HpcDraft (draft_plugin) where
+
+import Trace.Hpc.Tix
+import Trace.Hpc.Mix
+import Trace.Hpc.Util
+
+import HpcFlags
+
+import Control.Monad
+import qualified HpcSet as Set
+import qualified HpcMap as Map
+import System.Environment
+import HpcUtils
+import Data.Tree
+
+------------------------------------------------------------------------------
+draft_options = 
+  [ excludeOpt,includeOpt,hpcDirOpt,hsDirOpt,outputOpt ]
+                
+draft_plugin = Plugin { name = "draft"
+                      , usage = "[OPTION] .. <TIX_FILE>" 
+                      , options = draft_options 
+                      , summary = "Generate draft overlay that provides 100% coverage"
+                      , implementation = draft_main
+                      , init_flags = default_flags
+                      , final_flags = default_final_flags
+                      }
+
+------------------------------------------------------------------------------
+
+draft_main :: Flags -> [String] -> IO ()
+draft_main hpcflags (progName:mods) = do
+  let hpcflags1 = hpcflags 
+               { includeMods = Set.fromList mods 
+                                  `Set.union` 
+                               includeMods hpcflags }
+  let prog = getTixFileName $ progName 
+  tix <- readTix prog  
+  case tix of
+    Just (Tix tickCounts) -> do
+       outs <- sequence
+                     [ makeDraft hpcflags1 tixModule
+                     | tixModule@(TixModule m _ _ _) <- tickCounts
+                     , allowModule hpcflags1 m 
+                     ]
+        case outputFile hpcflags1 of
+         "-" -> putStrLn (unlines outs)
+         out -> writeFile out (unlines outs)
+    Nothing -> hpcError draft_plugin $ "unable to find tix file for:" ++ progName
+
+
+makeDraft :: Flags -> TixModule -> IO String
+makeDraft hpcflags tix = do 
+  let mod  = tixModuleName tix
+      hash = tixModuleHash tix
+      tixs = tixModuleTixs tix
+
+  mix@(Mix filepath timestamp hash tabstop entries) <- readMix (hpcDirs hpcflags) mod
+
+  let forest = createMixEntryDom 
+              [ (span,(box,v > 0))
+              | ((span,box),v) <- zip entries tixs
+              ]
+
+--  let show' (span,stuff) = show (span,stuff,grabHpcPos hsMap span)
+--  putStrLn $ drawForest $ map (fmap show) $ forest
+
+  let non_ticked = findNotTickedFromList forest
+
+  hs  <- readFileFromPath filepath (hsDirs hpcflags)
+
+  let hsMap :: Map.Map Int String
+      hsMap = Map.fromList (zip [1..] $ lines hs)
+
+  let quoteString = show
+  
+  let firstLine pos = case fromHpcPos pos of
+                        (ln,_,_,_) -> ln
+
+
+  let showPleaseTick :: Int -> PleaseTick -> String
+      showPleaseTick d (TickFun str pos) =
+                     spaces d ++ "tick function \"" ++ head str ++ "\" "
+                              ++ "on line " ++ show (firstLine pos) ++ ";"
+      showPleaseTick d (TickExp pos) =
+                     spaces d ++ "tick expression "
+                              ++ if '\n' `elem` txt 
+                                 then "at position " ++ show pos ++ ";"
+                                 else quoteString txt ++ " "  ++ "on line " ++ show (firstLine pos) ++ ";"
+                             
+          where
+                  txt = grabHpcPos hsMap pos
+
+      showPleaseTick d (TickInside [str] pos pleases) =
+                     spaces d ++ "function \"" ++ str ++ "\" {\n" ++
+                     showPleaseTicks (d + 2) pleases ++
+                     spaces d ++ "}"
+
+      showPleaseTicks d pleases = unlines (map (showPleaseTick d) pleases)
+
+      spaces d = take d (repeat ' ')
+
+  return $ "module " ++ show (fixPackageSuffix mod) ++ " {\n" ++
+         showPleaseTicks 2 non_ticked ++ "}"
+
+fixPackageSuffix :: String -> String
+fixPackageSuffix mod = case span (/= '/') mod of
+                         (before,'/':after) -> before ++ ":" ++ after
+                         _                  -> mod
+
+data PleaseTick
+   = TickFun [String] HpcPos
+   | TickExp HpcPos
+   | TickInside [String] HpcPos [PleaseTick]
+    deriving Show
+
+mkTickInside _ _ []        = id
+mkTickInside nm pos inside = (TickInside nm pos inside :)
+
+findNotTickedFromTree :: MixEntryDom [(BoxLabel,Bool)] -> [PleaseTick]
+findNotTickedFromTree (Node (pos,(ExpBox {},False):_) _) = [TickExp pos]
+findNotTickedFromTree (Node (pos,(TopLevelBox nm,False):_) _)
+  = [ TickFun nm pos ]
+findNotTickedFromTree (Node (pos,(LocalBox nm,False):_) _)
+  = [ TickFun nm pos ]
+findNotTickedFromTree (Node (pos,(TopLevelBox nm,True):others) children)
+  = mkTickInside nm pos (findNotTickedFromList children) []                           
+findNotTickedFromTree (Node (pos,_:others) children) = 
+                      findNotTickedFromTree (Node (pos,others) children)
+findNotTickedFromTree (Node (pos,[]) children) = findNotTickedFromList children
+
+findNotTickedFromList :: [MixEntryDom [(BoxLabel,Bool)]] -> [PleaseTick]
+findNotTickedFromList = concatMap findNotTickedFromTree
+
+readFileFromPath :: String -> [String] -> IO String
+readFileFromPath filename@('/':_) _ = readFile filename
+readFileFromPath filename path0 = readTheFile path0
+  where
+        readTheFile :: [String] -> IO String
+        readTheFile [] = error $ "could not find " ++ show filename 
+                                 ++ " in path " ++ show path0
+        readTheFile (dir:dirs) = 
+                catch (do str <- readFile (dir ++ "/" ++ filename) 
+                          return str) 
+                      (\ _ -> readTheFile dirs)

diff --git a/utils/hpc/HpcFlags.hs b/utils/hpc/HpcFlags.hs
index 38abe63..eb9a197 100644 (file)
--- a/utils/hpc/HpcFlags.hs
+++ b/utils/hpc/HpcFlags.hs
@@ -147,8 +147,8 @@ allowModule flags full_mod
   where
       -- pkg name always ends with '/', main 
          (pkg_name,mod_name) = 
-                       case span (/= ':') full_mod of
-                    (p,':':m) -> (p ++ ":",m)
+                       case span (/= '/') full_mod of
+                    (p,'/':m) -> (p ++ ":",m)
                     (m,[])    -> (":",m)
                     _         -> error "impossible case in allowModule" 
 
@@ -156,6 +156,8 @@ filterTix :: Flags -> Tix -> Tix
 filterTix flags (Tix tixs) =
      Tix $ filter (allowModule flags . tixModuleName) tixs
 
+         
+
 ------------------------------------------------------------------------------
 -- HpcCombine specifics 
 

diff --git a/utils/hpc/HpcShowTix.hs b/utils/hpc/HpcShowTix.hs
new file mode 100644 (file)
index 0000000..79c9fa3
--- /dev/null
+++ b/utils/hpc/HpcShowTix.hs
@@ -0,0 +1,60 @@
+module HpcShowTix (showtix_plugin) where
+
+import Trace.Hpc.Mix
+import Trace.Hpc.Tix
+import Trace.Hpc.Util
+
+import HpcFlags
+
+import qualified Data.Set as Set
+
+showtix_options = 
+  [ excludeOpt,includeOpt,hpcDirOpt
+  , outputOpt
+  ]
+
+showtix_plugin = Plugin { name = "show"
+                      , usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]" 
+                      , options = showtix_options 
+                      , summary = "Show .tix file in readable, verbose format"
+                      , implementation = showtix_main
+                      , init_flags = default_flags
+                      , final_flags = default_final_flags
+                      }
+
+
+
+showtix_main flags [] = hpcError showtix_plugin $ "no .tix file or executable name specified" 
+showtix_main flags (prog:modNames) = do
+  let hpcflags1 = flags 
+               { includeMods = Set.fromList modNames
+                                  `Set.union` 
+                               includeMods flags }
+
+  optTixs <- readTix (getTixFileName prog)
+  case optTixs of
+    Nothing -> hpcError showtix_plugin $ "could not read .tix file : "  ++ prog
+    Just (Tix tixs) -> do
+       let modules = map tixModuleName tixs       
+
+       mixs <- sequence
+               [ readMix (hpcDirs hpcflags1) modName            -- hard wired to .hpc for now
+               | modName <- modules
+              , allowModule hpcflags1 modName
+               ]
+     
+       let rjust n str = take (n - length str) (repeat ' ') ++ str 
+       let ljust n str = str ++ take (n - length str) (repeat ' ') 
+     
+       sequence_ [ sequence_ [ putStrLn (rjust 5 (show ix) ++ " " ++
+                                         rjust 10 (show count) ++ " " ++
+                                         ljust 20  modName ++ " " ++ rjust 20 (show pos) ++ " " ++ show lab)
+                             | (count,ix,(pos,lab)) <- zip3 tixs [(0::Int)..] entries
+                             ]
+                 | ( TixModule modName hash _ tixs
+                   , Mix _file _timestamp _hash _tab entries
+                   ) <- zip tixs mixs
+                 ]
+       
+       return ()
+     
\ No newline at end of file

diff --git a/utils/hpc/HpcUtils.hs b/utils/hpc/HpcUtils.hs
new file mode 100644 (file)
index 0000000..b679a37
--- /dev/null
+++ b/utils/hpc/HpcUtils.hs
@@ -0,0 +1,20 @@
+module HpcUtils where
+
+import Trace.Hpc.Util
+import qualified HpcMap as Map
+
+-- turns \n into ' '
+-- | grab's the text behind a HpcPos; 
+grabHpcPos :: Map.Map Int String -> HpcPos -> String
+grabHpcPos hsMap span = 
+         case lns of
+           [ln] -> (take ((c2 - c1) + 1) $ drop (c1 - 1) ln)
+           _ -> let lns1 = drop (c1 -1) (head lns) : tail lns
+                    lns2 = init lns1 ++ [take (c2 + 1) (last lns1) ]
+                 in foldl1 (\ xs ys -> xs ++ "\n" ++ ys) lns2
+  where (l1,c1,l2,c2) = fromHpcPos span
+        lns = map (\ n -> case Map.lookup n hsMap of
+                           Just ln -> ln
+                           Nothing -> error $ "bad line number : " ++ show n
+                  ) [l1..l2]
+