{-# LANGUAGE NoImplicitPrelude     #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE TupleSections         #-}

-- | Generate HPC (Haskell Program Coverage) reports
module Stack.Coverage
    ( deleteHpcReports
    , updateTixFile
    , generateHpcReport
    , HpcReportOpts(..)
    , generateHpcReportForTargets
    , generateHpcUnifiedReport
    , generateHpcMarkupIndex
    ) where

import           Stack.Prelude hiding (Display (..))
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as BL
import           Data.List
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy as LT
import           Path
import           Path.Extra (toFilePathNoTrailingSep)
import           Path.IO
import           Stack.Build.Target
import           Stack.Config (getLocalPackages)
import           Stack.Constants.Config
import           Stack.Package
import           Stack.PrettyPrint
import           Stack.Types.Compiler
import           Stack.Types.Config
import           Stack.Types.NamedComponent
import           Stack.Types.Package
import           Stack.Types.PackageIdentifier
import           Stack.Types.PackageName
import           Stack.Types.Runner
import           Stack.Types.Version
import           System.FilePath (isPathSeparator)
import qualified RIO
import           RIO.Process
import           Trace.Hpc.Tix
import           Web.Browser (openBrowser)

-- | Invoked at the beginning of running with "--coverage"
deleteHpcReports :: HasEnvConfig env => RIO env ()
deleteHpcReports = do
    hpcDir <- hpcReportDir
    liftIO $ ignoringAbsence (removeDirRecur hpcDir)

-- | Move a tix file into a sub-directory of the hpc report directory. Deletes the old one if one is
-- present.
updateTixFile :: HasEnvConfig env => PackageName -> Path Abs File -> String -> RIO env ()
updateTixFile pkgName tixSrc testName = do
    exists <- doesFileExist tixSrc
    when exists $ do
        tixDest <- tixFilePath pkgName testName
        liftIO $ ignoringAbsence (removeFile tixDest)
        ensureDir (parent tixDest)
        -- Remove exe modules because they are problematic. This could be revisited if there's a GHC
        -- version that fixes https://ghc.haskell.org/trac/ghc/ticket/1853
        mtix <- readTixOrLog tixSrc
        case mtix of
            Nothing -> logError $ "Failed to read " <> fromString (toFilePath tixSrc)
            Just tix -> do
                liftIO $ writeTix (toFilePath tixDest) (removeExeModules tix)
                -- TODO: ideally we'd do a file move, but IIRC this can
                -- have problems. Something about moving between drives
                -- on windows?
                copyFile tixSrc =<< parseAbsFile (toFilePath tixDest ++ ".premunging")
                liftIO $ ignoringAbsence (removeFile tixSrc)

-- | Get the directory used for hpc reports for the given pkgId.
hpcPkgPath :: HasEnvConfig env => PackageName -> RIO env (Path Abs Dir)
hpcPkgPath pkgName = do
    outputDir <- hpcReportDir
    pkgNameRel <- parseRelDir (packageNameString pkgName)
    return (outputDir </> pkgNameRel)

-- | Get the tix file location, given the name of the file (without extension), and the package
-- identifier string.
tixFilePath :: HasEnvConfig env
            => PackageName -> String -> RIO env (Path Abs File)
tixFilePath pkgName testName = do
    pkgPath <- hpcPkgPath pkgName
    tixRel <- parseRelFile (testName ++ "/" ++ testName ++ ".tix")
    return (pkgPath </> tixRel)

-- | Generates the HTML coverage report and shows a textual coverage summary for a package.
generateHpcReport :: HasEnvConfig env
                  => Path Abs Dir -> Package -> [Text] -> RIO env ()
generateHpcReport pkgDir package tests = do
    compilerVersion <- view actualCompilerVersionL
    -- If we're using > GHC 7.10, the hpc 'include' parameter must specify a ghc package key. See
    -- https://github.com/commercialhaskell/stack/issues/785
    let pkgName = packageNameText (packageName package)
        pkgId = packageIdentifierString (packageIdentifier package)
        ghcVersion = getGhcVersion compilerVersion
        hasLibrary =
          case packageLibraries package of
            NoLibraries -> False
            HasLibraries _ -> True
        internalLibs = packageInternalLibraries package
    eincludeName <-
        -- Pre-7.8 uses plain PKG-version in tix files.
        if ghcVersion < $(mkVersion "7.10") then return $ Right $ Just [pkgId]
        -- We don't expect to find a package key if there is no library.
        else if not hasLibrary && Set.null internalLibs then return $ Right Nothing
        -- Look in the inplace DB for the package key.
        -- See https://github.com/commercialhaskell/stack/issues/1181#issuecomment-148968986
        else do
            -- GHC 8.0 uses package id instead of package key.
            -- See https://github.com/commercialhaskell/stack/issues/2424
            let hpcNameField = if ghcVersion >= $(mkVersion "8.0") then "id" else "key"
            eincludeName <- findPackageFieldForBuiltPackage pkgDir (packageIdentifier package) internalLibs hpcNameField
            case eincludeName of
                Left err -> do
                    logError $ RIO.display err
                    return $ Left err
                Right includeNames -> return $ Right $ Just $ map T.unpack includeNames
    forM_ tests $ \testName -> do
        tixSrc <- tixFilePath (packageName package) (T.unpack testName)
        let report = "coverage report for " <> pkgName <> "'s test-suite \"" <> testName <> "\""
            reportDir = parent tixSrc
        case eincludeName of
            Left err -> generateHpcErrorReport reportDir (RIO.display (sanitize (T.unpack err)))
            -- Restrict to just the current library code, if there is a library in the package (see
            -- #634 - this will likely be customizable in the future)
            Right mincludeName -> do
                let extraArgs = case mincludeName of
                        Just includeNames -> "--include" : intersperse "--include" (map (\n -> n ++ ":") includeNames)
                        Nothing -> []
                mreportPath <- generateHpcReportInternal tixSrc reportDir report extraArgs extraArgs
                forM_ mreportPath (displayReportPath report . display)

generateHpcReportInternal :: HasEnvConfig env
                          => Path Abs File -> Path Abs Dir -> Text -> [String] -> [String]
                          -> RIO env (Maybe (Path Abs File))
generateHpcReportInternal tixSrc reportDir report extraMarkupArgs extraReportArgs = do
    -- If a .tix file exists, move it to the HPC output directory and generate a report for it.
    tixFileExists <- doesFileExist tixSrc
    if not tixFileExists
        then do
            logError $
                 "Didn't find .tix for " <>
                 RIO.display report <>
                 " - expected to find it at " <>
                 fromString (toFilePath tixSrc) <>
                 "."
            return Nothing
        else (`catch` \(err :: ProcessException) -> do
                 logError $ displayShow err
                 generateHpcErrorReport reportDir $ RIO.display $ sanitize $ show err
                 return Nothing) $
             (`onException` logError ("Error occurred while producing " <> RIO.display report)) $ do
            -- Directories for .mix files.
            hpcRelDir <- hpcRelativeDir
            -- Compute arguments used for both "hpc markup" and "hpc report".
            pkgDirs <- liftM (map lpvRoot . Map.elems . lpProject) getLocalPackages
            let args =
                    -- Use index files from all packages (allows cross-package coverage results).
                    concatMap (\x -> ["--srcdir", toFilePathNoTrailingSep x]) pkgDirs ++
                    -- Look for index files in the correct dir (relative to each pkgdir).
                    ["--hpcdir", toFilePathNoTrailingSep hpcRelDir, "--reset-hpcdirs"]
            logInfo $ "Generating " <> RIO.display report
            outputLines <- liftM (map (S8.filter (/= '\r')) . S8.lines . BL.toStrict . fst) $
                proc "hpc"
                ( "report"
                : toFilePath tixSrc
                : (args ++ extraReportArgs)
                )
                readProcess_
            if all ("(0/0)" `S8.isSuffixOf`) outputLines
                then do
                    let msg html =
                            "Error: The " <>
                            RIO.display report <>
                            " did not consider any code. One possible cause of this is" <>
                            " if your test-suite builds the library code (see stack " <>
                            (if html then "<a href='https://github.com/commercialhaskell/stack/issues/1008'>" else "") <>
                            "issue #1008" <>
                            (if html then "</a>" else "") <>
                            "). It may also indicate a bug in stack or" <>
                            " the hpc program. Please report this issue if you think" <>
                            " your coverage report should have meaningful results."
                    logError (msg False)
                    generateHpcErrorReport reportDir (msg True)
                    return Nothing
                else do
                    let reportPath = reportDir </> $(mkRelFile "hpc_index.html")
                    -- Print output, stripping @\r@ characters because Windows.
                    forM_ outputLines (logInfo . displayBytesUtf8)
                    -- Generate the markup.
                    void $ proc "hpc"
                        ( "markup"
                        : toFilePath tixSrc
                        : ("--destdir=" ++ toFilePathNoTrailingSep reportDir)
                        : (args ++ extraMarkupArgs)
                        )
                        readProcess_
                    return (Just reportPath)

data HpcReportOpts = HpcReportOpts
    { hroptsInputs :: [Text]
    , hroptsAll :: Bool
    , hroptsDestDir :: Maybe String
    , hroptsOpenBrowser :: Bool
    } deriving (Show)

generateHpcReportForTargets :: HasEnvConfig env
                            => HpcReportOpts -> RIO env ()
generateHpcReportForTargets opts = do
    let (tixFiles, targetNames) = partition (".tix" `T.isSuffixOf`) (hroptsInputs opts)
    targetTixFiles <-
         -- When there aren't any package component arguments, and --all
         -- isn't passed, default to not considering any targets.
         if not (hroptsAll opts) && null targetNames
         then return []
         else do
             when (hroptsAll opts && not (null targetNames)) $
                 logWarn $ "Since --all is used, it is redundant to specify these targets: " <> displayShow targetNames
             (_,_,targets) <- parseTargets
                 AllowNoTargets
                 defaultBuildOptsCLI
                    { boptsCLITargets = if hroptsAll opts then [] else targetNames }
             liftM concat $ forM (Map.toList targets) $ \(name, target) ->
                 case target of
                     TargetAll Dependency -> throwString $
                         "Error: Expected a local package, but " ++
                         packageNameString name ++
                         " is either an extra-dep or in the snapshot."
                     TargetComps comps -> do
                         pkgPath <- hpcPkgPath name
                         forM (toList comps) $ \nc ->
                             case nc of
                                 CTest testName ->
                                     liftM (pkgPath </>) $ parseRelFile (T.unpack testName ++ "/" ++ T.unpack testName ++ ".tix")
                                 _ -> fail $
                                     "Can't specify anything except test-suites as hpc report targets (" ++
                                     packageNameString name ++
                                     " is used with a non test-suite target)"
                     TargetAll ProjectPackage -> do
                         pkgPath <- hpcPkgPath name
                         exists <- doesDirExist pkgPath
                         if exists
                             then do
                                 (dirs, _) <- listDir pkgPath
                                 liftM concat $ forM dirs $ \dir -> do
                                     (_, files) <- listDir dir
                                     return (filter ((".tix" `isSuffixOf`) . toFilePath) files)
                             else return []
    tixPaths <- liftM (\xs -> xs ++ targetTixFiles) $ mapM (resolveFile' . T.unpack) tixFiles
    when (null tixPaths) $
        throwString "Not generating combined report, because no targets or tix files are specified."
    outputDir <- hpcReportDir
    reportDir <- case hroptsDestDir opts of
        Nothing -> return (outputDir </> $(mkRelDir "combined/custom"))
        Just destDir -> do
            dest <- resolveDir' destDir
            ensureDir dest
            return dest
    let report = "combined report"
    mreportPath <- generateUnionReport report reportDir tixPaths
    forM_ mreportPath $ \reportPath ->
        if hroptsOpenBrowser opts
            then do
                prettyInfo $ "Opening" <+> display reportPath <+> "in the browser."
                void $ liftIO $ openBrowser (toFilePath reportPath)
            else displayReportPath report (display reportPath)

generateHpcUnifiedReport :: HasEnvConfig env => RIO env ()
generateHpcUnifiedReport = do
    outputDir <- hpcReportDir
    ensureDir outputDir
    (dirs, _) <- listDir outputDir
    tixFiles0 <- liftM (concat . concat) $ forM (filter (("combined" /=) . dirnameString) dirs) $ \dir -> do
        (dirs', _) <- listDir dir
        forM dirs' $ \dir' -> do
            (_, files) <- listDir dir'
            return (filter ((".tix" `isSuffixOf`) . toFilePath) files)
    extraTixFiles <- findExtraTixFiles
    let tixFiles = tixFiles0  ++ extraTixFiles
        reportDir = outputDir </> $(mkRelDir "combined/all")
    if length tixFiles < 2
        then logInfo $
            (if null tixFiles then "No tix files" else "Only one tix file") <>
            " found in " <>
            fromString (toFilePath outputDir) <>
            ", so not generating a unified coverage report."
        else do
            let report = "unified report"
            mreportPath <- generateUnionReport report reportDir tixFiles
            forM_ mreportPath (displayReportPath report . display)

generateUnionReport :: HasEnvConfig env
                    => Text -> Path Abs Dir -> [Path Abs File]
                    -> RIO env (Maybe (Path Abs File))
generateUnionReport report reportDir tixFiles = do
    (errs, tix) <- fmap (unionTixes . map removeExeModules) (mapMaybeM readTixOrLog tixFiles)
    logDebug $ "Using the following tix files: " <> fromString (show tixFiles)
    unless (null errs) $ logWarn $
        "The following modules are left out of the " <>
        RIO.display report <>
        " due to version mismatches: " <>
        mconcat (intersperse ", " (map fromString errs))
    tixDest <- liftM (reportDir </>) $ parseRelFile (dirnameString reportDir ++ ".tix")
    ensureDir (parent tixDest)
    liftIO $ writeTix (toFilePath tixDest) tix
    generateHpcReportInternal tixDest reportDir report [] []

readTixOrLog :: HasLogFunc env => Path b File -> RIO env (Maybe Tix)
readTixOrLog path = do
    mtix <- liftIO (readTix (toFilePath path)) `catchAny` \errorCall -> do
        logError $ "Error while reading tix: " <> fromString (show errorCall)
        return Nothing
    when (isNothing mtix) $
        logError $ "Failed to read tix file " <> fromString (toFilePath path)
    return mtix

-- | Module names which contain '/' have a package name, and so they weren't built into the
-- executable.
removeExeModules :: Tix -> Tix
removeExeModules (Tix ms) = Tix (filter (\(TixModule name _ _ _) -> '/' `elem` name) ms)

unionTixes :: [Tix] -> ([String], Tix)
unionTixes tixes = (Map.keys errs, Tix (Map.elems outputs))
  where
    (errs, outputs) = Map.mapEither id $ Map.unionsWith merge $ map toMap tixes
    toMap (Tix ms) = Map.fromList (map (\x@(TixModule k _ _ _) -> (k, Right x)) ms)
    merge (Right (TixModule k hash1 len1 tix1))
          (Right (TixModule _ hash2 len2 tix2))
        | hash1 == hash2 && len1 == len2 = Right (TixModule k hash1 len1 (zipWith (+) tix1 tix2))
    merge _ _ = Left ()

generateHpcMarkupIndex :: HasEnvConfig env => RIO env ()
generateHpcMarkupIndex = do
    outputDir <- hpcReportDir
    let outputFile = outputDir </> $(mkRelFile "index.html")
    ensureDir outputDir
    (dirs, _) <- listDir outputDir
    rows <- liftM (catMaybes . concat) $ forM dirs $ \dir -> do
        (subdirs, _) <- listDir dir
        forM subdirs $ \subdir -> do
            let indexPath = subdir </> $(mkRelFile "hpc_index.html")
            exists' <- doesFileExist indexPath
            if not exists' then return Nothing else do
                relPath <- stripProperPrefix outputDir indexPath
                let package = dirname dir
                    testsuite = dirname subdir
                return $ Just $ T.concat
                  [ "<tr><td>"
                  , pathToHtml package
                  , "</td><td><a href=\""
                  , pathToHtml relPath
                  , "\">"
                  , pathToHtml testsuite
                  , "</a></td></tr>"
                  ]
    liftIO $ T.writeFile (toFilePath outputFile) $ T.concat $
        [ "<html><head><meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\">"
        -- Part of the css from HPC's output HTML
        , "<style type=\"text/css\">"
        , "table.dashboard { border-collapse: collapse; border: solid 1px black }"
        , ".dashboard td { border: solid 1px black }"
        , ".dashboard th { border: solid 1px black }"
        , "</style>"
        , "</head>"
        , "<body>"
        ] ++
        (if null rows
            then
                [ "<b>No hpc_index.html files found in \""
                , pathToHtml outputDir
                , "\".</b>"
                ]
            else
                [ "<table class=\"dashboard\" width=\"100%\" boder=\"1\"><tbody>"
                , "<p><b>NOTE: This is merely a listing of the html files found in the coverage reports directory.  Some of these reports may be old.</b></p>"
                , "<tr><th>Package</th><th>TestSuite</th><th>Modification Time</th></tr>"
                ] ++
                rows ++
                ["</tbody></table>"]) ++
        ["</body></html>"]
    unless (null rows) $
        logInfo $ "\nAn index of the generated HTML coverage reports is available at " <>
            fromString (toFilePath outputFile)

generateHpcErrorReport :: MonadIO m => Path Abs Dir -> Utf8Builder -> m ()
generateHpcErrorReport dir err = do
    ensureDir dir
    let fp = toFilePath (dir </> $(mkRelFile "hpc_index.html"))
    writeFileUtf8Builder fp $
        "<html><head><meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\"></head><body>" <>
        "<h1>HPC Report Generation Error</h1>" <>
        "<p>" <>
        err <>
        "</p>" <>
        "</body></html>"

pathToHtml :: Path b t -> Text
pathToHtml = T.dropWhileEnd (=='/') . sanitize . toFilePath

-- | Escape HTML symbols (copied from Text.Hastache)
htmlEscape :: LT.Text -> LT.Text
htmlEscape = LT.concatMap proc_
  where
    proc_ '&'  = "&amp;"
    proc_ '\\' = "&#92;"
    proc_ '"'  = "&quot;"
    proc_ '\'' = "&#39;"
    proc_ '<'  = "&lt;"
    proc_ '>'  = "&gt;"
    proc_ h    = LT.singleton h

sanitize :: String -> Text
sanitize = LT.toStrict . htmlEscape . LT.pack

dirnameString :: Path r Dir -> String
dirnameString = dropWhileEnd isPathSeparator . toFilePath . dirname

findPackageFieldForBuiltPackage
    :: HasEnvConfig env
    => Path Abs Dir -> PackageIdentifier -> Set.Set Text -> Text
    -> RIO env (Either Text [Text])
findPackageFieldForBuiltPackage pkgDir pkgId internalLibs field = do
    distDir <- distDirFromDir pkgDir
    let inplaceDir = distDir </> $(mkRelDir "package.conf.inplace")
        pkgIdStr = packageIdentifierString pkgId
        notFoundErr = return $ Left $ "Failed to find package key for " <> T.pack pkgIdStr
        extractField path = do
            contents <- liftIO $ T.readFile (toFilePath path)
            case asum (map (T.stripPrefix (field <> ": ")) (T.lines contents)) of
                Just result -> return $ Right result
                Nothing -> notFoundErr
    cabalVer <- view cabalVersionL
    if cabalVer < $(mkVersion "1.24")
        then do
            -- here we don't need to handle internal libs
            path <- liftM (inplaceDir </>) $ parseRelFile (pkgIdStr ++ "-inplace.conf")
            logDebug $ "Parsing config in Cabal < 1.24 location: " <> fromString (toFilePath path)
            exists <- doesFileExist path
            if exists then fmap (:[]) <$> extractField path else notFoundErr
        else do
            -- With Cabal-1.24, it's in a different location.
            logDebug $ "Scanning " <> fromString (toFilePath inplaceDir) <> " for files matching " <> fromString pkgIdStr
            (_, files) <- handleIO (const $ return ([], [])) $ listDir inplaceDir
            logDebug $ displayShow files
            -- From all the files obtained from the scanning process above, we
            -- need to identify which are .conf files and then ensure that
            -- there is at most one .conf file for each library and internal
            -- library (some might be missing if that component has not been
            -- built yet). We should error if there are more than one .conf
            -- file for a component or if there are no .conf files at all in
            -- the searched location.
            let toFilename = T.pack . toFilePath . filename
                -- strip known prefix and suffix from the found files to determine only the conf files
                stripKnown =  T.stripSuffix ".conf" <=< T.stripPrefix (T.pack (pkgIdStr ++ "-"))
                stripped = mapMaybe (\file -> fmap (,file) . stripKnown . toFilename $ file) files
                -- which component could have generated each of these conf files
                stripHash n = let z = T.dropWhile (/= '-') n in if T.null z then "" else T.tail z
                matchedComponents = map (\(n, f) -> (stripHash n, [f])) stripped
                byComponents = Map.restrictKeys (Map.fromListWith (++) matchedComponents) $ Set.insert "" internalLibs
            logDebug $ displayShow byComponents
            if Map.null $ Map.filter (\fs -> length fs > 1) byComponents
            then case concat $ Map.elems byComponents of
                [] -> notFoundErr
                -- for each of these files, we need to extract the requested field
                paths -> do
                  (errors, keys) <-  partitionEithers <$> traverse extractField paths
                  case errors of
                    (a:_) -> return $ Left a -- the first error only, since they're repeated anyway
                    [] -> return $ Right keys
            else return $ Left $ "Multiple files matching " <> T.pack (pkgIdStr ++ "-*.conf") <> " found in " <>
                    T.pack (toFilePath inplaceDir) <> ". Maybe try 'stack clean' on this package?"

displayReportPath :: (HasRunner env)
                  => Text -> AnsiDoc -> RIO env ()
displayReportPath report reportPath =
     prettyInfo $ "The" <+> fromString (T.unpack report) <+> "is available at" <+> reportPath

findExtraTixFiles :: HasEnvConfig env => RIO env [Path Abs File]
findExtraTixFiles = do
    outputDir <- hpcReportDir
    let dir = outputDir </> $(mkRelDir "extra-tix-files")
    dirExists <- doesDirExist dir
    if dirExists
        then do
            (_, files) <- listDir dir
            return $ filter ((".tix" `isSuffixOf`) . toFilePath) files
        else return []