1{-# LANGUAGE FlexibleContexts #-} 2{-# LANGUAGE RankNTypes #-} 3 4----------------------------------------------------------------------------- 5-- | 6-- Module : Distribution.Simple.Hpc 7-- Copyright : Thomas Tuegel 2011 8-- License : BSD3 9-- 10-- Maintainer : cabal-devel@haskell.org 11-- Portability : portable 12-- 13-- This module provides functions for locating various HPC-related paths and 14-- a function for adding the necessary options to a PackageDescription to 15-- build test suites with HPC enabled. 16 17module Distribution.Simple.Hpc 18 ( Way(..), guessWay 19 , htmlDir 20 , mixDir 21 , tixDir 22 , tixFilePath 23 , markupPackage 24 , markupTest 25 ) where 26 27import Prelude () 28import Distribution.Compat.Prelude 29 30import Distribution.Types.UnqualComponentName 31import Distribution.ModuleName ( main ) 32import Distribution.PackageDescription 33 ( TestSuite(..) 34 , testModules 35 ) 36import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) 37import Distribution.Simple.Program 38 ( hpcProgram 39 , requireProgramVersion 40 ) 41import Distribution.Simple.Program.Hpc ( markup, union ) 42import Distribution.Simple.Utils ( notice ) 43import Distribution.Version ( anyVersion ) 44import Distribution.Verbosity ( Verbosity() ) 45import System.Directory ( createDirectoryIfMissing, doesFileExist ) 46import System.FilePath 47 48-- ------------------------------------------------------------------------- 49-- Haskell Program Coverage 50 51data Way = Vanilla | Prof | Dyn 52 deriving (Bounded, Enum, Eq, Read, Show) 53 54hpcDir :: FilePath -- ^ \"dist/\" prefix 55 -> Way 56 -> FilePath -- ^ Directory containing component's HPC .mix files 57hpcDir distPref way = distPref </> "hpc" </> wayDir 58 where 59 wayDir = case way of 60 Vanilla -> "vanilla" 61 Prof -> "prof" 62 Dyn -> "dyn" 63 64mixDir :: FilePath -- ^ \"dist/\" prefix 65 -> Way 66 -> FilePath -- ^ Component name 67 -> FilePath -- ^ Directory containing test suite's .mix files 68mixDir distPref way name = hpcDir distPref way </> "mix" </> name 69 70tixDir :: FilePath -- ^ \"dist/\" prefix 71 -> Way 72 -> FilePath -- ^ Component name 73 -> FilePath -- ^ Directory containing test suite's .tix files 74tixDir distPref way name = hpcDir distPref way </> "tix" </> name 75 76-- | Path to the .tix file containing a test suite's sum statistics. 77tixFilePath :: FilePath -- ^ \"dist/\" prefix 78 -> Way 79 -> FilePath -- ^ Component name 80 -> FilePath -- ^ Path to test suite's .tix file 81tixFilePath distPref way name = tixDir distPref way name </> name <.> "tix" 82 83htmlDir :: FilePath -- ^ \"dist/\" prefix 84 -> Way 85 -> FilePath -- ^ Component name 86 -> FilePath -- ^ Path to test suite's HTML markup directory 87htmlDir distPref way name = hpcDir distPref way </> "html" </> name 88 89-- | Attempt to guess the way the test suites in this package were compiled 90-- and linked with the library so the correct module interfaces are found. 91guessWay :: LocalBuildInfo -> Way 92guessWay lbi 93 | withProfExe lbi = Prof 94 | withDynExe lbi = Dyn 95 | otherwise = Vanilla 96 97-- | Generate the HTML markup for a test suite. 98markupTest :: Verbosity 99 -> LocalBuildInfo 100 -> FilePath -- ^ \"dist/\" prefix 101 -> String -- ^ Library name 102 -> TestSuite 103 -> IO () 104markupTest verbosity lbi distPref libName suite = do 105 tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName' 106 when tixFileExists $ do 107 -- behaviour of 'markup' depends on version, so we need *a* version 108 -- but no particular one 109 (hpc, hpcVer, _) <- requireProgramVersion verbosity 110 hpcProgram anyVersion (withPrograms lbi) 111 let htmlDir_ = htmlDir distPref way testName' 112 markup hpc hpcVer verbosity 113 (tixFilePath distPref way testName') mixDirs 114 htmlDir_ 115 (testModules suite ++ [ main ]) 116 notice verbosity $ "Test coverage report written to " 117 ++ htmlDir_ </> "hpc_index" <.> "html" 118 where 119 way = guessWay lbi 120 testName' = unUnqualComponentName $ testName suite 121 mixDirs = map (mixDir distPref way) [ testName', libName ] 122 123-- | Generate the HTML markup for all of a package's test suites. 124markupPackage :: Verbosity 125 -> LocalBuildInfo 126 -> FilePath -- ^ \"dist/\" prefix 127 -> String -- ^ Library name 128 -> [TestSuite] 129 -> IO () 130markupPackage verbosity lbi distPref libName suites = do 131 let tixFiles = map (tixFilePath distPref way) testNames 132 tixFilesExist <- traverse doesFileExist tixFiles 133 when (and tixFilesExist) $ do 134 -- behaviour of 'markup' depends on version, so we need *a* version 135 -- but no particular one 136 (hpc, hpcVer, _) <- requireProgramVersion verbosity 137 hpcProgram anyVersion (withPrograms lbi) 138 let outFile = tixFilePath distPref way libName 139 htmlDir' = htmlDir distPref way libName 140 excluded = concatMap testModules suites ++ [ main ] 141 createDirectoryIfMissing True $ takeDirectory outFile 142 union hpc verbosity tixFiles outFile excluded 143 markup hpc hpcVer verbosity outFile mixDirs htmlDir' excluded 144 notice verbosity $ "Package coverage report written to " 145 ++ htmlDir' </> "hpc_index.html" 146 where 147 way = guessWay lbi 148 testNames = fmap (unUnqualComponentName . testName) suites 149 mixDirs = map (mixDir distPref way) $ libName : testNames 150