-- |
{-# LANGUAGE CPP #-}
-- Module:     Trace.Hpc.Codecov.Report.Entry
-- Copyright:  (c) 2023 8c6794b6
-- License:    BSD3
-- Maintainer: 8c6794b6 <[email protected]>
--
-- Codes for converting tix and mix files to 'CoverageEntry'.

module Trace.Hpc.Codecov.Report.Entry
  ( Report(..)
  , CoverageEntry(..)
  , Format(..)
  , LineHits
  , Hit(..)
  , FunctionHits
  , BranchHits
  , tixToCoverage
  , readTixFile
  ) where

-- base
import           Control.Applicative         ((<|>))
import           Control.Exception           (ErrorCall, handle, throw,
                                              throwIO)
import           Control.Monad               (when)
import           Control.Monad.ST            (ST)
import           Data.Function               (on)
import           Data.List                   (intercalate)
import           System.IO                   (hPutStrLn, stderr)

#if !MIN_VERSION_base(4,20,0)
import           Data.List                   (foldl')
#endif

-- array
import           Data.Array.Base             (unsafeAt)
import           Data.Array.IArray           (assocs, listArray)
import           Data.Array.MArray           (newArray, readArray,
                                              writeArray)
import           Data.Array.ST               (STArray, runSTArray)
import           Data.Array.Unboxed          (UArray)

-- containers
import qualified Data.IntMap                 as IntMap

-- directory
import           System.Directory            (doesFileExist)

-- filepath
import           System.FilePath             ((<.>), (</>))

-- hpc
import           Trace.Hpc.Mix               (BoxLabel (..), Mix (..),
                                              MixEntry)
import           Trace.Hpc.Tix               (Tix (..), TixModule (..))
import           Trace.Hpc.Util              (fromHpcPos)


-- Internal
import           Trace.Hpc.Codecov.Exception
import           Trace.Hpc.Codecov.Parser


-- ------------------------------------------------------------------------
--
-- Types
--
-- ------------------------------------------------------------------------

-- | Data type to hold information for generating test coverage
-- report.
data Report = Report
 { Report -> FilePath
reportTix          :: FilePath
   -- ^ Input tix file.
 , Report -> [FilePath]
reportMixDirs      :: [FilePath]
   -- ^ Directories containing mix files referred by the tix file.
 , Report -> [FilePath]
reportSrcDirs      :: [FilePath]
   -- ^ Directories containing source codes referred by the mix files.
 , Report -> [FilePath]
reportExcludes     :: [String]
   -- ^ Module name strings to exclude from coverage report.
 , Report -> Maybe FilePath
reportOutFile      :: Maybe FilePath
   -- ^ Output file to write report data, if given.
 , Report -> Bool
reportVerbose      :: Bool
   -- ^ Flag for showing verbose message during report generation.
 , Report -> Format
reportFormat       :: Format
   -- ^ Format of the report output.
   --
   -- @since 0.4.0.0
 , Report -> Bool
reportExprOnly     :: Bool
   -- ^ Flag for ignoring other data than 'ExpBox' entries in mix
   -- files.
   --
   -- @since 0.6.0.0
 , Report -> Bool
reportIgnoreDittos :: Bool
   -- ^ Flag for ignoring some of the compiler generated source codes.
   --
   -- As of the @.mix@ file generated by ghc 9.{4,6,8}, record field
   -- declarations, class names with more than two member functions in
   -- @deriving(..)@ clauses, and top-level TemplateHaskell splices
   -- are known to be ignored.
   --
   -- @since 0.6.0.0
 } deriving (Report -> Report -> Bool
(Report -> Report -> Bool)
-> (Report -> Report -> Bool) -> Eq Report
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Report -> Report -> Bool
== :: Report -> Report -> Bool
$c/= :: Report -> Report -> Bool
/= :: Report -> Report -> Bool
Eq, Tick -> Report -> ShowS
[Report] -> ShowS
Report -> FilePath
(Tick -> Report -> ShowS)
-> (Report -> FilePath) -> ([Report] -> ShowS) -> Show Report
forall a.
(Tick -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Tick -> Report -> ShowS
showsPrec :: Tick -> Report -> ShowS
$cshow :: Report -> FilePath
show :: Report -> FilePath
$cshowList :: [Report] -> ShowS
showList :: [Report] -> ShowS
Show)

instance Semigroup Report where
  <> :: Report -> Report -> Report
(<>) = Report -> Report -> Report
mappendReport

instance Monoid Report where
  mempty :: Report
mempty = Report
emptyReport

emptyReport :: Report
emptyReport :: Report
emptyReport = Report
  { reportTix :: FilePath
reportTix = HpcCodecovError -> FilePath
forall a e. Exception e => e -> a
throw HpcCodecovError
NoTarget
  , reportMixDirs :: [FilePath]
reportMixDirs = []
  , reportSrcDirs :: [FilePath]
reportSrcDirs = []
  , reportExcludes :: [FilePath]
reportExcludes = []
  , reportOutFile :: Maybe FilePath
reportOutFile = Maybe FilePath
forall a. Maybe a
Nothing
  , reportVerbose :: Bool
reportVerbose = Bool
False
  , reportFormat :: Format
reportFormat = Format
Codecov
  , reportExprOnly :: Bool
reportExprOnly = Bool
False
  , reportIgnoreDittos :: Bool
reportIgnoreDittos = Bool
False
  }

mappendReport :: Report -> Report -> Report
mappendReport :: Report -> Report -> Report
mappendReport Report
r1 Report
r2 =
  let extend :: (b -> b -> c) -> (Report -> b) -> c
extend b -> b -> c
f Report -> b
g = (b -> b -> c
f (b -> b -> c) -> (Report -> b) -> Report -> Report -> c
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Report -> b
g) Report
r1 Report
r2
  in  Report { reportTix :: FilePath
reportTix = Report -> FilePath
reportTix Report
r2
             , reportMixDirs :: [FilePath]
reportMixDirs = ([FilePath] -> [FilePath] -> [FilePath])
-> (Report -> [FilePath]) -> [FilePath]
forall {b} {c}. (b -> b -> c) -> (Report -> b) -> c
extend [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
(<>) Report -> [FilePath]
reportMixDirs
             , reportSrcDirs :: [FilePath]
reportSrcDirs = ([FilePath] -> [FilePath] -> [FilePath])
-> (Report -> [FilePath]) -> [FilePath]
forall {b} {c}. (b -> b -> c) -> (Report -> b) -> c
extend [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
(<>) Report -> [FilePath]
reportSrcDirs
             , reportExcludes :: [FilePath]
reportExcludes = ([FilePath] -> [FilePath] -> [FilePath])
-> (Report -> [FilePath]) -> [FilePath]
forall {b} {c}. (b -> b -> c) -> (Report -> b) -> c
extend [FilePath] -> [FilePath] -> [FilePath]
forall a. Semigroup a => a -> a -> a
(<>) Report -> [FilePath]
reportExcludes
             , reportOutFile :: Maybe FilePath
reportOutFile = (Maybe FilePath -> Maybe FilePath -> Maybe FilePath)
-> (Report -> Maybe FilePath) -> Maybe FilePath
forall {b} {c}. (b -> b -> c) -> (Report -> b) -> c
extend Maybe FilePath -> Maybe FilePath -> Maybe FilePath
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) Report -> Maybe FilePath
reportOutFile
             , reportVerbose :: Bool
reportVerbose = (Bool -> Bool -> Bool) -> (Report -> Bool) -> Bool
forall {b} {c}. (b -> b -> c) -> (Report -> b) -> c
extend Bool -> Bool -> Bool
(||) Report -> Bool
reportVerbose
             , reportFormat :: Format
reportFormat = Report -> Format
reportFormat Report
r2
             , reportExprOnly :: Bool
reportExprOnly = (Bool -> Bool -> Bool) -> (Report -> Bool) -> Bool
forall {b} {c}. (b -> b -> c) -> (Report -> b) -> c
extend Bool -> Bool -> Bool
(||) Report -> Bool
reportExprOnly
             , reportIgnoreDittos :: Bool
reportIgnoreDittos = (Bool -> Bool -> Bool) -> (Report -> Bool) -> Bool
forall {b} {c}. (b -> b -> c) -> (Report -> b) -> c
extend Bool -> Bool -> Bool
(||) Report -> Bool
reportIgnoreDittos
             }

-- | Single file entry in coverage report.
--
data CoverageEntry =
  CoverageEntry { CoverageEntry -> FilePath
ce_filename :: FilePath -- ^ Source code file name.
                , CoverageEntry -> LineHits
ce_hits     :: LineHits -- ^ Line hits of the file.
                , CoverageEntry -> FunctionHits
ce_fns      :: FunctionHits
                  -- ^ Function hits of the file.
                  --
                  -- @since 0.4.0.0
                , CoverageEntry -> BranchHits
ce_branches :: BranchHits
                  -- ^ Branch hits of the file.
                  --
                  -- @since 0.4.0.0
                } deriving (CoverageEntry -> CoverageEntry -> Bool
(CoverageEntry -> CoverageEntry -> Bool)
-> (CoverageEntry -> CoverageEntry -> Bool) -> Eq CoverageEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CoverageEntry -> CoverageEntry -> Bool
== :: CoverageEntry -> CoverageEntry -> Bool
$c/= :: CoverageEntry -> CoverageEntry -> Bool
/= :: CoverageEntry -> CoverageEntry -> Bool
Eq, Tick -> CoverageEntry -> ShowS
[CoverageEntry] -> ShowS
CoverageEntry -> FilePath
(Tick -> CoverageEntry -> ShowS)
-> (CoverageEntry -> FilePath)
-> ([CoverageEntry] -> ShowS)
-> Show CoverageEntry
forall a.
(Tick -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Tick -> CoverageEntry -> ShowS
showsPrec :: Tick -> CoverageEntry -> ShowS
$cshow :: CoverageEntry -> FilePath
show :: CoverageEntry -> FilePath
$cshowList :: [CoverageEntry] -> ShowS
showList :: [CoverageEntry] -> ShowS
Show)

-- | Pair of line number and hit tag.
type LineHits = [(Int, Hit)]

-- | Data type to represent coverage of source code line.
--
-- The 'Int' value in 'Partial' and 'Full' are the hit count.
data Hit
  = Missed  -- ^ The line is not covered at all.
  | Partial Int -- ^ The line is partially covered.
  | Full Int   -- ^ The line is fully covered.
  deriving (Hit -> Hit -> Bool
(Hit -> Hit -> Bool) -> (Hit -> Hit -> Bool) -> Eq Hit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Hit -> Hit -> Bool
== :: Hit -> Hit -> Bool
$c/= :: Hit -> Hit -> Bool
/= :: Hit -> Hit -> Bool
Eq, Tick -> Hit -> ShowS
[Hit] -> ShowS
Hit -> FilePath
(Tick -> Hit -> ShowS)
-> (Hit -> FilePath) -> ([Hit] -> ShowS) -> Show Hit
forall a.
(Tick -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Tick -> Hit -> ShowS
showsPrec :: Tick -> Hit -> ShowS
$cshow :: Hit -> FilePath
show :: Hit -> FilePath
$cshowList :: [Hit] -> ShowS
showList :: [Hit] -> ShowS
Show)

-- | Type synonym for tracking function enter count. Elements are
-- start line number, end line number, execution count, and function
-- name.
--
-- @since 0.4.0.0
type FunctionHits = [(Int, Int, Int, String)]

-- | Type synonym for tracking branch information. Elements are start
-- line number, branch block number, 'Bool' for the taken branch, and
-- execution count.
--
-- @since 0.4.0.0
type BranchHits = [(Int, Int, Bool, Int)]

-- | Data type for generated report format.
data Format
  = Codecov
  -- ^ Custom Codecov JSON format. See the
  -- <https://docs.codecov.io/docs/codecov-custom-coverage-format Codecov documentation>
  -- for detail.
  --
  -- @since 0.1.0.0
  | Lcov
  -- ^ LCOV tracefile format. See the
  -- <https://ltp.sourceforge.net/coverage/lcov/geninfo.1.php geninfo manpage>
  -- for detail.
  --
  -- @since 0.4.0.0
  | Cobertura
  -- ^ Cobertura XML file format. See the
  -- <https://cobertura.github.io/cobertura/ Cobertura> website for detail.
  --
  -- @since 0.5.0.0
  deriving (Format -> Format -> Bool
(Format -> Format -> Bool)
-> (Format -> Format -> Bool) -> Eq Format
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Format -> Format -> Bool
== :: Format -> Format -> Bool
$c/= :: Format -> Format -> Bool
/= :: Format -> Format -> Bool
Eq, Tick -> Format -> ShowS
[Format] -> ShowS
Format -> FilePath
(Tick -> Format -> ShowS)
-> (Format -> FilePath) -> ([Format] -> ShowS) -> Show Format
forall a.
(Tick -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Tick -> Format -> ShowS
showsPrec :: Tick -> Format -> ShowS
$cshow :: Format -> FilePath
show :: Format -> FilePath
$cshowList :: [Format] -> ShowS
showList :: [Format] -> ShowS
Show)


-- ------------------------------------------------------------------------
--
-- Tix to CoverageEntry
--
-- ------------------------------------------------------------------------

tixToCoverage :: Report -> Tix -> IO [CoverageEntry]
tixToCoverage :: Report -> Tix -> IO [CoverageEntry]
tixToCoverage Report
rpt (Tix [TixModule]
tms) =
  (TixModule -> IO CoverageEntry)
-> [TixModule] -> IO [CoverageEntry]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Report -> TixModule -> IO CoverageEntry
tixModuleToCoverage Report
rpt) (Report -> [TixModule] -> [TixModule]
excludeModules Report
rpt [TixModule]
tms)

tixModuleToCoverage :: Report -> TixModule -> IO CoverageEntry
tixModuleToCoverage :: Report -> TixModule -> IO CoverageEntry
tixModuleToCoverage Report
rpt tm :: TixModule
tm@(TixModule FilePath
name Hash
_hash Tick
count [Integer]
ixs) = do
  Report -> FilePath -> IO ()
say Report
rpt (FilePath
"Searching mix:  " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
name)
  Mix FilePath
path UTCTime
_ Hash
_ Tick
_ [MixEntry]
entries <- [FilePath] -> TixModule -> IO Mix
readMixFile (Report -> [FilePath]
reportMixDirs Report
rpt) TixModule
tm
  Report -> FilePath -> IO ()
say Report
rpt (FilePath
"Found mix:      " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
path)
  let (Tick
num_removed, [Integer]
ixs', [MixEntry]
entries')
        | Report -> Bool
reportIgnoreDittos Report
rpt = [Integer] -> [MixEntry] -> (Tick, [Integer], [MixEntry])
removeDittoEntries [Integer]
ixs [MixEntry]
entries
        | Bool
otherwise = (Tick
0, [Integer]
ixs, [MixEntry]
entries)
      Info Tick
_ Tick
min_line Tick
max_line [(Tick, Tick, Tick)]
hits FunctionHits
fns PreBranchHits
pre_brs =
        Bool -> Tick -> [Integer] -> [MixEntry] -> Info
makeInfo (Report -> Bool
reportExprOnly Report
rpt) (Tick
count Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
- Tick
num_removed) [Integer]
ixs' [MixEntry]
entries'
      lineHits :: LineHits
lineHits = Tick -> Tick -> [(Tick, Tick, Tick)] -> LineHits
makeLineHits Tick
min_line Tick
max_line [(Tick, Tick, Tick)]
hits
  FilePath
path' <- Report -> FilePath -> IO FilePath
ensureSrcPath Report
rpt FilePath
path
  CoverageEntry -> IO CoverageEntry
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoverageEntry { ce_filename :: FilePath
ce_filename = FilePath
path'
                        , ce_hits :: LineHits
ce_hits = LineHits
lineHits
                        , ce_fns :: FunctionHits
ce_fns = FunctionHits
fns
                        , ce_branches :: BranchHits
ce_branches = PreBranchHits -> BranchHits
reBranch PreBranchHits
pre_brs })

-- | Exclude modules specified in given 'Report'.
excludeModules :: Report -> [TixModule] -> [TixModule]
excludeModules :: Report -> [TixModule] -> [TixModule]
excludeModules Report
rpt = (TixModule -> Bool) -> [TixModule] -> [TixModule]
forall a. (a -> Bool) -> [a] -> [a]
filter TixModule -> Bool
exclude
  where
    exclude :: TixModule -> Bool
exclude (TixModule FilePath
pkg_slash_name Hash
_ Tick
_ [Integer]
_) =
      let modname :: FilePath
modname = case (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') FilePath
pkg_slash_name of
                      (FilePath
_, Char
'/':FilePath
name) -> FilePath
name
                      (FilePath
name, FilePath
_)     -> FilePath
name
      in  FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem FilePath
modname (Report -> [FilePath]
reportExcludes Report
rpt)

-- | Read tix file from file path, return a 'Tix' data or throw
-- a 'TixNotFound' exception.
readTixFile :: Report -> FilePath -> IO Tix
readTixFile :: Report -> FilePath -> IO Tix
readTixFile Report
rpt FilePath
path = do
  Maybe Tix
mb_tix <- {-# SCC "readTixFile.readTix'" #-} FilePath -> IO (Maybe Tix)
readTix' FilePath
path
  case Maybe Tix
mb_tix of
    Maybe Tix
Nothing  -> HpcCodecovError -> IO Tix
forall e a. Exception e => e -> IO a
throwIO (FilePath -> HpcCodecovError
TixNotFound FilePath
path)
    Just Tix
tix -> Report -> FilePath -> IO ()
say Report
rpt (FilePath
"Found tix file: " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
path) IO () -> IO Tix -> IO Tix
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Tix -> IO Tix
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Tix
tix

-- | Search mix file under given directories, return a 'Mix' data or
-- throw a 'MixNotFound' exception.
readMixFile :: [FilePath] -> TixModule -> IO Mix
readMixFile :: [FilePath] -> TixModule -> IO Mix
readMixFile [FilePath]
dirs tm :: TixModule
tm@(TixModule FilePath
name Hash
_h Tick
_c [Integer]
_i) = (ErrorCall -> IO Mix) -> IO Mix -> IO Mix
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle ErrorCall -> IO Mix
forall a. ErrorCall -> IO a
handler IO Mix
go
  where
    handler :: ErrorCall -> IO a
    handler :: forall a. ErrorCall -> IO a
handler ErrorCall
_ = HpcCodecovError -> IO a
forall e a. Exception e => e -> IO a
throwIO (FilePath -> [FilePath] -> HpcCodecovError
MixNotFound FilePath
name [FilePath]
dirs')
    dirs' :: [FilePath]
dirs' = ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> ShowS
</> (FilePath
name FilePath -> ShowS
<.> FilePath
"mix")) [FilePath]
dirs
    go :: IO Mix
go = {-# SCC "readMixFile.readMix'" #-} [FilePath] -> Either FilePath TixModule -> IO Mix
readMix' [FilePath]
dirs (TixModule -> Either FilePath TixModule
forall a b. b -> Either a b
Right TixModule
tm)

-- | Ensure the given source file exist, return the ensured 'FilePath'
-- or throw a 'SrcNotFound' exception.
ensureSrcPath :: Report -> FilePath -> IO FilePath
ensureSrcPath :: Report -> FilePath -> IO FilePath
ensureSrcPath Report
rpt FilePath
path = [FilePath] -> [FilePath] -> IO FilePath
go [] (Report -> [FilePath]
reportSrcDirs Report
rpt)
  where
    go :: [FilePath] -> [FilePath] -> IO FilePath
go [FilePath]
acc [] = HpcCodecovError -> IO FilePath
forall e a. Exception e => e -> IO a
throwIO (FilePath -> [FilePath] -> HpcCodecovError
SrcNotFound FilePath
path [FilePath]
acc)
    go [FilePath]
acc (FilePath
dir:[FilePath]
dirs) = do
      let path' :: FilePath
path' = FilePath
dir FilePath -> ShowS
</> FilePath
path
      Bool
exist <- FilePath -> IO Bool
doesFileExist FilePath
path'
      if Bool
exist
        then Report -> FilePath -> IO ()
say Report
rpt (FilePath
"Found source:   " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
path') IO () -> IO FilePath -> IO FilePath
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
path'
        else [FilePath] -> [FilePath] -> IO FilePath
go (FilePath
path'FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
acc) [FilePath]
dirs

-- | Remove consequent non-'BinBox' entries from given tix and mix
-- entries with identical source code positions. Returns a triple of
-- (number_of_removed_entries, filtered_tix, filtered_mix).
removeDittoEntries
  :: [Integer] -> [MixEntry] -> (Int, [Integer], [MixEntry])
removeDittoEntries :: [Integer] -> [MixEntry] -> (Tick, [Integer], [MixEntry])
removeDittoEntries = Maybe MixEntry
-> (Tick, [Integer], [MixEntry])
-> [Integer]
-> [MixEntry]
-> (Tick, [Integer], [MixEntry])
forall {a} {a} {a}.
(Eq a, Num a) =>
Maybe (a, BoxLabel)
-> (a, [a], [(a, BoxLabel)])
-> [a]
-> [(a, BoxLabel)]
-> (a, [a], [(a, BoxLabel)])
go Maybe MixEntry
forall a. Maybe a
Nothing (Tick
0, [], [])
  where
    go :: Maybe (a, BoxLabel)
-> (a, [a], [(a, BoxLabel)])
-> [a]
-> [(a, BoxLabel)]
-> (a, [a], [(a, BoxLabel)])
go Maybe (a, BoxLabel)
Nothing (a
n, [a]
rixs, [(a, BoxLabel)]
rmes) (a
_:a
_:[a]
ixs) ((a, BoxLabel)
m1:(a, BoxLabel)
m2:[(a, BoxLabel)]
mes)
      | (a, BoxLabel) -> (a, BoxLabel) -> Bool
forall {a} {b}. Eq a => (a, BoxLabel) -> (a, b) -> Bool
isDitto (a, BoxLabel)
m1 (a, BoxLabel)
m2 = Maybe (a, BoxLabel)
-> (a, [a], [(a, BoxLabel)])
-> [a]
-> [(a, BoxLabel)]
-> (a, [a], [(a, BoxLabel)])
go ((a, BoxLabel) -> Maybe (a, BoxLabel)
forall a. a -> Maybe a
Just (a, BoxLabel)
m1) (a
na -> a -> a
forall a. Num a => a -> a -> a
+a
2, [a]
rixs, [(a, BoxLabel)]
rmes) [a]
ixs [(a, BoxLabel)]
mes

    go Maybe (a, BoxLabel)
Nothing (a
n, [a]
rixs, [(a, BoxLabel)]
rmes) (a
i:[a]
ixs) ((a, BoxLabel)
m:[(a, BoxLabel)]
mes) =
      Maybe (a, BoxLabel)
-> (a, [a], [(a, BoxLabel)])
-> [a]
-> [(a, BoxLabel)]
-> (a, [a], [(a, BoxLabel)])
go Maybe (a, BoxLabel)
forall a. Maybe a
Nothing (a
n, a
ia -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
rixs, (a, BoxLabel)
m(a, BoxLabel) -> [(a, BoxLabel)] -> [(a, BoxLabel)]
forall a. a -> [a] -> [a]
:[(a, BoxLabel)]
rmes) [a]
ixs [(a, BoxLabel)]
mes

    go (Just (a, BoxLabel)
removed) acc :: (a, [a], [(a, BoxLabel)])
acc@(a
n, [a]
rixs, [(a, BoxLabel)]
rmes) (a
i:[a]
ixs) ((a, BoxLabel)
m:[(a, BoxLabel)]
mes)
      | (a, BoxLabel) -> (a, BoxLabel) -> Bool
forall {a} {b}. Eq a => (a, BoxLabel) -> (a, b) -> Bool
isDitto (a, BoxLabel)
removed (a, BoxLabel)
m = Maybe (a, BoxLabel)
-> (a, [a], [(a, BoxLabel)])
-> [a]
-> [(a, BoxLabel)]
-> (a, [a], [(a, BoxLabel)])
go ((a, BoxLabel) -> Maybe (a, BoxLabel)
forall a. a -> Maybe a
Just (a, BoxLabel)
m) (a
na -> a -> a
forall a. Num a => a -> a -> a
+a
1, [a]
rixs, [(a, BoxLabel)]
rmes) [a]
ixs [(a, BoxLabel)]
mes
      | Bool
otherwise = Maybe (a, BoxLabel)
-> (a, [a], [(a, BoxLabel)])
-> [a]
-> [(a, BoxLabel)]
-> (a, [a], [(a, BoxLabel)])
go Maybe (a, BoxLabel)
forall a. Maybe a
Nothing (a, [a], [(a, BoxLabel)])
acc (a
ia -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ixs) ((a, BoxLabel)
m(a, BoxLabel) -> [(a, BoxLabel)] -> [(a, BoxLabel)]
forall a. a -> [a] -> [a]
:[(a, BoxLabel)]
mes)

    go Maybe (a, BoxLabel)
_ (a
n, [a]
rixs, [(a, BoxLabel)]
rmes) [a]
_ [(a, BoxLabel)]
_ =
      (a
n, [a] -> [a]
forall a. [a] -> [a]
reverse [a]
rixs, [(a, BoxLabel)] -> [(a, BoxLabel)]
forall a. [a] -> [a]
reverse [(a, BoxLabel)]
rmes)

    isDitto :: (a, BoxLabel) -> (a, b) -> Bool
isDitto (a
_, BinBox {}) (a, b)
_ = Bool
False
    isDitto (a
p1, BoxLabel
_) (a
p2, b
_)  = a
p1 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
p2

-- | Arrange branch hit information.
--
-- LCOV tracefile seems like want to have a true branch before the
-- corresponding false branch, so arranging the order.
--
-- Also assigning sequential block numbers to the branch entries
-- starting with identical line number.
reBranch :: PreBranchHits -> BranchHits
reBranch :: PreBranchHits -> BranchHits
reBranch = IntMap Tick -> PreBranchHits -> BranchHits
forall {c} {d}.
IntMap Tick -> [(Tick, c, d)] -> [(Tick, Tick, c, d)]
go IntMap Tick
forall a. Monoid a => a
mempty
  where
    go :: IntMap Tick -> [(Tick, c, d)] -> [(Tick, Tick, c, d)]
go IntMap Tick
im0 ((Tick
lf,c
brf,d
nf) : (Tick
lt,c
brt,d
nt) : [(Tick, c, d)]
rest) =
      let (Maybe Tick
mb_i, IntMap Tick
im1) = (Tick -> Tick -> Tick -> Tick)
-> Tick -> Tick -> IntMap Tick -> (Maybe Tick, IntMap Tick)
forall a.
(Tick -> a -> a -> a)
-> Tick -> a -> IntMap a -> (Maybe a, IntMap a)
IntMap.insertLookupWithKey Tick -> Tick -> Tick -> Tick
forall {p} {p}. p -> p -> Tick -> Tick
f Tick
lf Tick
0 IntMap Tick
im0
          f :: p -> p -> Tick -> Tick
f p
_key p
_new Tick
old = Tick
old Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
+ Tick
1 :: Int
          i :: Tick
i = Tick -> (Tick -> Tick) -> Maybe Tick -> Tick
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Tick
0 Tick -> Tick
forall a. Enum a => a -> a
succ Maybe Tick
mb_i
      in  (Tick
lt,Tick
i,c
brt,d
nt) (Tick, Tick, c, d) -> [(Tick, Tick, c, d)] -> [(Tick, Tick, c, d)]
forall a. a -> [a] -> [a]
: (Tick
lf,Tick
i,c
brf,d
nf) (Tick, Tick, c, d) -> [(Tick, Tick, c, d)] -> [(Tick, Tick, c, d)]
forall a. a -> [a] -> [a]
: IntMap Tick -> [(Tick, c, d)] -> [(Tick, Tick, c, d)]
go IntMap Tick
im1 [(Tick, c, d)]
rest
    go IntMap Tick
_ [(Tick, c, d)]
_ = []

-- | Print given message to 'stderr' when the verbose flag is 'True'.
say :: Report -> String -> IO ()
say :: Report -> FilePath -> IO ()
say Report
rpt = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Report -> Bool
reportVerbose Report
rpt) (IO () -> IO ()) -> (FilePath -> IO ()) -> FilePath -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr

-- | Internal type synonym to represent code line hit. Using 'Int' so
-- that unboxed arrays can use in its elements.
type Tick = Int

-- | Internal type synonym to represent line hit count.
type Count = Int

-- | Like 'BranchHits', but without branch block number.
type PreBranchHits = [(Int, Bool, Count)]

-- | Internal type used for accumulating mix entries.
data Info =
  Info {-# UNPACK #-} !Int -- ^ Index count
       {-# UNPACK #-} !Int -- ^ Min line number
       {-# UNPACK #-} !Int -- ^ Max line number
       [(Int, Tick, Count)] -- ^ Start line number, tick, and count.
       FunctionHits -- ^ For tracking function.
       PreBranchHits -- ^ For tracking branch.

-- | Make line hits from intermediate info.
makeLineHits :: Int -> Int -> [(Int, Tick, Count)] -> LineHits
makeLineHits :: Tick -> Tick -> [(Tick, Tick, Tick)] -> LineHits
makeLineHits Tick
min_line Tick
max_line [(Tick, Tick, Tick)]
hits = [(Tick, (Tick, Tick))] -> LineHits
ticksToHits (Array Tick (Tick, Tick) -> [(Tick, (Tick, Tick))]
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> [(i, e)]
assocs Array Tick (Tick, Tick)
merged)
  where
    merged :: Array Tick (Tick, Tick)
merged = (forall s. ST s (STArray s Tick (Tick, Tick)))
-> Array Tick (Tick, Tick)
forall i e. (forall s. ST s (STArray s i e)) -> Array i e
runSTArray ((forall s. ST s (STArray s Tick (Tick, Tick)))
 -> Array Tick (Tick, Tick))
-> (forall s. ST s (STArray s Tick (Tick, Tick)))
-> Array Tick (Tick, Tick)
forall a b. (a -> b) -> a -> b
$ do
      STArray s Tick (Tick, Tick)
arr <- (Tick, Tick) -> (Tick, Tick) -> ST s (STArray s Tick (Tick, Tick))
forall i.
Ix i =>
(i, i) -> (Tick, Tick) -> ST s (STArray s i (Tick, Tick))
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Tick
min_line, Tick
max_line) (Tick
ignored, Tick
0)
      ((Tick, Tick, Tick) -> ST s ()) -> [(Tick, Tick, Tick)] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (STArray s Tick (Tick, Tick) -> (Tick, Tick, Tick) -> ST s ()
forall s.
STArray s Tick (Tick, Tick) -> (Tick, Tick, Tick) -> ST s ()
updateOne STArray s Tick (Tick, Tick)
arr) [(Tick, Tick, Tick)]
hits
      STArray s Tick (Tick, Tick) -> ST s (STArray s Tick (Tick, Tick))
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return STArray s Tick (Tick, Tick)
arr

    updateOne :: STArray s Int (Tick, Count) -> (Int, Tick, Count) -> ST s ()
    updateOne :: forall s.
STArray s Tick (Tick, Tick) -> (Tick, Tick, Tick) -> ST s ()
updateOne STArray s Tick (Tick, Tick)
arr (Tick
i, Tick
hit, Tick
count) = do
      (Tick
old_hit, Tick
old_count) <- STArray s Tick (Tick, Tick) -> Tick -> ST s (Tick, Tick)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STArray s Tick (Tick, Tick)
arr Tick
i
      STArray s Tick (Tick, Tick) -> Tick -> (Tick, Tick) -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STArray s Tick (Tick, Tick)
arr Tick
i (Tick -> Tick -> Tick
mergeEntry Tick
old_hit Tick
hit, Tick -> Tick -> Tick
forall a. Ord a => a -> a -> a
max Tick
old_count Tick
count)

    mergeEntry :: Tick -> Tick -> Tick
mergeEntry Tick
prev Tick
curr
      | Tick -> Bool
isMissed Tick
prev, Tick -> Bool
isFull Tick
curr = Tick
partial
      | Tick -> Bool
isFull Tick
prev, Tick -> Bool
isMissed Tick
curr = Tick
partial
      | Tick -> Bool
isPartial Tick
prev = Tick
prev
      | Bool
otherwise = Tick
curr

-- | Convert array of ticks to list of hits.
ticksToHits :: [(Int, (Tick, Count))] -> LineHits
ticksToHits :: [(Tick, (Tick, Tick))] -> LineHits
ticksToHits = ((Tick, (Tick, Tick)) -> LineHits -> LineHits)
-> LineHits -> [(Tick, (Tick, Tick))] -> LineHits
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Tick, (Tick, Tick)) -> LineHits -> LineHits
forall {a}. (a, (Tick, Tick)) -> [(a, Hit)] -> [(a, Hit)]
f []
  where
    f :: (a, (Tick, Tick)) -> [(a, Hit)] -> [(a, Hit)]
f (a
i,(Tick
tck,Tick
n)) [(a, Hit)]
acc
      | Tick -> Bool
isIgnored Tick
tck = [(a, Hit)]
acc
      | Tick -> Bool
isMissed Tick
tck  = (a
i, Hit
Missed) (a, Hit) -> [(a, Hit)] -> [(a, Hit)]
forall a. a -> [a] -> [a]
: [(a, Hit)]
acc
      | Tick -> Bool
isFull Tick
tck    = (a
i, Tick -> Hit
Full Tick
n) (a, Hit) -> [(a, Hit)] -> [(a, Hit)]
forall a. a -> [a] -> [a]
: [(a, Hit)]
acc
      | Bool
otherwise     = (a
i, Tick -> Hit
Partial Tick
n) (a, Hit) -> [(a, Hit)] -> [(a, Hit)]
forall a. a -> [a] -> [a]
: [(a, Hit)]
acc

ignored, missed, partial, full :: Tick
ignored :: Tick
ignored = -Tick
1
missed :: Tick
missed = Tick
0
partial :: Tick
partial = Tick
1
full :: Tick
full = Tick
2

isIgnored :: Tick -> Bool
isIgnored :: Tick -> Bool
isIgnored = (Tick -> Tick -> Bool
forall a. Eq a => a -> a -> Bool
== Tick
ignored)

isMissed :: Tick -> Bool
isMissed :: Tick -> Bool
isMissed = (Tick -> Tick -> Bool
forall a. Eq a => a -> a -> Bool
== Tick
missed)

isPartial :: Tick -> Bool
isPartial :: Tick -> Bool
isPartial = (Tick -> Tick -> Bool
forall a. Eq a => a -> a -> Bool
== Tick
partial)

isFull :: Tick -> Bool
isFull :: Tick -> Bool
isFull = (Tick -> Tick -> Bool
forall a. Eq a => a -> a -> Bool
== Tick
full)

notTicked, ticked :: Tick
notTicked :: Tick
notTicked = Tick
missed
ticked :: Tick
ticked = Tick
full

-- See also: "utils/hpc/HpcMarkup.hs" in "ghc" git repository.
makeInfo :: Bool -> Int -> [Integer] -> [MixEntry] -> Info
makeInfo :: Bool -> Tick -> [Integer] -> [MixEntry] -> Info
makeInfo Bool
expr_only Tick
size [Integer]
tixs = (Info -> MixEntry -> Info) -> Info -> [MixEntry] -> Info
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Info -> MixEntry -> Info
f Info
z
  where
    z :: Info
z = Tick
-> Tick
-> Tick
-> [(Tick, Tick, Tick)]
-> FunctionHits
-> PreBranchHits
-> Info
Info Tick
0 Tick
forall a. Bounded a => a
maxBound Tick
0 [] [] []
    f :: Info -> MixEntry -> Info
f (Info Tick
i0 Tick
min_line Tick
max_line [(Tick, Tick, Tick)]
txs FunctionHits
fns PreBranchHits
brs) (HpcPos
pos, BoxLabel
boxLabel) =
      let binBox :: [(Tick, Tick, Tick)]
binBox =
            case (Tick -> Bool
isTicked Tick
i0, Tick -> Bool
isTicked Tick
i1) of
              (Bool
False, Bool
False) -> [(Tick, Tick, Tick)]
txs
              (Bool
True,  Bool
False) -> (Tick
sl, Tick
partial, Tick
numTicked_i0) (Tick, Tick, Tick) -> [(Tick, Tick, Tick)] -> [(Tick, Tick, Tick)]
forall a. a -> [a] -> [a]
: [(Tick, Tick, Tick)]
txs
              (Bool
False, Bool
True)  -> (Tick
sl, Tick
partial, Tick -> Tick
numTicked Tick
i1) (Tick, Tick, Tick) -> [(Tick, Tick, Tick)] -> [(Tick, Tick, Tick)]
forall a. a -> [a] -> [a]
: [(Tick, Tick, Tick)]
txs
              (Bool
True, Bool
True)   -> [(Tick, Tick, Tick)]
txs
          tickBox :: [(Tick, Tick, Tick)]
tickBox =
            let t :: Tick
t | Tick -> Bool
isTicked Tick
i0 = Tick
ticked
                  | Bool
otherwise = Tick
notTicked
            in  (Tick
sl, Tick
t, Tick
numTicked_i0) (Tick, Tick, Tick) -> [(Tick, Tick, Tick)] -> [(Tick, Tick, Tick)]
forall a. a -> [a] -> [a]
: [(Tick, Tick, Tick)]
txs
          tlBox :: [FilePath] -> FunctionHits
tlBox [FilePath]
ns = (Tick
sl, Tick
el, Tick
numTicked_i0, FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"." [FilePath]
ns) (Tick, Tick, Tick, FilePath) -> FunctionHits -> FunctionHits
forall a. a -> [a] -> [a]
: FunctionHits
fns
          br :: b -> (Tick, b, Tick)
br b
bool = (Tick
sl, b
bool, Tick
numTicked_i0)
          numTicked_i0 :: Tick
numTicked_i0 = Tick -> Tick
numTicked Tick
i0
          ([(Tick, Tick, Tick)]
txs', FunctionHits
fns', PreBranchHits
brs')
            | Bool
expr_only = case BoxLabel
boxLabel of
                ExpBox {} -> ([(Tick, Tick, Tick)]
tickBox, FunctionHits
fns, PreBranchHits
brs)
                BoxLabel
_         -> ([(Tick, Tick, Tick)]
txs, FunctionHits
fns, PreBranchHits
brs)
            | Bool
otherwise = case BoxLabel
boxLabel of
                ExpBox {}      -> ([(Tick, Tick, Tick)]
tickBox, FunctionHits
fns, PreBranchHits
brs)
                TopLevelBox [FilePath]
ns -> ([(Tick, Tick, Tick)]
tickBox, [FilePath] -> FunctionHits
tlBox [FilePath]
ns, PreBranchHits
brs)
                LocalBox {}    -> ([(Tick, Tick, Tick)]
tickBox, FunctionHits
fns, PreBranchHits
brs)
                BinBox CondBox
_ Bool
True  -> ([(Tick, Tick, Tick)]
binBox, FunctionHits
fns, Bool -> (Tick, Bool, Tick)
forall {b}. b -> (Tick, b, Tick)
br Bool
True (Tick, Bool, Tick) -> PreBranchHits -> PreBranchHits
forall a. a -> [a] -> [a]
: PreBranchHits
brs)
                BinBox CondBox
_ Bool
False -> ([(Tick, Tick, Tick)]
txs, FunctionHits
fns, Bool -> (Tick, Bool, Tick)
forall {b}. b -> (Tick, b, Tick)
br Bool
False (Tick, Bool, Tick) -> PreBranchHits -> PreBranchHits
forall a. a -> [a] -> [a]
: PreBranchHits
brs)
          (Tick
sl, Tick
_, Tick
el, Tick
_) = HpcPos -> (Tick, Tick, Tick, Tick)
fromHpcPos HpcPos
pos
          i1 :: Tick
i1 = Tick
i0 Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
+ Tick
1
      in  Tick
-> Tick
-> Tick
-> [(Tick, Tick, Tick)]
-> FunctionHits
-> PreBranchHits
-> Info
Info Tick
i1 (Tick -> Tick -> Tick
forall a. Ord a => a -> a -> a
min Tick
sl Tick
min_line) (Tick -> Tick -> Tick
forall a. Ord a => a -> a -> a
max Tick
el Tick
max_line) [(Tick, Tick, Tick)]
txs' FunctionHits
fns' PreBranchHits
brs'

    -- Hope that the mix file does not contain out of bound index.
    numTicked :: Tick -> Tick
numTicked = UArray Tick Tick -> Tick -> Tick
forall i. Ix i => UArray i Tick -> Tick -> Tick
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> Tick -> e
unsafeAt UArray Tick Tick
arr_tix
    isTicked :: Tick -> Bool
isTicked Tick
n = Tick -> Tick
numTicked Tick
n Tick -> Tick -> Bool
forall a. Eq a => a -> a -> Bool
/= Tick
0

    arr_tix :: UArray Int Tick
    arr_tix :: UArray Tick Tick
arr_tix = (Tick, Tick) -> [Tick] -> UArray Tick Tick
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Tick
0, Tick
size Tick -> Tick -> Tick
forall a. Num a => a -> a -> a
- Tick
1) ((Integer -> Tick) -> [Integer] -> [Tick]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> Tick
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Integer]
tixs)