{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HWM.Integrations.Toolchain.Package
  ( Package (..),
    BoundsDiff,
    syncPackages,
    deriveRegistry,
    packageDiffs,
    validatePackage,
  )
where

import Control.Monad.Except (MonadError (..))
import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON)
import qualified Data.Map as Map
import qualified Data.Set as Set
import HWM.Core.Formatting (Color (..), Format (..), chalk, displayStatus, genMaxLen, padDots, subPathSign)
import HWM.Core.Pkg (Pkg (..), PkgName, pkgMemberId, pkgYamlPath)
import HWM.Core.Result (Issue (..), IssueDetails (..), MonadIssue (..), Severity (..))
import HWM.Core.Version (Version)
import HWM.Domain.ConfigT (ConfigT, askVersion, askWorkspaceGroups)
import HWM.Domain.Dependencies (Dependencies, Dependency (Dependency), DependencyGraph (DependencyGraph), externalRegistry, normalizeDependencies, toDependencyList)
import HWM.Domain.Workspace (memberPkgs, pkgGroupName)
import HWM.Integrations.Toolchain.Cabal (syncCabal)
import HWM.Integrations.Toolchain.Lib
  ( BoundsDiff,
    Libraries,
    Library (..),
    checkDependencies,
    checkLibraries,
    checkLibrary,
    updateDependencies,
    updateLibraries,
    updateLibrary,
  )
import HWM.Runtime.Files (aesonYAMLOptions, readYaml, rewrite_, statusM)
import HWM.Runtime.UI (putLine, sectionWorkspace)
import Relude

data Package = Package
  { Package -> PkgName
name :: PkgName,
    Package -> Version
version :: Version,
    Package -> Maybe Library
library :: Maybe Library,
    Package -> Dependencies
dependencies :: Dependencies,
    Package -> Maybe Libraries
tests :: Maybe Libraries,
    Package -> Maybe Libraries
executables :: Maybe Libraries,
    Package -> Maybe Libraries
benchmarks :: Maybe Libraries,
    Package -> Maybe Libraries
internalLibraries :: Maybe Libraries,
    Package -> Maybe Libraries
foreignLibraries :: Maybe Libraries
  }
  deriving (Int -> Package -> ShowS
[Package] -> ShowS
Package -> String
(Int -> Package -> ShowS)
-> (Package -> String) -> ([Package] -> ShowS) -> Show Package
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Package -> ShowS
showsPrec :: Int -> Package -> ShowS
$cshow :: Package -> String
show :: Package -> String
$cshowList :: [Package] -> ShowS
showList :: [Package] -> ShowS
Show, (forall x. Package -> Rep Package x)
-> (forall x. Rep Package x -> Package) -> Generic Package
forall x. Rep Package x -> Package
forall x. Package -> Rep Package x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Package -> Rep Package x
from :: forall x. Package -> Rep Package x
$cto :: forall x. Rep Package x -> Package
to :: forall x. Rep Package x -> Package
Generic)

instance FromJSON Package where
  parseJSON :: Value -> Parser Package
parseJSON = Options -> Value -> Parser Package
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON Options
aesonYAMLOptions

instance ToJSON Package where
  toJSON :: Package -> Value
toJSON = Options -> Package -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON Options
aesonYAMLOptions

updatePackage :: Pkg -> Maybe Package -> ConfigT Package
updatePackage :: Pkg -> Maybe Package -> ConfigT Package
updatePackage Pkg
pkg Maybe Package
Nothing =
  Issue -> ConfigT Package
forall a. Issue -> ConfigT a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
    (Issue -> ConfigT Package) -> Issue -> ConfigT Package
forall a b. (a -> b) -> a -> b
$ Issue
      { issueTopic :: Text
issueTopic = Pkg -> Text
pkgMemberId Pkg
pkg,
        issueMessage :: Text
issueMessage = Text
"could not find package file",
        issueSeverity :: Severity
issueSeverity = Severity
SeverityWarning,
        issueDetails :: Maybe IssueDetails
issueDetails = IssueDetails -> Maybe IssueDetails
forall a. a -> Maybe a
Just GenericIssue {issueFile :: String
issueFile = Pkg -> String
pkgYamlPath Pkg
pkg}
      }
updatePackage Pkg
pkg (Just Package {Maybe Libraries
Maybe Library
Version
PkgName
Dependencies
name :: Package -> PkgName
version :: Package -> Version
library :: Package -> Maybe Library
dependencies :: Package -> Dependencies
tests :: Package -> Maybe Libraries
executables :: Package -> Maybe Libraries
benchmarks :: Package -> Maybe Libraries
internalLibraries :: Package -> Maybe Libraries
foreignLibraries :: Package -> Maybe Libraries
name :: PkgName
version :: Version
library :: Maybe Library
dependencies :: Dependencies
tests :: Maybe Libraries
executables :: Maybe Libraries
benchmarks :: Maybe Libraries
internalLibraries :: Maybe Libraries
foreignLibraries :: Maybe Libraries
..}) = do
  let path :: String
path = Pkg -> String
pkgYamlPath Pkg
pkg
      pkgId :: Text
pkgId = Pkg -> Text
pkgMemberId Pkg
pkg
  Maybe Library
newLibrary <- (Library -> ConfigT Library)
-> Maybe Library -> ConfigT (Maybe Library)
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) -> Maybe a -> f (Maybe b)
traverse (Text -> Text -> String -> Library -> ConfigT Library
updateLibrary Text
pkgId Text
"library" String
path) Maybe Library
library
  Maybe Libraries
newTests <- Text
-> Text -> String -> Maybe Libraries -> ConfigT (Maybe Libraries)
updateLibraries Text
pkgId Text
"tests" String
path Maybe Libraries
tests
  Maybe Libraries
newExecutables <- Text
-> Text -> String -> Maybe Libraries -> ConfigT (Maybe Libraries)
updateLibraries Text
pkgId Text
"executables" String
path Maybe Libraries
executables
  Maybe Libraries
newBenchmarks <- Text
-> Text -> String -> Maybe Libraries -> ConfigT (Maybe Libraries)
updateLibraries Text
pkgId Text
"benchmarks" String
path Maybe Libraries
benchmarks
  Maybe Libraries
newInternalLibraries <- Text
-> Text -> String -> Maybe Libraries -> ConfigT (Maybe Libraries)
updateLibraries Text
pkgId Text
"internal" String
path Maybe Libraries
internalLibraries
  Maybe Libraries
newForeignLibraries <- Text
-> Text -> String -> Maybe Libraries -> ConfigT (Maybe Libraries)
updateLibraries Text
pkgId Text
"foreign" String
path Maybe Libraries
foreignLibraries
  Dependencies
newDependencies <- Text -> Text -> String -> Dependencies -> ConfigT Dependencies
updateDependencies Text
pkgId Text
"dependencies" String
path Dependencies
dependencies
  Version
newVersion <- ConfigT Version
forall env (m :: * -> *).
(MonadReader env m, Has env Version) =>
m Version
askVersion
  Package -> ConfigT Package
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Package -> ConfigT Package) -> Package -> ConfigT Package
forall a b. (a -> b) -> a -> b
$ Package
      { version :: Version
version = Version
newVersion,
        library :: Maybe Library
library = Maybe Library
newLibrary,
        tests :: Maybe Libraries
tests = Maybe Libraries
newTests,
        executables :: Maybe Libraries
executables = Maybe Libraries
newExecutables,
        benchmarks :: Maybe Libraries
benchmarks = Maybe Libraries
newBenchmarks,
        internalLibraries :: Maybe Libraries
internalLibraries = Maybe Libraries
newInternalLibraries,
        foreignLibraries :: Maybe Libraries
foreignLibraries = Maybe Libraries
newForeignLibraries,
        dependencies :: Dependencies
dependencies = Dependencies
newDependencies,
        PkgName
name :: PkgName
name :: PkgName
..
      }

-- | Determine whether a package already matches the expected configuration.
packageDiffs :: Text -> FilePath -> Package -> ConfigT [BoundsDiff]
packageDiffs :: Text -> String -> Package -> ConfigT [BoundsDiff]
packageDiffs Text
memberId String
path Package {Maybe Libraries
Maybe Library
Version
PkgName
Dependencies
name :: Package -> PkgName
version :: Package -> Version
library :: Package -> Maybe Library
dependencies :: Package -> Dependencies
tests :: Package -> Maybe Libraries
executables :: Package -> Maybe Libraries
benchmarks :: Package -> Maybe Libraries
internalLibraries :: Package -> Maybe Libraries
foreignLibraries :: Package -> Maybe Libraries
name :: PkgName
version :: Version
library :: Maybe Library
dependencies :: Dependencies
tests :: Maybe Libraries
executables :: Maybe Libraries
benchmarks :: Maybe Libraries
internalLibraries :: Maybe Libraries
foreignLibraries :: Maybe Libraries
..} = do
  [BoundsDiff]
depsDiffs <- Text -> Text -> String -> Dependencies -> ConfigT [BoundsDiff]
checkDependencies Text
memberId Text
"dependencies" String
path Dependencies
dependencies
  [BoundsDiff]
libraryDiffs <- Text -> Maybe Library -> ConfigT [BoundsDiff]
traverseLibrary Text
"library" Maybe Library
library
  [BoundsDiff]
testsDiffs <- Text -> Maybe Libraries -> ConfigT [BoundsDiff]
traverseLibraries Text
"tests" Maybe Libraries
tests
  [BoundsDiff]
executablesDiffs <- Text -> Maybe Libraries -> ConfigT [BoundsDiff]
traverseLibraries Text
"executables" Maybe Libraries
executables
  [BoundsDiff]
benchmarksDiffs <- Text -> Maybe Libraries -> ConfigT [BoundsDiff]
traverseLibraries Text
"benchmarks" Maybe Libraries
benchmarks
  [BoundsDiff]
internalDiffs <- Text -> Maybe Libraries -> ConfigT [BoundsDiff]
traverseLibraries Text
"internal" Maybe Libraries
internalLibraries
  [BoundsDiff]
foreignDiffs <- Text -> Maybe Libraries -> ConfigT [BoundsDiff]
traverseLibraries Text
"foreign" Maybe Libraries
foreignLibraries
  [BoundsDiff] -> ConfigT [BoundsDiff]
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ( [BoundsDiff]
depsDiffs
        [BoundsDiff] -> [BoundsDiff] -> [BoundsDiff]
forall a. Semigroup a => a -> a -> a
<> [BoundsDiff]
libraryDiffs
        [BoundsDiff] -> [BoundsDiff] -> [BoundsDiff]
forall a. Semigroup a => a -> a -> a
<> [BoundsDiff]
testsDiffs
        [BoundsDiff] -> [BoundsDiff] -> [BoundsDiff]
forall a. Semigroup a => a -> a -> a
<> [BoundsDiff]
executablesDiffs
        [BoundsDiff] -> [BoundsDiff] -> [BoundsDiff]
forall a. Semigroup a => a -> a -> a
<> [BoundsDiff]
benchmarksDiffs
        [BoundsDiff] -> [BoundsDiff] -> [BoundsDiff]
forall a. Semigroup a => a -> a -> a
<> [BoundsDiff]
internalDiffs
        [BoundsDiff] -> [BoundsDiff] -> [BoundsDiff]
forall a. Semigroup a => a -> a -> a
<> [BoundsDiff]
foreignDiffs
    )
  where
    traverseLibrary :: Text -> Maybe Library -> ConfigT [BoundsDiff]
    traverseLibrary :: Text -> Maybe Library -> ConfigT [BoundsDiff]
traverseLibrary Text
_ Maybe Library
Nothing = [BoundsDiff] -> ConfigT [BoundsDiff]
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    traverseLibrary Text
scope (Just Library
lib) = Text -> Text -> String -> Library -> ConfigT [BoundsDiff]
checkLibrary Text
memberId Text
scope String
path Library
lib

    traverseLibraries :: Text -> Maybe Libraries -> ConfigT [BoundsDiff]
    traverseLibraries :: Text -> Maybe Libraries -> ConfigT [BoundsDiff]
traverseLibraries Text
_ Maybe Libraries
Nothing = [BoundsDiff] -> ConfigT [BoundsDiff]
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    traverseLibraries Text
scope (Just Libraries
libs) = Text -> Text -> String -> Libraries -> ConfigT [BoundsDiff]
checkLibraries Text
memberId Text
scope String
path Libraries
libs

syncPackages :: ConfigT ()
syncPackages :: ConfigT ()
syncPackages = ConfigT () -> ConfigT ()
forall (m :: * -> *) a. MonadUI m => m a -> m ()
sectionWorkspace (ConfigT () -> ConfigT ()) -> ConfigT () -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ do
  [WorkspaceGroup]
groups <- ConfigT [WorkspaceGroup]
askWorkspaceGroups
  [WorkspaceGroup] -> (WorkspaceGroup -> ConfigT ()) -> ConfigT ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [WorkspaceGroup]
groups ((WorkspaceGroup -> ConfigT ()) -> ConfigT ())
-> (WorkspaceGroup -> ConfigT ()) -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ \WorkspaceGroup
g -> do
    Text -> ConfigT ()
forall (m :: * -> *). MonadUI m => Text -> m ()
putLine Text
""
    Text -> ConfigT ()
forall (m :: * -> *). MonadUI m => Text -> m ()
putLine (Text -> ConfigT ()) -> Text -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ Text
"• " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Color -> Text -> Text
chalk Color
Bold (WorkspaceGroup -> Text
pkgGroupName WorkspaceGroup
g)
    [Pkg]
dirs <- WorkspaceGroup -> ConfigT [Pkg]
forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
WorkspaceGroup -> m [Pkg]
memberPkgs WorkspaceGroup
g
    let maxLen :: Int
maxLen = [Text] -> Int
genMaxLen ((Pkg -> Text) -> [Pkg] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Pkg -> Text
pkgMemberId [Pkg]
dirs)
    [Pkg] -> (Pkg -> ConfigT ()) -> ConfigT ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Pkg]
dirs ((Pkg -> ConfigT ()) -> ConfigT ())
-> (Pkg -> ConfigT ()) -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ \Pkg
pkg -> do
      let path :: String
path = Pkg -> String
pkgYamlPath Pkg
pkg
      Status
package <- String -> ConfigT () -> ConfigT Status
forall (m :: * -> *) t. MonadIO m => String -> m t -> m Status
statusM String
path (String -> (Maybe Package -> ConfigT Package) -> ConfigT ()
forall (m :: * -> *) t.
(MonadError Issue m, MonadIO m, FromJSON t, ToJSON t) =>
String -> (Maybe t -> m t) -> m ()
rewrite_ String
path (Pkg -> Maybe Package -> ConfigT Package
updatePackage Pkg
pkg))
      Status
cabal <- Pkg -> ConfigT Status
syncCabal Pkg
pkg
      Text -> ConfigT ()
forall (m :: * -> *). MonadUI m => Text -> m ()
putLine
        ( Text
subPathSign
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
padDots Int
maxLen (Pkg -> Text
pkgMemberId Pkg
pkg)
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [(Text, Status)] -> Text
displayStatus [(Text
"pkg", Status
package), (Text
"cabal", Status
cabal)]
        )

collectPackageDependencies :: Package -> [Dependency]
collectPackageDependencies :: Package -> [Dependency]
collectPackageDependencies Package {Maybe Libraries
Maybe Library
Version
PkgName
Dependencies
name :: Package -> PkgName
version :: Package -> Version
library :: Package -> Maybe Library
dependencies :: Package -> Dependencies
tests :: Package -> Maybe Libraries
executables :: Package -> Maybe Libraries
benchmarks :: Package -> Maybe Libraries
internalLibraries :: Package -> Maybe Libraries
foreignLibraries :: Package -> Maybe Libraries
name :: PkgName
version :: Version
library :: Maybe Library
dependencies :: Dependencies
tests :: Maybe Libraries
executables :: Maybe Libraries
benchmarks :: Maybe Libraries
internalLibraries :: Maybe Libraries
foreignLibraries :: Maybe Libraries
..} =
  [Dependency] -> [Dependency]
normalizeDependencies
    ( Dependencies -> [Dependency]
toDependencyList Dependencies
dependencies
        [Dependency] -> [Dependency] -> [Dependency]
forall a. Semigroup a => a -> a -> a
<> Maybe Library -> [Dependency]
collectLibrary Maybe Library
library
        [Dependency] -> [Dependency] -> [Dependency]
forall a. Semigroup a => a -> a -> a
<> Maybe Libraries -> [Dependency]
collectLibraries Maybe Libraries
tests
        [Dependency] -> [Dependency] -> [Dependency]
forall a. Semigroup a => a -> a -> a
<> Maybe Libraries -> [Dependency]
collectLibraries Maybe Libraries
executables
        [Dependency] -> [Dependency] -> [Dependency]
forall a. Semigroup a => a -> a -> a
<> Maybe Libraries -> [Dependency]
collectLibraries Maybe Libraries
benchmarks
        [Dependency] -> [Dependency] -> [Dependency]
forall a. Semigroup a => a -> a -> a
<> Maybe Libraries -> [Dependency]
collectLibraries Maybe Libraries
internalLibraries
        [Dependency] -> [Dependency] -> [Dependency]
forall a. Semigroup a => a -> a -> a
<> Maybe Libraries -> [Dependency]
collectLibraries Maybe Libraries
foreignLibraries
    )
  where
    collectLibrary :: Maybe Library -> [Dependency]
    collectLibrary :: Maybe Library -> [Dependency]
collectLibrary Maybe Library
Nothing = []
    collectLibrary (Just Library {dependencies :: Library -> Maybe Dependencies
dependencies = Maybe Dependencies
Nothing}) = []
    collectLibrary (Just Library {dependencies :: Library -> Maybe Dependencies
dependencies = Just Dependencies
deps}) = Dependencies -> [Dependency]
toDependencyList Dependencies
deps

    collectLibraries :: Maybe Libraries -> [Dependency]
    collectLibraries :: Maybe Libraries -> [Dependency]
collectLibraries Maybe Libraries
Nothing = []
    collectLibraries (Just Libraries
libs) = (Library -> [Dependency]) -> [Library] -> [Dependency]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Maybe Library -> [Dependency]
collectLibrary (Maybe Library -> [Dependency])
-> (Library -> Maybe Library) -> Library -> [Dependency]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Library -> Maybe Library
forall a. a -> Maybe a
Just) (Libraries -> [Library]
forall k a. Map k a -> [a]
Map.elems Libraries
libs)

deriveRegistry :: (Monad m, MonadError Issue m, MonadIO m) => [Pkg] -> m (Dependencies, DependencyGraph)
deriveRegistry :: forall (m :: * -> *).
(Monad m, MonadError Issue m, MonadIO m) =>
[Pkg] -> m (Dependencies, DependencyGraph)
deriveRegistry [Pkg]
pkgs = do
  [Package]
packages <- (Pkg -> m Package) -> [Pkg] -> m [Package]
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 (String -> m Package
forall (m :: * -> *) a.
(MonadError Issue m, MonadIO m, FromJSON a) =>
String -> m a
readYaml (String -> m Package) -> (Pkg -> String) -> Pkg -> m Package
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pkg -> String
pkgYamlPath) [Pkg]
pkgs
  let graph :: DependencyGraph
graph = [Package] -> DependencyGraph
deriveDependencyGraph [Package]
packages
  let deps :: Dependencies
deps = [PkgName] -> [Dependency] -> Dependencies
externalRegistry ((Pkg -> PkgName) -> [Pkg] -> [PkgName]
forall a b. (a -> b) -> [a] -> [b]
map Pkg -> PkgName
pkgName [Pkg]
pkgs) ([Dependency] -> Dependencies) -> [Dependency] -> Dependencies
forall a b. (a -> b) -> a -> b
$ (Package -> [Dependency]) -> [Package] -> [Dependency]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Package -> [Dependency]
collectPackageDependencies [Package]
packages
  (Dependencies, DependencyGraph)
-> m (Dependencies, DependencyGraph)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dependencies
deps, DependencyGraph
graph)

collectCriticalDependencies :: Package -> [Dependency]
collectCriticalDependencies :: Package -> [Dependency]
collectCriticalDependencies Package {Maybe Libraries
Maybe Library
Version
PkgName
Dependencies
name :: Package -> PkgName
version :: Package -> Version
library :: Package -> Maybe Library
dependencies :: Package -> Dependencies
tests :: Package -> Maybe Libraries
executables :: Package -> Maybe Libraries
benchmarks :: Package -> Maybe Libraries
internalLibraries :: Package -> Maybe Libraries
foreignLibraries :: Package -> Maybe Libraries
name :: PkgName
version :: Version
library :: Maybe Library
dependencies :: Dependencies
tests :: Maybe Libraries
executables :: Maybe Libraries
benchmarks :: Maybe Libraries
internalLibraries :: Maybe Libraries
foreignLibraries :: Maybe Libraries
..} = [Dependency] -> [Dependency]
normalizeDependencies (Dependencies -> [Dependency]
toDependencyList Dependencies
dependencies [Dependency] -> [Dependency] -> [Dependency]
forall a. Semigroup a => a -> a -> a
<> Maybe Library -> [Dependency]
collectLibrary Maybe Library
library)
  where
    collectLibrary :: Maybe Library -> [Dependency]
    collectLibrary :: Maybe Library -> [Dependency]
collectLibrary Maybe Library
Nothing = []
    collectLibrary (Just Library {dependencies :: Library -> Maybe Dependencies
dependencies = Maybe Dependencies
Nothing}) = []
    collectLibrary (Just Library {dependencies :: Library -> Maybe Dependencies
dependencies = Just Dependencies
deps}) = Dependencies -> [Dependency]
toDependencyList Dependencies
deps

deriveDependencyGraph :: [Package] -> DependencyGraph
deriveDependencyGraph :: [Package] -> DependencyGraph
deriveDependencyGraph [Package]
pkgs = Map PkgName [PkgName] -> DependencyGraph
DependencyGraph (Map PkgName [PkgName] -> DependencyGraph)
-> Map PkgName [PkgName] -> DependencyGraph
forall a b. (a -> b) -> a -> b
$ [(PkgName, [PkgName])] -> Map PkgName [PkgName]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Package -> PkgName
name Package
pkg, Package -> [PkgName]
internalDeps Package
pkg) | Package
pkg <- [Package]
pkgs]
  where
    internalNames :: Set PkgName
internalNames = [PkgName] -> Set PkgName
forall a. Ord a => [a] -> Set a
Set.fromList ((Package -> PkgName) -> [Package] -> [PkgName]
forall a b. (a -> b) -> [a] -> [b]
map Package -> PkgName
name [Package]
pkgs)
    internalDeps :: Package -> [PkgName]
internalDeps Package
pkg = (Dependency -> Maybe PkgName) -> [Dependency] -> [PkgName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Dependency -> Maybe PkgName
selectInternal (Package -> [Dependency]
collectCriticalDependencies Package
pkg)
    selectInternal :: Dependency -> Maybe PkgName
selectInternal (Dependency PkgName
depName Bounds
_) =
      if PkgName -> Set PkgName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member PkgName
depName Set PkgName
internalNames then PkgName -> Maybe PkgName
forall a. a -> Maybe a
Just PkgName
depName else Maybe PkgName
forall a. Maybe a
Nothing

-- | Validate package against expected version and configuration
validatePackage :: Pkg -> ConfigT ()
validatePackage :: Pkg -> ConfigT ()
validatePackage Pkg
pkg = do
  let path :: String
path = Pkg -> String
pkgYamlPath Pkg
pkg
      pkgId :: Text
pkgId = Pkg -> Text
pkgMemberId Pkg
pkg

  Package
currentPkg <- String -> ConfigT Package
forall (m :: * -> *) a.
(MonadError Issue m, MonadIO m, FromJSON a) =>
String -> m a
readYaml String
path :: ConfigT Package
  Version
expectedVersion <- ConfigT Version
forall env (m :: * -> *).
(MonadReader env m, Has env Version) =>
m Version
askVersion

  let currentVersion :: Version
currentVersion = Package -> Version
version Package
currentPkg
      versionMatch :: Bool
versionMatch = Version
currentVersion Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
expectedVersion
  [BoundsDiff]
diffs <- Text -> String -> Package -> ConfigT [BoundsDiff]
packageDiffs Text
pkgId String
path Package
currentPkg

  Bool -> ConfigT () -> ConfigT ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
versionMatch
    (ConfigT () -> ConfigT ()) -> ConfigT () -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ Issue -> ConfigT ()
forall (m :: * -> *). MonadIssue m => Issue -> m ()
injectIssue
      Issue
        { issueTopic :: Text
issueTopic = Text
pkgId,
          issueMessage :: Text
issueMessage = Text
"version mismatch: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Version -> Text
forall a. Format a => a -> Text
format Version
currentVersion Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" → " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Version -> Text
forall a. Format a => a -> Text
format Version
expectedVersion,
          issueSeverity :: Severity
issueSeverity = Severity
SeverityWarning,
          issueDetails :: Maybe IssueDetails
issueDetails = IssueDetails -> Maybe IssueDetails
forall a. a -> Maybe a
Just GenericIssue {issueFile :: String
issueFile = String
path}
        }

  Bool -> ConfigT () -> ConfigT ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([BoundsDiff] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BoundsDiff]
diffs)
    (ConfigT () -> ConfigT ()) -> ConfigT () -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ Issue -> ConfigT ()
forall (m :: * -> *). MonadIssue m => Issue -> m ()
injectIssue
      Issue
        { issueTopic :: Text
issueTopic = Text
pkgId,
          issueMessage :: Text
issueMessage =
            let baseMsg :: Text
baseMsg =
                  if Bool
versionMatch
                    then Text
"package out of sync (run 'hwm sync' to fix)"
                    else Text
"package configuration diverged from expected (run 'hwm sync')"
                diffCount :: Int
diffCount = [BoundsDiff] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BoundsDiff]
diffs
                countSuffix :: Text
countSuffix = if Int
diffCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Text
" (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
diffCount Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" dependencies differ)" else Text
""
             in Text
baseMsg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
countSuffix,
          issueSeverity :: Severity
issueSeverity = Severity
SeverityWarning,
          issueDetails :: Maybe IssueDetails
issueDetails =
            IssueDetails -> Maybe IssueDetails
forall a. a -> Maybe a
Just
              DependencyIssue
                { issueDependencies :: [(Text, Text, Text, Text)]
issueDependencies = (BoundsDiff -> (Text, Text, Text, Text))
-> [BoundsDiff] -> [(Text, Text, Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
scope, PkgName
depName, Bounds
actual, Bounds
expected) -> (Text
scope, PkgName -> Text
forall a. Format a => a -> Text
format PkgName
depName, Bounds -> Text
forall a. Format a => a -> Text
format Bounds
actual, Bounds -> Text
forall a. Format a => a -> Text
format Bounds
expected)) [BoundsDiff]
diffs,
                  issueFile :: String
issueFile = String
path
                }
        }