import Trace.Hpc.Util
import HpcFlags
+import HpcUtils
import System.Environment
+import System.Directory
import Data.List
import Data.Maybe(fromJust)
import Data.Array
-import qualified Data.Set as Set
+import Data.Monoid
+import qualified HpcSet as Set
------------------------------------------------------------------------------
-markup_options =
- [ excludeOpt,includeOpt,hpcDirOpt,hsDirOpt,funTotalsOpt
- , altHighlightOpt
- , destDirOpt
- ]
+markup_options
+ = excludeOpt
+ . includeOpt
+ . srcDirOpt
+ . hpcDirOpt
+ . funTotalsOpt
+ . altHighlightOpt
+ . destDirOpt
markup_plugin = Plugin { name = "markup"
, usage = "[OPTION] .. <TIX_FILE> [<MODULE> [<MODULE> ..]]"
`Set.union`
includeMods flags }
let Flags
- { hpcDirs = hpcDirs
- , hsDirs = theHsPath
- , funTotals = theFunTotals
+ { funTotals = theFunTotals
, altHighlight = invertOutput
, destDir = dest_dir
} = hpcflags1
mtix <- readTix (getTixFileName prog)
Tix tixs <- case mtix of
- Nothing -> error $ "unable to find tix file for: " ++ prog
+ Nothing -> hpcError markup_plugin $ "unable to find tix file for: " ++ prog
Just a -> return a
+#if __GLASGOW_HASKELL__ >= 604
+ -- create the dest_dir if needed
+ createDirectoryIfMissing True dest_dir
+#endif
+
mods <-
- sequence [ genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput
+ sequence [ genHtmlFromMod dest_dir hpcflags1 tix theFunTotals invertOutput
| tix <- tixs
, allowModule hpcflags1 (tixModuleName tix)
]
let writeSummary name cmp = do
let mods' = sortBy cmp mods
+
+
+
putStrLn $ "Writing: " ++ (name ++ ".html")
writeFile (dest_dir ++ "/" ++ name ++ ".html") $
"<style type=\"text/css\">" ++
"table.bar { background-color: #f25913; }\n" ++
"td.bar { background-color: #60de51; }\n" ++
+ "td.invbar { background-color: #f25913; }\n" ++
"table.dashboard { border-collapse: collapse ; border: solid 1px black }\n" ++
".dashboard td { border: solid 1px black }\n" ++
".dashboard th { border: solid 1px black }\n" ++
| (modName,fileName,summary) <- mods'
] ++
"<tr></tr>" ++
- showTotalSummary (foldr1 combineSummary
+ showTotalSummary (mconcat
[ summary
| (_,_,summary) <- mods'
])
(percent (expTicked s1) (expTotal s1))
-markup_main flags [] = error $ "no .tix file or executable name specified"
+markup_main flags [] = hpcError markup_plugin $ "no .tix file or executable name specified"
genHtmlFromMod
:: String
- -> [FilePath]
+ -> Flags
-> TixModule
-> Bool
- -> [String]
-> Bool
-> IO (String, [Char], ModuleSummary)
-genHtmlFromMod dest_dir hpcDirs tix theFunTotals theHsPath invertOutput = do
+genHtmlFromMod dest_dir flags tix theFunTotals invertOutput = do
+ let theHsPath = srcDirs flags
let modName0 = tixModuleName tix
- (Mix origFile _ mixHash tabStop mix') <- readMix hpcDirs modName0
+ (Mix origFile _ mixHash tabStop mix') <- readMixWithFlags flags (Right tix)
let arr_tix :: Array Int Integer
arr_tix = listArray (0,length (tixModuleTixs tix) - 1)
, let ticked = if isTicked gid
then succ
else id
- ] $ ModuleSummary
- { expTicked = 0
- , expTotal = 0
- , topFunTicked = 0
- , topFunTotal = 0
- , altTicked = 0
- , altTotal = 0
- }
+ ] $ mempty
-- add prefix to modName argument
- content <- readFileFromPath origFile theHsPath
+ content <- readFileFromPath (hpcError markup_plugin) origFile theHsPath
let content' = markup tabStop info content
let show' = reverse . take 5 . (++ " ") . reverse . show
"<td width=100>" ++
(case percent ticked total of
Nothing -> " "
- Just w -> "<table cellpadding=0 cellspacing=0 width=\"100\" class=\"bar\">" ++
- "<tr><td><table cellpadding=0 cellspacing=0 width=\"" ++ show w ++ "%\">" ++
- "<tr><td height=12 class=\"bar\"></td></tr>" ++
- "</table></td></tr></table>")
- ++ "</td>"
+ Just w -> bar w "bar"
+ ) ++ "</td>"
where
showP Nothing = "- "
showP (Just x) = show x ++ "%"
+ bar 0 inner = bar 100 "invbar"
+ bar w inner = "<table cellpadding=0 cellspacing=0 width=\"100\" class=\"bar\">" ++
+ "<tr><td><table cellpadding=0 cellspacing=0 width=\"" ++ show w ++ "%\">" ++
+ "<tr><td height=12 class=" ++ show inner ++ "></td></tr>" ++
+ "</table></td></tr></table>"
percent :: (Integral a) => a -> a -> Maybe a
percent ticked total = if total == 0 then Nothing else Just (ticked * 100 `div` total)
-combineSummary :: ModuleSummary -> ModuleSummary -> ModuleSummary
-combineSummary (ModuleSummary eTik1 eTot1 tTik1 tTot1 aTik1 aTot1)
- (ModuleSummary eTik2 eTot2 tTik2 tTot2 aTik2 aTot2)
- = ModuleSummary (eTik1 + eTik2) (eTot1 + eTot2) (tTik1 + tTik2) (tTot1 + tTot2) (aTik1 + aTik2) (aTot1 + aTot2)
+instance Monoid ModuleSummary where
+ mempty = ModuleSummary
+ { expTicked = 0
+ , expTotal = 0
+ , topFunTicked = 0
+ , topFunTotal = 0
+ , altTicked = 0
+ , altTotal = 0
+ }
+ mappend (ModuleSummary eTik1 eTot1 tTik1 tTot1 aTik1 aTot1)
+ (ModuleSummary eTik2 eTot2 tTik2 tTot2 aTik2 aTot2)
+ = ModuleSummary (eTik1 + eTik2) (eTot1 + eTot2) (tTik1 + tTik2) (tTot1 + tTot2) (aTik1 + aTik2) (aTot1 + aTot2)
+
------------------------------------------------------------------------------
-- global color pallete
green = "#60de51"
yellow = "yellow"
-------------------------------------------------------------------------------
-
-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)