{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} -- | Build-specific types. module Stack.Types.Build ( BuildException (..) , BuildPrettyException (..) , ConstructPlanException (..) , BadDependency (..) , ParentMap , FlagSource (..) , UnusedFlags (..) , InstallLocation (..) , Installed (..) , psVersion , Task (..) , taskIsTarget , taskLocation , taskTargetIsMutable , LocalPackage (..) , BaseConfigOpts (..) , Plan (..) , TestOpts (..) , BenchmarkOpts (..) , FileWatchOpts (..) , BuildOpts (..) , BuildSubset (..) , defaultBuildOpts , TaskType (..) , IsMutable (..) , installLocationIsMutable , TaskConfigOpts (..) , BuildCache (..) , ConfigCache (..) , 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.PackageDescription ( TestSuiteInterface, mkPackageName ) import Distribution.System ( Arch ) import qualified Distribution.Text as C import qualified Distribution.Version as C import Path ( parseRelDir, (), parent ) import Path.Extra ( toFilePathNoTrailingSep ) import RIO.Process ( showProcessArgDebug ) import Stack.Constants import Stack.Prelude import Stack.Types.Compiler import Stack.Types.CompilerBuild import Stack.Types.Config import Stack.Types.GhcPkgId import Stack.Types.NamedComponent import Stack.Types.Package import Stack.Types.Version 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) | InvalidFlagSpecification (Set UnusedFlags) | InvalidGhcOptionsSpecification [PackageName] | TargetParseException [Text] | SomeTargetsNotBuildable [(PackageName, NamedComponent)] | TestSuiteExeMissing Bool String String String | CabalCopyFailed Bool String | LocalPackagesPresent [PackageIdentifier] | CouldNotLockDistDir !(Path Abs File) | TaskCycleBug PackageIdentifier | PackageIdMissingBug PackageIdentifier | AllInOneBuildBug | MulipleResultsBug 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 (\l -> " " ++ l) . 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 (InvalidFlagSpecification unused) = unlines $ "Error: [S-8664]" : "Invalid flag specification:" : map go (Set.toList unused) where showFlagSrc :: FlagSource -> String showFlagSrc FSCommandLine = " (specified on command line)" showFlagSrc FSStackYaml = " (specified in stack.yaml)" go :: UnusedFlags -> String go (UFNoPackage src name) = concat [ "- Package '" , packageNameString name , "' not found" , showFlagSrc src ] go (UFFlagsNotDefined src pname pkgFlags flags) = concat [ "- Package '" , name , "' does not define the following flags" , showFlagSrc src , ":\n" , intercalate "\n" (map (\flag -> " " ++ flagNameString flag) (Set.toList flags)) , "\n- Flags defined by package '" ++ name ++ "':\n" , intercalate "\n" (map (\flag -> " " ++ name ++ ":" ++ flagNameString flag) (Set.toList pkgFlags)) ] where name = packageNameString pname go (UFSnapshot name) = concat [ "- Attempted to set flag on snapshot package " , packageNameString name , ", please add to extra-deps" ] displayException (InvalidGhcOptionsSpecification unused) = unlines $ "Error: [S-4925]" : "Invalid GHC options specification:" : map showGhcOptionSrc unused where showGhcOptionSrc name = concat [ "- Package '" , packageNameString name , "' not found" ] displayException (TargetParseException [err]) = concat [ "Error: [S-8506]\n" , "Error parsing targets: " , T.unpack err ] displayException (TargetParseException errs) = unlines $ "Error [S-8506]" : "The following errors occurred while parsing the build targets:" : map (("- " ++) . T.unpack) errs displayException (SomeTargetsNotBuildable xs) = unlines [ "Error: [S-7086]" , "The following components have 'buildable: False' set in the Cabal \ \configuration, and so cannot be targets:" , " " <> T.unpack (renderPkgComponents xs) , "To resolve this, either provide flags such that these components \ \are buildable, or only specify buildable targets." ] 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]" $ "Error: The impossible happened! Unexpected task cycle for " ++ packageNameString (pkgName pid) displayException (PackageIdMissingBug ident) = bugReport "[S-8923]" $ "The impossible happened! 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 (MulipleResultsBug 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 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 <> flow "While executing the build plan, Stack encountered the \ \following errors:" <> blankLine <> hcat (L.intersperse blankLine (map ppExceptions es)) where ppExceptions :: SomeException -> StyleDoc ppExceptions e = case fromException e of Just (PrettyException e') -> pretty e' Nothing -> (string . show) e 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 instance Exception BuildPrettyException 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 ( flow "Set 'allow-newer: true' in " <+> pretty (defaultUserConfigPath stackRoot) <+> "to ignore all version constraints and build anyway." ) , blankLine ] ++ addExtraDepsRecommendations addExtraDepsRecommendations | Map.null extras = [] | (Just _) <- Map.lookup (mkPackageName "base") extras = [ " *" <+> align (flow "Build requires unattainable version of base. Since base is a part of GHC, you most likely need to use a different GHC version with the matching base.") , line ] | otherwise = [ " *" <+> align (style Recommendation (flow "Recommended action:") <+> flow "try adding the following to your 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 <> 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 $ 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 $ 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 $ 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 <> flow "but this GHC boot package has been pruned (issue #4510);" <+> flow "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 <> 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 (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 x y = max x y -- 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 (Typeable, Eq, Show) -- | 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 (Typeable, Eq, Ord, Show) 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 (Show, Eq, Ord) data UnusedFlags = UFNoPackage FlagSource PackageName | UFFlagsNotDefined FlagSource PackageName (Set FlagName) -- defined in package (Set FlagName) -- not defined | UFSnapshot PackageName deriving (Show, Eq, Ord) 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." : if isSimpleBuildType then [] else ["The Setup.hs file is changing the installation target dir."] 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:" <+> style File (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 = PkgDeps PackageName deriving (Show,Typeable,Eq,NFData) -- | Stored on disk to know whether the files have changed. newtype BuildCache = BuildCache { buildCacheTimes :: Map FilePath FileCacheInfo -- ^ Modification times of files. } deriving (Generic, Eq, Show, Typeable, ToJSON, FromJSON) instance NFData BuildCache -- | Stored on disk to know whether the flags have changed. data ConfigCache = ConfigCache { configCacheOpts :: !ConfigureOpts -- ^ All options used for this package. , configCacheDeps :: !(Set GhcPkgId) -- ^ The GhcPkgIds of all of the dependencies. Since Cabal doesn't take -- the complete GhcPkgId (only a PackageIdentifier) in the configure -- options, just using the previous value is insufficient to know if -- dependencies have changed. , configCacheComponents :: !(Set S.ByteString) -- ^ The components to be built. It's a bit of a hack to include this in -- here, as it's not a configure option (just a build option), but this -- is a convenient way to force compilation when the components change. , configCacheHaddock :: !Bool -- ^ Are haddocks to be built? , configCachePkgSrc :: !CachePkgSrc , configCachePathEnvVar :: !Text -- ^ Value of the PATH env var, see } deriving (Generic, Eq, Show, Data, Typeable) instance NFData ConfigCache data CachePkgSrc = CacheSrcUpstream | CacheSrcLocal FilePath deriving (Generic, Eq, Read, Show, Data, Typeable) instance NFData CachePkgSrc instance PersistField CachePkgSrc where toPersistValue CacheSrcUpstream = PersistText "upstream" toPersistValue (CacheSrcLocal fp) = PersistText ("local:" <> T.pack fp) fromPersistValue (PersistText t) = do if t == "upstream" then Right CacheSrcUpstream else case T.stripPrefix "local:" t of Just fp -> Right $ CacheSrcLocal (T.unpack fp) Nothing -> Left $ "Unexpected CachePkgSrc value: " <> t fromPersistValue _ = Left "Unexpected CachePkgSrc type" instance PersistFieldSql CachePkgSrc where sqlType _ = SqlString toCachePkgSrc :: PackageSource -> CachePkgSrc toCachePkgSrc (PSFilePath lp) = CacheSrcLocal (toFilePath (parent (lpCabalFile lp))) toCachePkgSrc PSRemote{} = CacheSrcUpstream -- | A task to perform when building data Task = Task { taskProvides :: !PackageIdentifier -- FIXME turn this into a function on taskType? -- ^ the package/version to be built , taskType :: !TaskType -- ^ the task type, telling us how to build this , taskConfigOpts :: !TaskConfigOpts , taskBuildHaddock :: !Bool , taskPresent :: !(Map PackageIdentifier GhcPkgId) -- ^ GhcPkgIds of already-installed dependencies , taskAllInOne :: !Bool -- ^ indicates that the package can be built in one step , taskCachePkgSrc :: !CachePkgSrc , taskAnyMissing :: !Bool -- ^ Were any of the dependencies missing? The reason this is -- necessary is... hairy. And as you may expect, a bug in -- Cabal. See: -- . The -- problem is that Cabal may end up generating the same package ID -- for a dependency, even if the ABI has changed. As a result, -- without this field, Stack would think that a reconfigure is -- unnecessary, when in fact we _do_ need to reconfigure. The -- details here suck. We really need proper hashes for package -- identifiers. , taskBuildTypeConfig :: !Bool -- ^ Is the build type of this package Configure. Check out -- ensureConfigureScript in Stack.Build.Execute for the motivation } deriving Show -- | Given the IDs of any missing packages, produce the configure options data TaskConfigOpts = TaskConfigOpts { tcoMissing :: !(Set PackageIdentifier) -- ^ Dependencies for which we don't yet have an GhcPkgId , tcoOpts :: !(Map PackageIdentifier GhcPkgId -> ConfigureOpts) -- ^ Produce the list of options given the missing @GhcPkgId@s } instance Show TaskConfigOpts where show (TaskConfigOpts missing f) = concat [ "Missing: " , show missing , ". Without those: " , show $ f Map.empty ] -- | The type of a task, either building local code or something from the -- package index (upstream) data TaskType = TTLocalMutable LocalPackage | 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 TTLocalMutable lp -> lpWanted lp _ -> False taskLocation :: Task -> InstallLocation taskLocation task = case taskType task of TTLocalMutable _ -> Local TTRemotePackage Mutable _ _ -> Local TTRemotePackage Immutable _ _ -> Snap taskTargetIsMutable :: Task -> IsMutable taskTargetIsMutable task = case taskType task of TTLocalMutable _ -> Mutable TTRemotePackage mutable _ _ -> mutable installLocationIsMutable :: InstallLocation -> IsMutable installLocationIsMutable Snap = Immutable installLocationIsMutable Local = Mutable -- | A complete plan of what needs to be built and how to do it data Plan = Plan { planTasks :: !(Map PackageName Task) , planFinals :: !(Map PackageName Task) -- ^ Final actions to be taken (test, benchmark, etc) , planUnregisterLocal :: !(Map GhcPkgId (PackageIdentifier, Text)) -- ^ Text is reason we're unregistering, for display only , planInstallExes :: !(Map Text InstallLocation) -- ^ Executables that should be installed after successful building } 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] -- Cabal < 1.21.1 does not support --enable-profiling, use --enable-executable-profiling instead , let profFlag = "--enable-" <> concat ["executable-" | not newerCabal] <> "profiling" in [ profFlag | 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 newerCabal = view cabalVersionL econfig >= C.mkVersion [1, 22] -- Unioning atop defaults is needed so that all flags are specified -- with --exact-configuration. flags = packageFlags package `Map.union` packageDefaultFlags package depOptions = map (uncurry toDepOption) $ Map.toList deps where toDepOption = if newerCabal then toDepOption1_22 else toDepOption1_18 toDepOption1_22 (PackageIdentifier name _) gid = concat [ "--dependency=" , packageNameString name , "=" , ghcPkgIdString gid ] toDepOption1_18 ident _gid = concat [ "--constraint=" , packageNameString name , "==" , versionString version' ] where PackageIdentifier name version' = ident -- | 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 (Show, Eq, Generic, Data, 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 { pcLibrary :: !(Maybe (Path base File)) -- ^ .conf file inside the package database , pcSubLibs :: ![Path base File] -- ^ .conf file inside the package database, for each of the sublibraries , pcExes :: ![Path base File] -- ^ Full paths to executables } deriving (Show, Eq, Generic, Typeable) instance NFData (PrecompiledCache Abs) instance NFData (PrecompiledCache Rel)