diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index 06e754eca5..fb70273576 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -41,6 +41,7 @@ import Stack.Package ( buildableExes, resolvePackage ) import Stack.Prelude hiding ( loadPackage ) import Stack.Runners ( ShouldReexec (..), withConfig, withEnvConfig ) import Stack.Setup ( withNewLocalBuildTargets ) +import Stack.Types.Build.ConstructPlan ( PackageLoader ) import Stack.Types.Build.Exception ( BuildException (..), BuildPrettyException (..) ) import Stack.Types.BuildConfig ( HasBuildConfig, configFileL ) @@ -408,13 +409,7 @@ mkBaseConfigOpts buildOptsCLI = do } -- | Provide a function for loading package information from the package index -loadPackage :: - (HasBuildConfig env, HasSourceMap env) - => PackageLocationImmutable - -> Map FlagName Bool - -> [Text] -- ^ GHC options - -> [Text] -- ^ Cabal configure options - -> RIO env Package +loadPackage :: (HasBuildConfig env, HasSourceMap env) => PackageLoader (RIO env) loadPackage loc flags ghcOptions cabalConfigOpts = do compilerVersion <- view actualCompilerVersionL platform <- view platformL diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 941ca44c04..5b9388a64d 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -47,9 +47,9 @@ import Stack.Prelude hiding ( loadPackage ) import Stack.SourceMap ( getPLIVersion, mkProjectPackage ) import Stack.Types.Build.ConstructPlan ( AddDepRes (..), CombinedMap, Ctx (..), LibraryMap, M - , MissingPresentDeps (..), PackageInfo (..), ToolWarning(..) - , UnregisterState (..), W (..), adrHasLibrary, adrVersion - , isAdrToInstall, toTask + , MissingPresentDeps (..), PackageInfo (..), PackageLoader + , ToolWarning(..), UnregisterState (..), W (..) + , adrHasLibrary, adrVersion, isAdrToInstall, toTask ) import Stack.Types.Build.Exception ( BadDependency (..), BuildException (..) @@ -121,16 +121,11 @@ import System.Environment ( lookupEnv ) constructPlan :: forall env. HasEnvConfig env => BaseConfigOpts - -> [DumpPackage] -- ^ locally registered - -> ( PackageLocationImmutable - -> Map FlagName Bool - -> [Text] - -- ^ GHC options - -> [Text] - -- ^ Cabal configure options - -> RIO EnvConfig Package - ) - -- ^ load upstream package + -> [DumpPackage] + -- ^ Locally registered. + -> PackageLoader (RIO EnvConfig) + -- ^ Function to load a 'Package' given the location of a package assumed + -- to be immutable. -> SourceMap -> InstalledMap -> Bool @@ -195,7 +190,11 @@ constructPlan let ctx = mkCtx econfig globalCabalVersion sources curator pathEnvVar targetPackageNames = Map.keys sourceMap.targets.targets -- Ignore the result of 'getCachedDepOrAddDep'. - onTarget = void . getCachedDepOrAddDep + onTarget pkgName = do + logDebugPlanS "constructPlan" $ + "Constructing for target " + <> fromPackageName pkgName + void $ getCachedDepOrAddDep pkgName inner :: M () inner = mapM_ onTarget targetPackageNames action :: RIO Ctx (((), W), LibraryMap) @@ -250,18 +249,23 @@ constructPlan -> Maybe Curator -> Text -> Ctx - mkCtx ctxEnvConfig globalCabalVersion sources curator pathEnvVar = Ctx - { baseConfigOpts = baseConfigOpts0 - , loadPackage = \w x y z -> runRIO ctxEnvConfig $ - applyForceCustomBuild globalCabalVersion <$> loadPackage0 w x y z - , combinedMap = combineMap sources installedMap - , ctxEnvConfig - , callStack = [] - , wanted = Map.keysSet sourceMap.targets.targets - , localNames = Map.keysSet sourceProject - , curator - , pathEnvVar - } + mkCtx ctxEnvConfig globalCabalVersion sources curator pathEnvVar = + let loadPackage loc flags ghcOptions cabalConfigOpts = do + let action = do + package <- loadPackage0 loc flags ghcOptions cabalConfigOpts + pure $ applyForceCustomBuild globalCabalVersion package + runRIO ctxEnvConfig action + in Ctx + { baseConfigOpts = baseConfigOpts0 + , loadPackage + , combinedMap = combineMap sources installedMap + , ctxEnvConfig + , callStack = [] + , wanted = Map.keysSet sourceMap.targets.targets + , localNames = Map.keysSet sourceProject + , curator + , pathEnvVar + } toEither :: (k, Either e v) -> Either e (k, v) toEither (_, Left e) = Left e @@ -478,6 +482,7 @@ addFinal :: -- ^ Should Haddock documentation be built? -> M () addFinal lp package allInOne buildHaddocks = do + let name = package.name res <- addPackageDeps package >>= \case Left e -> pure $ Left e Right (MissingPresentDeps missing present _minLoc) -> do @@ -500,7 +505,11 @@ addFinal lp package allInOne buildHaddocks = do , cachePkgSrc = CacheSrcLocal (toFilePath (parent lp.cabalFP)) , buildTypeConfig = packageBuildTypeConfig package } - tell mempty { wFinals = Map.singleton package.name res } + logDebugPlanS "addFinal" $ + "Adding to construction output " + <> fromPackageName name + <> summariseResult res + tell mempty { wFinals = Map.singleton name res } -- | Given a 'PackageName', adds all of the build tasks to build the package, if -- needed. First checks if the package name is in the library map. @@ -551,10 +560,19 @@ checkCallStackAndAddDep name = do <> fromPackageName name <> "." pure $ Left $ UnknownPackage compiler name - Just packageInfo -> + Just packageInfo -> do + logDebugPlanS "checkCallStackAndAddDep" $ + "Pushing " + <> fromPackageName name + <> " on to the call stack." -- Add the current package name to the head of the call stack. - local (\ctx' -> ctx' { callStack = name : ctx'.callStack }) $ + res <- local (\ctx' -> ctx' { callStack = name : ctx'.callStack }) $ addDep name packageInfo + logDebugPlanS "checkCallStackAndAddDep" $ + "Popped " + <> fromPackageName name + <> " from the call stack." + pure res updateLibMap name res pure res @@ -688,15 +706,16 @@ installPackage name ps minstalled = do resolveDepsAndInstall True lp.buildHaddocks ps lp.package minstalled Just tb -> do + -- Preserve the current library map. + libMap <- get -- Attempt to find a plan which performs an all-in-one build. Ignore -- the writer action + reset the state if it fails. - libMap <- get res <- pass $ do res <- addPackageDeps tb - let writerFunc w = case res of - Left _ -> mempty - _ -> w - pure (res, writerFunc) + let modifyOutput = case res of + Left _ -> const mempty + _ -> id + pure (res, modifyOutput) case res of Right deps -> do logDebugPlanS "installPackage" $ @@ -768,8 +787,14 @@ installPackageGivenDeps :: -> Maybe Installed -> MissingPresentDeps -> M AddDepRes -installPackageGivenDeps allInOne buildHaddocks ps package minstalled - (MissingPresentDeps missing present minMutable) = do +installPackageGivenDeps + allInOne + buildHaddocks + ps + package + minstalled + (MissingPresentDeps missing present minMutable) + = do let name = package.name mRightVersionInstalled <- case minstalled of Just installed -> if Set.null missing @@ -822,10 +847,15 @@ packageBuildTypeConfig pkg = pkg.buildType == Configure -- Update response in the library map. If it is an error, and there's already an -- error about cyclic dependencies, prefer the cyclic error. updateLibMap :: PackageName -> Either ConstructPlanException AddDepRes -> M () -updateLibMap name val = modify $ \mp -> - case (Map.lookup name mp, val) of - (Just (Left DependencyCycleDetected{}), Left _) -> mp - _ -> Map.insert name val mp +updateLibMap name res = do + logDebugPlanS "updateLibMap" $ + "Updating for: " + <> fromPackageName name + <> summariseResult res + modify $ \mp -> + case (Map.lookup name mp, res) of + (Just (Left DependencyCycleDetected{}), Left _) -> mp + _ -> Map.insert name res mp addEllipsis :: Text -> Text addEllipsis t @@ -1273,6 +1303,12 @@ logDebugPlanS s msg = do debugPlan <- view $ globalOptsL . to (.planInLog) when debugPlan $ logDebugS s msg +-- | A function to summarise a result. Assumes that 'Left' is an error and +-- 'Right' is not. Intended to be used to annotate, so includes an initial space +-- character. +summariseResult :: Either a b -> Utf8Builder +summariseResult res = " (" <> either (const "error") (const "ok") res <> ")" + -- | A function to yield a 'PackageInfo' value from: (1) a 'PackageSource' -- value; and (2) a pair of an 'InstallLocation' value and an 'Installed' value. -- Checks that the version of the 'PackageSource' value and the version of the diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index a30ea47146..6ae52f7dd1 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -625,7 +625,8 @@ mkDepPackage pl = do -- | Force a package to be treated as a custom build type, see -- applyForceCustomBuild :: - Version -- ^ global Cabal version + Version + -- ^ Global Cabal version. -> Package -> Package applyForceCustomBuild cabalVersion package diff --git a/src/Stack/Types/Build/ConstructPlan.hs b/src/Stack/Types/Build/ConstructPlan.hs index 21a508c7b4..35a6c8b9a9 100644 --- a/src/Stack/Types/Build/ConstructPlan.hs +++ b/src/Stack/Types/Build/ConstructPlan.hs @@ -22,6 +22,7 @@ module Stack.Types.Build.ConstructPlan , adrHasLibrary , isAdrToInstall , Ctx (..) + , PackageLoader , UnregisterState (..) , ToolWarning (..) , MissingPresentDeps (..) @@ -173,14 +174,9 @@ instance Monoid MissingPresentDeps where data Ctx = Ctx { baseConfigOpts :: !BaseConfigOpts -- ^ Basic information used to determine configure options - , loadPackage :: !( PackageLocationImmutable - -> Map FlagName Bool - -> [Text] - -- ^ GHC options. - -> [Text] - -- ^ Cabal configure options. - -> M Package - ) + , loadPackage :: !(PackageLoader M) + -- ^ A function to load a `Package` given the location of a package assumed + -- to be immutable. , combinedMap :: !CombinedMap -- ^ A dictionary of package names, and combined information about the -- package in respect of whether or not it is already installed and, unless @@ -195,6 +191,20 @@ data Ctx = Ctx , pathEnvVar :: !Text } +-- | A type synonym representing functions that yield a 'Package' given the +-- location of a package assumed to be immutable, parameterised by the relevant +-- monad. +type PackageLoader m = + PackageLocationImmutable + -- ^ Location of a package that is assumed to be immutable. + -> Map FlagName Bool + -- ^ Cabal flags. + -> [Text] + -- ^ GHC options. + -> [Text] + -- ^ Cabal configure options. + -> m Package + instance HasPlatform Ctx where platformL = configL . platformL {-# INLINE platformL #-}