    {-# LANGUAGE FlexibleContexts #-}
    {-# 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
        , markupPackage
        , markupTest
        ) where

    import Prelude ()
    import Distribution.Compat.Prelude

    import Distribution.Types.UnqualComponentName
    import Distribution.ModuleName ( main )
    import qualified Distribution.PackageDescription as PD
    import Distribution.PackageDescription
        ( Library(..)
        , TestSuite(..)
        , testModules
        )
    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.Version ( anyVersion )
    import Distribution.Verbosity ( Verbosity() )
    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  -- ^ Component name
           -> FilePath  -- ^ Directory containing test suite's .mix files
    mixDir :: String -> Way -> ShowS
    mixDir String
    distPref Way
    way String
    name = String -> Way -> String
    hpcDir String
    distPrefBuild Way
    way String -> ShowS
    </> String
    "mix" String -> ShowS
    </> String
    name
     where
      -- This is a hack for HPC over test suites, needed to match the directory
      -- where HPC saves and reads .mix files when the main library of the same
      -- package is being processed, perhaps in a previous cabal run (#5213).
      -- E.g., @distPref@ may be
      -- @./dist-newstyle/build/x86_64-linux/ghc-9.0.1/cabal-gh5213-0.1/t/tests@
      -- but the path where library mix files reside has two less components
      -- at the end (@t/tests@) and this reduced path needs to be passed to
      -- both @hpc@ and @ghc@. For non-default optimization levels, the path
      -- suffix is one element longer and the extra path element needs
      -- to be preserved.
      distPrefElements :: [String]
    distPrefElements = String -> [String]
    splitDirectories String
    distPref
      distPrefBuild :: String
    distPrefBuild = case Int -> [String] -> [String]
    forall a. Int -> [a] -> [a]
    drop ([String] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [String]
    distPrefElements Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    3) [String]
    distPrefElements of
        [String
    "t", String
    _, String
    "noopt"] ->
          [String] -> String
    joinPath ([String] -> String) -> [String] -> String
    forall a b. (a -> b) -> a -> b
    $ Int -> [String] -> [String]
    forall a. Int -> [a] -> [a]
    take ([String] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [String]
    distPrefElements Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    3) [String]
    distPrefElements
                     [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ [String
    "noopt"]
        [String
    "t", String
    _, String
    "opt"] ->
          [String] -> String
    joinPath ([String] -> String) -> [String] -> String
    forall a b. (a -> b) -> a -> b
    $ Int -> [String] -> [String]
    forall a. Int -> [a] -> [a]
    take ([String] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [String]
    distPrefElements Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    3) [String]
    distPrefElements
                     [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ [String
    "opt"]
        [String
    _, String
    "t", String
    _] ->
          [String] -> String
    joinPath ([String] -> String) -> [String] -> String
    forall a b. (a -> b) -> a -> b
    $ Int -> [String] -> [String]
    forall a. Int -> [a] -> [a]
    take ([String] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [String]
    distPrefElements Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    2) [String]
    distPrefElements
        [String]
    _ -> String
    distPref

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

    -- | 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 -> ShowS
    tixDir String
    distPref Way
    way String
    name String -> ShowS
    </> String
    name String -> ShowS
    <.> String
    "tix"

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

    -- | 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

    -- | Generate the HTML markup for a test suite.
    markupTest :: Verbosity
               -> LocalBuildInfo
               -> FilePath     -- ^ \"dist/\" prefix
               -> String       -- ^ Library name
               -> TestSuite
               -> Library
               -> IO ()
    markupTest :: Verbosity
    -> LocalBuildInfo
    -> String
    -> String
    -> TestSuite
    -> Library
    -> IO ()
    markupTest Verbosity
    verbosity LocalBuildInfo
    lbi String
    distPref String
    libraryName TestSuite
    suite Library
    library = do
        Bool
    tixFileExists <- String -> IO Bool
    doesFileExist (String -> IO Bool) -> String -> IO Bool
    forall a b. (a -> b) -> a -> b
    $ String -> Way -> ShowS
    tixFilePath String
    distPref Way
    way ShowS -> ShowS
    forall a b. (a -> b) -> a -> b
    $ String
    testName'
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when Bool
    tixFileExists (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
            -- behaviour of 'markup' depends on version, so we need *a* version
            -- but no particular one
            (ConfiguredProgram
    hpc, Version
    hpcVer, ProgramDb
    _) <- Verbosity
    -> Program
    -> VersionRange
    -> ProgramDb
    -> IO (ConfiguredProgram, Version, ProgramDb)
    requireProgramVersion Verbosity
    verbosity
                Program
    hpcProgram VersionRange
    anyVersion (LocalBuildInfo -> ProgramDb
    withPrograms LocalBuildInfo
    lbi)
            let htmlDir_ :: String
    htmlDir_ = String -> Way -> ShowS
    htmlDir String
    distPref Way
    way String
    testName'
            ConfiguredProgram
    -> Version
    -> Verbosity
    -> String
    -> [String]
    -> String
    -> [ModuleName]
    -> IO ()
    markup ConfiguredProgram
    hpc Version
    hpcVer Verbosity
    verbosity
                (String -> Way -> ShowS
    tixFilePath String
    distPref Way
    way String
    testName') [String]
    mixDirs
                String
    htmlDir_
                (Library -> [ModuleName]
    exposedModules Library
    library)
            Verbosity -> String -> IO ()
    notice Verbosity
    verbosity (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ String
    "Test coverage report written to "
                                String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    htmlDir_ String -> ShowS
    </> String
    "hpc_index" String -> ShowS
    <.> String
    "html"
      where
        way :: Way
    way = LocalBuildInfo -> Way
    guessWay LocalBuildInfo
    lbi
        testName' :: String
    testName' = UnqualComponentName -> String
    unUnqualComponentName (UnqualComponentName -> String) -> UnqualComponentName -> String
    forall a b. (a -> b) -> a -> b
    $ TestSuite -> UnqualComponentName
    testName TestSuite
    suite
        mixDirs :: [String]
    mixDirs = ShowS -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (String -> Way -> ShowS
    mixDir String
    distPref Way
    way) [ String
    testName', String
    libraryName ]

    -- | Generate the HTML markup for all of a package's test suites.
    markupPackage :: Verbosity
                  -> LocalBuildInfo
                  -> FilePath       -- ^ \"dist/\" prefix
                  -> PD.PackageDescription
                  -> [TestSuite]
                  -> IO ()
    markupPackage :: Verbosity
    -> LocalBuildInfo
    -> String
    -> PackageDescription
    -> [TestSuite]
    -> IO ()
    markupPackage Verbosity
    verbosity LocalBuildInfo
    lbi String
    distPref 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
    distPref Way
    way) [String]
    testNames
        [Bool]
    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
        Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when ([Bool] -> Bool
    forall (t :: * -> *). Foldable t => t Bool -> Bool
    and [Bool]
    tixFilesExist) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $ do
            -- behaviour of 'markup' depends on version, so we need *a* version
            -- but no particular one
            (ConfiguredProgram
    hpc, Version
    hpcVer, ProgramDb
    _) <- Verbosity
    -> Program
    -> VersionRange
    -> ProgramDb
    -> IO (ConfiguredProgram, Version, ProgramDb)
    requireProgramVersion Verbosity
    verbosity
                Program
    hpcProgram VersionRange
    anyVersion (LocalBuildInfo -> ProgramDb
    withPrograms LocalBuildInfo
    lbi)
            let outFile :: String
    outFile = String -> Way -> ShowS
    tixFilePath String
    distPref Way
    way String
    libraryName
                htmlDir' :: String
    htmlDir' = String -> Way -> ShowS
    htmlDir String
    distPref Way
    way String
    libraryName
                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 ]
            Bool -> String -> IO ()
    createDirectoryIfMissing Bool
    True (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ ShowS
    takeDirectory String
    outFile
            ConfiguredProgram
    -> Verbosity -> [String] -> String -> [ModuleName] -> IO ()
    union ConfiguredProgram
    hpc Verbosity
    verbosity [String]
    tixFiles String
    outFile [ModuleName]
    excluded
            ConfiguredProgram
    -> Version
    -> Verbosity
    -> String
    -> [String]
    -> String
    -> [ModuleName]
    -> IO ()
    markup ConfiguredProgram
    hpc Version
    hpcVer Verbosity
    verbosity String
    outFile [String]
    mixDirs String
    htmlDir' [ModuleName]
    included
            Verbosity -> String -> IO ()
    notice Verbosity
    verbosity (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ String
    "Package coverage report written to "
                               String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    htmlDir' String -> ShowS
    </> String
    "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 -> ShowS
    mixDir String
    distPref Way
    way) ([String] -> [String]) -> [String] -> [String]
    forall a b. (a -> b) -> a -> b
    $ String
    libraryName String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    : [String]
    testNames
        included :: [ModuleName]
    included = (Library -> [ModuleName]) -> [Library] -> [ModuleName]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (Library -> [ModuleName]
    exposedModules) ([Library] -> [ModuleName]) -> [Library] -> [ModuleName]
    forall a b. (a -> b) -> a -> b
    $ PackageDescription -> [Library]
    PD.allLibraries PackageDescription
    pkg_descr
        libraryName :: String
    libraryName = 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