diff --git a/src/Stack/Build/Installed.hs b/src/Stack/Build/Installed.hs index 13ab0b38b7..99e71755f7 100644 --- a/src/Stack/Build/Installed.hs +++ b/src/Stack/Build/Installed.hs @@ -8,6 +8,7 @@ module Stack.Build.Installed ( InstalledMap , Installed (..) , GetInstalledOpts (..) + , defaultGetInstalledOpts , getInstalled ) where @@ -58,10 +59,18 @@ data GetInstalledOpts = GetInstalledOpts -- ^ Require haddocks? } +defaultGetInstalledOpts :: GetInstalledOpts +defaultGetInstalledOpts = GetInstalledOpts + { getInstalledProfiling = False + , getInstalledHaddock = False + } + -- | Returns the new InstalledMap and all of the locally registered packages. getInstalled :: (M env m, PackageInstallInfo pii) => EnvOverride -> GetInstalledOpts + -- TODO: Clarify what the Map is used for and what properties it + -- should have. -> Map PackageName pii -- ^ does not contain any installed information -> m ( InstalledMap , [DumpPackage () ()] -- globally installed diff --git a/src/Stack/BuildPlan.hs b/src/Stack/BuildPlan.hs index 42be96cfb7..fcbe13377d 100644 --- a/src/Stack/BuildPlan.hs +++ b/src/Stack/BuildPlan.hs @@ -424,7 +424,7 @@ getToolMap mbp = loadResolver :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m, MonadMask m) - => Maybe (Path Abs File) + => Maybe (Path Abs File) -- ^ Optional path to project config file -> Resolver -> m (MiniBuildPlan, LoadedResolver) loadResolver mconfigPath resolver = @@ -958,7 +958,7 @@ shadowMiniBuildPlan (MiniBuildPlan cv pkgs0) shadowed = parseCustomMiniBuildPlan :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, HasGHCVariant env, MonadBaseControl IO m) - => Maybe (Path Abs File) -- ^ Root directory for when url is a filepath + => Maybe (Path Abs File) -- ^ Optional path to project config file -> T.Text -> m (MiniBuildPlan, SnapshotHash) parseCustomMiniBuildPlan mconfigPath0 url0 = do diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index cef6d0a5d8..75c6487e0c 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -26,6 +26,7 @@ module Stack.Config ,loadConfig ,loadConfigMaybeProject ,loadMiniConfig + ,loadProjectConfig ,packagesParser ,resolvePackageEntry ,getImplicitGlobalProjectDir diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index c7362a20a9..8c98e61314 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -31,7 +31,7 @@ import qualified Data.Traversable as T import Network.HTTP.Client.Conduit (HasHttpManager) import Prelude -- Fix redundant import warnings import Stack.Build (withLoadPackage) -import Stack.Build.Installed (getInstalled, GetInstalledOpts(..)) +import Stack.Build.Installed (getInstalled, defaultGetInstalledOpts) import Stack.Build.Source import Stack.Build.Target import Stack.Constants @@ -97,7 +97,7 @@ createDependencyGraph dotOpts = do let graph = Map.fromList (localDependencies dotOpts locals) menv <- getMinimalEnvOverride installedMap <- fmap snd . fst4 <$> getInstalled menv - (GetInstalledOpts False False) + defaultGetInstalledOpts sourceMap withLoadPackage menv (\loader -> do let depLoader = diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index 75e3f5bc67..d5e79ee7f8 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -311,10 +311,7 @@ ghciSetup GhciOpts{..} = do menv <- getMinimalEnvOverride (installedMap, _, _, _) <- getInstalled menv - GetInstalledOpts - { getInstalledProfiling = False - , getInstalledHaddock = False - } + defaultGetInstalledOpts sourceMap econfig <- asks getEnvConfig directlyWanted <- diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index 759bd2cf34..bcb3b165f6 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -24,49 +24,52 @@ module Stack.Options ,testOptsParser ,haddockOptsParser ,hpcReportOptsParser + ,sdistOptsParser ,pvpBoundsOption + ,pvpBoundsOptsParser ,globalOptsFromMonoid ,splitObjsWarning ) where -import Control.Monad.Logger (LogLevel (..)) -import Data.Char (isSpace, toLower, toUpper) -import Data.List (intercalate) -import Data.List.Split (splitOn) -import qualified Data.Map as Map -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M +import Control.Monad.Logger (LogLevel (..)) +import Data.Char (isSpace, toLower, toUpper) +import Data.List (intercalate) +import Data.List.Split (splitOn) +import qualified Data.Map as Map +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid.Extra -import qualified Data.Set as Set -import qualified Data.Text as T -import Data.Text.Read (decimal) -import Distribution.Version (anyVersion) +import qualified Data.Set as Set +import qualified Data.Text as T +import Data.Text.Read (decimal) +import Distribution.Version (anyVersion) import Options.Applicative import Options.Applicative.Args import Options.Applicative.Builder.Extra -import Options.Applicative.Types (fromM, oneM, readerAsk) -import Stack.Build (splitObjsWarning) -import Stack.Clean (CleanOpts (..)) -import Stack.Config (packagesParser) +import Options.Applicative.Types (fromM, oneM, readerAsk) +import Stack.Build (splitObjsWarning) +import Stack.Clean (CleanOpts (..)) +import Stack.Config (packagesParser) import Stack.ConfigCmd import Stack.Constants -import Stack.Coverage (HpcReportOpts (..)) +import Stack.Coverage (HpcReportOpts (..)) import Stack.Docker -import qualified Stack.Docker as Docker +import qualified Stack.Docker as Docker import Stack.Dot -import Stack.Ghci (GhciOpts (..)) +import Stack.Ghci (GhciOpts (..)) import Stack.Init import Stack.New import Stack.Nix -import Stack.Types.FlagName -import Stack.Types.PackageName -import Stack.Types.Version +import Stack.SDist +import Stack.Types.Compiler import Stack.Types.Config import Stack.Types.Docker +import Stack.Types.FlagName import Stack.Types.Nix -import Stack.Types.Compiler +import Stack.Types.PackageName import Stack.Types.TemplateName +import Stack.Types.Version -- | Allows adjust global options depending on their context -- Note: This was being used to remove ambibuity between the local and global @@ -949,6 +952,29 @@ hpcReportOptsParser = HpcReportOpts <*> switch (long "all" <> help "Use results from all packages and components") <*> optional (strOption (long "destdir" <> help "Output directy for HTML report")) +sdistOptsParser :: Parser SDistOpts +sdistOptsParser = SDistOpts + <$> many (strArgument $ metavar "DIR") + <*> optional pvpBoundsOptsParser + <*> switch (long "ignore-check" <> help "Do not check package for common mistakes") + <*> switch (long "sign" <> help "Sign & upload signatures") + <*> strOption + (long "sig-server" <> metavar "URL" <> showDefault <> + value "https://sig.commercialhaskell.org" <> + help "URL") + +pvpBoundsOptsParser :: Parser PvpBoundsOpts +pvpBoundsOptsParser = PvpBoundsOpts + <$> pvpBoundsOption + <*> many (option readDependencyConfigurationSource + (long "also-considering" <> + help "Extra dependency configs to consider during bounds generation" <> + metavar "RESOLVER_OR_STACK_YAML")) + where + readDependencyConfigurationSource = + DCSResolver <$> readAbstractResolver <|> + DCSProjectConfig <$> str + pvpBoundsOption :: Parser PvpBounds pvpBoundsOption = option diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 1adfaac02b..87f4c46e34 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -5,11 +5,19 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecordWildCards #-} + -- Create a source distribution tarball module Stack.SDist - ( getSDistTarball + ( sdist + , getSDistTarball , checkSDistTarball , checkSDistTarball' + , SDistOpts(..) + , PvpBoundsOpts(..) + , DependencyConfigurationSource(..) ) where import qualified Codec.Archive.Tar as Tar @@ -17,7 +25,7 @@ import qualified Codec.Archive.Tar.Entry as Tar import qualified Codec.Compression.GZip as GZip import Control.Applicative import Control.Concurrent.Execute (ActionContext(..)) -import Control.Monad (unless, void, liftM) +import Control.Monad (when, unless, void, liftM) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger @@ -26,14 +34,17 @@ import Control.Monad.Trans.Control (liftBaseWith) import Control.Monad.Trans.Resource import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import Data.Data (Data, Typeable, cast, gmapT) +import Data.Data (Data, Typeable, cast, gmapM) import Data.Either (partitionEithers) +import Data.Foldable (forM_) import Data.List import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NE +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Data.Maybe (fromMaybe) -import Data.Monoid ((<>)) +import Data.Maybe +import Data.Maybe.Extra +import Data.Semigroup ((<>)) import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -42,9 +53,10 @@ import Data.Time.Clock.POSIX import Distribution.Package (Dependency (..)) import qualified Distribution.PackageDescription.Check as Check import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) -import Distribution.Version (simplifyVersionRange, orLaterVersion, earlierVersion) +import qualified Distribution.Text +import Distribution.Version hiding (Version, intersectVersionRanges) import Distribution.Version.Extra -import Network.HTTP.Client.Conduit (HasHttpManager) +import Network.HTTP.Client.Conduit (HasHttpManager(..)) import Path import Path.IO hiding (getModificationTime, getPermissions) import Prelude -- Fix redundant import warnings @@ -53,33 +65,92 @@ import Stack.Build.Execute import Stack.Build.Installed import Stack.Build.Source (loadSourceMap, getDefaultPackageConfig) import Stack.Build.Target +import Stack.BuildPlan (loadResolver) +import Stack.Config (loadProjectConfig, makeConcreteResolver, resolvePackageEntry) import Stack.Constants import Stack.Package +import qualified Stack.Sig as Sig +import Stack.Types.Build +import Stack.Types.Config +import Stack.Types.Internal +import Stack.Types.Package import Stack.Types.PackageIdentifier import Stack.Types.PackageName import Stack.Types.Version -import Stack.Types.Config -import Stack.Types.Build -import Stack.Types.Package -import Stack.Types.Internal import System.Directory (getModificationTime, getPermissions) import qualified System.FilePath as FP --- | Special exception to throw when you want to fail because of bad results --- of package check. +-- | Options for the PVP bounds generation. +data PvpBoundsOpts = PvpBoundsOpts + { pvpBoundsOptsPvpBounds :: !PvpBounds + -- TODO (sjakobi): It would be better to use a Set or HashSet here than a list if only I could + -- figure out how to get the necessary instances for 'Resolver'. + , pvpBoundsOptsExtraDependencyConfigurationSources :: ![DependencyConfigurationSource FilePath AbstractResolver] + } deriving (Show) -data CheckException - = CheckException (NonEmpty Check.PackageCheck) - deriving (Typeable) +defaultPvpBoundsOpts :: PvpBoundsOpts +defaultPvpBoundsOpts = PvpBoundsOpts + { pvpBoundsOptsPvpBounds = PvpBoundsNone + , pvpBoundsOptsExtraDependencyConfigurationSources = [] + } -instance Exception CheckException +-- | A "dependency configuration" is basically a @'Map' 'PackageName' 'Version'@. +-- +-- A 'DependencyConfigurationSource' specifies such a configuration. +data DependencyConfigurationSource projectConfig resolver + = DCSProjectConfig !projectConfig + | DCSResolver !resolver + | DCSCurrentConfiguration + deriving (Eq, Ord, Show) + +data SDistException + = ProjectConfigDoesn'tExist (Path Abs File) + | CheckException (NonEmpty Check.PackageCheck) + -- ^ Package check with negative results. + deriving (Typeable) + +instance Exception SDistException + +instance Show SDistException where + show (ProjectConfigDoesn'tExist absFile) = + "There is no file at " ++ toFilePath absFile + show (CheckException xs) = + "Package check reported the following errors:\n" ++ + (intercalate "\n" . fmap show . NE.toList $ xs) + +data SDistOpts = SDistOpts + { sdistOptsDirs :: ![FilePath] + -- ^ The package directories of the packages for which the tarballs should be built. + -- If no directories are specified, the tarballs for all the project-local packages the project should be built. + , sdistOptsPvpBoundsOpts :: !(Maybe PvpBoundsOpts) + , sdistOptsIgnoreCheck :: !Bool + -- ^ Skip checking the packages for common mistakes? + , sdistOptsSign :: !Bool + -- ^ Sign packages and upload signatures? + , sdistOptsSigServerUrl :: !String + -- ^ URL of the signature server. + } -instance Show CheckException where - show (CheckException xs) = - "Package check reported the following errors:\n" ++ - (intercalate "\n" . fmap show . NE.toList $ xs) +type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env,HasHttpManager env) -type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,MonadLogger m,MonadBaseControl IO m,MonadMask m,HasLogLevel env,HasEnvConfig env,HasTerminal env) +sdist :: M env m => SDistOpts -> m () +sdist SDistOpts{..} = do + -- If no directories are specified, build all sdist tarballs. + dirs' <- if null sdistOptsDirs + then asks (Map.keys . envConfigPackages . getEnvConfig) + else mapM resolveDir' sdistOptsDirs + manager <- asks getHttpManager + forM_ dirs' $ \dir -> do + -- TODO: Instead of recomputing the known dependency versions for each package, + -- compute them once, and pass them to getSDistTarball. + (tarName, tarBytes) <- getSDistTarball sdistOptsPvpBoundsOpts dir + distDir <- distDirFromDir dir + tarPath <- (distDir ) <$> parseRelFile tarName + ensureDir (parent tarPath) + liftIO $ L.writeFile (toFilePath tarPath) tarBytes + unless sdistOptsIgnoreCheck (checkSDistTarball tarPath) + $logInfo $ "Wrote sdist tarball to " <> T.pack (toFilePath tarPath) + when sdistOptsSign (void $ Sig.sign manager sdistOptsSigServerUrl tarPath) -- | Given the path to a local package, creates its source -- distribution tarball. @@ -89,13 +160,16 @@ type M env m = (MonadIO m,MonadReader env m,HasHttpManager env,MonadLogger m,Mon -- bytestring. getSDistTarball :: M env m - => Maybe PvpBounds -- ^ Override Config value - -> Path Abs Dir -- ^ Path to local package - -> m (FilePath, L.ByteString) -- ^ Filename and tarball contents -getSDistTarball mpvpBounds pkgDir = do + => Maybe PvpBoundsOpts + -> Path Abs Dir -- ^ Path to local package + -> m (FilePath, L.ByteString) -- ^ Filename and tarball contents +getSDistTarball mpvpBoundsOpts pkgDir = do config <- asks getConfig - let pvpBounds = fromMaybe (configPvpBounds config) mpvpBounds - tweakCabal = pvpBounds /= PvpBoundsNone + let pvpBoundsOpts = + fromMaybe + defaultPvpBoundsOpts { pvpBoundsOptsPvpBounds = configPvpBounds config } + mpvpBoundsOpts + tweakCabal = pvpBoundsOptsPvpBounds pvpBoundsOpts /= PvpBoundsNone pkgFp = toFilePath pkgDir lp <- readLocalPackage pkgDir $logInfo $ "Getting file list for " <> T.pack pkgFp @@ -112,7 +186,7 @@ getSDistTarball mpvpBounds pkgDir = do packDir = packWith Tar.packDirectoryEntry True packFile fp | tweakCabal && isCabalFp fp = do - lbs <- getCabalLbs pvpBounds $ toFilePath cabalfp + lbs <- getCabalLbs pvpBoundsOpts cabalfp currTime <- liftIO getPOSIXTime -- Seconds from UNIX epoch return $ (Tar.fileEntry (tarPath False fp) lbs) { Tar.entryTime = floor currTime } | otherwise = packWith packFileEntry False fp @@ -124,56 +198,230 @@ getSDistTarball mpvpBounds pkgDir = do return (tarName, GZip.compress (Tar.write (dirEntries ++ fileEntries))) -- | Get the PVP bounds-enabled version of the given cabal file -getCabalLbs :: M env m => PvpBounds -> FilePath -> m L.ByteString -getCabalLbs pvpBounds fp = do - bs <- liftIO $ S.readFile fp +getCabalFileContents + :: M env m + => PvpBoundsOpts + -> Path Abs File -- ^ Cabal file + -> m L.ByteString +getCabalFileContents pvpBoundsOpts fp = do + bs <- liftIO $ S.readFile (toFilePath fp) (_warnings, gpd) <- readPackageUnresolvedBS Nothing bs - (_, _, _, _, sourceMap) <- loadSourceMap AllowNoTargets defaultBuildOptsCLI - menv <- getMinimalEnvOverride - (installedMap, _, _, _) <- getInstalled menv GetInstalledOpts - { getInstalledProfiling = False - , getInstalledHaddock = False - } - sourceMap - let gpd' = gtraverseT (addBounds sourceMap installedMap) gpd + versionsWithWitnesses <- do + let dependencyConfigurationSources = + DCSCurrentConfiguration : pvpBoundsOptsExtraDependencyConfigurationSources pvpBoundsOpts + dependencyConfigs <- mapMaybeM (loadDependencyConfigs fp) dependencyConfigurationSources + return (mergeDependencyConfigs dependencyConfigs) + gpd' <- gtraverseM (addBounds versionsWithWitnesses) gpd return $ TLE.encodeUtf8 $ TL.pack $ showGenericPackageDescription gpd' where - addBounds :: SourceMap -> InstalledMap -> Dependency -> Dependency - addBounds sourceMap installedMap dep@(Dependency cname range) = - case lookupVersion (fromCabalPackageName cname) of - Nothing -> dep - Just version -> Dependency cname $ simplifyVersionRange - $ (if toAddUpper && not (hasUpper range) then addUpper version else id) - $ (if toAddLower && not (hasLower range) then addLower version else id) - range + addBounds :: M env m => MultiSourceDependencyConfig (Path Abs File) Resolver -> Dependency -> m Dependency + addBounds depConfig dep@(Dependency cname range) = do + let pkgName = fromCabalPackageName cname + case Map.lookup pkgName depConfig of + Nothing -> do + $logWarn $ T.concat + [ T.pack (toFilePath fp) + , " contains unknown dependency: " + , T.pack (Distribution.Text.display dep) + , ". Can't apply pvp bounds." + ] + return dep + Just witnessedVersions -> do + let computedVersionRange = + computePvpVersionRange (pvpBoundsOptsPvpBounds pvpBoundsOpts) range witnessedVersions + gaps = inferredVersionRangeInferenceGaps computedVersionRange + newRange = inferredVersionRangeInferredVersionRange computedVersionRange + versionRangeChanged = newRange /= simplifyVersionRange range + when versionRangeChanged $ do + projectRoot <- asks (bcRoot . getBuildConfig) + let tryStripProjectRoot absFile = + case stripDir projectRoot absFile of + Just x -> toFilePath x + Nothing -> toFilePath absFile + formatDCS (DCSProjectConfig absFile) = T.pack (tryStripProjectRoot absFile) + formatDCS (DCSResolver resolver) = resolverName resolver + formatDCS DCSCurrentConfiguration = "current configuration" + $logInfo $ T.concat + [ "Adjusting version range for dependency " + , packageNameText pkgName + , ":" + ] + $logInfo " Known versions:" + forM_ (Map.toList witnessedVersions) $ \(version, witnesses) -> + $logInfo $ T.concat + [ " * " + , versionText version + , " (" + , T.intercalate ", " (map formatDCS (NE.toList witnesses)) + , ")" + ] + $logInfo (" Old range: " <> T.pack (Distribution.Text.display range)) + $logInfo (" New range: " <> T.pack (Distribution.Text.display newRange)) + unless (isNoVersion gaps) $ do + $logInfo " The new version range contains subranges compatibility with which cannot be inferred within the PVP:" + $logInfo (" " <> T.pack (Distribution.Text.display gaps)) + return (Dependency cname newRange) + +-- | 'Version's together with the dependendency configurations in which they are specified. +type VersionWitnesses projectConfig resolver = + Map Version (NonEmpty (DependencyConfigurationSource projectConfig resolver)) + +type MultiSourceDependencyConfig projectConfig resolver = + Map PackageName (VersionWitnesses projectConfig resolver) + +mergeDependencyConfigs + :: [(DependencyConfigurationSource projectConfig resolver, Map PackageName Version)] + -> MultiSourceDependencyConfig projectConfig resolver +mergeDependencyConfigs xs = + Map.unionsWith + (Map.unionWith (<>)) + [ Map.map (\v -> Map.singleton v (dcs NE.:| [])) m + | (dcs, m) <- xs + ] + +-- TODO: It would probably be better to use existing functionality like @stack list-dependencies" +-- to get the package versions. +loadDependencyConfigs + :: M env m + => Path Abs File -- ^ Cabal file of the current package + -> DependencyConfigurationSource FilePath AbstractResolver + -> m (Maybe (DependencyConfigurationSource (Path Abs File) Resolver, Map PackageName Version)) + -- ^ Nothing if the 'DependencyConfigurationSource' doesn't apply to the package, e.g. + -- a project config doesn't list the package. +loadDependencyConfigs cabalFp = \case + DCSProjectConfig fp -> do + absFile <- resolveFile' fp + mProjectConfig <- loadProjectConfig (Just absFile) + case mProjectConfig of + Just (project, _fp, _configMonoid) -> do + packageInProject <- project `projectContainsPackage` cabalFp + if packageInProject + then do + resolverVersions <- + loadResolverVersions (Just absFile) (projectResolver project) + let versions = projectExtraDeps project `Map.union` resolverVersions + return (Just (DCSProjectConfig absFile, versions)) + -- FIXME: Respect sourceMap of project (as configured in fp) + -- TODO: Do we need to look at extra package dbs etc, too? + else do + $logWarn $ T.concat + [ "The project configuration in " + , T.pack (toFilePath absFile) + , " doesn't contain the " + , packageName' cabalFp + , " package." + ] + $logWarn "I will ignore this configuration during pvp-bounds generation." + return Nothing + Nothing -> + throwM (ProjectConfigDoesn'tExist absFile) + DCSResolver abstractResolver -> do + resolver <- makeConcreteResolver abstractResolver + resolverVersions <- do + configPath <- asks (bcStackYaml . getBuildConfig) + loadResolverVersions (Just configPath) resolver + sourceVersions <- do + (_, _, _, _, sourceMap) <- loadSourceMap AllowNoTargets defaultBuildOptsCLI + return (Map.map piiVersion sourceMap) + return (Just (DCSResolver resolver, sourceVersions `Map.union` resolverVersions)) + DCSCurrentConfiguration -> do + versions <- loadConfiguredPackageVersions + return (Just (DCSCurrentConfiguration, versions)) + where + packageName' = T.pack . FP.dropExtension . toFilePath . filename + +projectContainsPackage + :: M env m + => Project + -> Path Abs File -- ^ Location of the cabal file of the package + -> m Bool +projectContainsPackage project cabalAbsFile = do + menv <- getMinimalEnvOverride + projectRoot <- asks (bcRoot . getBuildConfig) + projectPackageDirs <- do + allProjectPackageDirs <- + concat <$> mapM (resolvePackageEntry menv projectRoot) (projectPackages project) + -- exclude "local extra-deps" + return [ dir | (dir, treatLikeExtraDep) <- allProjectPackageDirs, not treatLikeExtraDep ] + return ((parent cabalAbsFile) `elem` projectPackageDirs) + +loadConfiguredPackageVersions + :: M env m + => m (Map PackageName Version) +loadConfiguredPackageVersions = do + (_, _, _, _, sourceMap) <- loadSourceMap AllowNoTargets defaultBuildOptsCLI + let sourceVersions = Map.map piiVersion sourceMap + installedVersions <- do + menv <- getMinimalEnvOverride + (installedMap, _, _, _) <- getInstalled menv defaultGetInstalledOpts sourceMap + return (Map.map (installedVersion . snd) installedMap) + return (sourceVersions `Map.union` installedVersions) + +loadResolverVersions + :: M env m + => Maybe (Path Abs File) + -> Resolver + -> m (Map PackageName Version) +loadResolverVersions mConfigPath resolver = do + (mbp, _loadedResolver) <- loadResolver mConfigPath resolver + return (Map.map mpiVersion (mbpPackages mbp)) + +data InferredVersionRange = InferredVersionRange + { inferredVersionRangeInferredVersionRange :: !VersionRange + , inferredVersionRangeInferenceGaps :: !VersionRange + } + +computePvpVersionRange + :: PvpBounds + -> VersionRange -- ^ Original version range + -> VersionWitnesses a b -- ^ Versions that are known to be compatible, must be non-empty + -> InferredVersionRange +computePvpVersionRange pvpBounds oldRange witnesses = + InferredVersionRange newRange gaps + where + newRange = simplifyVersionRange + $ (if toAddUpper && not (hasUpper oldRange) then addUpper maxVersion else id) + $ (if toAddLower && not (hasLower oldRange) then addLower minVersion else id) + oldRange + where + (toAddLower, toAddUpper) = + case pvpBounds of + PvpBoundsNone -> (False, False) + PvpBoundsUpper -> (False, True) + PvpBoundsLower -> (True, False) + PvpBoundsBoth -> (True, True) + + addUpper version = intersectVersionRanges + (earlierVersion $ toCabalVersion $ nextMajorVersion version) + addLower version = intersectVersionRanges + (orLaterVersion (toCabalVersion version)) + + minVersion = Set.findMin (Map.keysSet witnesses) + maxVersion = Set.findMax (Map.keysSet witnesses) + + gaps = simplifyVersionRange (differenceVersionRanges newRange totalWitnessedRange) where - lookupVersion name = - case Map.lookup name sourceMap of - Just (PSLocal lp) -> Just $ packageVersion $ lpPackage lp - Just (PSUpstream version _ _ _ _) -> Just version - Nothing -> - case Map.lookup name installedMap of - Just (_, installed) -> Just (installedVersion installed) - Nothing -> Nothing - - addUpper version = intersectVersionRanges - (earlierVersion $ toCabalVersion $ nextMajorVersion version) - addLower version = intersectVersionRanges - (orLaterVersion (toCabalVersion version)) - - (toAddLower, toAddUpper) = - case pvpBounds of - PvpBoundsNone -> (False, False) - PvpBoundsUpper -> (False, True) - PvpBoundsLower -> (True, False) - PvpBoundsBoth -> (True, True) + differenceVersionRanges vr0 vr1 = intersectVersionRanges vr0 (invertVersionRange vr1) + + totalWitnessedRange = + foldl' + unionVersionRanges + noVersion + (map witnessedRange (Map.keys witnesses)) + where + witnessedRange version = + intersectVersionRanges + (earlierVersion $ toCabalVersion $ nextMajorVersion version) + (orLaterVersion $ toCabalVersion version) -- | Traverse a data type. -gtraverseT :: (Data a,Typeable b) => (Typeable b => b -> b) -> a -> a -gtraverseT f = - gmapT (\x -> case cast x of - Nothing -> gtraverseT f x - Just b -> fromMaybe x (cast (f b))) +gtraverseM :: (Data a, Typeable b, Monad m) => (b -> m b) -> a -> m a +gtraverseM f = + gmapM (\x -> case cast x of + Nothing -> gtraverseM f x + Just b -> do + b' <- f b + return (fromMaybe x (cast b'))) -- | Read in a 'LocalPackage' config. This makes some default decisions -- about 'LocalPackage' fields that might not be appropriate for other diff --git a/src/main/Main.hs b/src/main/Main.hs index 9d4295d7d7..62bad1c788 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -19,7 +19,8 @@ import Control.Monad.Trans.Either (EitherT) import Control.Monad.Writer.Lazy (Writer) import Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping)) import Data.Attoparsec.Interpreter (getInterpreterArgs) -import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Char8 as S8 +import Data.IORef import Data.List import qualified Data.Map as Map import Data.Maybe @@ -71,8 +72,7 @@ import Stack.Options import qualified Stack.PackageIndex import qualified Stack.Path import Stack.Runners -import Stack.SDist (getSDistTarball, checkSDistTarball, checkSDistTarball') -import Stack.SetupCmd +import Stack.Setup import qualified Stack.Sig as Sig import Stack.Solver (solveExtraDeps) import Stack.Types.Version @@ -275,7 +275,7 @@ commandLineHandler progName isInterpreter = complicatedOptions "Upload a package to Hackage" uploadCmd ((,,,,) <$> many (strArgument $ metavar "TARBALL/DIR") <*> - optional pvpBoundsOption <*> + optional pvpBoundsOptsParser <*> ignoreCheckSwitch <*> switch (long "no-signature" <> help "Do not sign & upload signatures") <*> strOption @@ -286,14 +286,7 @@ commandLineHandler progName isInterpreter = complicatedOptions "sdist" "Create source distribution tarballs" sdistCmd - ((,,,,) <$> many (strArgument $ metavar "DIR") <*> - optional pvpBoundsOption <*> - ignoreCheckSwitch <*> - switch (long "sign" <> help "Sign & upload signatures") <*> - strOption - (long "sig-server" <> metavar "URL" <> showDefault <> - value "https://sig.commercialhaskell.org" <> - help "URL")) + sdistOptsParser addCommand' "dot" "Visualize your project's dependency graph using Graphviz dot" dotCmd @@ -625,9 +618,9 @@ upgradeCmd (fromGit, repo) go = withGlobalConfigAndLock go $ do #endif -- | Upload to Hackage -uploadCmd :: ([String], Maybe PvpBounds, Bool, Bool, String) -> GlobalOpts -> IO () +uploadCmd :: ([String], Maybe PvpBoundsOpts, Bool, Bool, String) -> GlobalOpts -> IO () uploadCmd ([], _, _, _, _) _ = error "To upload the current package, please run 'stack upload .'" -uploadCmd (args, mpvpBounds, ignoreCheck, don'tSign, sigServerUrl) go = do +uploadCmd (args, mpvpBoundsOpts, ignoreCheck, don'tSign, sigServerUrl) go = do let partitionM _ [] = return ([], []) partitionM f (x:xs) = do r <- f x @@ -649,7 +642,7 @@ uploadCmd (args, mpvpBounds, ignoreCheck, don'tSign, sigServerUrl) go = do uploader <- getUploader manager <- asks envManager unless ignoreCheck $ - mapM_ (resolveFile' >=> checkSDistTarball) files + mapM_ (resolveFile' >=> SDist.checkSDistTarball) files forM_ files (\file -> @@ -666,8 +659,8 @@ uploadCmd (args, mpvpBounds, ignoreCheck, don'tSign, sigServerUrl) go = do unless (null dirs) $ forM_ dirs $ \dir -> do pkgDir <- resolveDir' dir - (tarName, tarBytes) <- getSDistTarball mpvpBounds pkgDir - unless ignoreCheck $ checkSDistTarball' tarName tarBytes + (tarName, tarBytes) <- SDist.getSDistTarball mpvpBoundsOpts pkgDir + unless ignoreCheck $ SDist.checkSDistTarball' tarName tarBytes liftIO $ Upload.uploadBytes uploader tarName tarBytes tarPath <- parseRelFile tarName unless @@ -679,23 +672,9 @@ uploadCmd (args, mpvpBounds, ignoreCheck, don'tSign, sigServerUrl) go = do tarPath tarBytes) -sdistCmd :: ([String], Maybe PvpBounds, Bool, Bool, String) -> GlobalOpts -> IO () -sdistCmd (dirs, mpvpBounds, ignoreCheck, sign, sigServerUrl) go = - withBuildConfig go $ do -- No locking needed. - -- If no directories are specified, build all sdist tarballs. - dirs' <- if null dirs - then asks (Map.keys . envConfigPackages . getEnvConfig) - else mapM resolveDir' dirs - manager <- asks envManager - forM_ dirs' $ \dir -> do - (tarName, tarBytes) <- getSDistTarball mpvpBounds dir - distDir <- distDirFromDir dir - tarPath <- (distDir ) <$> parseRelFile tarName - ensureDir (parent tarPath) - liftIO $ L.writeFile (toFilePath tarPath) tarBytes - unless ignoreCheck (checkSDistTarball tarPath) - $logInfo $ "Wrote sdist tarball to " <> T.pack (toFilePath tarPath) - when sign (void $ Sig.sign manager sigServerUrl tarPath) +sdistCmd :: SDistOpts -> GlobalOpts -> IO () +sdistCmd opts go = + withBuildConfig go (SDist.sdist opts) -- No locking needed. -- | Execute a command. execCmd :: ExecOpts -> GlobalOpts -> IO () @@ -772,14 +751,33 @@ ghciCmd ghciOpts go@GlobalOpts{..} = (ghci ghciOpts) -- | List packages in the project. -idePackagesCmd :: () -> GlobalOpts -> IO () -idePackagesCmd () go = - withBuildConfig go IDE.listPackages +packagesCmd :: () -> GlobalOpts -> IO () +packagesCmd () go@GlobalOpts{..} = + withBuildConfig go $ + do econfig <- asks getEnvConfig + locals <- + forM (Map.toList (envConfigPackages econfig)) $ + \(dir,_) -> + do cabalfp <- findOrGenerateCabalFile dir + parsePackageNameFromFilePath cabalfp + forM_ locals (liftIO . putStrLn . packageNameString) -- | List targets in the project. -ideTargetsCmd :: () -> GlobalOpts -> IO () -ideTargetsCmd () go = - withBuildConfig go IDE.listTargets +targetsCmd :: () -> GlobalOpts -> IO () +targetsCmd () go@GlobalOpts{..} = + withBuildConfig go $ + do rawLocals <- getLocalPackageViews + $logInfo + (T.intercalate + "\n" + (map + renderPkgComponent + (concatMap + toNameAndComponent + (Map.toList (Map.map fst rawLocals))))) + where + toNameAndComponent (packageName,view) = + map (packageName, ) (Set.toList (lpvComponents view)) -- | Pull the current Docker image. dockerPullCmd :: () -> GlobalOpts -> IO () diff --git a/stack-7.8.yaml b/stack-7.8.yaml index bb901980e9..2dce5e2911 100644 --- a/stack-7.8.yaml +++ b/stack-7.8.yaml @@ -30,7 +30,7 @@ extra-deps: - deepseq-1.4.1.2 - aeson-0.11.2.0 - bytestring-0.10.6.0 -- Cabal-1.18.1.6 +- Cabal-1.24.0.0 - containers-0.5.6.3 - hpc-0.6.0.2 - process-1.2.1.0 diff --git a/stack.cabal b/stack.cabal index ecc5a24b46..b47e772774 100644 --- a/stack.cabal +++ b/stack.cabal @@ -247,7 +247,7 @@ executable stack if flag(static) ld-options: -static -pthread - build-depends: Cabal >= 1.18.1.5 && < 1.25 + build-depends: Cabal >= 1.24 && < 1.25 , base >=4.7 && < 5 , bytestring >= 0.10.4.0 , containers >= 0.5.5.1 diff --git a/stack.yaml b/stack.yaml index 26844bedac..e7208197ed 100644 --- a/stack.yaml +++ b/stack.yaml @@ -21,3 +21,4 @@ extra-deps: - http-conduit-2.2.0 - path-0.5.8 - unicode-transforms-0.1.0.1 +- Cabal-1.24.0.0