{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HWM.Integrations.Toolchain.Cabal
  ( syncCabal,
    validateHackage,
  )
where

import Data.Foldable (Foldable (..))
import Distribution.PackageDescription.Check (PackageCheck (..), checkPackage)
import Distribution.Simple.PackageDescription (readGenericPackageDescription)
import Distribution.Verbosity (normal)
import HWM.Core.Formatting (Status (..))
import HWM.Core.Pkg (Pkg (..), pkgYamlPath)
import HWM.Core.Result (Issue (..), IssueDetails (..), MonadIssue (..), Severity (..))
import HWM.Domain.ConfigT (ConfigT)
import Hpack (Result (..), defaultOptions, hpackResult, setProgramName, setTarget)
import qualified Hpack as H
import Hpack.Config (ProgramName (..))
import Relude

-- | Translate Cabal warnings into formatting status for downstream reporting.
toStatus :: PackageCheck -> Status
toStatus :: PackageCheck -> Status
toStatus PackageCheck
p
  | PackageCheck -> Bool
isError PackageCheck
p = Status
Invalid
  | Bool
otherwise = Status
Warning

isError :: PackageCheck -> Bool
isError :: PackageCheck -> Bool
isError PackageDistInexcusable {} = Bool
True
isError PackageBuildImpossible {} = Bool
True
isError PackageBuildWarning {} = Bool
False
isError PackageDistSuspiciousWarn {} = Bool
False
isError PackageDistSuspicious {} = Bool
False

validateHackage :: Pkg -> FilePath -> ConfigT [Status]
validateHackage :: Pkg -> FilePath -> ConfigT [Status]
validateHackage Pkg
pkg FilePath
cabalFilePath = do
  GenericPackageDescription
gpd <- IO GenericPackageDescription -> ConfigT GenericPackageDescription
forall a. IO a -> ConfigT a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GenericPackageDescription -> ConfigT GenericPackageDescription)
-> IO GenericPackageDescription
-> ConfigT GenericPackageDescription
forall a b. (a -> b) -> a -> b
$ Verbosity -> FilePath -> IO GenericPackageDescription
readGenericPackageDescription Verbosity
normal FilePath
cabalFilePath
  let ls :: [PackageCheck]
ls = GenericPackageDescription
-> Maybe PackageDescription -> [PackageCheck]
checkPackage GenericPackageDescription
gpd Maybe PackageDescription
forall a. Maybe a
Nothing
  [PackageCheck] -> (PackageCheck -> ConfigT ()) -> ConfigT ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [PackageCheck]
ls ((PackageCheck -> ConfigT ()) -> ConfigT ())
-> (PackageCheck -> ConfigT ()) -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ \PackageCheck
l -> do
    Issue -> ConfigT ()
forall (m :: * -> *). MonadIssue m => Issue -> m ()
injectIssue
      ( Issue
          { issueMessage :: Text
issueMessage = Text
"Invalid package: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PackageCheck -> Text
forall b a. (Show a, IsString b) => a -> b
show PackageCheck
l,
            issueSeverity :: Severity
issueSeverity = if PackageCheck -> Bool
isError PackageCheck
l then Severity
SeverityError else Severity
SeverityWarning,
            issueTopic :: Text
issueTopic = Pkg -> Text
pkgMemberId Pkg
pkg,
            issueDetails :: Maybe IssueDetails
issueDetails = IssueDetails -> Maybe IssueDetails
forall a. a -> Maybe a
Just GenericIssue {issueFile :: FilePath
issueFile = FilePath
cabalFilePath}
          }
      )
  [Status] -> ConfigT [Status]
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((PackageCheck -> Status) -> [PackageCheck] -> [Status]
forall a b. (a -> b) -> [a] -> [b]
map PackageCheck -> Status
toStatus [PackageCheck]
ls)

syncCabal :: Pkg -> ConfigT Status
syncCabal :: Pkg -> ConfigT Status
syncCabal Pkg
pkg = do
  let programName :: ProgramName
programName = FilePath -> ProgramName
ProgramName (FilePath -> ProgramName) -> FilePath -> ProgramName
forall a b. (a -> b) -> a -> b
$ PkgName -> FilePath
forall a. ToString a => a -> FilePath
toString (PkgName -> FilePath) -> PkgName -> FilePath
forall a b. (a -> b) -> a -> b
$ Pkg -> PkgName
pkgName Pkg
pkg
  let ops :: Options
ops = FilePath -> Options -> Options
setTarget (Pkg -> FilePath
pkgYamlPath Pkg
pkg) (Options -> Options) -> Options -> Options
forall a b. (a -> b) -> a -> b
$ ProgramName -> Options -> Options
setProgramName ProgramName
programName Options
defaultOptions
  Result {FilePath
[FilePath]
Status
resultWarnings :: [FilePath]
resultCabalFile :: FilePath
resultStatus :: Status
resultStatus :: Result -> Status
resultCabalFile :: Result -> FilePath
resultWarnings :: Result -> [FilePath]
..} <- IO Result -> ConfigT Result
forall a. IO a -> ConfigT a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> ConfigT Result) -> IO Result -> ConfigT Result
forall a b. (a -> b) -> a -> b
$ Options -> IO Result
hpackResult Options
ops
  [Status]
ls <- Pkg -> FilePath -> ConfigT [Status]
validateHackage Pkg
pkg FilePath
resultCabalFile

  Status
s <- case Status
resultStatus of
    Status
H.OutputUnchanged -> Status -> ConfigT Status
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
Checked
    Status
_ -> Status -> ConfigT Status
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
Updated
  Status -> ConfigT Status
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Status -> ConfigT Status) -> Status -> ConfigT Status
forall a b. (a -> b) -> a -> b
$ [Status] -> Status
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (Status
s Status -> [Status] -> [Status]
forall a. a -> [a] -> [a]
: [Status]
ls)