arch-hs-0.16.2: sync/Check.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}

module Check (check, checkNewerVersions, prettyNewerVersions) where

import Check.Options
import Control.Monad (forM)
import Data.List (partition)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Distribution.ArchHs.DepCheck
import Distribution.ArchHs.Exception
import Distribution.ArchHs.Hackage
import Distribution.ArchHs.Internal.Prelude
import Distribution.ArchHs.Name (ghcProvidedPackages)
import Distribution.ArchHs.PP
import Distribution.ArchHs.RDepCheck
import Distribution.ArchHs.Types
import Text.Read (readMaybe)
import Utils

data NewerVersion
  = NewerVersion Version (Maybe CheckResult)
  | UncheckedVersion Version MyException

data CheckResult = CheckResult
  { depFailures :: [DependencyFailure],
    existingDepFailures :: [DependencyFailure],
    rdepFailures :: [ReverseDependencyFailure],
    existingRdepFailures :: [ReverseDependencyFailure]
  }

data ReverseDependencyFailure = ReverseDependencyFailure ArchLinuxName DepSrc VersionRange

check ::
  Members
    [ HackageEnv,
      RawHackageEnv,
      ExtraEnv,
      KnownGHCVersion,
      FlagAssignmentsEnv,
      Trace,
      DependencyRecord,
      WithMyErr,
      Embed IO
    ]
    r =>
  CheckOptions ->
  Sem r ()
check CheckOptions {..} = do
  extra <- ask @ExtraDB
  let providedByGHC = ghcProvidedPackages extra
  linked <- sortPackages optSort optReverse <$> linkedHaskellPackageDescs
  checked <-
    traverse
      ( \(archName, desc, hackageName) -> do
          let rawArchVersion = _version desc
          case simpleParsec rawArchVersion of
            Just archVersion
              | optShowGHCLibs || Set.notMember hackageName providedByGHC -> do
                  hackageVersions <- getNewerVersions hackageName archVersion
                  if null hackageVersions
                    then pure ([], [])
                    else do
                      (newerVersions, skipped) <- checkNewerVersions optDepCheck hackageName archVersion hackageVersions
                      pure ([prettyNewerVersions optVerbose archName (_rawVersion desc) hackageName archVersion newerVersions], skipped)
            _ -> pure ([], [])
      )
      linked
  let result = concatMap fst checked
      skipped = uniqueSkippedReverseDeps $ concatMap snd checked
  mapM_ (printWarn . prettySkippedReverseDep) skipped
  if null result
    then printSuccess "Finished checking"
    else do
      printWarn "Finished checking with inconsistenc(ies):"
      embed $ putDoc $ vcat result <> line

sortPackages :: Maybe CheckSort -> Bool -> [(ArchLinuxName, PkgDesc, PackageName)] -> [(ArchLinuxName, PkgDesc, PackageName)]
sortPackages Nothing reverseOrder = if reverseOrder then reverse else id
sortPackages (Just sortKey) reverseOrder = sortBy comparePackage
  where
    comparePackage (leftName, leftDesc, _) (rightName, rightDesc, _) =
      ( case sortKey of
          SortName -> compareKey False leftName rightName
          SortUpdated -> compareOptional True (_buildDate leftDesc) (_buildDate rightDesc)
          SortPkgrel -> compareOptional False (pkgrelKey $ _rawVersion leftDesc) (pkgrelKey $ _rawVersion rightDesc)
      )
        <> compare leftName rightName

    compareKey :: Ord key => Bool -> key -> key -> Ordering
    compareKey descending left right
      | descending /= reverseOrder = compare right left
      | otherwise = compare left right

    compareOptional :: Ord key => Bool -> Maybe key -> Maybe key -> Ordering
    compareOptional _ Nothing Nothing = EQ
    compareOptional _ Nothing (Just _) = GT
    compareOptional _ (Just _) Nothing = LT
    compareOptional descending (Just left) (Just right) = compareKey descending left right

pkgrelKey :: ArchLinuxVersion -> Maybe [Integer]
pkgrelKey rawVersion = pkgrelSuffix rawVersion >>= traverse readMaybe . splitOn "." . drop 1

checkNewerVersions ::
  Members
    [ ExtraEnv,
      HackageEnv,
      RawHackageEnv,
      KnownGHCVersion,
      FlagAssignmentsEnv,
      Trace,
      DependencyRecord,
      WithMyErr,
      Embed IO
    ]
    r =>
  Bool ->
  PackageName ->
  Version ->
  [Version] ->
  Sem r ([NewerVersion], [SkippedReverseDep])
checkNewerVersions False _ _ hackageVersions =
  pure ((\hackageVersion -> NewerVersion hackageVersion Nothing) <$> hackageVersions, [])
checkNewerVersions True hackageName archVersion hackageVersions = do
  (reverseDeps, skipped) <- reverseDependencyRangesWithSkips hackageName
  currentFailures <- try @MyException $ getCabalIncludingDeprecated hackageName archVersion >>= dependencyFailuresByCategory
  let (currentDepends, currentMakeDepends) = either (const ([], [])) id currentFailures
  newerVersions <-
    forM hackageVersions $ \hackageVersion -> do
      -- Candidates are already filtered by preferred versions. Parse the raw
      -- cabal here so failures use MyException instead of hackage-db's throws.
      eCabal <- try @MyException $ getCabalIncludingDeprecated hackageName hackageVersion
      case eCabal of
        Left err -> pure $ UncheckedVersion hackageVersion err
        Right cabal -> do
          (depends, makeDepends) <- dependencyFailuresByCategory cabal
          let (newDepends, oldDepends) = classifyDependencyFailures currentDepends depends
              (newMakeDepends, oldMakeDepends) = classifyDependencyFailures currentMakeDepends makeDepends
              (newRdepFailures, oldRdepFailures) =
                partition
                  (\(ReverseDependencyFailure _ _ range) -> withinRange archVersion range)
                  (rdepFailureDetails hackageVersion reverseDeps)
          pure $
            NewerVersion
              hackageVersion
              ( Just
                  CheckResult
                    { depFailures = newDepends <> newMakeDepends,
                      existingDepFailures = oldDepends <> oldMakeDepends,
                      rdepFailures = newRdepFailures,
                      existingRdepFailures = oldRdepFailures
                    }
              )
  pure (newerVersions, skipped)

classifyDependencyFailures :: [DependencyFailure] -> [DependencyFailure] -> ([DependencyFailure], [DependencyFailure])
classifyDependencyFailures current = partition ((`Set.notMember` existing) . dependencyFailureName)
  where
    existing = Set.fromList $ dependencyFailureName <$> current

dependencyFailureName :: DependencyFailure -> PackageName
dependencyFailureName = \case
  MissingDependency name _ -> name
  DependencyOutOfRange name _ _ -> name

uniqueSkippedReverseDeps :: [SkippedReverseDep] -> [SkippedReverseDep]
uniqueSkippedReverseDeps =
  Map.elems
    . Map.fromList
    . fmap
      ( \skipped ->
          ( (skippedReverseDepName skipped, show $ skippedReverseDepError skipped),
            skipped
          )
      )

rdepFailureDetails :: Version -> [ReverseDep] -> [ReverseDependencyFailure]
rdepFailureDetails version reverseDeps =
  [ ReverseDependencyFailure name src range
    | ReverseDep name ranges <- reverseDeps,
      (src, range) <- versionFailures (Just version) ranges
    ]

prettyNewerVersions :: Bool -> ArchLinuxName -> ArchLinuxVersion -> PackageName -> Version -> [NewerVersion] -> Doc AnsiStyle
prettyNewerVersions verbose archName rawArchVersion hackageName archVersion hackageVersions =
  base <> verboseDetails
  where
    base =
      annMagneta (pretty (unArchLinuxName archName))
        <+> "in"
        <+> ppExtra
        <+> "has version"
        <+> prettyArchVersion rawArchVersion archVersion
        <> comma
          <+> "but linked"
          <+> annMagneta (pretty (unPackageName hackageName))
          <+> "in"
          <+> annCyan "Hackage"
          <+> (if length hackageVersions == 1 then "has newer version" else "has newer versions")
          <+> hsep (punctuate comma $ prettyNewerVersion <$> hackageVersions)

    verboseDetails =
      case concatMap prettyVerboseNewerVersion hackageVersions of
        details | verbose && not (null details) -> line <> indent 2 (vsep details)
        _ -> mempty

prettyArchVersion :: ArchLinuxVersion -> Version -> Doc AnsiStyle
prettyArchVersion rawVersion archVersion =
  annRed (viaPretty archVersion) <> maybe mempty (annBlue . pretty) (pkgrelSuffix rawVersion)

pkgrelSuffix :: ArchLinuxVersion -> Maybe String
pkgrelSuffix rawVersion =
  case splitOn "-" withoutEpoch of
    _ : pkgrelParts@(_ : _) -> Just $ "-" <> intercalate "-" pkgrelParts
    _ -> Nothing
  where
    withoutEpoch =
      case splitOn ":" rawVersion of
        [_epoch, versionRelease] -> versionRelease
        _ -> rawVersion

prettyNewerVersion :: NewerVersion -> Doc AnsiStyle
prettyNewerVersion (UncheckedVersion version _) =
  annRed $ viaPretty version <+> parens "unchecked: cabal parse failed"
prettyNewerVersion (NewerVersion version Nothing) = annGreen $ viaPretty version
prettyNewerVersion (NewerVersion version (Just CheckResult {depFailures = [], existingDepFailures = [], rdepFailures = [], existingRdepFailures = []})) =
  annGreen $ viaPretty version <+> parens "ok"
prettyNewerVersion (NewerVersion version (Just failures@CheckResult {depFailures = [], rdepFailures = []})) =
  annYellow $ viaPretty version <+> parens ("existing:" <+> prettyCheckFailures failures)
prettyNewerVersion (NewerVersion version (Just failures)) =
  annRed $ viaPretty version <+> parens ("blocked:" <+> prettyCheckFailures failures)

prettyCheckFailures :: CheckResult -> Doc AnsiStyle
prettyCheckFailures CheckResult {..} =
  hsep . punctuate comma $
    ["dep=" <> pretty (length depFailures) | not (null depFailures)]
      <> ["dep-old=" <> pretty (length existingDepFailures) | not (null existingDepFailures)]
      <> ["rdep=" <> pretty (length rdepFailures) | not (null rdepFailures)]
      <> ["rdep-old=" <> pretty (length existingRdepFailures) | not (null existingRdepFailures)]

prettyVerboseNewerVersion :: NewerVersion -> [Doc AnsiStyle]
prettyVerboseNewerVersion (UncheckedVersion version err) =
  [viaPretty version <> colon, indent 2 $ viaShow err]
prettyVerboseNewerVersion (NewerVersion _ Nothing) = []
prettyVerboseNewerVersion (NewerVersion _ (Just CheckResult {depFailures = [], existingDepFailures = [], rdepFailures = [], existingRdepFailures = []})) = []
prettyVerboseNewerVersion (NewerVersion version (Just CheckResult {..})) =
  (viaPretty version <> colon)
    : fmap (indent 2 . prettyDependencyFailure (annRed "dep:")) depFailures
      <> fmap (indent 2 . prettyDependencyFailure (annYellow "dep-old:")) existingDepFailures
      <> fmap (indent 2 . prettyReverseDependencyFailure (annRed "rdep:")) rdepFailures
      <> fmap (indent 2 . prettyReverseDependencyFailure (annYellow "rdep-old:")) existingRdepFailures

prettyDependencyFailure :: Doc AnsiStyle -> DependencyFailure -> Doc AnsiStyle
prettyDependencyFailure label = \case
  MissingDependency name range ->
    label
      <+> viaPretty name
      <+> "requires"
      <+> viaPretty range
      <> comma
      <+> ppExtra
      <+> "missing"
  DependencyOutOfRange name range version ->
    label
      <+> viaPretty name
      <+> "requires"
      <+> viaPretty range
      <> comma
      <+> ppExtra
      <+> "has"
      <+> viaPretty version

prettyReverseDependencyFailure :: Doc AnsiStyle -> ReverseDependencyFailure -> Doc AnsiStyle
prettyReverseDependencyFailure label (ReverseDependencyFailure name src range) =
  label
    <+> pretty (unArchLinuxName name)
    <+> pretty src
    <+> "requires"
    <+> viaPretty range