    {-# LANGUAGE FlexibleContexts #-}
    {-# LANGUAGE NamedFieldPuns #-}
    {-# LANGUAGE RankNTypes #-}

    -----------------------------------------------------------------------------

    -- |
    -- Module      :  Distribution.Simple.Hpc
    -- Copyright   :  Thomas Tuegel 2011
    -- License     :  BSD3
    --
    -- Maintainer  :  cabal-devel@haskell.org
    -- Portability :  portable
    --
    -- This module provides functions for locating various HPC-related paths and
    -- a function for adding the necessary options to a PackageDescription to
    -- build test suites with HPC enabled.
    module Distribution.Simple.Hpc
      ( Way (..)
      , guessWay
      , htmlDir
      , mixDir
      , tixDir
      , tixFilePath
      , HPCMarkupInfo (..)
      , markupPackage
      ) where

    import Distribution.Compat.Prelude
    import Prelude ()

    import Distribution.ModuleName (ModuleName, main)
    import Distribution.PackageDescription
      ( TestSuite (..)
      , testModules
      )
    import qualified Distribution.PackageDescription as PD
    import Distribution.Pretty
    import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..))
    import Distribution.Simple.Program
      ( hpcProgram
      , requireProgramVersion
      )
    import Distribution.Simple.Program.Hpc (markup, union)
    import Distribution.Simple.Utils (notice)
    import Distribution.Types.UnqualComponentName
    import Distribution.Verbosity (Verbosity ())
    import Distribution.Version (anyVersion)
    import System.Directory (createDirectoryIfMissing, doesFileExist)
    import System.FilePath

    -- -------------------------------------------------------------------------
    -- Haskell Program Coverage

    data Way = Vanilla | Prof | Dyn
      deriving (Way
    Way -> Way -> Bounded Way
    forall a. a -> a -> Bounded a
    $cminBound :: Way
    minBound :: Way
    $cmaxBound :: Way
    maxBound :: Way
    Bounded, Int -> Way
    Way -> Int
    Way -> [Way]
    Way -> Way
    Way -> Way -> [Way]
    Way -> Way -> Way -> [Way]
    (Way -> Way)
    -> (Way -> Way)
    -> (Int -> Way)
    -> (Way -> Int)
    -> (Way -> [Way])
    -> (Way -> Way -> [Way])
    -> (Way -> Way -> [Way])
    -> (Way -> Way -> Way -> [Way])
    -> Enum Way
    forall a.
    (a -> a)
    -> (a -> a)
    -> (Int -> a)
    -> (a -> Int)
    -> (a -> [a])
    -> (a -> a -> [a])
    -> (a -> a -> [a])
    -> (a -> a -> a -> [a])
    -> Enum a
    $csucc :: Way -> Way
    succ :: Way -> Way
    $cpred :: Way -> Way
    pred :: Way -> Way
    $ctoEnum :: Int -> Way
    toEnum :: Int -> Way
    $cfromEnum :: Way -> Int
    fromEnum :: Way -> Int
    $cenumFrom :: Way -> [Way]
    enumFrom :: Way -> [Way]
    $cenumFromThen :: Way -> Way -> [Way]
    enumFromThen :: Way -> Way -> [Way]
    $cenumFromTo :: Way -> Way -> [Way]
    enumFromTo :: Way -> Way -> [Way]
    $cenumFromThenTo :: Way -> Way -> Way -> [Way]
    enumFromThenTo :: Way -> Way -> Way -> [Way]
    Enum, Way -> Way -> Bool
    (Way -> Way -> Bool) -> (Way -> Way -> Bool) -> Eq Way
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Way -> Way -> Bool
    == :: Way -> Way -> Bool
    $c/= :: Way -> Way -> Bool
    /= :: Way -> Way -> Bool
    Eq, ReadPrec [Way]
    ReadPrec Way
    Int -> ReadS Way
    ReadS [Way]
    (Int -> ReadS Way)
    -> ReadS [Way] -> ReadPrec Way -> ReadPrec [Way] -> Read Way
    forall a.
    (Int -> ReadS a)
    -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
    $creadsPrec :: Int -> ReadS Way
    readsPrec :: Int -> ReadS Way
    $creadList :: ReadS [Way]
    readList :: ReadS [Way]
    $creadPrec :: ReadPrec Way
    readPrec :: ReadPrec Way
    $creadListPrec :: ReadPrec [Way]
    readListPrec :: ReadPrec [Way]
    Read, Int -> Way -> ShowS
    [Way] -> ShowS
    Way -> String
    (Int -> Way -> ShowS)
    -> (Way -> String) -> ([Way] -> ShowS) -> Show Way
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Way -> ShowS
    showsPrec :: Int -> Way -> ShowS
    $cshow :: Way -> String
    show :: Way -> String
    $cshowList :: [Way] -> ShowS
    showList :: [Way] -> ShowS
    Show)

    hpcDir
      :: FilePath
      -- ^ \"dist/\" prefix
      -> Way
      -> FilePath
      -- ^ Directory containing component's HPC .mix files
    hpcDir :: String -> Way -> String
    hpcDir String
    distPref Way
    way = String
    distPref String -> ShowS
    </> String
    "hpc" String -> ShowS
    </> String
    wayDir
      where
        wayDir :: String
    wayDir = case Way
    way of
          Way
    Vanilla -> String
    "vanilla"
          Way
    Prof -> String
    "prof"
          Way
    Dyn -> String
    "dyn"

    mixDir
      :: FilePath
      -- ^ \"dist/\" prefix
      -> Way
      -> FilePath
      -- ^ Directory containing test suite's .mix files
    mixDir :: String -> Way -> String
    mixDir String
    distPref Way
    way = String -> Way -> String
    hpcDir String
    distPref Way
    way String -> ShowS
    </> String
    "mix"

    tixDir
      :: FilePath
      -- ^ \"dist/\" prefix
      -> Way
      -> FilePath
      -- ^ Directory containing test suite's .tix files
    tixDir :: String -> Way -> String
    tixDir String
    distPref Way
    way = String -> Way -> String
    hpcDir String
    distPref Way
    way String -> ShowS
    </> String
    "tix"

    -- | Path to the .tix file containing a test suite's sum statistics.
    tixFilePath
      :: FilePath
      -- ^ \"dist/\" prefix
      -> Way
      -> FilePath
      -- ^ Component name
      -> FilePath
      -- ^ Path to test suite's .tix file
    tixFilePath :: String -> Way -> ShowS
    tixFilePath String
    distPref Way
    way String
    name = String -> Way -> String
    tixDir String
    distPref Way
    way String -> ShowS
    </> String
    name String -> ShowS
    <.> String
    "tix"

    htmlDir
      :: FilePath
      -- ^ \"dist/\" prefix
      -> Way
      -> FilePath
      -- ^ Path to test suite's HTML markup directory
    htmlDir :: String -> Way -> String
    htmlDir String
    distPref Way
    way = String -> Way -> String
    hpcDir String
    distPref Way
    way String -> ShowS
    </> String
    "html"

    -- | Attempt to guess the way the test suites in this package were compiled
    -- and linked with the library so the correct module interfaces are found.
    guessWay :: LocalBuildInfo -> Way
    guessWay :: LocalBuildInfo -> Way
    guessWay LocalBuildInfo
    lbi
      | LocalBuildInfo -> Bool
    withProfExe LocalBuildInfo
    lbi = Way
    Prof
      | LocalBuildInfo -> Bool
    withDynExe LocalBuildInfo
    lbi = Way
    Dyn
      | Bool
    otherwise = Way
    Vanilla

    -- | Haskell Program Coverage information required to produce a valid HPC
    -- report through the `hpc markup` call for the package libraries.
    data HPCMarkupInfo = HPCMarkupInfo
      { HPCMarkupInfo -> [String]
    pathsToLibsArtifacts :: [FilePath]
      -- ^ The paths to the library components whose modules are included in the
      -- coverage report
      , HPCMarkupInfo -> [ModuleName]
    libsModulesToInclude :: [ModuleName]
      -- ^ The modules to include in the coverage report
      }

    -- | Generate the HTML markup for a package's test suites.
    markupPackage
      :: Verbosity
      -> HPCMarkupInfo
      -> LocalBuildInfo
      -> FilePath
      -- ^ Testsuite \"dist/\" prefix
      -> PD.PackageDescription
      -> [TestSuite]
      -> IO ()
    markupPackage :: Verbosity
    -> HPCMarkupInfo
    -> LocalBuildInfo
    -> String
    -> PackageDescription
    -> [TestSuite]
    -> IO ()
    markupPackage Verbosity
    verbosity HPCMarkupInfo{[String]
    pathsToLibsArtifacts :: HPCMarkupInfo -> [String]
    pathsToLibsArtifacts :: [String]
    pathsToLibsArtifacts, [ModuleName]
    libsModulesToInclude :: HPCMarkupInfo -> [ModuleName]
    libsModulesToInclude :: [ModuleName]
    libsModulesToInclude} LocalBuildInfo
    lbi String
    testDistPref PackageDescription
    pkg_descr [TestSuite]
    suites = do
      let tixFiles :: [String]
    tixFiles = ShowS -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (String -> Way -> ShowS
    tixFilePath String
    testDistPref Way
    way) [String]
    testNames
      tixFilesExist <- (String -> IO Bool) -> [String] -> IO [Bool]
    forall (t :: * -> *) (f :: * -> *) a b.
    (Traversable t, Applicative f) =>
    (a -> f b) -> t a -> f (t b)
    forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> [a] -> f [b]
    traverse String -> IO Bool
    doesFileExist [String]
    tixFiles
      when (and tixFilesExist) $ do
        -- behaviour of 'markup' depends on version, so we need *a* version
        -- but no particular one
        (hpc, hpcVer, _) <-
          requireProgramVersion
            verbosity
            hpcProgram
            anyVersion
            (withPrograms lbi)
        let htmlDir' = String -> Way -> String
    htmlDir String
    testDistPref Way
    way
        -- The tix file used to generate the report is either the testsuite's
        -- tix file, when there is only one testsuite, or the sum of the tix
        -- files of all testsuites in the package, which gets put under pkgName
        -- for this component (a bit weird)
        -- TODO: cabal-install should pass to Cabal where to put the summed tix
        -- and report, and perhaps even the testsuites from other packages in
        -- the project which are currently not accounted for in the summed
        -- report.
        tixFile <- case suites of
          -- We call 'markupPackage' once for each testsuite to run individually,
          -- to get the coverage report of just the one testsuite
          [TestSuite
    oneTest] -> do
            let testName' :: String
    testName' = UnqualComponentName -> String
    unUnqualComponentName (UnqualComponentName -> String) -> UnqualComponentName -> String
    forall a b. (a -> b) -> a -> b
    $ TestSuite -> UnqualComponentName
    testName TestSuite
    oneTest
            String -> IO String
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> IO String) -> String -> IO String
    forall a b. (a -> b) -> a -> b
    $
              String -> Way -> ShowS
    tixFilePath String
    testDistPref Way
    way String
    testName'
          -- And call 'markupPackage' once per `test` invocation with all the
          -- testsuites to run, which results in multiple tix files being considered
          [TestSuite]
    _ -> do
            let excluded :: [ModuleName]
    excluded = (TestSuite -> [ModuleName]) -> [TestSuite] -> [ModuleName]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap TestSuite -> [ModuleName]
    testModules [TestSuite]
    suites [ModuleName] -> [ModuleName] -> [ModuleName]
    forall a. [a] -> [a] -> [a]
    ++ [ModuleName
    main]
                pkgName :: String
    pkgName = PackageIdentifier -> String
    forall a. Pretty a => a -> String
    prettyShow (PackageIdentifier -> String) -> PackageIdentifier -> String
    forall a b. (a -> b) -> a -> b
    $ PackageDescription -> PackageIdentifier
    PD.package PackageDescription
    pkg_descr
                summedTixFile :: String
    summedTixFile = String -> Way -> ShowS
    tixFilePath String
    testDistPref Way
    way String
    pkgName
            Bool -> String -> IO ()
    createDirectoryIfMissing Bool
    True (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ ShowS
    takeDirectory String
    summedTixFile
            ConfiguredProgram
    -> Verbosity -> [String] -> String -> [ModuleName] -> IO ()
    union ConfiguredProgram
    hpc Verbosity
    verbosity [String]
    tixFiles String
    summedTixFile [ModuleName]
    excluded
            String -> IO String
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    summedTixFile

        markup hpc hpcVer verbosity tixFile mixDirs htmlDir' libsModulesToInclude
        notice verbosity $
          "Package coverage report written to "
            ++ htmlDir'
            </> "hpc_index.html"
      where
        way :: Way
    way = LocalBuildInfo -> Way
    guessWay LocalBuildInfo
    lbi
        testNames :: [String]
    testNames = (TestSuite -> String) -> [TestSuite] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (UnqualComponentName -> String
    unUnqualComponentName (UnqualComponentName -> String)
    -> (TestSuite -> UnqualComponentName) -> TestSuite -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TestSuite -> UnqualComponentName
    testName) [TestSuite]
    suites
        mixDirs :: [String]
    mixDirs = ShowS -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (String -> Way -> String
    `mixDir` Way
    way) [String]
    pathsToLibsArtifacts