{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

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

-- |
-- Module      :  Distribution.Simple.Program.Hpc
-- Copyright   :  Thomas Tuegel 2011
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This module provides an library interface to the @hpc@ program.
module Distribution.Simple.Program.Hpc
  ( markup
  , union
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.ModuleName
import Distribution.Pretty
import Distribution.Simple.Program.Run
import Distribution.Simple.Program.Types
import Distribution.Simple.Utils
import Distribution.Utils.Path
import Distribution.Verbosity
import Distribution.Version

-- | Invoke hpc with the given parameters.
--
-- Prior to HPC version 0.7 (packaged with GHC 7.8), hpc did not handle
-- multiple .mix paths correctly, so we print a warning, and only pass it the
-- first path in the list. This means that e.g. test suites that import their
-- library as a dependency can still work, but those that include the library
-- modules directly (in other-modules) don't.
markup
  :: Maybe (SymbolicPath CWD (Dir Pkg))
  -> ConfiguredProgram
  -> Version
  -> Verbosity
  -> SymbolicPath Pkg File
  -- ^ Path to .tix file
  -> [SymbolicPath Pkg (Dir Mix)]
  -- ^ Paths to .mix file directories
  -> SymbolicPath Pkg (Dir Artifacts)
  -- ^ Path where html output should be located
  -> [ModuleName]
  -- ^ List of modules to include in the report
  -> IO ()
markup :: Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram
-> Version
-> Verbosity
-> SymbolicPath Pkg 'File
-> [SymbolicPath Pkg ('Dir Mix)]
-> SymbolicPath Pkg ('Dir Artifacts)
-> [ModuleName]
-> IO ()
markup Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
hpc Version
hpcVer Verbosity
verbosity SymbolicPath Pkg 'File
tixFile [SymbolicPath Pkg ('Dir Mix)]
hpcDirs SymbolicPath Pkg ('Dir Artifacts)
destDir [ModuleName]
included = do
  [SymbolicPath Pkg ('Dir Mix)]
hpcDirs' <-
    if Version -> VersionRange -> Bool
withinRange Version
hpcVer (Version -> VersionRange
orLaterVersion Version
version07)
      then [SymbolicPath Pkg ('Dir Mix)] -> IO [SymbolicPath Pkg ('Dir Mix)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [SymbolicPath Pkg ('Dir Mix)]
hpcDirs
      else do
        Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
          String
"Your version of HPC ("
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
prettyShow Version
hpcVer
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") does not properly handle multiple search paths. "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Coverage report generation may fail unexpectedly. These "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"issues are addressed in version 0.7 or later (GHC 7.8 or "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"later)."
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ if [SymbolicPath Pkg ('Dir Mix)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SymbolicPath Pkg ('Dir Mix)]
droppedDirs
              then String
""
              else
                String
" The following search paths have been abandoned: "
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ [SymbolicPath Pkg ('Dir Mix)] -> String
forall a. Show a => a -> String
show [SymbolicPath Pkg ('Dir Mix)]
droppedDirs
        [SymbolicPath Pkg ('Dir Mix)] -> IO [SymbolicPath Pkg ('Dir Mix)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [SymbolicPath Pkg ('Dir Mix)]
passedDirs

  -- Prior to GHC 8.0, hpc assumes all .mix paths are relative.
  [SymbolicPath Pkg ('Dir Mix)]
hpcDirs'' <- (SymbolicPath Pkg ('Dir Mix) -> IO (SymbolicPath Pkg ('Dir Mix)))
-> [SymbolicPath Pkg ('Dir Mix)]
-> IO [SymbolicPath Pkg ('Dir Mix)]
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 (Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Mix) -> IO (SymbolicPath Pkg ('Dir Mix))
forall dir (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir dir))
-> SymbolicPath dir to -> IO (SymbolicPath dir to)
tryMakeRelative Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir) [SymbolicPath Pkg ('Dir Mix)]
hpcDirs'

  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation
    Verbosity
verbosity
    (Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram
-> SymbolicPath Pkg 'File
-> [SymbolicPath Pkg ('Dir Mix)]
-> SymbolicPath Pkg ('Dir Artifacts)
-> [ModuleName]
-> ProgramInvocation
markupInvocation Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
hpc SymbolicPath Pkg 'File
tixFile [SymbolicPath Pkg ('Dir Mix)]
hpcDirs'' SymbolicPath Pkg ('Dir Artifacts)
destDir [ModuleName]
included)
  where
    version07 :: Version
version07 = [Int] -> Version
mkVersion [Int
0, Int
7]
    ([SymbolicPath Pkg ('Dir Mix)]
passedDirs, [SymbolicPath Pkg ('Dir Mix)]
droppedDirs) = Int
-> [SymbolicPath Pkg ('Dir Mix)]
-> ([SymbolicPath Pkg ('Dir Mix)], [SymbolicPath Pkg ('Dir Mix)])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
1 [SymbolicPath Pkg ('Dir Mix)]
hpcDirs

markupInvocation
  :: Maybe (SymbolicPath CWD (Dir Pkg))
  -> ConfiguredProgram
  -> SymbolicPath Pkg File
  -- ^ Path to .tix file
  -> [SymbolicPath Pkg (Dir Mix)]
  -- ^ Paths to .mix file directories
  -> SymbolicPath Pkg (Dir Artifacts)
  -- ^ Path where html output should be
  -- located
  -> [ModuleName]
  -- ^ List of modules to include
  -> ProgramInvocation
markupInvocation :: Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram
-> SymbolicPath Pkg 'File
-> [SymbolicPath Pkg ('Dir Mix)]
-> SymbolicPath Pkg ('Dir Artifacts)
-> [ModuleName]
-> ProgramInvocation
markupInvocation Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
hpc SymbolicPath Pkg 'File
tixFile [SymbolicPath Pkg ('Dir Mix)]
hpcDirs SymbolicPath Pkg ('Dir Artifacts)
destDir [ModuleName]
included =
  let args :: [String]
args =
        [ String
"markup"
        , SymbolicPath Pkg 'File -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPath Pkg 'File
tixFile
        , String
"--destdir=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SymbolicPath Pkg ('Dir Artifacts) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPath Pkg ('Dir Artifacts)
destDir
        ]
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (SymbolicPath Pkg ('Dir Mix) -> String)
-> [SymbolicPath Pkg ('Dir Mix)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"--hpcdir=" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (SymbolicPath Pkg ('Dir Mix) -> String)
-> SymbolicPath Pkg ('Dir Mix)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPath Pkg ('Dir Mix) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath) [SymbolicPath Pkg ('Dir Mix)]
hpcDirs
          [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"--include=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
forall a. Pretty a => a -> String
prettyShow ModuleName
moduleName
             | ModuleName
moduleName <- [ModuleName]
included
             ]
   in Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram -> [String] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [String] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
hpc [String]
args

union
  :: Maybe (SymbolicPath CWD (Dir Pkg))
  -> ConfiguredProgram
  -> Verbosity
  -> [SymbolicPath Pkg File]
  -- ^ Paths to .tix files
  -> SymbolicPath Pkg File
  -- ^ Path to resultant .tix file
  -> [ModuleName]
  -- ^ List of modules to exclude from union
  -> IO ()
union :: Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram
-> Verbosity
-> [SymbolicPath Pkg 'File]
-> SymbolicPath Pkg 'File
-> [ModuleName]
-> IO ()
union Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
hpc Verbosity
verbosity [SymbolicPath Pkg 'File]
tixFiles SymbolicPath Pkg 'File
outFile [ModuleName]
excluded =
  Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation
    Verbosity
verbosity
    (Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram
-> [SymbolicPath Pkg 'File]
-> SymbolicPath Pkg 'File
-> [ModuleName]
-> ProgramInvocation
unionInvocation Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
hpc [SymbolicPath Pkg 'File]
tixFiles SymbolicPath Pkg 'File
outFile [ModuleName]
excluded)

unionInvocation
  :: Maybe (SymbolicPath CWD (Dir Pkg))
  -> ConfiguredProgram
  -> [SymbolicPath Pkg File]
  -- ^ Paths to .tix files
  -> SymbolicPath Pkg File
  -- ^ Path to resultant .tix file
  -> [ModuleName]
  -- ^ List of modules to exclude from union
  -> ProgramInvocation
unionInvocation :: Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram
-> [SymbolicPath Pkg 'File]
-> SymbolicPath Pkg 'File
-> [ModuleName]
-> ProgramInvocation
unionInvocation Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
hpc [SymbolicPath Pkg 'File]
tixFiles SymbolicPath Pkg 'File
outFile [ModuleName]
excluded =
  Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram -> [String] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [String] -> ProgramInvocation
programInvocationCwd Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ConfiguredProgram
hpc ([String] -> ProgramInvocation) -> [String] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$
    [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [String
"sum", String
"--union"]
      , (SymbolicPath Pkg 'File -> String)
-> [SymbolicPath Pkg 'File] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath Pkg 'File -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath [SymbolicPath Pkg 'File]
tixFiles
      , [String
"--output=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SymbolicPath Pkg 'File -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPath Pkg 'File
outFile]
      , [ String
"--exclude=" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
forall a. Pretty a => a -> String
prettyShow ModuleName
moduleName
        | ModuleName
moduleName <- [ModuleName]
excluded
        ]
      ]