{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
-- | Representation of a concrete build plan, and how to generate a new one
-- based on constraints.
module Stackage.BuildPlan
( BuildPlan (..)
, PackagePlan (..)
, newBuildPlan
, makeToolMap
, getLatestAllowedPlans
) where
import Control.Monad.State.Strict (execState, get, put)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Distribution.Compiler
import Stackage.BuildConstraints
import Stackage.GithubPings
import Stackage.PackageDescription
import Stackage.PackageIndex
import Stackage.Prelude
-- | Make a build plan given these package set and build constraints.
newBuildPlan :: MonadIO m
=> Either SomeException Text -- ^ all-cabal-hashes repo commit
-> Map PackageName PackagePlan -- ^ latest allowed plans
-> Map PackageName Version -- ^ latest package version available
-> BuildConstraints
-> m BuildPlan
newBuildPlan eallCabalHashesCommit packagesOrig packagesLatest bc@BuildConstraints {..} = liftIO $ do
unless (Map.null packagesLatest) $ do
let unknownPackages = bcPackages `Set.difference` Map.keysSet packagesLatest
forM_ (NE.nonEmpty $ setToList unknownPackages) $ \pkgNames -> do
putStrLn "Couldn't find the following package names in the package index:"
forM_ pkgNames $ \p -> do
let mmaintainer = unMaintainer <$> pcMaintainer (bcPackageConstraints p)
maintainerT = fromMaybe "" ((++ ")") . (" (" ++) <$> mmaintainer)
putStrLn ("- " ++ display p ++ maintainerT)
putStrLn "Please check them for typos."
error "Exiting due to unknown packages"
let newReleased = mapMaybe checkReleased $ mapToList bcTellMeWhenItsReleased
checkReleased (name, expectedVersion) =
case lookup name packagesLatest of
Nothing -> Just $ concat
[ "No package version found for "
, display name
, ", expected version "
, display expectedVersion
]
Just latestVersion
| latestVersion == expectedVersion -> Nothing
| otherwise -> Just $ concat
[ "Mismatched package version found for "
, display name
, ", expected version "
, display expectedVersion
, ", latest version "
, display latestVersion
]
unless (null newReleased) $ do
putStrLn "The following packages have new releases (see tell-me-when-its-released):"
mapM_ putStrLn newReleased
error "Exiting due to presence of new releases"
let toolMap :: Map ExeName (Set PackageName)
toolMap = makeToolMap bcBuildToolOverrides packagesOrig
packages = populateUsers $ removeUnincluded bc toolMap packagesOrig
toolNames :: [ExeName]
toolNames = concatMap (Map.keys . sdTools . ppDesc) packages
tools <- topologicalSortTools toolMap $ mapFromList $ do
exeName <- toolNames
guard $ exeName `notMember` siCoreExecutables
packageName <- maybe mempty setToList $ lookup exeName toolMap
packagePlan <- maybeToList $ lookup packageName packagesOrig
return (packageName, packagePlan)
-- FIXME topologically sort packages? maybe just leave that to the build phase
return BuildPlan
{ bpSystemInfo = bcSystemInfo
, bpTools = tools
, bpPackages = packages
, bpGithubUsers = bcGithubUsers
, bpBuildToolOverrides = bcBuildToolOverrides
, bpAllCabalHashesCommit = either (const Nothing) Just eallCabalHashesCommit
, bpNoRevisions = bcNoRevisions
, bpCabalFormatVersion = bcCabalFormatVersion
}
where
SystemInfo {..} = bcSystemInfo
makeToolMap :: Map Text (Set Text) -- ^ build tool overrides
-> Map PackageName PackagePlan
-> Map ExeName (Set PackageName)
makeToolMap overrides =
(overrides' ++) . unionsWith (++) . map go . mapToList
where
go (packageName, pp) =
foldMap go' $ sdProvidedExes $ ppDesc pp
where
go' exeName = singletonMap exeName (singletonSet packageName)
overrides' :: Map ExeName (Set PackageName)
overrides' = Map.mapKeysWith (++) ExeName
$ fmap (Set.map (mkPackageName . unpack)) overrides
topologicalSortTools :: MonadThrow m
=> Map ExeName (Set PackageName)
-> Map PackageName PackagePlan
-> m (Vector (PackageName, Version))
topologicalSortTools toolMap = topologicalSort
ppVersion
(concatMap (fromMaybe mempty . flip lookup toolMap) . Map.keys . sdTools . ppDesc)
-- | Include only packages which are dependencies of the required packages and
-- their build tools.
removeUnincluded :: BuildConstraints
-> Map ExeName (Set PackageName)
-> Map PackageName PackagePlan
-> Map PackageName PackagePlan
removeUnincluded BuildConstraints {..} toolMap orig =
mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig
where
SystemInfo {..} = bcSystemInfo
included :: Set PackageName
included = flip execState mempty $ mapM_ add bcPackages
add name = do
inc <- get
when (name `notMember` inc) $ do
put $ insertSet name inc
case lookup name orig of
Nothing -> return ()
Just pb -> do
mapM_ add $ Map.keys $ sdPackages $ ppDesc pb
forM_ (Map.keys $ sdTools $ ppDesc pb) $
\exeName -> when (exeName `notMember` siCoreExecutables)
$ mapM_ add $ fromMaybe mempty $ lookup exeName toolMap
populateUsers :: Map PackageName PackagePlan
-> Map PackageName PackagePlan
populateUsers orig =
mapWithKey go orig
where
go name pb = pb { ppUsers = foldMap (go2 name) (mapToList orig) }
go2 dep (user, pb)
| dep `member` sdPackages (ppDesc pb) = singletonSet user
| otherwise = mempty
-- | Check whether the given package/version combo meets the constraints
-- currently in place.
isAllowed :: BuildConstraints
-> PackageName -> Version -> Bool
isAllowed bc = \name version ->
case lookup name $ siCorePackages $ bcSystemInfo bc of
Just _ -> False -- never reinstall a core package
Nothing -> withinRange version $ pcVersionRange $ bcPackageConstraints bc name
mkPackagePlan :: MonadThrow m
=> BuildConstraints
-> SimplifiedPackageDescription
-> m PackagePlan
mkPackagePlan bc spd = do
ppDesc <- toSimpleDesc CheckCond {..} spd
return PackagePlan {..}
where
name = spdName spd
ppVersion = spdVersion spd
ppCabalFileInfo = Just $ spdCabalFileInfo spd
ppGithubPings = applyGithubMapping bc $ spdGithubPings spd
ppConstraints = onlyRelevantFlags $ bcPackageConstraints bc name
ppUsers = mempty -- must be filled in later
ppSourceUrl = Nothing
-- Only include flags that are actually provided by the package. For more
-- information, see: https://github.com/fpco/stackage-curator/issues/11
onlyRelevantFlags :: PackageConstraints -> PackageConstraints
onlyRelevantFlags pc = pc
{ pcFlagOverrides = pcFlagOverrides pc `intersection`
spdPackageFlags spd
}
ccPackageName = name
ccOS = siOS
ccArch = siArch
ccCompilerFlavor = Distribution.Compiler.GHC
ccCompilerVersion = siGhcVersion
ccFlags = flags
ccIncludeTests = pcTests ppConstraints /= Don'tBuild
ccIncludeBenchmarks = pcBenches ppConstraints /= Don'tBuild
SystemInfo {..} = bcSystemInfo bc
overrides = pcFlagOverrides ppConstraints
flags = mapWithKey overrideFlag $ spdPackageFlags spd
overrideFlag name' defVal = fromMaybe defVal $ lookup name' overrides
getLatestAllowedPlans :: MonadIO m => BuildConstraints -> m (Map PackageName PackagePlan, Map PackageName Version)
getLatestAllowedPlans bc =
getLatestDescriptions
(bcNoRevisions bc)
(isAllowed bc)
(mkPackagePlan bc)