From 07eec968f1f50a191276c37c1902d00a639385a3 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Sat, 22 Apr 2023 15:29:54 +0100 Subject: [PATCH] Re #2407 Move exceptions out of Stack.Types.Build Also move out ConfigureOpts (and related), IsMutable, ParentMap and UnusedFlags. --- package.yaml | 5 + src/Stack/Build.hs | 8 +- src/Stack/Build/Cache.hs | 7 +- src/Stack/Build/ConstructPlan.hs | 45 +- src/Stack/Build/Execute.hs | 14 +- src/Stack/Build/Haddock.hs | 3 +- src/Stack/Build/Source.hs | 2 +- src/Stack/Build/Target.hs | 2 +- src/Stack/Config.hs | 3 +- src/Stack/Ghci.hs | 2 +- src/Stack/SDist.hs | 5 +- src/Stack/Setup.hs | 2 +- src/Stack/SourceMap.hs | 4 +- src/Stack/Storage/Project.hs | 4 +- src/Stack/Types/Build.hs | 1093 +--------------------------- src/Stack/Types/Build/Exception.hs | 842 +++++++++++++++++++++ src/Stack/Types/ConfigureOpts.hs | 202 +++++ src/Stack/Types/IsMutable.hs | 21 + src/Stack/Types/ParentMap.hs | 12 + src/Stack/Types/UnusedFlags.hs | 23 + stack.cabal | 5 + 21 files changed, 1186 insertions(+), 1118 deletions(-) create mode 100644 src/Stack/Types/Build/Exception.hs create mode 100644 src/Stack/Types/ConfigureOpts.hs create mode 100644 src/Stack/Types/IsMutable.hs create mode 100644 src/Stack/Types/ParentMap.hs create mode 100644 src/Stack/Types/UnusedFlags.hs diff --git a/package.yaml b/package.yaml index cbb1ab1c66..65889c5902 100644 --- a/package.yaml +++ b/package.yaml @@ -265,6 +265,7 @@ library: - Stack.Types.ApplyGhcOptions - Stack.Types.ApplyProgOptions - Stack.Types.Build + - Stack.Types.Build.Exception - Stack.Types.BuildConfig - Stack.Types.BuildOpts - Stack.Types.CabalConfigKey @@ -275,6 +276,7 @@ library: - Stack.Types.Config - Stack.Types.Config.Exception - Stack.Types.ConfigMonoid + - Stack.Types.ConfigureOpts - Stack.Types.Curator - Stack.Types.Docker - Stack.Types.DockerEntrypoint @@ -291,11 +293,13 @@ library: - Stack.Types.GhcPkgId - Stack.Types.GlobalOpts - Stack.Types.GlobalOptsMonoid + - Stack.Types.IsMutable - Stack.Types.LockFileBehavior - Stack.Types.NamedComponent - Stack.Types.Nix - Stack.Types.Package - Stack.Types.PackageName + - Stack.Types.ParentMap - Stack.Types.Platform - Stack.Types.Project - Stack.Types.ProjectAndConfigMonoid @@ -308,6 +312,7 @@ library: - Stack.Types.SourceMap - Stack.Types.StackYamlLoc - Stack.Types.TemplateName + - Stack.Types.UnusedFlags - Stack.Types.Version - Stack.Types.VersionedDownloadInfo - Stack.Uninstall diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index c7d13f73c2..6d44aae208 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -34,10 +34,9 @@ import Stack.Prelude hiding ( loadPackage ) import Stack.Runners ( ShouldReexec (..), withConfig, withEnvConfig ) import Stack.Setup ( withNewLocalBuildTargets ) import Stack.Types.Build - ( BaseConfigOpts (..), BuildException (..) - , BuildPrettyException (..), Plan (..), Task (..) - , TaskType (..), taskLocation - ) + ( Plan (..), Task (..), TaskType (..), taskLocation ) +import Stack.Types.Build.Exception + ( BuildException (..), BuildPrettyException (..) ) import Stack.Types.BuildConfig ( HasBuildConfig, stackYamlL ) import Stack.Types.BuildOpts ( BuildCommand (..), BuildOpts (..), BuildOptsCLI (..) @@ -50,6 +49,7 @@ import Stack.Types.CompilerPaths ( cabalVersionL ) import Stack.Types.Config ( Config (..), HasConfig (..), buildOptsL ) +import Stack.Types.ConfigureOpts ( BaseConfigOpts (..) ) import Stack.Types.EnvConfig ( EnvConfig (..), HasEnvConfig (..), HasSourceMap , actualCompilerVersionL, installationRootDeps diff --git a/src/Stack/Build/Cache.hs b/src/Stack/Build/Cache.hs index e57b99e3f7..8386e80f61 100644 --- a/src/Stack/Build/Cache.hs +++ b/src/Stack/Build/Cache.hs @@ -57,13 +57,14 @@ import Stack.Storage.User , precompiledCacheKey, savePrecompiledCache ) import Stack.Types.Build - ( BuildCache (..), BaseConfigOpts (..), ConfigCache - , ConfigureOpts (..), FileCacheInfo, InstallLocation (..) - , Installed (..), PrecompiledCache (..) + ( BuildCache (..), ConfigCache, FileCacheInfo + , InstallLocation (..), Installed (..), PrecompiledCache (..) ) import Stack.Types.Cache ( ConfigCacheType (..) ) import Stack.Types.CompilerPaths ( cabalVersionL ) import Stack.Types.Config ( stackRootL ) +import Stack.Types.ConfigureOpts + ( BaseConfigOpts (..), ConfigureOpts (..) ) import Stack.Types.EnvConfig ( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL , installationRootDeps, installationRootLocal diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 41cabc8640..62bba2f0d3 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -29,14 +29,14 @@ import Stack.Package ( applyForceCustomBuild ) import Stack.Prelude hiding ( loadPackage ) import Stack.SourceMap ( getPLIVersion, mkProjectPackage ) import Stack.Types.Build - ( BaseConfigOpts (..), BadDependency (..) - , BuildException (..), BuildPrettyException (..) - , CachePkgSrc (..), ConfigCache (..), ConfigureOpts (..) - , ConstructPlanException (..), IsMutable (..), ParentMap - , Plan (..), Task (..), TaskConfigOpts (..), TaskType (..) - , configureOpts, installLocationIsMutable, isStackOpt - , taskIsTarget, taskLocation, taskTargetIsMutable - , toCachePkgSrc + ( CachePkgSrc (..), ConfigCache (..), Plan (..), Task (..) + , TaskConfigOpts (..), TaskType (..) + , installLocationIsMutable, taskIsTarget, taskLocation + , taskTargetIsMutable, toCachePkgSrc + ) +import Stack.Types.Build.Exception + ( BadDependency (..), BuildException (..) + , BuildPrettyException (..), ConstructPlanException (..) ) import Stack.Types.BuildConfig ( BuildConfig (..), HasBuildConfig (..), stackYamlL ) @@ -46,6 +46,8 @@ import Stack.Types.Compiler ( WhichCompiler (..) ) import Stack.Types.CompilerPaths ( CompilerPaths (..), HasCompiler (..) ) import Stack.Types.Config ( Config (..), HasConfig (..), stackRootL ) +import Stack.Types.ConfigureOpts + ( BaseConfigOpts (..), ConfigureOpts (..), configureOpts ) import Stack.Types.Curator ( Curator (..) ) import Stack.Types.Dependency ( DepValue (DepValue), DepType (AsLibrary) ) @@ -55,6 +57,7 @@ import Stack.Types.EnvConfig import Stack.Types.EnvSettings ( EnvSettings (..), minimalEnvSettings ) import Stack.Types.GHCVariant ( HasGHCVariant (..) ) import Stack.Types.GhcPkgId ( GhcPkgId ) +import Stack.Types.IsMutable ( IsMutable (..) ) import Stack.Types.NamedComponent ( exeComponents, renderComponent ) import Stack.Types.Package ( ExeName (..), InstallLocation (..), Installed (..) @@ -62,6 +65,7 @@ import Stack.Types.Package , PackageLibraries (..), PackageSource (..), installedVersion , packageIdentifier, psVersion, runMemoizedWith ) +import Stack.Types.ParentMap ( ParentMap ) import Stack.Types.Platform ( HasPlatform (..) ) import Stack.Types.Runner ( HasRunner (..) ) import Stack.Types.SourceMap @@ -1129,6 +1133,31 @@ describeConfigDiff config old new . map T.pack . (\(ConfigureOpts x y) -> x ++ y) . configCacheOpts + where + -- options set by Stack + isStackOpt :: Text -> Bool + isStackOpt t = any (`T.isPrefixOf` t) + [ "--dependency=" + , "--constraint=" + , "--package-db=" + , "--libdir=" + , "--bindir=" + , "--datadir=" + , "--libexecdir=" + , "--sysconfdir" + , "--docdir=" + , "--htmldir=" + , "--haddockdir=" + , "--enable-tests" + , "--enable-benchmarks" + , "--exact-configuration" + -- Treat these as causing dirtiness, to resolve + -- https://github.com/commercialhaskell/stack/issues/2984 + -- + -- , "--enable-library-profiling" + -- , "--enable-executable-profiling" + -- , "--enable-profiling" + ] || t == "--user" (oldOpts, newOpts) = removeMatching (userOpts old) (userOpts new) diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index 9f91087dbd..c12b78a332 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -130,13 +130,12 @@ import Stack.PackageDump ( conduitDumpPackage, ghcPkgDescribe ) import Stack.Prelude import Stack.Types.ApplyGhcOptions ( ApplyGhcOptions (..) ) import Stack.Types.Build - ( BaseConfigOpts (..), BuildException (..) - , BuildPrettyException (..), ConfigCache (..) - , ConfigureOpts (..), IsMutable (..), Plan (..) - , PrecompiledCache (..), Task (..), TaskConfigOpts (..) - , TaskType (..), configCacheComponents, taskIsTarget - , taskLocation + ( ConfigCache (..), Plan (..), PrecompiledCache (..) + , Task (..), TaskConfigOpts (..), TaskType (..) + , configCacheComponents, taskIsTarget, taskLocation ) +import Stack.Types.Build.Exception + ( BuildException (..), BuildPrettyException (..) ) import Stack.Types.BuildConfig ( BuildConfig (..), HasBuildConfig (..), projectRootL ) import Stack.Types.BuildOpts @@ -153,6 +152,8 @@ import Stack.Types.CompilerPaths ) import Stack.Types.Config ( Config (..), HasConfig (..), buildOptsL, stackRootL ) +import Stack.Types.ConfigureOpts + ( BaseConfigOpts (..), ConfigureOpts (..) ) import Stack.Types.DumpLogs ( DumpLogs (..) ) import Stack.Types.DumpPackage ( DumpPackage (..) ) import Stack.Types.EnvConfig @@ -165,6 +166,7 @@ import Stack.Types.EnvConfig import Stack.Types.EnvSettings ( EnvSettings (..) ) import Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdString, unGhcPkgId ) import Stack.Types.GlobalOpts ( GlobalOpts (..) ) +import Stack.Types.IsMutable ( IsMutable (..) ) import Stack.Types.NamedComponent ( NamedComponent, benchComponents, exeComponents, isCBench , isCTest, renderComponent, testComponents diff --git a/src/Stack/Build/Haddock.hs b/src/Stack/Build/Haddock.hs index b288f623ea..a8f5a27165 100644 --- a/src/Stack/Build/Haddock.hs +++ b/src/Stack/Build/Haddock.hs @@ -30,9 +30,10 @@ import RIO.List ( intercalate ) import RIO.Process ( HasProcessContext, withWorkingDir ) import Stack.Constants ( docDirSuffix, relDirAll, relFileIndexHtml ) import Stack.Prelude -import Stack.Types.Build ( BaseConfigOpts (..), BuildException (..) ) +import Stack.Types.Build.Exception ( BuildException (..) ) import Stack.Types.CompilerPaths ( CompilerPaths (..), HasCompiler (..) ) +import Stack.Types.ConfigureOpts ( BaseConfigOpts (..) ) import Stack.Types.BuildOpts ( BuildOpts (..), BuildOptsCLI (..), HaddockOpts (..) ) import Stack.Types.DumpPackage ( DumpPackage (..) ) diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index 74fd6e1c2f..028beb78a6 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -34,7 +34,6 @@ import Stack.SourceMap ) import Stack.Types.ApplyGhcOptions ( ApplyGhcOptions (..) ) import Stack.Types.ApplyProgOptions ( ApplyProgOptions (..) ) -import Stack.Types.Build ( FlagSource (..) ) import Stack.Types.BuildConfig ( BuildConfig (..), HasBuildConfig (..) ) import Stack.Types.BuildOpts @@ -63,6 +62,7 @@ import Stack.Types.SourceMap , SMActual (..), SMTargets (..), SourceMap (..) , SourceMapHash (..), Target (..), ppGPD, ppRoot ) +import Stack.Types.UnusedFlags ( FlagSource (..) ) import System.FilePath ( takeFileName ) import System.IO.Error ( isDoesNotExistError ) diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs index 922591ca7c..e4ad1b65b4 100644 --- a/src/Stack/Build/Target.hs +++ b/src/Stack/Build/Target.hs @@ -80,7 +80,7 @@ import Stack.Types.BuildOpts ( BuildOptsCLI (..) ) import Stack.Types.Config ( Config (..) ) import Stack.Types.NamedComponent ( NamedComponent (..), renderComponent ) -import Stack.Types.Build ( BuildPrettyException (..) ) +import Stack.Types.Build.Exception ( BuildPrettyException (..) ) import Stack.Types.ProjectConfig ( ProjectConfig (..) ) import Stack.Types.SourceMap ( DepPackage (..), GlobalPackage (..), PackageType (..) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 4f29229c03..b11df51e57 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -100,7 +100,7 @@ import Stack.Storage.Util ( handleMigrationException ) import Stack.Types.AllowNewerDeps ( AllowNewerDeps (..) ) import Stack.Types.ApplyGhcOptions ( ApplyGhcOptions (..) ) import Stack.Types.ApplyProgOptions ( ApplyProgOptions (..) ) -import Stack.Types.Build ( BuildException (..), FlagSource (..) ) +import Stack.Types.Build.Exception ( BuildException (..) ) import Stack.Types.BuildConfig ( BuildConfig (..) ) import Stack.Types.BuildOpts ( BuildOpts (..) ) import Stack.Types.ColorWhen ( ColorWhen (..) ) @@ -133,6 +133,7 @@ import Stack.Types.SourceMap , SMWanted (..) ) import Stack.Types.StackYamlLoc ( StackYamlLoc (..) ) +import Stack.Types.UnusedFlags ( FlagSource (..) ) import Stack.Types.Version ( IntersectingVersionRange (..), VersionCheck (..) , stackVersion, withinRange diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs index b0ef367238..87a40a66e7 100644 --- a/src/Stack/Ghci.hs +++ b/src/Stack/Ghci.hs @@ -52,7 +52,7 @@ import Stack.Package ) import Stack.Prelude import Stack.Runners ( ShouldReexec (..), withConfig, withEnvConfig ) -import Stack.Types.Build +import Stack.Types.Build.Exception ( BuildPrettyException (..), pprintTargetParseErrors ) import Stack.Types.BuildConfig ( BuildConfig (..), HasBuildConfig (..), stackYamlL ) diff --git a/src/Stack/SDist.hs b/src/Stack/SDist.hs index 9034ab0d35..76f1cb68a5 100644 --- a/src/Stack/SDist.hs +++ b/src/Stack/SDist.hs @@ -61,14 +61,15 @@ import Stack.Runners ( ShouldReexec (..), withConfig, withDefaultEnvConfig ) import Stack.SourceMap ( mkProjectPackage ) import Stack.Types.Build - ( CachePkgSrc (..), ConfigureOpts (..), Task (..) - , TaskConfigOpts (..), TaskType (..) + ( CachePkgSrc (..), Task (..), TaskConfigOpts (..) + , TaskType (..) ) import Stack.Types.BuildConfig ( BuildConfig (..), HasBuildConfig (..), stackYamlL ) import Stack.Types.BuildOpts ( BuildOpts (..), defaultBuildOpts, defaultBuildOptsCLI ) import Stack.Types.Config ( Config (..), HasConfig (..) ) +import Stack.Types.ConfigureOpts ( ConfigureOpts (..) ) import Stack.Types.EnvConfig ( EnvConfig (..), HasEnvConfig (..), actualCompilerVersionL ) import Stack.Types.GhcPkgId ( GhcPkgId ) diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index eea06fb659..99a55dad0f 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -108,7 +108,7 @@ import Stack.Setup.Installed import Stack.SourceMap ( actualFromGhc, globalsFromDump, pruneGlobals ) import Stack.Storage.User ( loadCompilerPaths, saveCompilerPaths ) -import Stack.Types.Build ( BuildException (..) ) +import Stack.Types.Build.Exception ( BuildException (..) ) import Stack.Types.BuildConfig ( BuildConfig (..), HasBuildConfig (..), projectRootL , wantedCompilerVersionL diff --git a/src/Stack/SourceMap.hs b/src/Stack/SourceMap.hs index 5153b67b99..99bd964799 100644 --- a/src/Stack/SourceMap.hs +++ b/src/Stack/SourceMap.hs @@ -33,14 +33,14 @@ import RIO.Process ( HasProcessContext ) import qualified RIO.Set as Set import Stack.PackageDump ( conduitDumpPackage, ghcPkgDump ) import Stack.Prelude -import Stack.Types.Build - ( BuildPrettyException (..), FlagSource, UnusedFlags (..) ) +import Stack.Types.Build.Exception ( BuildPrettyException (..) ) import Stack.Types.Compiler ( ActualCompiler, actualToWanted, wantedToActual ) import Stack.Types.CompilerPaths ( CompilerPaths (..), GhcPkgExe, HasCompiler (..) ) import Stack.Types.Config ( HasConfig ) import Stack.Types.DumpPackage ( DumpPackage (..) ) +import Stack.Types.UnusedFlags ( FlagSource, UnusedFlags (..) ) import Stack.Types.Platform ( HasPlatform (..) ) import Stack.Types.Runner ( rslInLogL ) import Stack.Types.SourceMap diff --git a/src/Stack/Storage/Project.hs b/src/Stack/Storage/Project.hs index ddf6214864..ba0e06e9ad 100644 --- a/src/Stack/Storage/Project.hs +++ b/src/Stack/Storage/Project.hs @@ -34,11 +34,11 @@ import qualified Pantry.Internal as SQLite import Stack.Prelude import Stack.Storage.Util ( handleMigrationException, updateList, updateSet ) -import Stack.Types.Build - ( CachePkgSrc, ConfigCache (..), ConfigureOpts (..) ) +import Stack.Types.Build ( CachePkgSrc, ConfigCache (..) ) import Stack.Types.BuildConfig ( BuildConfig (..), HasBuildConfig (..) ) import Stack.Types.Cache ( ConfigCacheType ) +import Stack.Types.ConfigureOpts ( ConfigureOpts (..) ) import Stack.Types.GhcPkgId ( GhcPkgId ) import Stack.Types.Storage ( ProjectStorage (..) ) diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index 0655d9762c..ce522e4131 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -5,15 +5,7 @@ -- | Build-specific types. module Stack.Types.Build - ( BuildException (..) - , BuildPrettyException (..) - , pprintTargetParseErrors - , ConstructPlanException (..) - , BadDependency (..) - , ParentMap - , FlagSource (..) - , UnusedFlags (..) - , InstallLocation (..) + ( InstallLocation (..) , Installed (..) , psVersion , Task (..) @@ -21,7 +13,6 @@ module Stack.Types.Build , taskLocation , taskTargetIsMutable , LocalPackage (..) - , BaseConfigOpts (..) , Plan (..) , TestOpts (..) , BenchmarkOpts (..) @@ -30,7 +21,6 @@ module Stack.Types.Build , BuildSubset (..) , defaultBuildOpts , TaskType (..) - , IsMutable (..) , installLocationIsMutable , TaskConfigOpts (..) , BuildCache (..) @@ -38,890 +28,33 @@ module Stack.Types.Build , configureOpts , CachePkgSrc (..) , toCachePkgSrc - , isStackOpt - , wantedLocalPackages , FileCacheInfo (..) - , ConfigureOpts (..) , PrecompiledCache (..) ) where import Data.Aeson ( ToJSON, FromJSON ) import qualified Data.ByteString as S -import Data.Char ( isSpace ) import Data.List as L import qualified Data.Map as Map -import qualified Data.Map.Strict as M -import Data.Monoid.Map ( MonoidMap (..) ) -import qualified Data.Set as Set import qualified Data.Text as T import Database.Persist.Sql ( PersistField (..), PersistFieldSql (..) , PersistValue (PersistText), SqlType (SqlString) ) -import Distribution.System ( Arch ) -import qualified Distribution.Text as C -import Distribution.Types.MungedPackageName - ( decodeCompatPackageName ) -import Distribution.Types.PackageName ( mkPackageName, unPackageName ) -import Distribution.Types.TestSuiteInterface ( TestSuiteInterface ) -import Distribution.Types.UnqualComponentName - ( unUnqualComponentName ) -import qualified Distribution.Version as C -import Path ( parseRelDir, (), parent ) -import Path.Extra ( toFilePathNoTrailingSep ) -import RIO.Process ( showProcessArgDebug ) -import Stack.Constants - ( bindirSuffix, compilerOptionsCabalFlag - , defaultUserConfigPath, docDirSuffix, relDirEtc, relDirLib - , relDirLibexec, relDirShare, wiredInPackages - ) +import Path ( parent ) import Stack.Prelude import Stack.Types.BuildOpts - ( BenchmarkOpts (..), BuildOpts (..), BuildOptsCLI - , BuildSubset (..), FileWatchOpts (..), TestOpts (..) - , defaultBuildOpts - ) -import Stack.Types.Compiler - ( ActualCompiler, compilerVersionString, getGhcVersion - , whichCompiler + ( BenchmarkOpts (..), BuildOpts (..), BuildSubset (..) + , FileWatchOpts (..), TestOpts (..), defaultBuildOpts ) -import Stack.Types.CompilerBuild - ( CompilerBuild, compilerBuildSuffix ) -import Stack.Types.Config ( Config (..), HasConfig (..) ) -import Stack.Types.DumpPackage ( DumpPackage ) -import Stack.Types.EnvConfig ( EnvConfig, actualCompilerVersionL ) -import Stack.Types.GHCVariant ( GHCVariant, ghcVariantSuffix ) -import Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdString ) -import Stack.Types.NamedComponent - ( NamedComponent, renderPkgComponent ) +import Stack.Types.ConfigureOpts ( ConfigureOpts, configureOpts ) +import Stack.Types.GhcPkgId ( GhcPkgId ) +import Stack.Types.IsMutable ( IsMutable (..) ) import Stack.Types.Package ( FileCacheInfo (..), InstallLocation (..), Installed (..) , LocalPackage (..), Package (..), PackageSource (..) - , packageIdentifier, psVersion + , psVersion ) -import Stack.Types.Version ( VersionCheck (..), VersionRange ) -import System.FilePath ( pathSeparator ) - --- | Type representing exceptions thrown by functions exported by modules with --- names beginning @Stack.Build@. -data BuildException - = Couldn'tFindPkgId PackageName - | CompilerVersionMismatch - (Maybe (ActualCompiler, Arch)) -- found - (WantedCompiler, Arch) -- expected - GHCVariant -- expected - CompilerBuild -- expected - VersionCheck - (Maybe (Path Abs File)) -- Path to the stack.yaml file - Text -- recommended resolution - | Couldn'tParseTargets [Text] - | UnknownTargets - (Set PackageName) -- no known version - (Map PackageName Version) -- not in snapshot, here's the most recent - -- version in the index - (Path Abs File) -- stack.yaml - | TestSuiteFailure - PackageIdentifier - (Map Text (Maybe ExitCode)) - (Maybe (Path Abs File)) - S.ByteString - | TestSuiteTypeUnsupported TestSuiteInterface - | LocalPackageDoesn'tMatchTarget - PackageName - Version -- local version - Version -- version specified on command line - | NoSetupHsFound (Path Abs Dir) - | InvalidGhcOptionsSpecification [PackageName] - | TestSuiteExeMissing Bool String String String - | CabalCopyFailed Bool String - | LocalPackagesPresent [PackageIdentifier] - | CouldNotLockDistDir !(Path Abs File) - | TaskCycleBug PackageIdentifier - | PackageIdMissingBug PackageIdentifier - | AllInOneBuildBug - | MultipleResultsBug PackageName [DumpPackage] - | TemplateHaskellNotFoundBug - | HaddockIndexNotFound - | ShowBuildErrorBug - deriving (Show, Typeable) - -instance Exception BuildException where - displayException (Couldn'tFindPkgId name) = bugReport "[S-7178]" $ concat - [ "After installing " - , packageNameString name - ,", the package id couldn't be found (via ghc-pkg describe " - , packageNameString name - , ")." - ] - displayException (CompilerVersionMismatch mactual (expected, eArch) ghcVariant ghcBuild check mstack resolution) = concat - [ "Error: [S-6362]\n" - , case mactual of - Nothing -> "No compiler found, expected " - Just (actual, arch) -> concat - [ "Compiler version mismatched, found " - , compilerVersionString actual - , " (" - , C.display arch - , ")" - , ", but expected " - ] - , case check of - MatchMinor -> "minor version match with " - MatchExact -> "exact version " - NewerMinor -> "minor version match or newer with " - , T.unpack $ utf8BuilderToText $ display expected - , " (" - , C.display eArch - , ghcVariantSuffix ghcVariant - , compilerBuildSuffix ghcBuild - , ") (based on " - , case mstack of - Nothing -> "command line arguments" - Just stack -> "resolver setting in " ++ toFilePath stack - , ").\n" - , T.unpack resolution - ] - displayException (Couldn'tParseTargets targets) = unlines - $ "Error: [S-3127]" - : "The following targets could not be parsed as package names or \ - \directories:" - : map T.unpack targets - displayException (UnknownTargets noKnown notInSnapshot stackYaml) = unlines - $ "Error: [S-2154]" - : (noKnown' ++ notInSnapshot') - where - noKnown' - | Set.null noKnown = [] - | otherwise = pure $ - "The following target packages were not found: " ++ - intercalate ", " (map packageNameString $ Set.toList noKnown) ++ - "\nSee https://docs.haskellstack.org/en/stable/build_command/#target-syntax for details." - notInSnapshot' - | Map.null notInSnapshot = [] - | otherwise = - "The following packages are not in your snapshot, but exist" - : "in your package index. Recommended action: add them to your" - : ("extra-deps in " ++ toFilePath stackYaml) - : "(Note: these are the most recent versions," - : "but there's no guarantee that they'll build together)." - : "" - : map - (\(name, version') -> "- " ++ packageIdentifierString - (PackageIdentifier name version')) - (Map.toList notInSnapshot) - displayException (TestSuiteFailure ident codes mlogFile bs) = unlines - $ "Error: [S-1995]" - : concat - [ ["Test suite failure for package " ++ packageIdentifierString ident] - , flip map (Map.toList codes) $ \(name, mcode) -> concat - [ " " - , T.unpack name - , ": " - , case mcode of - Nothing -> " executable not found" - Just ec -> " exited with: " ++ displayException ec - ] - , pure $ case mlogFile of - Nothing -> "Logs printed to console" - -- TODO Should we load up the full error output and print it here? - Just logFile -> "Full log available at " ++ toFilePath logFile - , if S.null bs - then [] - else - [ "" - , "" - , doubleIndent $ T.unpack $ decodeUtf8With lenientDecode bs - ] - ] - where - indent' = dropWhileEnd isSpace . unlines . fmap (" " ++) . lines - doubleIndent = indent' . indent' - displayException (TestSuiteTypeUnsupported interface) = concat - [ "Error: [S-3819]\n" - , "Unsupported test suite type: " - , show interface - ] - -- Suppressing duplicate output - displayException (LocalPackageDoesn'tMatchTarget name localV requestedV) = concat - [ "Error: [S-5797]\n" - , "Version for local package " - , packageNameString name - , " is " - , versionString localV - , ", but you asked for " - , versionString requestedV - , " on the command line" - ] - displayException (NoSetupHsFound dir) = concat - [ "Error: [S-3118]\n" - , "No Setup.hs or Setup.lhs file found in " - , toFilePath dir - ] - displayException (InvalidGhcOptionsSpecification unused) = unlines - $ "Error: [S-4925]" - : "Invalid GHC options specification:" - : map showGhcOptionSrc unused - where - showGhcOptionSrc name = concat - [ "- Package '" - , packageNameString name - , "' not found" - ] - displayException (TestSuiteExeMissing isSimpleBuildType exeName pkgName' testName) = - missingExeError "[S-7987]" - isSimpleBuildType $ concat - [ "Test suite executable \"" - , exeName - , " not found for " - , pkgName' - , ":test:" - , testName - ] - displayException (CabalCopyFailed isSimpleBuildType innerMsg) = - missingExeError "[S-8027]" - isSimpleBuildType $ concat - [ "'cabal copy' failed. Error message:\n" - , innerMsg - , "\n" - ] - displayException (LocalPackagesPresent locals) = unlines - $ "Error: [S-5510]" - : "Local packages are not allowed when using the 'script' command. \ - \Packages found:" - : map (\ident -> "- " ++ packageIdentifierString ident) locals - displayException (CouldNotLockDistDir lockFile) = unlines - [ "Error: [S-7168]" - , "Locking the dist directory failed, try to lock file:" - , " " ++ toFilePath lockFile - , "Maybe you're running another copy of Stack?" - ] - displayException (TaskCycleBug pid) = bugReport "[S-7868]" $ - "Unexpected task cycle for " - ++ packageNameString (pkgName pid) - displayException (PackageIdMissingBug ident) = bugReport "[S-8923]" $ - "singleBuild: missing package ID missing: " - ++ show ident - displayException AllInOneBuildBug = bugReport "[S-7371]" - "Cannot have an all-in-one build that also has a final build step." - displayException (MultipleResultsBug name dps) = bugReport "[S-6739]" $ - "singleBuild: multiple results when describing installed package " - ++ show (name, dps) - displayException TemplateHaskellNotFoundBug = bugReport "[S-3121]" - "template-haskell is a wired-in GHC boot library but it wasn't found." - displayException HaddockIndexNotFound = - "Error: [S-6901]\n" - ++ "No local or snapshot doc index found to open." - displayException ShowBuildErrorBug = bugReport "[S-5452]" - "Unexpected case in showBuildError." - -data BuildPrettyException - = ConstructPlanFailed - [ConstructPlanException] - (Path Abs File) - (Path Abs Dir) - ParentMap - (Set PackageName) - (Map PackageName [PackageName]) - | ExecutionFailure [SomeException] - | CabalExitedUnsuccessfully - ExitCode - PackageIdentifier - (Path Abs File) -- cabal Executable - [String] -- cabal arguments - (Maybe (Path Abs File)) -- logfiles location - [Text] -- log contents - | SetupHsBuildFailure - ExitCode - (Maybe PackageIdentifier) -- which package's custom setup, is simple setup - -- if Nothing - (Path Abs File) -- ghc Executable - [String] -- ghc arguments - (Maybe (Path Abs File)) -- logfiles location - [Text] -- log contents - | TargetParseException [StyleDoc] - | SomeTargetsNotBuildable [(PackageName, NamedComponent)] - | InvalidFlagSpecification (Set UnusedFlags) - | GHCProfOptionInvalid - deriving (Show, Typeable) - -instance Pretty BuildPrettyException where - pretty ( ConstructPlanFailed errs stackYaml stackRoot parents wanted prunedGlobalDeps ) = - "[S-4804]" - <> line - <> flow "Stack failed to construct a build plan." - <> blankLine - <> pprintExceptions - errs stackYaml stackRoot parents wanted prunedGlobalDeps - pretty (ExecutionFailure es) = - "[S-7282]" - <> line - <> flow "Stack failed to execute the build plan." - <> blankLine - <> fillSep - [ flow "While executing the build plan, Stack encountered the" - , case es of - [_] -> "error:" - _ -> flow "following errors:" - ] - <> blankLine - <> hcat (L.intersperse blankLine (map ppException es)) - pretty (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bss) = - showBuildError "[S-7011]" - False exitCode (Just taskProvides') execName fullArgs logFiles bss - pretty (SetupHsBuildFailure exitCode mtaskProvides execName fullArgs logFiles bss) = - showBuildError "[S-6374]" - True exitCode mtaskProvides execName fullArgs logFiles bss - pretty (TargetParseException errs) = - "[S-8506]" - <> pprintTargetParseErrors errs - pretty (SomeTargetsNotBuildable xs) = - "[S-7086]" - <> line - <> fillSep - ( [ flow "The following components have" - , style Shell (flow "buildable: False") - , flow "set in the Cabal configuration, and so cannot be targets:" - ] - <> mkNarrativeList (Just Target) False - (map (fromString . T.unpack . renderPkgComponent) xs :: [StyleDoc]) - ) - <> blankLine - <> flow "To resolve this, either provide flags such that these components \ - \are buildable, or only specify buildable targets." - pretty (InvalidFlagSpecification unused) = - "[S-8664]" - <> line - <> flow "Invalid flag specification:" - <> line - <> bulletedList (map go (Set.toList unused)) - where - showFlagSrc :: FlagSource -> StyleDoc - showFlagSrc FSCommandLine = flow "(specified on the command line)" - showFlagSrc FSStackYaml = - flow "(specified in the project-level configuration (e.g. stack.yaml))" - - go :: UnusedFlags -> StyleDoc - go (UFNoPackage src name) = fillSep - [ "Package" - , style Error (fromString $ packageNameString name) - , flow "not found" - , showFlagSrc src - ] - go (UFFlagsNotDefined src pname pkgFlags flags) = - fillSep - ( "Package" - : style Current (fromString name) - : flow "does not define the following flags" - : showFlagSrc src <> ":" - : mkNarrativeList (Just Error) False - (map (fromString . flagNameString) (Set.toList flags) :: [StyleDoc]) - ) - <> line - <> if Set.null pkgFlags - then fillSep - [ flow "No flags are defined by package" - , style Current (fromString name) <> "." - ] - else fillSep - ( flow "Flags defined by package" - : style Current (fromString name) - : "are:" - : mkNarrativeList (Just Good) False - (map (fromString . flagNameString) (Set.toList pkgFlags) :: [StyleDoc]) - ) - where - name = packageNameString pname - go (UFSnapshot name) = fillSep - [ flow "Attempted to set flag on snapshot package" - , style Current (fromString $ packageNameString name) <> "," - , flow "please add the package to" - , style Shell "extra-deps" <> "." - ] - pretty GHCProfOptionInvalid = - "[S-8100]" - <> line - <> fillSep - [ flow "When building with Stack, you should not use GHC's" - , style Shell "-prof" - , flow "option. Instead, please use Stack's" - , style Shell "--library-profiling" - , "and" - , style Shell "--executable-profiling" - , flow "flags. See:" - , style Url "https://github.com/commercialhaskell/stack/issues/1015" <> "." - ] - -instance Exception BuildPrettyException - --- | Helper function to pretty print an error message for target parse errors. -pprintTargetParseErrors :: [StyleDoc] -> StyleDoc -pprintTargetParseErrors errs = - line - <> flow "Stack failed to parse the target(s)." - <> blankLine - <> fillSep - [ flow "While parsing, Stack encountered the" - , case errs of - [err] -> - "error:" - <> blankLine - <> indent 4 err - _ -> - flow "following errors:" - <> blankLine - <> bulletedList errs - ] - <> blankLine - <> fillSep - [ flow "Stack expects a target to be a package name (e.g." - , style Shell "my-package" <> ")," - , flow "a package identifier (e.g." - , style Shell "my-package-0.1.2.3" <> ")," - , flow "a package component (e.g." - , style Shell "my-package:test:my-test-suite" <> ")," - , flow "or, failing that, a relative path to a directory that is a \ - \local package directory or a parent directory of one or more \ - \local package directories." - ] - -pprintExceptions :: - [ConstructPlanException] - -> Path Abs File - -> Path Abs Dir - -> ParentMap - -> Set PackageName - -> Map PackageName [PackageName] - -> StyleDoc -pprintExceptions exceptions stackYaml stackRoot parentMap wanted' prunedGlobalDeps = - mconcat $ - [ flow "While constructing the build plan, Stack encountered the \ - \following errors:" - , blankLine - , mconcat (L.intersperse blankLine (mapMaybe pprintException exceptions')) - ] ++ if L.null recommendations - then [] - else - [ blankLine - , flow "Some different approaches to resolving this:" - , blankLine - ] ++ recommendations - - where - exceptions' = {- should we dedupe these somehow? nubOrd -} exceptions - - recommendations = - if not onlyHasDependencyMismatches - then [] - else - [ " *" <+> align (fillSep - [ "Set" - , style Shell (flow "allow-newer: true") - , "in" - , pretty (defaultUserConfigPath stackRoot) - , flow "to ignore all version constraints and build anyway." - ]) - , blankLine - ] - ++ addExtraDepsRecommendations - - addExtraDepsRecommendations - | Map.null extras = [] - | (Just _) <- Map.lookup (mkPackageName "base") extras = - [ " *" <+> align (fillSep - [ flow "Build requires unattainable version of the" - , style Current "base" - , flow "package. Since" - , style Current "base" - , flow "is a part of GHC, you most likely need to use a \ - \different GHC version with the matching" - , style Current "base"<> "." - ]) - , line - ] - | otherwise = - [ " *" <+> align (fillSep - [ style Recommendation (flow "Recommended action:") - , flow "try adding the following to your" - , style Shell "extra-deps" - , "in" - , pretty stackYaml <> ":" - ]) - , blankLine - , vsep (map pprintExtra (Map.toList extras)) - , line - ] - - extras = Map.unions $ map getExtras exceptions' - getExtras DependencyCycleDetected{} = Map.empty - getExtras UnknownPackage{} = Map.empty - getExtras (DependencyPlanFailures _ m) = - Map.unions $ map go $ Map.toList m - where - -- TODO: Likely a good idea to distinguish these to the user. In - -- particular, for DependencyMismatch - go (name, (_range, Just (version,cabalHash), NotInBuildPlan)) = - Map.singleton name (version,cabalHash) - go (name, (_range, Just (version,cabalHash), DependencyMismatch{})) = - Map.singleton name (version, cabalHash) - go _ = Map.empty - pprintExtra (name, (version, BlobKey cabalHash cabalSize)) = - let cfInfo = CFIHash cabalHash (Just cabalSize) - packageIdRev = PackageIdentifierRevision name version cfInfo - in fromString ("- " ++ T.unpack (utf8BuilderToText (display packageIdRev))) - - allNotInBuildPlan = Set.fromList $ concatMap toNotInBuildPlan exceptions' - toNotInBuildPlan (DependencyPlanFailures _ pDeps) = - map fst $ - filter - (\(_, (_, _, badDep)) -> badDep == NotInBuildPlan) - (Map.toList pDeps) - toNotInBuildPlan _ = [] - - -- This checks if 'allow-newer: true' could resolve all issues. - onlyHasDependencyMismatches = all go exceptions' - where - go DependencyCycleDetected{} = False - go UnknownPackage{} = False - go (DependencyPlanFailures _ m) = - all (\(_, _, depErr) -> isMismatch depErr) (M.elems m) - isMismatch DependencyMismatch{} = True - isMismatch Couldn'tResolveItsDependencies{} = True - isMismatch _ = False - - pprintException (DependencyCycleDetected pNames) = Just $ - flow "Dependency cycle detected in packages:" - <> line - <> indent 4 - ( encloseSep "[" "]" "," - (map (style Error . fromString . packageNameString) pNames) - ) - pprintException (DependencyPlanFailures pkg pDeps) = - case mapMaybe pprintDep (Map.toList pDeps) of - [] -> Nothing - depErrors -> Just $ - flow "In the dependencies for" <+> pkgIdent <> - pprintFlags (packageFlags pkg) <> ":" <> line <> - indent 4 (vsep depErrors) <> - case getShortestDepsPath parentMap wanted' (packageName pkg) of - Nothing -> - line - <> flow "needed for unknown reason - stack invariant violated." - Just [] -> - line - <> fillSep - [ flow "needed since" - , pkgName' - , flow "is a build target." - ] - Just (target:path) -> - line - <> flow "needed due to" <+> encloseSep "" "" " -> " pathElems - where - pathElems = - [style Target . fromString . packageIdentifierString $ target] ++ - map (fromString . packageIdentifierString) path ++ - [pkgIdent] - where - pkgName' = - style Current . fromString . packageNameString $ packageName pkg - pkgIdent = - style - Current - (fromString . packageIdentifierString $ packageIdentifier pkg) - -- Skip these when they are redundant with 'NotInBuildPlan' info. - pprintException (UnknownPackage name) - | name `Set.member` allNotInBuildPlan = Nothing - | name `Set.member` wiredInPackages = Just $ fillSep - [ flow "Can't build a package with same name as a wired-in-package:" - , style Current . fromString . packageNameString $ name - ] - | Just pruned <- Map.lookup name prunedGlobalDeps = - let prunedDeps = - map (style Current . fromString . packageNameString) pruned - in Just $ fillSep - [ flow "Can't use GHC boot package" - , style Current . fromString . packageNameString $ name - , flow "when it has an overridden dependency (issue #4510);" - , flow "you need to add the following as explicit dependencies \ - \to the project:" - , line - , encloseSep "" "" ", " prunedDeps - ] - | otherwise = Just $ fillSep - [ flow "Unknown package:" - , style Current . fromString . packageNameString $ name - ] - - pprintFlags flags - | Map.null flags = "" - | otherwise = parens $ sep $ map pprintFlag $ Map.toList flags - pprintFlag (name, True) = "+" <> fromString (flagNameString name) - pprintFlag (name, False) = "-" <> fromString (flagNameString name) - - pprintDep (name, (range, mlatestApplicable, badDep)) = case badDep of - NotInBuildPlan - | name `elem` fold prunedGlobalDeps -> Just $ - style Error (fromString $ packageNameString name) <+> - align - ( ( if range == C.anyVersion - then flow "needed" - else flow "must match" <+> goodRange - ) - <> "," - <> softline - <> fillSep - [ flow "but this GHC boot package has been pruned (issue \ - \#4510); you need to add the package explicitly to \ - \extra-deps" - ,latestApplicable Nothing - ] - ) - | otherwise -> Just $ - style Error (fromString $ packageNameString name) <+> - align - ( ( if range == C.anyVersion - then flow "needed" - else flow "must match" <+> goodRange - ) - <> "," - <> softline - <> fillSep - [ flow "but the Stack configuration has no specified version" - , latestApplicable Nothing - ] - ) - -- TODO: For local packages, suggest editing constraints - DependencyMismatch version -> Just $ - style - Error - (fromString . packageIdentifierString $ PackageIdentifier name version) - <+> - align - ( fillSep - [ flow "from Stack configuration does not match" - , goodRange - , latestApplicable (Just version) - ] - ) - -- I think the main useful info is these explain why missing packages are - -- needed. Instead lets give the user the shortest path from a target to the - -- package. - Couldn'tResolveItsDependencies _version -> Nothing - HasNoLibrary -> Just $ - style Error (fromString $ packageNameString name) <+> - align (flow "is a library dependency, but the package provides no library") - BDDependencyCycleDetected names -> Just $ - style Error (fromString $ packageNameString name) <+> - align - ( flow $ "dependency cycle detected: " - ++ L.intercalate ", " (map packageNameString names) - ) - where - goodRange = style Good (fromString (C.display range)) - latestApplicable mversion = - case mlatestApplicable of - Nothing - | isNothing mversion -> - flow "(no package with that name found, perhaps there is a typo \ - \in a package's build-depends or an omission from the \ - \stack.yaml packages list?)" - | otherwise -> "" - Just (laVer, _) - | Just laVer == mversion -> - flow "(latest matching version is specified)" - | otherwise -> - fillSep - [ flow "(latest matching version is" - , style Good (fromString $ versionString laVer) <> ")" - ] - --- | Get the shortest reason for the package to be in the build plan. In --- other words, trace the parent dependencies back to a 'wanted' --- package. -getShortestDepsPath :: - ParentMap - -> Set PackageName - -> PackageName - -> Maybe [PackageIdentifier] -getShortestDepsPath (MonoidMap parentsMap) wanted' name = - if Set.member name wanted' - then Just [] - else case M.lookup name parentsMap of - Nothing -> Nothing - Just (_, parents) -> Just $ findShortest 256 paths0 - where - paths0 = M.fromList $ - map (\(ident, _) -> (pkgName ident, startDepsPath ident)) parents - where - -- The 'paths' map is a map from PackageName to the shortest path - -- found to get there. It is the frontier of our breadth-first - -- search of dependencies. - findShortest :: Int -> Map PackageName DepsPath -> [PackageIdentifier] - findShortest fuel _ | fuel <= 0 = - [ PackageIdentifier - (mkPackageName "stack-ran-out-of-jet-fuel") - (C.mkVersion [0]) - ] - findShortest _ paths | M.null paths = [] - findShortest fuel paths = - case targets of - [] -> findShortest (fuel - 1) $ M.fromListWith chooseBest $ - concatMap extendPath recurses - _ -> let (DepsPath _ _ path) = L.minimum (map snd targets) in path - where - (targets, recurses) = - L.partition (\(n, _) -> n `Set.member` wanted') (M.toList paths) - chooseBest :: DepsPath -> DepsPath -> DepsPath - chooseBest = max - -- Extend a path to all its parents. - extendPath :: (PackageName, DepsPath) -> [(PackageName, DepsPath)] - extendPath (n, dp) = - case M.lookup n parentsMap of - Nothing -> [] - Just (_, parents) -> - map (\(pkgId, _) -> (pkgName pkgId, extendDepsPath pkgId dp)) parents - -startDepsPath :: PackageIdentifier -> DepsPath -startDepsPath ident = DepsPath - { dpLength = 1 - , dpNameLength = length (packageNameString (pkgName ident)) - , dpPath = [ident] - } - -extendDepsPath :: PackageIdentifier -> DepsPath -> DepsPath -extendDepsPath ident dp = DepsPath - { dpLength = dpLength dp + 1 - , dpNameLength = dpNameLength dp + length (packageNameString (pkgName ident)) - , dpPath = [ident] - } - -data ConstructPlanException - = DependencyCycleDetected [PackageName] - | DependencyPlanFailures - Package - (Map PackageName (VersionRange, LatestApplicableVersion, BadDependency)) - | UnknownPackage PackageName -- TODO perhaps this constructor will be removed, - -- and BadDependency will handle it all - -- ^ Recommend adding to extra-deps, give a helpful version number? - deriving (Eq, Show, Typeable) - --- | The latest applicable version and it's latest Cabal file revision. --- For display purposes only, Nothing if package not found -type LatestApplicableVersion = Maybe (Version, BlobKey) - --- | Reason why a dependency was not used -data BadDependency - = NotInBuildPlan - | Couldn'tResolveItsDependencies Version - | DependencyMismatch Version - | HasNoLibrary - -- ^ See description of 'DepType' - | BDDependencyCycleDetected ![PackageName] - deriving (Eq, Ord, Show, Typeable) - -type ParentMap = - MonoidMap PackageName (First Version, [(PackageIdentifier, VersionRange)]) - -data DepsPath = DepsPath - { dpLength :: Int - -- ^ Length of dpPath - , dpNameLength :: Int - -- ^ Length of package names combined - , dpPath :: [PackageIdentifier] - -- ^ A path where the packages later in the list depend on those that come - -- earlier - } - deriving (Eq, Ord, Show) - -data FlagSource - = FSCommandLine - | FSStackYaml - deriving (Eq, Ord, Show) - -data UnusedFlags - = UFNoPackage FlagSource PackageName - | UFFlagsNotDefined - FlagSource - PackageName - (Set FlagName) -- defined in package - (Set FlagName) -- not defined - | UFSnapshot PackageName - deriving (Eq, Ord, Show) - -missingExeError :: String -> Bool -> String -> String -missingExeError errorCode isSimpleBuildType msg = unlines - $ "Error: " <> errorCode - : msg - : "Possible causes of this issue:" - : map ("* " <>) possibleCauses - where - possibleCauses - = "No module named \"Main\". The 'main-is' source file should usually \ - \have a header indicating that it's a 'Main' module." - : "A Cabal file that refers to nonexistent other files (e.g. a \ - \license-file that doesn't exist). Running 'cabal check' may point \ - \out these issues." - : [ "The Setup.hs file is changing the installation target dir." - | not isSimpleBuildType - ] - -showBuildError :: - String - -> Bool - -> ExitCode - -> Maybe PackageIdentifier - -> Path Abs File - -> [String] - -> Maybe (Path Abs File) - -> [Text] - -> StyleDoc -showBuildError errorCode isBuildingSetup exitCode mtaskProvides execName fullArgs logFiles bss = - let fullCmd = unwords - $ dropQuotes (toFilePath execName) - : map (T.unpack . showProcessArgDebug) fullArgs - logLocations = - maybe - mempty - (\fp -> line <> flow "Logs have been written to:" <+> - pretty fp) - logFiles - in fromString errorCode - <> line - <> flow "While building" <+> - ( case (isBuildingSetup, mtaskProvides) of - (False, Nothing) -> impureThrow ShowBuildErrorBug - (False, Just taskProvides') -> - "package" <+> - style - Target - (fromString $ dropQuotes (packageIdentifierString taskProvides')) - (True, Nothing) -> "simple" <+> style File "Setup.hs" - (True, Just taskProvides') -> - "custom" <+> - style File "Setup.hs" <+> - flow "for package" <+> - style - Target - (fromString $ dropQuotes (packageIdentifierString taskProvides')) - ) <+> - flow "(scroll up to its section to see the error) using:" - <> line - <> style Shell (fromString fullCmd) - <> line - <> flow "Process exited with code:" <+> (fromString . show) exitCode <+> - ( if exitCode == ExitFailure (-9) - then flow "(THIS MAY INDICATE OUT OF MEMORY)" - else mempty - ) - <> logLocations - <> if null bss - then mempty - else blankLine <> string (removeTrailingSpaces (map T.unpack bss)) - where - removeTrailingSpaces = dropWhileEnd isSpace . unlines - dropQuotes = filter ('\"' /=) - ----------------------------------------------- -- | Package dependency oracle. newtype PkgDepsOracle @@ -1038,20 +171,6 @@ data TaskType | TTRemotePackage IsMutable Package PackageLocationImmutable deriving Show -data IsMutable - = Mutable - | Immutable - deriving (Eq, Show) - -instance Semigroup IsMutable where - Mutable <> _ = Mutable - _ <> Mutable = Mutable - Immutable <> Immutable = Immutable - -instance Monoid IsMutable where - mempty = Immutable - mappend = (<>) - taskIsTarget :: Task -> Bool taskIsTarget t = case taskType t of @@ -1087,202 +206,6 @@ data Plan = Plan } deriving Show --- | Basic information used to calculate what the configure options are -data BaseConfigOpts = BaseConfigOpts - { bcoSnapDB :: !(Path Abs Dir) - , bcoLocalDB :: !(Path Abs Dir) - , bcoSnapInstallRoot :: !(Path Abs Dir) - , bcoLocalInstallRoot :: !(Path Abs Dir) - , bcoBuildOpts :: !BuildOpts - , bcoBuildOptsCLI :: !BuildOptsCLI - , bcoExtraDBs :: ![Path Abs Dir] - } - deriving Show - --- | Render a @BaseConfigOpts@ to an actual list of options -configureOpts :: EnvConfig - -> BaseConfigOpts - -> Map PackageIdentifier GhcPkgId -- ^ dependencies - -> Bool -- ^ local non-extra-dep? - -> IsMutable - -> Package - -> ConfigureOpts -configureOpts econfig bco deps isLocal isMutable package = ConfigureOpts - { coDirs = configureOptsDirs bco isMutable package - , coNoDirs = configureOptsNoDir econfig bco deps isLocal package - } - --- options set by stack -isStackOpt :: Text -> Bool -isStackOpt t = any (`T.isPrefixOf` t) - [ "--dependency=" - , "--constraint=" - , "--package-db=" - , "--libdir=" - , "--bindir=" - , "--datadir=" - , "--libexecdir=" - , "--sysconfdir" - , "--docdir=" - , "--htmldir=" - , "--haddockdir=" - , "--enable-tests" - , "--enable-benchmarks" - , "--exact-configuration" - -- Treat these as causing dirtiness, to resolve - -- https://github.com/commercialhaskell/stack/issues/2984 - -- - -- , "--enable-library-profiling" - -- , "--enable-executable-profiling" - -- , "--enable-profiling" - ] || t == "--user" - -configureOptsDirs :: BaseConfigOpts - -> IsMutable - -> Package - -> [String] -configureOptsDirs bco isMutable package = concat - [ ["--user", "--package-db=clear", "--package-db=global"] - , map (("--package-db=" ++) . toFilePathNoTrailingSep) $ case isMutable of - Immutable -> bcoExtraDBs bco ++ [bcoSnapDB bco] - Mutable -> bcoExtraDBs bco ++ [bcoSnapDB bco] ++ [bcoLocalDB bco] - , [ "--libdir=" ++ toFilePathNoTrailingSep (installRoot relDirLib) - , "--bindir=" ++ toFilePathNoTrailingSep (installRoot bindirSuffix) - , "--datadir=" ++ toFilePathNoTrailingSep (installRoot relDirShare) - , "--libexecdir=" ++ toFilePathNoTrailingSep (installRoot relDirLibexec) - , "--sysconfdir=" ++ toFilePathNoTrailingSep (installRoot relDirEtc) - , "--docdir=" ++ toFilePathNoTrailingSep docDir - , "--htmldir=" ++ toFilePathNoTrailingSep docDir - , "--haddockdir=" ++ toFilePathNoTrailingSep docDir] - ] - where - installRoot = - case isMutable of - Immutable -> bcoSnapInstallRoot bco - Mutable -> bcoLocalInstallRoot bco - docDir = - case pkgVerDir of - Nothing -> installRoot docDirSuffix - Just dir -> installRoot docDirSuffix dir - pkgVerDir = parseRelDir - ( packageIdentifierString - (PackageIdentifier (packageName package) (packageVersion package)) - ++ [pathSeparator] - ) - --- | Same as 'configureOpts', but does not include directory path options -configureOptsNoDir :: - EnvConfig - -> BaseConfigOpts - -> Map PackageIdentifier GhcPkgId -- ^ Dependencies. - -> Bool -- ^ Is this a local, non-extra-dep? - -> Package - -> [String] -configureOptsNoDir econfig bco deps isLocal package = concat - [ depOptions - , [ "--enable-library-profiling" - | boptsLibProfile bopts || boptsExeProfile bopts - ] - , ["--enable-profiling" | boptsExeProfile bopts && isLocal] - , ["--enable-split-objs" | boptsSplitObjs bopts] - , [ "--disable-library-stripping" - | not $ boptsLibStrip bopts || boptsExeStrip bopts - ] - , ["--disable-executable-stripping" | not (boptsExeStrip bopts) && isLocal] - , map (\(name,enabled) -> - "-f" <> - (if enabled - then "" - else "-") <> - flagNameString name) - (Map.toList flags) - , map T.unpack $ packageCabalConfigOpts package - , processGhcOptions (packageGhcOptions package) - , map ("--extra-include-dirs=" ++) (configExtraIncludeDirs config) - , map ("--extra-lib-dirs=" ++) (configExtraLibDirs config) - , maybe - [] - (\customGcc -> ["--with-gcc=" ++ toFilePath customGcc]) - (configOverrideGccPath config) - , ["--exact-configuration"] - , ["--ghc-option=-fhide-source-paths" | hideSourcePaths cv] - ] - where - -- This function parses the GHC options that are providing in the - -- stack.yaml file. In order to handle RTS arguments correctly, we need - -- to provide the RTS arguments as a single argument. - processGhcOptions :: [Text] -> [String] - processGhcOptions args = - let (preRtsArgs, mid) = break ("+RTS" ==) args - (rtsArgs, end) = break ("-RTS" ==) mid - fullRtsArgs = - case rtsArgs of - [] -> - -- This means that we didn't have any RTS args - no `+RTS` - and - -- therefore no need for a `-RTS`. - [] - _ -> - -- In this case, we have some RTS args. `break` puts the `"-RTS"` - -- string in the `snd` list, so we want to append it on the end of - -- `rtsArgs` here. - -- - -- We're not checking that `-RTS` is the first element of `end`. - -- This is because the GHC RTS allows you to omit a trailing -RTS - -- if that's the last of the arguments. This permits a GHC options - -- in stack.yaml that matches what you might pass directly to GHC. - [T.unwords $ rtsArgs ++ ["-RTS"]] - -- We drop the first element from `end`, because it is always either - -- `"-RTS"` (and we don't want that as a separate argument) or the list - -- is empty (and `drop _ [] = []`). - postRtsArgs = drop 1 end - newArgs = concat [preRtsArgs, fullRtsArgs, postRtsArgs] - in concatMap (\x -> [compilerOptionsCabalFlag wc, T.unpack x]) newArgs - - wc = view (actualCompilerVersionL.to whichCompiler) econfig - cv = view (actualCompilerVersionL.to getGhcVersion) econfig - - hideSourcePaths ghcVersion = - ghcVersion >= C.mkVersion [8, 2] && configHideSourcePaths config - - config = view configL econfig - bopts = bcoBuildOpts bco - - -- Unioning atop defaults is needed so that all flags are specified with - -- --exact-configuration. - flags = packageFlags package `Map.union` packageDefaultFlags package - - depOptions = map toDepOption $ Map.toList deps - - toDepOption (PackageIdentifier name _, gid) = concat - [ "--dependency=" - , depOptionKey - , "=" - , ghcPkgIdString gid - ] - where - MungedPackageName subPkgName lib = decodeCompatPackageName name - depOptionKey = case lib of - LMainLibName -> unPackageName name - LSubLibName cn -> - unPackageName subPkgName <> ":" <> unUnqualComponentName cn - --- | Get set of wanted package names from locals. -wantedLocalPackages :: [LocalPackage] -> Set PackageName -wantedLocalPackages = - Set.fromList . map (packageName . lpPackage) . filter lpWanted - --- | Configure options to be sent to Setup.hs configure -data ConfigureOpts = ConfigureOpts - { coDirs :: ![String] - -- ^ Options related to various paths. We separate these out since they do - -- not have an impact on the contents of the compiled binary for checking - -- if we can use an existing precompiled cache. - , coNoDirs :: ![String] - } - deriving (Data, Eq, Generic, Show, Typeable) - -instance NFData ConfigureOpts - -- | Information on a compiled package: the library conf file (if relevant), -- the sublibraries (if present) and all of the executable paths. data PrecompiledCache base = PrecompiledCache diff --git a/src/Stack/Types/Build/Exception.hs b/src/Stack/Types/Build/Exception.hs new file mode 100644 index 0000000000..f584962f0b --- /dev/null +++ b/src/Stack/Types/Build/Exception.hs @@ -0,0 +1,842 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +module Stack.Types.Build.Exception + ( BuildException (..) + , BuildPrettyException (..) + , pprintTargetParseErrors + , ConstructPlanException (..) + , LatestApplicableVersion + , BadDependency (..) + ) where + +import qualified Data.ByteString as S +import Data.Char ( isSpace ) +import Data.List as L +import qualified Data.Map as Map +import qualified Data.Map.Strict as M +import Data.Monoid.Map ( MonoidMap (..) ) +import qualified Data.Set as Set +import qualified Data.Text as T +import Distribution.System ( Arch ) +import qualified Distribution.Text as C +import Distribution.Types.PackageName ( mkPackageName ) +import Distribution.Types.TestSuiteInterface ( TestSuiteInterface ) +import qualified Distribution.Version as C +import RIO.Process ( showProcessArgDebug ) +import Stack.Constants + ( defaultUserConfigPath, wiredInPackages ) +import Stack.Prelude +import Stack.Types.Compiler ( ActualCompiler, compilerVersionString ) +import Stack.Types.CompilerBuild + ( CompilerBuild, compilerBuildSuffix ) +import Stack.Types.DumpPackage ( DumpPackage ) +import Stack.Types.UnusedFlags ( FlagSource (..), UnusedFlags (..) ) +import Stack.Types.GHCVariant ( GHCVariant, ghcVariantSuffix ) +import Stack.Types.NamedComponent + ( NamedComponent, renderPkgComponent ) +import Stack.Types.Package ( Package (..), packageIdentifier ) +import Stack.Types.ParentMap ( ParentMap ) +import Stack.Types.Version ( VersionCheck (..), VersionRange ) + +-- | Type representing exceptions thrown by functions exported by modules with +-- names beginning @Stack.Build@. +data BuildException + = Couldn'tFindPkgId PackageName + | CompilerVersionMismatch + (Maybe (ActualCompiler, Arch)) -- found + (WantedCompiler, Arch) -- expected + GHCVariant -- expected + CompilerBuild -- expected + VersionCheck + (Maybe (Path Abs File)) -- Path to the stack.yaml file + Text -- recommended resolution + | Couldn'tParseTargets [Text] + | UnknownTargets + (Set PackageName) -- no known version + (Map PackageName Version) -- not in snapshot, here's the most recent + -- version in the index + (Path Abs File) -- stack.yaml + | TestSuiteFailure + PackageIdentifier + (Map Text (Maybe ExitCode)) + (Maybe (Path Abs File)) + S.ByteString + | TestSuiteTypeUnsupported TestSuiteInterface + | LocalPackageDoesn'tMatchTarget + PackageName + Version -- local version + Version -- version specified on command line + | NoSetupHsFound (Path Abs Dir) + | InvalidGhcOptionsSpecification [PackageName] + | TestSuiteExeMissing Bool String String String + | CabalCopyFailed Bool String + | LocalPackagesPresent [PackageIdentifier] + | CouldNotLockDistDir !(Path Abs File) + | TaskCycleBug PackageIdentifier + | PackageIdMissingBug PackageIdentifier + | AllInOneBuildBug + | MultipleResultsBug PackageName [DumpPackage] + | TemplateHaskellNotFoundBug + | HaddockIndexNotFound + | ShowBuildErrorBug + deriving (Show, Typeable) + +instance Exception BuildException where + displayException (Couldn'tFindPkgId name) = bugReport "[S-7178]" $ concat + [ "After installing " + , packageNameString name + ,", the package id couldn't be found (via ghc-pkg describe " + , packageNameString name + , ")." + ] + displayException (CompilerVersionMismatch mactual (expected, eArch) ghcVariant ghcBuild check mstack resolution) = concat + [ "Error: [S-6362]\n" + , case mactual of + Nothing -> "No compiler found, expected " + Just (actual, arch) -> concat + [ "Compiler version mismatched, found " + , compilerVersionString actual + , " (" + , C.display arch + , ")" + , ", but expected " + ] + , case check of + MatchMinor -> "minor version match with " + MatchExact -> "exact version " + NewerMinor -> "minor version match or newer with " + , T.unpack $ utf8BuilderToText $ display expected + , " (" + , C.display eArch + , ghcVariantSuffix ghcVariant + , compilerBuildSuffix ghcBuild + , ") (based on " + , case mstack of + Nothing -> "command line arguments" + Just stack -> "resolver setting in " ++ toFilePath stack + , ").\n" + , T.unpack resolution + ] + displayException (Couldn'tParseTargets targets) = unlines + $ "Error: [S-3127]" + : "The following targets could not be parsed as package names or \ + \directories:" + : map T.unpack targets + displayException (UnknownTargets noKnown notInSnapshot stackYaml) = unlines + $ "Error: [S-2154]" + : (noKnown' ++ notInSnapshot') + where + noKnown' + | Set.null noKnown = [] + | otherwise = pure $ + "The following target packages were not found: " ++ + intercalate ", " (map packageNameString $ Set.toList noKnown) ++ + "\nSee https://docs.haskellstack.org/en/stable/build_command/#target-syntax for details." + notInSnapshot' + | Map.null notInSnapshot = [] + | otherwise = + "The following packages are not in your snapshot, but exist" + : "in your package index. Recommended action: add them to your" + : ("extra-deps in " ++ toFilePath stackYaml) + : "(Note: these are the most recent versions," + : "but there's no guarantee that they'll build together)." + : "" + : map + (\(name, version') -> "- " ++ packageIdentifierString + (PackageIdentifier name version')) + (Map.toList notInSnapshot) + displayException (TestSuiteFailure ident codes mlogFile bs) = unlines + $ "Error: [S-1995]" + : concat + [ ["Test suite failure for package " ++ packageIdentifierString ident] + , flip map (Map.toList codes) $ \(name, mcode) -> concat + [ " " + , T.unpack name + , ": " + , case mcode of + Nothing -> " executable not found" + Just ec -> " exited with: " ++ displayException ec + ] + , pure $ case mlogFile of + Nothing -> "Logs printed to console" + -- TODO Should we load up the full error output and print it here? + Just logFile -> "Full log available at " ++ toFilePath logFile + , if S.null bs + then [] + else + [ "" + , "" + , doubleIndent $ T.unpack $ decodeUtf8With lenientDecode bs + ] + ] + where + indent' = dropWhileEnd isSpace . unlines . fmap (" " ++) . lines + doubleIndent = indent' . indent' + displayException (TestSuiteTypeUnsupported interface) = concat + [ "Error: [S-3819]\n" + , "Unsupported test suite type: " + , show interface + ] + -- Suppressing duplicate output + displayException (LocalPackageDoesn'tMatchTarget name localV requestedV) = concat + [ "Error: [S-5797]\n" + , "Version for local package " + , packageNameString name + , " is " + , versionString localV + , ", but you asked for " + , versionString requestedV + , " on the command line" + ] + displayException (NoSetupHsFound dir) = concat + [ "Error: [S-3118]\n" + , "No Setup.hs or Setup.lhs file found in " + , toFilePath dir + ] + displayException (InvalidGhcOptionsSpecification unused) = unlines + $ "Error: [S-4925]" + : "Invalid GHC options specification:" + : map showGhcOptionSrc unused + where + showGhcOptionSrc name = concat + [ "- Package '" + , packageNameString name + , "' not found" + ] + displayException (TestSuiteExeMissing isSimpleBuildType exeName pkgName' testName) = + missingExeError "[S-7987]" + isSimpleBuildType $ concat + [ "Test suite executable \"" + , exeName + , " not found for " + , pkgName' + , ":test:" + , testName + ] + displayException (CabalCopyFailed isSimpleBuildType innerMsg) = + missingExeError "[S-8027]" + isSimpleBuildType $ concat + [ "'cabal copy' failed. Error message:\n" + , innerMsg + , "\n" + ] + displayException (LocalPackagesPresent locals) = unlines + $ "Error: [S-5510]" + : "Local packages are not allowed when using the 'script' command. \ + \Packages found:" + : map (\ident -> "- " ++ packageIdentifierString ident) locals + displayException (CouldNotLockDistDir lockFile) = unlines + [ "Error: [S-7168]" + , "Locking the dist directory failed, try to lock file:" + , " " ++ toFilePath lockFile + , "Maybe you're running another copy of Stack?" + ] + displayException (TaskCycleBug pid) = bugReport "[S-7868]" $ + "Unexpected task cycle for " + ++ packageNameString (pkgName pid) + displayException (PackageIdMissingBug ident) = bugReport "[S-8923]" $ + "singleBuild: missing package ID missing: " + ++ show ident + displayException AllInOneBuildBug = bugReport "[S-7371]" + "Cannot have an all-in-one build that also has a final build step." + displayException (MultipleResultsBug name dps) = bugReport "[S-6739]" $ + "singleBuild: multiple results when describing installed package " + ++ show (name, dps) + displayException TemplateHaskellNotFoundBug = bugReport "[S-3121]" + "template-haskell is a wired-in GHC boot library but it wasn't found." + displayException HaddockIndexNotFound = + "Error: [S-6901]\n" + ++ "No local or snapshot doc index found to open." + displayException ShowBuildErrorBug = bugReport "[S-5452]" + "Unexpected case in showBuildError." + +data BuildPrettyException + = ConstructPlanFailed + [ConstructPlanException] + (Path Abs File) + (Path Abs Dir) + ParentMap + (Set PackageName) + (Map PackageName [PackageName]) + | ExecutionFailure [SomeException] + | CabalExitedUnsuccessfully + ExitCode + PackageIdentifier + (Path Abs File) -- cabal Executable + [String] -- cabal arguments + (Maybe (Path Abs File)) -- logfiles location + [Text] -- log contents + | SetupHsBuildFailure + ExitCode + (Maybe PackageIdentifier) -- which package's custom setup, is simple setup + -- if Nothing + (Path Abs File) -- ghc Executable + [String] -- ghc arguments + (Maybe (Path Abs File)) -- logfiles location + [Text] -- log contents + | TargetParseException [StyleDoc] + | SomeTargetsNotBuildable [(PackageName, NamedComponent)] + | InvalidFlagSpecification (Set UnusedFlags) + | GHCProfOptionInvalid + deriving (Show, Typeable) + +instance Pretty BuildPrettyException where + pretty ( ConstructPlanFailed errs stackYaml stackRoot parents wanted prunedGlobalDeps ) = + "[S-4804]" + <> line + <> flow "Stack failed to construct a build plan." + <> blankLine + <> pprintExceptions + errs stackYaml stackRoot parents wanted prunedGlobalDeps + pretty (ExecutionFailure es) = + "[S-7282]" + <> line + <> flow "Stack failed to execute the build plan." + <> blankLine + <> fillSep + [ flow "While executing the build plan, Stack encountered the" + , case es of + [_] -> "error:" + _ -> flow "following errors:" + ] + <> blankLine + <> hcat (L.intersperse blankLine (map ppException es)) + pretty (CabalExitedUnsuccessfully exitCode taskProvides' execName fullArgs logFiles bss) = + showBuildError "[S-7011]" + False exitCode (Just taskProvides') execName fullArgs logFiles bss + pretty (SetupHsBuildFailure exitCode mtaskProvides execName fullArgs logFiles bss) = + showBuildError "[S-6374]" + True exitCode mtaskProvides execName fullArgs logFiles bss + pretty (TargetParseException errs) = + "[S-8506]" + <> pprintTargetParseErrors errs + pretty (SomeTargetsNotBuildable xs) = + "[S-7086]" + <> line + <> fillSep + ( [ flow "The following components have" + , style Shell (flow "buildable: False") + , flow "set in the Cabal configuration, and so cannot be targets:" + ] + <> mkNarrativeList (Just Target) False + (map (fromString . T.unpack . renderPkgComponent) xs :: [StyleDoc]) + ) + <> blankLine + <> flow "To resolve this, either provide flags such that these components \ + \are buildable, or only specify buildable targets." + pretty (InvalidFlagSpecification unused) = + "[S-8664]" + <> line + <> flow "Invalid flag specification:" + <> line + <> bulletedList (map go (Set.toList unused)) + where + showFlagSrc :: FlagSource -> StyleDoc + showFlagSrc FSCommandLine = flow "(specified on the command line)" + showFlagSrc FSStackYaml = + flow "(specified in the project-level configuration (e.g. stack.yaml))" + + go :: UnusedFlags -> StyleDoc + go (UFNoPackage src name) = fillSep + [ "Package" + , style Error (fromString $ packageNameString name) + , flow "not found" + , showFlagSrc src + ] + go (UFFlagsNotDefined src pname pkgFlags flags) = + fillSep + ( "Package" + : style Current (fromString name) + : flow "does not define the following flags" + : showFlagSrc src <> ":" + : mkNarrativeList (Just Error) False + (map (fromString . flagNameString) (Set.toList flags) :: [StyleDoc]) + ) + <> line + <> if Set.null pkgFlags + then fillSep + [ flow "No flags are defined by package" + , style Current (fromString name) <> "." + ] + else fillSep + ( flow "Flags defined by package" + : style Current (fromString name) + : "are:" + : mkNarrativeList (Just Good) False + (map (fromString . flagNameString) (Set.toList pkgFlags) :: [StyleDoc]) + ) + where + name = packageNameString pname + go (UFSnapshot name) = fillSep + [ flow "Attempted to set flag on snapshot package" + , style Current (fromString $ packageNameString name) <> "," + , flow "please add the package to" + , style Shell "extra-deps" <> "." + ] + pretty GHCProfOptionInvalid = + "[S-8100]" + <> line + <> fillSep + [ flow "When building with Stack, you should not use GHC's" + , style Shell "-prof" + , flow "option. Instead, please use Stack's" + , style Shell "--library-profiling" + , "and" + , style Shell "--executable-profiling" + , flow "flags. See:" + , style Url "https://github.com/commercialhaskell/stack/issues/1015" <> "." + ] + +instance Exception BuildPrettyException + +-- | Helper function to pretty print an error message for target parse errors. +pprintTargetParseErrors :: [StyleDoc] -> StyleDoc +pprintTargetParseErrors errs = + line + <> flow "Stack failed to parse the target(s)." + <> blankLine + <> fillSep + [ flow "While parsing, Stack encountered the" + , case errs of + [err] -> + "error:" + <> blankLine + <> indent 4 err + _ -> + flow "following errors:" + <> blankLine + <> bulletedList errs + ] + <> blankLine + <> fillSep + [ flow "Stack expects a target to be a package name (e.g." + , style Shell "my-package" <> ")," + , flow "a package identifier (e.g." + , style Shell "my-package-0.1.2.3" <> ")," + , flow "a package component (e.g." + , style Shell "my-package:test:my-test-suite" <> ")," + , flow "or, failing that, a relative path to a directory that is a \ + \local package directory or a parent directory of one or more \ + \local package directories." + ] + +pprintExceptions :: + [ConstructPlanException] + -> Path Abs File + -> Path Abs Dir + -> ParentMap + -> Set PackageName + -> Map PackageName [PackageName] + -> StyleDoc +pprintExceptions exceptions stackYaml stackRoot parentMap wanted' prunedGlobalDeps = + mconcat $ + [ flow "While constructing the build plan, Stack encountered the \ + \following errors:" + , blankLine + , mconcat (L.intersperse blankLine (mapMaybe pprintException exceptions')) + ] ++ if L.null recommendations + then [] + else + [ blankLine + , flow "Some different approaches to resolving this:" + , blankLine + ] ++ recommendations + + where + exceptions' = {- should we dedupe these somehow? nubOrd -} exceptions + + recommendations = + if not onlyHasDependencyMismatches + then [] + else + [ " *" <+> align (fillSep + [ "Set" + , style Shell (flow "allow-newer: true") + , "in" + , pretty (defaultUserConfigPath stackRoot) + , flow "to ignore all version constraints and build anyway." + ]) + , blankLine + ] + ++ addExtraDepsRecommendations + + addExtraDepsRecommendations + | Map.null extras = [] + | (Just _) <- Map.lookup (mkPackageName "base") extras = + [ " *" <+> align (fillSep + [ flow "Build requires unattainable version of the" + , style Current "base" + , flow "package. Since" + , style Current "base" + , flow "is a part of GHC, you most likely need to use a \ + \different GHC version with the matching" + , style Current "base"<> "." + ]) + , line + ] + | otherwise = + [ " *" <+> align (fillSep + [ style Recommendation (flow "Recommended action:") + , flow "try adding the following to your" + , style Shell "extra-deps" + , "in" + , pretty stackYaml <> ":" + ]) + , blankLine + , vsep (map pprintExtra (Map.toList extras)) + , line + ] + + extras = Map.unions $ map getExtras exceptions' + getExtras DependencyCycleDetected{} = Map.empty + getExtras UnknownPackage{} = Map.empty + getExtras (DependencyPlanFailures _ m) = + Map.unions $ map go $ Map.toList m + where + -- TODO: Likely a good idea to distinguish these to the user. In + -- particular, for DependencyMismatch + go (name, (_range, Just (version,cabalHash), NotInBuildPlan)) = + Map.singleton name (version,cabalHash) + go (name, (_range, Just (version,cabalHash), DependencyMismatch{})) = + Map.singleton name (version, cabalHash) + go _ = Map.empty + pprintExtra (name, (version, BlobKey cabalHash cabalSize)) = + let cfInfo = CFIHash cabalHash (Just cabalSize) + packageIdRev = PackageIdentifierRevision name version cfInfo + in fromString ("- " ++ T.unpack (utf8BuilderToText (display packageIdRev))) + + allNotInBuildPlan = Set.fromList $ concatMap toNotInBuildPlan exceptions' + toNotInBuildPlan (DependencyPlanFailures _ pDeps) = + map fst $ + filter + (\(_, (_, _, badDep)) -> badDep == NotInBuildPlan) + (Map.toList pDeps) + toNotInBuildPlan _ = [] + + -- This checks if 'allow-newer: true' could resolve all issues. + onlyHasDependencyMismatches = all go exceptions' + where + go DependencyCycleDetected{} = False + go UnknownPackage{} = False + go (DependencyPlanFailures _ m) = + all (\(_, _, depErr) -> isMismatch depErr) (M.elems m) + isMismatch DependencyMismatch{} = True + isMismatch Couldn'tResolveItsDependencies{} = True + isMismatch _ = False + + pprintException (DependencyCycleDetected pNames) = Just $ + flow "Dependency cycle detected in packages:" + <> line + <> indent 4 + ( encloseSep "[" "]" "," + (map (style Error . fromString . packageNameString) pNames) + ) + pprintException (DependencyPlanFailures pkg pDeps) = + case mapMaybe pprintDep (Map.toList pDeps) of + [] -> Nothing + depErrors -> Just $ + flow "In the dependencies for" <+> pkgIdent <> + pprintFlags (packageFlags pkg) <> ":" <> line <> + indent 4 (vsep depErrors) <> + case getShortestDepsPath parentMap wanted' (packageName pkg) of + Nothing -> + line + <> flow "needed for unknown reason - stack invariant violated." + Just [] -> + line + <> fillSep + [ flow "needed since" + , pkgName' + , flow "is a build target." + ] + Just (target:path) -> + line + <> flow "needed due to" <+> encloseSep "" "" " -> " pathElems + where + pathElems = + [style Target . fromString . packageIdentifierString $ target] ++ + map (fromString . packageIdentifierString) path ++ + [pkgIdent] + where + pkgName' = + style Current . fromString . packageNameString $ packageName pkg + pkgIdent = + style + Current + (fromString . packageIdentifierString $ packageIdentifier pkg) + -- Skip these when they are redundant with 'NotInBuildPlan' info. + pprintException (UnknownPackage name) + | name `Set.member` allNotInBuildPlan = Nothing + | name `Set.member` wiredInPackages = Just $ fillSep + [ flow "Can't build a package with same name as a wired-in-package:" + , style Current . fromString . packageNameString $ name + ] + | Just pruned <- Map.lookup name prunedGlobalDeps = + let prunedDeps = + map (style Current . fromString . packageNameString) pruned + in Just $ fillSep + [ flow "Can't use GHC boot package" + , style Current . fromString . packageNameString $ name + , flow "when it has an overridden dependency (issue #4510);" + , flow "you need to add the following as explicit dependencies \ + \to the project:" + , line + , encloseSep "" "" ", " prunedDeps + ] + | otherwise = Just $ fillSep + [ flow "Unknown package:" + , style Current . fromString . packageNameString $ name + ] + + pprintFlags flags + | Map.null flags = "" + | otherwise = parens $ sep $ map pprintFlag $ Map.toList flags + pprintFlag (name, True) = "+" <> fromString (flagNameString name) + pprintFlag (name, False) = "-" <> fromString (flagNameString name) + + pprintDep (name, (range, mlatestApplicable, badDep)) = case badDep of + NotInBuildPlan + | name `elem` fold prunedGlobalDeps -> Just $ + style Error (fromString $ packageNameString name) <+> + align + ( ( if range == C.anyVersion + then flow "needed" + else flow "must match" <+> goodRange + ) + <> "," + <> softline + <> fillSep + [ flow "but this GHC boot package has been pruned (issue \ + \#4510); you need to add the package explicitly to \ + \extra-deps" + ,latestApplicable Nothing + ] + ) + | otherwise -> Just $ + style Error (fromString $ packageNameString name) <+> + align + ( ( if range == C.anyVersion + then flow "needed" + else flow "must match" <+> goodRange + ) + <> "," + <> softline + <> fillSep + [ flow "but the Stack configuration has no specified version" + , latestApplicable Nothing + ] + ) + -- TODO: For local packages, suggest editing constraints + DependencyMismatch version -> Just $ + style + Error + (fromString . packageIdentifierString $ PackageIdentifier name version) + <+> + align + ( fillSep + [ flow "from Stack configuration does not match" + , goodRange + , latestApplicable (Just version) + ] + ) + -- I think the main useful info is these explain why missing packages are + -- needed. Instead lets give the user the shortest path from a target to the + -- package. + Couldn'tResolveItsDependencies _version -> Nothing + HasNoLibrary -> Just $ + style Error (fromString $ packageNameString name) <+> + align (flow "is a library dependency, but the package provides no library") + BDDependencyCycleDetected names -> Just $ + style Error (fromString $ packageNameString name) <+> + align + ( flow $ "dependency cycle detected: " + ++ L.intercalate ", " (map packageNameString names) + ) + where + goodRange = style Good (fromString (C.display range)) + latestApplicable mversion = + case mlatestApplicable of + Nothing + | isNothing mversion -> + flow "(no package with that name found, perhaps there is a typo \ + \in a package's build-depends or an omission from the \ + \stack.yaml packages list?)" + | otherwise -> "" + Just (laVer, _) + | Just laVer == mversion -> + flow "(latest matching version is specified)" + | otherwise -> + fillSep + [ flow "(latest matching version is" + , style Good (fromString $ versionString laVer) <> ")" + ] + +data ConstructPlanException + = DependencyCycleDetected [PackageName] + | DependencyPlanFailures + Package + (Map PackageName (VersionRange, LatestApplicableVersion, BadDependency)) + | UnknownPackage PackageName -- TODO perhaps this constructor will be removed, + -- and BadDependency will handle it all + -- ^ Recommend adding to extra-deps, give a helpful version number? + deriving (Eq, Show, Typeable) + +-- | The latest applicable version and it's latest Cabal file revision. +-- For display purposes only, Nothing if package not found +type LatestApplicableVersion = Maybe (Version, BlobKey) + +-- | Reason why a dependency was not used +data BadDependency + = NotInBuildPlan + | Couldn'tResolveItsDependencies Version + | DependencyMismatch Version + | HasNoLibrary + -- ^ See description of 'DepType' + | BDDependencyCycleDetected ![PackageName] + deriving (Eq, Ord, Show, Typeable) + +missingExeError :: String -> Bool -> String -> String +missingExeError errorCode isSimpleBuildType msg = unlines + $ "Error: " <> errorCode + : msg + : "Possible causes of this issue:" + : map ("* " <>) possibleCauses + where + possibleCauses + = "No module named \"Main\". The 'main-is' source file should usually \ + \have a header indicating that it's a 'Main' module." + : "A Cabal file that refers to nonexistent other files (e.g. a \ + \license-file that doesn't exist). Running 'cabal check' may point \ + \out these issues." + : [ "The Setup.hs file is changing the installation target dir." + | not isSimpleBuildType + ] + +showBuildError :: + String + -> Bool + -> ExitCode + -> Maybe PackageIdentifier + -> Path Abs File + -> [String] + -> Maybe (Path Abs File) + -> [Text] + -> StyleDoc +showBuildError errorCode isBuildingSetup exitCode mtaskProvides execName fullArgs logFiles bss = + let fullCmd = unwords + $ dropQuotes (toFilePath execName) + : map (T.unpack . showProcessArgDebug) fullArgs + logLocations = + maybe + mempty + (\fp -> line <> flow "Logs have been written to:" <+> + pretty fp) + logFiles + in fromString errorCode + <> line + <> flow "While building" <+> + ( case (isBuildingSetup, mtaskProvides) of + (False, Nothing) -> impureThrow ShowBuildErrorBug + (False, Just taskProvides') -> + "package" <+> + style + Target + (fromString $ dropQuotes (packageIdentifierString taskProvides')) + (True, Nothing) -> "simple" <+> style File "Setup.hs" + (True, Just taskProvides') -> + "custom" <+> + style File "Setup.hs" <+> + flow "for package" <+> + style + Target + (fromString $ dropQuotes (packageIdentifierString taskProvides')) + ) <+> + flow "(scroll up to its section to see the error) using:" + <> line + <> style Shell (fromString fullCmd) + <> line + <> flow "Process exited with code:" <+> (fromString . show) exitCode <+> + ( if exitCode == ExitFailure (-9) + then flow "(THIS MAY INDICATE OUT OF MEMORY)" + else mempty + ) + <> logLocations + <> if null bss + then mempty + else blankLine <> string (removeTrailingSpaces (map T.unpack bss)) + where + removeTrailingSpaces = dropWhileEnd isSpace . unlines + dropQuotes = filter ('\"' /=) + +-- | Get the shortest reason for the package to be in the build plan. In +-- other words, trace the parent dependencies back to a 'wanted' +-- package. +getShortestDepsPath :: + ParentMap + -> Set PackageName + -> PackageName + -> Maybe [PackageIdentifier] +getShortestDepsPath (MonoidMap parentsMap) wanted' name = + if Set.member name wanted' + then Just [] + else case M.lookup name parentsMap of + Nothing -> Nothing + Just (_, parents) -> Just $ findShortest 256 paths0 + where + paths0 = M.fromList $ + map (\(ident, _) -> (pkgName ident, startDepsPath ident)) parents + where + -- The 'paths' map is a map from PackageName to the shortest path + -- found to get there. It is the frontier of our breadth-first + -- search of dependencies. + findShortest :: Int -> Map PackageName DepsPath -> [PackageIdentifier] + findShortest fuel _ | fuel <= 0 = + [ PackageIdentifier + (mkPackageName "stack-ran-out-of-jet-fuel") + (C.mkVersion [0]) + ] + findShortest _ paths | M.null paths = [] + findShortest fuel paths = + case targets of + [] -> findShortest (fuel - 1) $ M.fromListWith chooseBest $ + concatMap extendPath recurses + _ -> let (DepsPath _ _ path) = L.minimum (map snd targets) in path + where + (targets, recurses) = + L.partition (\(n, _) -> n `Set.member` wanted') (M.toList paths) + chooseBest :: DepsPath -> DepsPath -> DepsPath + chooseBest = max + -- Extend a path to all its parents. + extendPath :: (PackageName, DepsPath) -> [(PackageName, DepsPath)] + extendPath (n, dp) = + case M.lookup n parentsMap of + Nothing -> [] + Just (_, parents) -> + map (\(pkgId, _) -> (pkgName pkgId, extendDepsPath pkgId dp)) parents + +startDepsPath :: PackageIdentifier -> DepsPath +startDepsPath ident = DepsPath + { dpLength = 1 + , dpNameLength = length (packageNameString (pkgName ident)) + , dpPath = [ident] + } + +extendDepsPath :: PackageIdentifier -> DepsPath -> DepsPath +extendDepsPath ident dp = DepsPath + { dpLength = dpLength dp + 1 + , dpNameLength = dpNameLength dp + length (packageNameString (pkgName ident)) + , dpPath = [ident] + } + +data DepsPath = DepsPath + { dpLength :: Int + -- ^ Length of dpPath + , dpNameLength :: Int + -- ^ Length of package names combined + , dpPath :: [PackageIdentifier] + -- ^ A path where the packages later in the list depend on those that come + -- earlier + } + deriving (Eq, Ord, Show) diff --git a/src/Stack/Types/ConfigureOpts.hs b/src/Stack/Types/ConfigureOpts.hs new file mode 100644 index 0000000000..e4f2b2209a --- /dev/null +++ b/src/Stack/Types/ConfigureOpts.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Stack.Types.ConfigureOpts + ( ConfigureOpts (..) + , BaseConfigOpts (..) + , configureOpts + , configureOptsDirs + , configureOptsNoDir + ) where + +import qualified Data.Map as Map +import qualified Data.Text as T +import Distribution.Types.MungedPackageName + ( decodeCompatPackageName ) +import Distribution.Types.PackageName ( unPackageName ) +import Distribution.Types.UnqualComponentName + ( unUnqualComponentName ) +import qualified Distribution.Version as C +import Path ( (), parseRelDir ) +import Path.Extra ( toFilePathNoTrailingSep ) +import Stack.Constants + ( bindirSuffix, compilerOptionsCabalFlag, docDirSuffix + , relDirEtc, relDirLib, relDirLibexec, relDirShare + ) +import Stack.Prelude +import Stack.Types.BuildOpts ( BuildOpts (..), BuildOptsCLI ) +import Stack.Types.Compiler ( getGhcVersion, whichCompiler ) +import Stack.Types.Config + ( Config (..), HasConfig (..) ) +import Stack.Types.EnvConfig ( EnvConfig, actualCompilerVersionL ) +import Stack.Types.GhcPkgId ( GhcPkgId, ghcPkgIdString ) +import Stack.Types.IsMutable ( IsMutable (..) ) +import Stack.Types.Package ( Package (..) ) +import System.FilePath ( pathSeparator ) + +-- | Basic information used to calculate what the configure options are +data BaseConfigOpts = BaseConfigOpts + { bcoSnapDB :: !(Path Abs Dir) + , bcoLocalDB :: !(Path Abs Dir) + , bcoSnapInstallRoot :: !(Path Abs Dir) + , bcoLocalInstallRoot :: !(Path Abs Dir) + , bcoBuildOpts :: !BuildOpts + , bcoBuildOptsCLI :: !BuildOptsCLI + , bcoExtraDBs :: ![Path Abs Dir] + } + deriving Show + +-- | Render a @BaseConfigOpts@ to an actual list of options +configureOpts :: EnvConfig + -> BaseConfigOpts + -> Map PackageIdentifier GhcPkgId -- ^ dependencies + -> Bool -- ^ local non-extra-dep? + -> IsMutable + -> Package + -> ConfigureOpts +configureOpts econfig bco deps isLocal isMutable package = ConfigureOpts + { coDirs = configureOptsDirs bco isMutable package + , coNoDirs = configureOptsNoDir econfig bco deps isLocal package + } + + +configureOptsDirs :: BaseConfigOpts + -> IsMutable + -> Package + -> [String] +configureOptsDirs bco isMutable package = concat + [ ["--user", "--package-db=clear", "--package-db=global"] + , map (("--package-db=" ++) . toFilePathNoTrailingSep) $ case isMutable of + Immutable -> bcoExtraDBs bco ++ [bcoSnapDB bco] + Mutable -> bcoExtraDBs bco ++ [bcoSnapDB bco] ++ [bcoLocalDB bco] + , [ "--libdir=" ++ toFilePathNoTrailingSep (installRoot relDirLib) + , "--bindir=" ++ toFilePathNoTrailingSep (installRoot bindirSuffix) + , "--datadir=" ++ toFilePathNoTrailingSep (installRoot relDirShare) + , "--libexecdir=" ++ toFilePathNoTrailingSep (installRoot relDirLibexec) + , "--sysconfdir=" ++ toFilePathNoTrailingSep (installRoot relDirEtc) + , "--docdir=" ++ toFilePathNoTrailingSep docDir + , "--htmldir=" ++ toFilePathNoTrailingSep docDir + , "--haddockdir=" ++ toFilePathNoTrailingSep docDir] + ] + where + installRoot = + case isMutable of + Immutable -> bcoSnapInstallRoot bco + Mutable -> bcoLocalInstallRoot bco + docDir = + case pkgVerDir of + Nothing -> installRoot docDirSuffix + Just dir -> installRoot docDirSuffix dir + pkgVerDir = parseRelDir + ( packageIdentifierString + (PackageIdentifier (packageName package) (packageVersion package)) + ++ [pathSeparator] + ) + +-- | Same as 'configureOpts', but does not include directory path options +configureOptsNoDir :: + EnvConfig + -> BaseConfigOpts + -> Map PackageIdentifier GhcPkgId -- ^ Dependencies. + -> Bool -- ^ Is this a local, non-extra-dep? + -> Package + -> [String] +configureOptsNoDir econfig bco deps isLocal package = concat + [ depOptions + , [ "--enable-library-profiling" + | boptsLibProfile bopts || boptsExeProfile bopts + ] + , ["--enable-profiling" | boptsExeProfile bopts && isLocal] + , ["--enable-split-objs" | boptsSplitObjs bopts] + , [ "--disable-library-stripping" + | not $ boptsLibStrip bopts || boptsExeStrip bopts + ] + , ["--disable-executable-stripping" | not (boptsExeStrip bopts) && isLocal] + , map (\(name,enabled) -> + "-f" <> + (if enabled + then "" + else "-") <> + flagNameString name) + (Map.toList flags) + , map T.unpack $ packageCabalConfigOpts package + , processGhcOptions (packageGhcOptions package) + , map ("--extra-include-dirs=" ++) (configExtraIncludeDirs config) + , map ("--extra-lib-dirs=" ++) (configExtraLibDirs config) + , maybe + [] + (\customGcc -> ["--with-gcc=" ++ toFilePath customGcc]) + (configOverrideGccPath config) + , ["--exact-configuration"] + , ["--ghc-option=-fhide-source-paths" | hideSourcePaths cv] + ] + where + -- This function parses the GHC options that are providing in the + -- stack.yaml file. In order to handle RTS arguments correctly, we need + -- to provide the RTS arguments as a single argument. + processGhcOptions :: [Text] -> [String] + processGhcOptions args = + let (preRtsArgs, mid) = break ("+RTS" ==) args + (rtsArgs, end) = break ("-RTS" ==) mid + fullRtsArgs = + case rtsArgs of + [] -> + -- This means that we didn't have any RTS args - no `+RTS` - and + -- therefore no need for a `-RTS`. + [] + _ -> + -- In this case, we have some RTS args. `break` puts the `"-RTS"` + -- string in the `snd` list, so we want to append it on the end of + -- `rtsArgs` here. + -- + -- We're not checking that `-RTS` is the first element of `end`. + -- This is because the GHC RTS allows you to omit a trailing -RTS + -- if that's the last of the arguments. This permits a GHC options + -- in stack.yaml that matches what you might pass directly to GHC. + [T.unwords $ rtsArgs ++ ["-RTS"]] + -- We drop the first element from `end`, because it is always either + -- `"-RTS"` (and we don't want that as a separate argument) or the list + -- is empty (and `drop _ [] = []`). + postRtsArgs = drop 1 end + newArgs = concat [preRtsArgs, fullRtsArgs, postRtsArgs] + in concatMap (\x -> [compilerOptionsCabalFlag wc, T.unpack x]) newArgs + + wc = view (actualCompilerVersionL.to whichCompiler) econfig + cv = view (actualCompilerVersionL.to getGhcVersion) econfig + + hideSourcePaths ghcVersion = + ghcVersion >= C.mkVersion [8, 2] && configHideSourcePaths config + + config = view configL econfig + bopts = bcoBuildOpts bco + + -- Unioning atop defaults is needed so that all flags are specified with + -- --exact-configuration. + flags = packageFlags package `Map.union` packageDefaultFlags package + + depOptions = map toDepOption $ Map.toList deps + + toDepOption (PackageIdentifier name _, gid) = concat + [ "--dependency=" + , depOptionKey + , "=" + , ghcPkgIdString gid + ] + where + MungedPackageName subPkgName lib = decodeCompatPackageName name + depOptionKey = case lib of + LMainLibName -> unPackageName name + LSubLibName cn -> + unPackageName subPkgName <> ":" <> unUnqualComponentName cn + +-- | Configure options to be sent to Setup.hs configure +data ConfigureOpts = ConfigureOpts + { coDirs :: ![String] + -- ^ Options related to various paths. We separate these out since they do + -- not have an impact on the contents of the compiled binary for checking + -- if we can use an existing precompiled cache. + , coNoDirs :: ![String] + } + deriving (Data, Eq, Generic, Show, Typeable) + +instance NFData ConfigureOpts diff --git a/src/Stack/Types/IsMutable.hs b/src/Stack/Types/IsMutable.hs new file mode 100644 index 0000000000..a2169b1bba --- /dev/null +++ b/src/Stack/Types/IsMutable.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Stack.Types.IsMutable + ( IsMutable (..) + ) where + +import Stack.Prelude + +data IsMutable + = Mutable + | Immutable + deriving (Eq, Show) + +instance Semigroup IsMutable where + Mutable <> _ = Mutable + _ <> Mutable = Mutable + Immutable <> Immutable = Immutable + +instance Monoid IsMutable where + mempty = Immutable + mappend = (<>) diff --git a/src/Stack/Types/ParentMap.hs b/src/Stack/Types/ParentMap.hs new file mode 100644 index 0000000000..5634badd15 --- /dev/null +++ b/src/Stack/Types/ParentMap.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Stack.Types.ParentMap + ( ParentMap + ) where + +import Data.Monoid.Map ( MonoidMap (..) ) +import Stack.Prelude +import Stack.Types.Version ( VersionRange ) + +type ParentMap = + MonoidMap PackageName (First Version, [(PackageIdentifier, VersionRange)]) diff --git a/src/Stack/Types/UnusedFlags.hs b/src/Stack/Types/UnusedFlags.hs new file mode 100644 index 0000000000..9cb566bfa1 --- /dev/null +++ b/src/Stack/Types/UnusedFlags.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Stack.Types.UnusedFlags + ( UnusedFlags (..) + , FlagSource (..) + ) where + +import Stack.Prelude + +data FlagSource + = FSCommandLine + | FSStackYaml + deriving (Eq, Ord, Show) + +data UnusedFlags + = UFNoPackage FlagSource PackageName + | UFFlagsNotDefined + FlagSource + PackageName + (Set FlagName) -- defined in package + (Set FlagName) -- not defined + | UFSnapshot PackageName + deriving (Eq, Ord, Show) diff --git a/stack.cabal b/stack.cabal index ee09059ed1..3550a83e65 100644 --- a/stack.cabal +++ b/stack.cabal @@ -245,6 +245,7 @@ library Stack.Types.ApplyGhcOptions Stack.Types.ApplyProgOptions Stack.Types.Build + Stack.Types.Build.Exception Stack.Types.BuildConfig Stack.Types.BuildOpts Stack.Types.CabalConfigKey @@ -255,6 +256,7 @@ library Stack.Types.Config Stack.Types.Config.Exception Stack.Types.ConfigMonoid + Stack.Types.ConfigureOpts Stack.Types.Curator Stack.Types.Docker Stack.Types.DockerEntrypoint @@ -271,11 +273,13 @@ library Stack.Types.GhcPkgId Stack.Types.GlobalOpts Stack.Types.GlobalOptsMonoid + Stack.Types.IsMutable Stack.Types.LockFileBehavior Stack.Types.NamedComponent Stack.Types.Nix Stack.Types.Package Stack.Types.PackageName + Stack.Types.ParentMap Stack.Types.Platform Stack.Types.Project Stack.Types.ProjectAndConfigMonoid @@ -288,6 +292,7 @@ library Stack.Types.SourceMap Stack.Types.StackYamlLoc Stack.Types.TemplateName + Stack.Types.UnusedFlags Stack.Types.Version Stack.Types.VersionedDownloadInfo Stack.Uninstall