diff --git a/ChangeLog.md b/ChangeLog.md index 5a3ed39874..009af2e1cf 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -120,6 +120,9 @@ Other enhancements: [#4480](https://github.com/commercialhaskell/stack/issues/4480). * Add `stack purge` as a shortcut for `stack clean --full`. See [#3863](https://github.com/commercialhaskell/stack/issues/3863). +* Both `stack dot` and `stack ls dependencies` accept a + `--global-hints` flag to bypass the need for an installed GHC. See + [#4390](https://github.com/commercialhaskell/stack/issues/4390). Bug fixes: diff --git a/src/Stack/Build.hs b/src/Stack/Build.hs index db7b2f6b85..bbedb3361f 100644 --- a/src/Stack/Build.hs +++ b/src/Stack/Build.hs @@ -252,7 +252,7 @@ mkBaseConfigOpts boptsCli = do -- | Provide a function for loading package information from the package index loadPackage - :: HasEnvConfig env + :: (HasBuildConfig env, HasSourceMap env) => PackageLocationImmutable -> Map FlagName Bool -> [Text] diff --git a/src/Stack/Build/ConstructPlan.hs b/src/Stack/Build/ConstructPlan.hs index 503fb5acc2..9be0614122 100644 --- a/src/Stack/Build/ConstructPlan.hs +++ b/src/Stack/Build/ConstructPlan.hs @@ -145,6 +145,8 @@ instance HasPantryConfig Ctx where instance HasProcessContext Ctx where processContextL = configL.processContextL instance HasBuildConfig Ctx +instance HasSourceMap Ctx where + sourceMapL = envConfigL.sourceMapL instance HasEnvConfig Ctx where envConfigL = lens ctxEnvConfig (\x y -> x { ctxEnvConfig = y }) @@ -246,7 +248,7 @@ constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap getSources = do pPackages <- for (smProject sourceMap) $ \pp -> do - lp <- loadLocalPackage sourceMap pp + lp <- loadLocalPackage pp return $ PSFilePath lp bopts <- view $ configL.to configBuild deps <- for (smDeps sourceMap) $ \dp -> @@ -255,7 +257,7 @@ constructPlan baseConfigOpts0 localDumpPkgs loadPackage0 sourceMap installedMap return $ PSRemote loc (getPLIVersion loc) (dpFromSnapshot dp) (dpCommon dp) PLMutable dir -> do pp <- mkProjectPackage YesPrintWarnings dir (shouldHaddockDeps bopts) - lp <- loadLocalPackage sourceMap pp + lp <- loadLocalPackage pp return $ PSFilePath lp return $ pPackages <> deps @@ -871,8 +873,11 @@ psForceDirty :: PackageSource -> Bool psForceDirty (PSFilePath lp) = lpForceDirty lp psForceDirty PSRemote{} = False -psDirty :: MonadIO m => PackageSource -> m (Maybe (Set FilePath)) -psDirty (PSFilePath lp) = runMemoized $ lpDirtyFiles lp +psDirty + :: (MonadIO m, HasEnvConfig env, MonadReader env m) + => PackageSource + -> m (Maybe (Set FilePath)) +psDirty (PSFilePath lp) = runMemoizedWith $ lpDirtyFiles lp psDirty PSRemote {} = pure Nothing -- files never change in a remote package psLocal :: PackageSource -> Bool diff --git a/src/Stack/Build/Execute.hs b/src/Stack/Build/Execute.hs index e7decbab43..eb8f5ed944 100644 --- a/src/Stack/Build/Execute.hs +++ b/src/Stack/Build/Execute.hs @@ -1480,7 +1480,7 @@ singleBuild ac@ActionContext {..} ee@ExecuteEnv {..} task@Task {..} installedMap case taskType of TTLocalMutable lp -> do when enableTests $ unsetTestSuccess pkgDir - caches <- runMemoized $ lpNewBuildCaches lp + caches <- runMemoizedWith $ lpNewBuildCaches lp mapM_ (uncurry (writeBuildCache pkgDir)) (Map.toList caches) TTRemotePackage{} -> return () @@ -1722,7 +1722,7 @@ checkExeStatus compiler platform distDir name = do -- | Check if any unlisted files have been found, and add them to the build cache. checkForUnlistedFiles :: HasEnvConfig env => TaskType -> CTime -> Path Abs Dir -> RIO env [PackageWarning] checkForUnlistedFiles (TTLocalMutable lp) preBuildTime pkgDir = do - caches <- runMemoized $ lpNewBuildCaches lp + caches <- runMemoizedWith $ lpNewBuildCaches lp (addBuildCache,warnings) <- addUnlistedToBuildCache preBuildTime diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs index c1aac1abbc..6bf84fefa7 100644 --- a/src/Stack/Build/Source.hs +++ b/src/Stack/Build/Source.hs @@ -51,7 +51,7 @@ projectLocalPackages :: HasEnvConfig env => RIO env [LocalPackage] projectLocalPackages = do sm <- view $ envConfigL.to envConfigSourceMap - for (toList $ smProject sm) $ loadLocalPackage sm + for (toList $ smProject sm) loadLocalPackage -- | loads all local dependencies - project packages and local extra-deps localDependencies :: HasEnvConfig env => RIO env [LocalPackage] @@ -62,7 +62,7 @@ localDependencies = do case dpLocation dp of PLMutable dir -> do pp <- mkProjectPackage YesPrintWarnings dir (shouldHaddockDeps bopts) - Just <$> loadLocalPackage sourceMap pp + Just <$> loadLocalPackage pp _ -> return Nothing -- | Given the parsed targets and buld command line options constructs @@ -236,7 +236,7 @@ splitComponents = go a b c (CBench x:xs) = go a b (c . (x:)) xs loadCommonPackage :: - forall env. HasEnvConfig env + forall env. (HasBuildConfig env, HasSourceMap env) => CommonPackage -> RIO env Package loadCommonPackage common = do @@ -247,11 +247,11 @@ loadCommonPackage common = do -- | Upgrade the initial project package info to a full-blown @LocalPackage@ -- based on the selected components loadLocalPackage :: - forall env. HasEnvConfig env - => SourceMap - -> ProjectPackage + forall env. (HasBuildConfig env, HasSourceMap env) + => ProjectPackage -> RIO env LocalPackage -loadLocalPackage sm pp = do +loadLocalPackage pp = do + sm <- view sourceMapL let common = ppCommon pp bopts <- view buildOptsL mcurator <- view $ buildConfigL.to bcCurator @@ -338,10 +338,10 @@ loadLocalPackage sm pp = do testpkg = resolvePackage testconfig gpkg benchpkg = resolvePackage benchconfig gpkg - componentFiles <- memoizeRef $ fst <$> getPackageFilesForTargets pkg (ppCabalFP pp) nonLibComponents + componentFiles <- memoizeRefWith $ fst <$> getPackageFilesForTargets pkg (ppCabalFP pp) nonLibComponents - checkCacheResults <- memoizeRef $ do - componentFiles' <- runMemoized componentFiles + checkCacheResults <- memoizeRefWith $ do + componentFiles' <- runMemoizedWith componentFiles forM (Map.toList componentFiles') $ \(component, files) -> do mbuildCache <- tryGetBuildCache (ppRoot pp) component checkCacheResult <- checkBuildCache @@ -503,10 +503,11 @@ calcFci modTime' fp = liftIO $ } -- | Get 'PackageConfig' for package given its name. -getPackageConfig :: (MonadReader env m, HasEnvConfig env) +getPackageConfig + :: (HasBuildConfig env, HasSourceMap env) => Map FlagName Bool -> [Text] - -> m PackageConfig + -> RIO env PackageConfig getPackageConfig flags ghcOptions = do platform <- view platformL compilerVersion <- view actualCompilerVersionL diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index e6d99c8281..3cf5d53cc1 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -26,6 +26,8 @@ import qualified Distribution.PackageDescription as PD import qualified Distribution.SPDX.License as SPDX import Distribution.License (License(BSD3), licenseFromSPDX) import Distribution.Types.PackageName (mkPackageName) +import RIO.PrettyPrint (HasTerm (..), HasStylesUpdate (..)) +import RIO.Process (HasProcessContext (..)) import Stack.Build (loadPackage) import Stack.Build.Installed (getInstalled, toInstallMap) import Stack.Build.Source @@ -34,11 +36,14 @@ import Stack.Package import Stack.PackageDump (DumpPackage(..)) import Stack.Prelude hiding (Display (..), pkgName, loadPackage) import qualified Stack.Prelude (pkgName) +import Stack.Runners import Stack.SourceMap import Stack.Types.Build +import Stack.Types.Compiler (wantedToActual) import Stack.Types.Config import Stack.Types.GhcPkgId import Stack.Types.SourceMap +import Stack.Build.Target(NeedTargets(..), parseTargets) -- | Options record for @stack dot@ data DotOpts = DotOpts @@ -58,6 +63,8 @@ data DotOpts = DotOpts -- ^ Like the "--test" flag for build, affects the meaning of 'dotTargets'. , dotBenchTargets :: Bool -- ^ Like the "--bench" flag for build, affects the meaning of 'dotTargets'. + , dotGlobalHints :: Bool + -- ^ Use global hints instead of relying on an actual GHC installation. } data ListDepsOpts = ListDepsOpts @@ -72,7 +79,7 @@ data ListDepsOpts = ListDepsOpts } -- | Visualize the project's dependencies as a graphviz graph -dot :: HasEnvConfig env => DotOpts -> RIO env () +dot :: DotOpts -> RIO Runner () dot dotOpts = do (localNames, prunedGraph) <- createPrunedDependencyGraph dotOpts printGraph dotOpts localNames prunedGraph @@ -88,12 +95,11 @@ data DotPayload = DotPayload -- | Create the dependency graph and also prune it as specified in the dot -- options. Returns a set of local names and and a map from package names to -- dependencies. -createPrunedDependencyGraph :: HasEnvConfig env - => DotOpts - -> RIO env +createPrunedDependencyGraph :: DotOpts + -> RIO Runner (Set PackageName, Map PackageName (Set PackageName, DotPayload)) -createPrunedDependencyGraph dotOpts = do +createPrunedDependencyGraph dotOpts = withConfig $ withDotConfig dotOpts $ do localNames <- view $ buildConfigL.to (Map.keysSet . smwProject . bcSMWanted) resultGraph <- createDependencyGraph dotOpts let pkgsToPrune = if dotIncludeBase dotOpts @@ -106,15 +112,14 @@ createPrunedDependencyGraph dotOpts = do -- name to a tuple of dependencies and payload if available. This -- function mainly gathers the required arguments for -- @resolveDependencies@. -createDependencyGraph :: HasEnvConfig env - => DotOpts - -> RIO env (Map PackageName (Set PackageName, DotPayload)) +createDependencyGraph + :: DotOpts + -> RIO DotConfig (Map PackageName (Set PackageName, DotPayload)) createDependencyGraph dotOpts = do - sourceMap <- view $ envConfigL.to envConfigSourceMap - locals <- projectLocalPackages + sourceMap <- view sourceMapL + locals <- for (toList $ smProject sourceMap) loadLocalPackage let graph = Map.fromList $ projectPackageDependencies dotOpts (filter lpWanted locals) - installMap <- toInstallMap sourceMap - (_, globalDump, _, _) <- getInstalled installMap + globalDump <- view $ to dcGlobalDump -- TODO: Can there be multiple entries for wired-in-packages? If so, -- this will choose one arbitrarily.. let globalDumpMap = Map.fromList $ map (\dp -> (Stack.Prelude.pkgName (dpPackageIdent dp), dp)) globalDump @@ -129,9 +134,9 @@ createDependencyGraph dotOpts = do resolveDependencies (dotDependencyDepth dotOpts) graph depLoader where makePayload pkg = DotPayload (Just $ packageVersion pkg) (Just $ packageLicense pkg) -listDependencies :: HasEnvConfig env - => ListDepsOpts - -> RIO env () +listDependencies + :: ListDepsOpts + -> RIO Runner () listDependencies opts = do let dotOpts = listDepsDotOpts opts (pkgs, resultGraph) <- createPrunedDependencyGraph dotOpts @@ -244,14 +249,13 @@ resolveDependencies limit graph loadPackageDeps = do where unifier (pkgs1,v1) (pkgs2,_) = (Set.union pkgs1 pkgs2, v1) -- | Given a SourceMap and a dependency loader, load the set of dependencies for a package -createDepLoader :: HasEnvConfig env - => SourceMap +createDepLoader :: SourceMap -> Map PackageName DumpPackage -> Map GhcPkgId PackageIdentifier -> (PackageName -> Version -> PackageLocationImmutable -> - Map FlagName Bool -> [Text] -> RIO env (Set PackageName, DotPayload)) + Map FlagName Bool -> [Text] -> RIO DotConfig (Set PackageName, DotPayload)) -> PackageName - -> RIO env (Set PackageName, DotPayload) + -> RIO DotConfig (Set PackageName, DotPayload) createDepLoader sourceMap globalDumpMap globalIdMap loadPackageDeps pkgName = do fromMaybe noDepsErr (projectPackageDeps <|> dependencyDeps <|> globalDeps) @@ -372,3 +376,97 @@ isWiredIn = (`Set.member` wiredInPackages) localPackageToPackage :: LocalPackage -> Package localPackageToPackage lp = fromMaybe (lpPackage lp) (lpTestBench lp) + +-- Plumbing for --test and --bench flags +withDotConfig + :: DotOpts + -> RIO DotConfig a + -> RIO Config a +withDotConfig opts inner = + local (over globalOptsL modifyGO) $ + if dotGlobalHints opts + then withBuildConfig withGlobalHints + else withReal + where + withGlobalHints = do + bconfig <- view buildConfigL + globals <- globalsFromHints $ smwCompiler $ bcSMWanted bconfig + fakeGhcPkgId <- parseGhcPkgId "ignored" + let smActual = SMActual + { smaCompiler = wantedToActual $ smwCompiler $ bcSMWanted bconfig + , smaProject = smwProject $ bcSMWanted bconfig + , smaDeps = smwDeps $ bcSMWanted bconfig + , smaGlobal = Map.mapWithKey toDump globals + } + toDump :: PackageName -> Version -> DumpPackage + toDump name version = DumpPackage + { dpGhcPkgId = fakeGhcPkgId + , dpPackageIdent = PackageIdentifier name version + , dpParentLibIdent = Nothing + , dpLicense = Nothing + , dpLibDirs = [] + , dpLibraries = [] + , dpHasExposedModules = True + , dpExposedModules = mempty + , dpDepends = [] + , dpHaddockInterfaces = [] + , dpHaddockHtml = Nothing + , dpIsExposed = True + } + actualPkgs = Map.keysSet (smaDeps smActual) <> + Map.keysSet (smaProject smActual) + prunedActual = smActual { smaGlobal = pruneGlobals (smaGlobal smActual) actualPkgs } + targets <- parseTargets NeedTargets False boptsCLI prunedActual + sourceMap <- loadSourceMap targets boptsCLI smActual + let dc = DotConfig + { dcBuildConfig = bconfig + , dcSourceMap = sourceMap + , dcGlobalDump = toList $ smaGlobal smActual + } + runRIO dc inner + + withReal = withEnvConfig NeedTargets boptsCLI $ do + envConfig <- ask + let sourceMap = envConfigSourceMap envConfig + installMap <- toInstallMap sourceMap + (_, globalDump, _, _) <- getInstalled installMap + let dc = DotConfig + { dcBuildConfig = envConfigBuildConfig envConfig + , dcSourceMap = sourceMap + , dcGlobalDump = globalDump + } + runRIO dc inner + + boptsCLI = defaultBuildOptsCLI + { boptsCLITargets = dotTargets opts + , boptsCLIFlags = dotFlags opts + } + modifyGO = + (if dotTestTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidTestsL) (Just True) else id) . + (if dotBenchTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidBenchmarksL) (Just True) else id) + +data DotConfig = DotConfig + { dcBuildConfig :: !BuildConfig + , dcSourceMap :: !SourceMap + , dcGlobalDump :: ![DumpPackage] + } +instance HasLogFunc DotConfig where + logFuncL = runnerL.logFuncL +instance HasPantryConfig DotConfig where + pantryConfigL = configL.pantryConfigL +instance HasTerm DotConfig where + useColorL = runnerL.useColorL + termWidthL = runnerL.termWidthL +instance HasStylesUpdate DotConfig where + stylesUpdateL = runnerL.stylesUpdateL +instance HasGHCVariant DotConfig +instance HasPlatform DotConfig +instance HasRunner DotConfig where + runnerL = configL.runnerL +instance HasProcessContext DotConfig where + processContextL = runnerL.processContextL +instance HasConfig DotConfig +instance HasBuildConfig DotConfig where + buildConfigL = lens dcBuildConfig (\x y -> x { dcBuildConfig = y }) +instance HasSourceMap DotConfig where + sourceMapL = lens dcSourceMap (\x y -> x { dcSourceMap = y }) diff --git a/src/Stack/Ls.hs b/src/Stack/Ls.hs index decc508148..f17bc2da42 100644 --- a/src/Stack/Ls.hs +++ b/src/Stack/Ls.hs @@ -10,9 +10,6 @@ module Stack.Ls ) where import Control.Exception (Exception, throw) -import Control.Monad.Catch (MonadThrow) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Reader (MonadReader) import Control.Monad (when) import Data.Aeson import Data.Array.IArray ((//), elems) @@ -34,7 +31,7 @@ import RIO.PrettyPrint.DefaultStyles (defaultStyles) import RIO.PrettyPrint.Types (StyleSpec) import RIO.PrettyPrint.StylesUpdate (StylesUpdate (..), stylesUpdateL) import Stack.Dot -import Stack.Runners (withConfig, withDefaultEnvConfig, withEnvConfigDot) +import Stack.Runners (withConfig, withDefaultEnvConfig) import Stack.Options.DotParser (listDepsOptsParser) import Stack.Types.Config import System.Console.ANSI.Codes (SGR (Reset), setSGRCode, sgrToCode) @@ -226,11 +223,9 @@ displayLocalSnapshot term xs = renderData term (localSnaptoText xs) localSnaptoText :: [String] -> Text localSnaptoText xs = T.intercalate "\n" $ L.map T.pack xs -handleLocal - :: (HasEnvConfig env) - => LsCmdOpts -> RIO env () +handleLocal :: LsCmdOpts -> RIO Runner () handleLocal lsOpts = do - (instRoot :: Path Abs Dir) <- installationRootDeps + (instRoot :: Path Abs Dir) <- withConfig $ withDefaultEnvConfig installationRootDeps isStdoutTerminal <- view terminalL let snapRootDir = parent $ parent instRoot snapData' <- liftIO $ listDirectory $ toFilePath snapRootDir @@ -251,8 +246,8 @@ handleLocal lsOpts = do LsStyles _ -> return () handleRemote - :: (MonadIO m, MonadThrow m, MonadReader env m, HasEnvConfig env) - => LsCmdOpts -> m () + :: HasRunner env + => LsCmdOpts -> RIO env () handleRemote lsOpts = do req <- liftIO $ parseRequest urlInfo isStdoutTerminal <- view terminalL @@ -278,23 +273,22 @@ handleRemote lsOpts = do lsCmd :: LsCmdOpts -> RIO Runner () lsCmd lsOpts = - withConfig $ case lsView lsOpts of LsSnapshot SnapshotOpts {..} -> case soptViewType of - Local -> withDefaultEnvConfig (handleLocal lsOpts) - Remote -> withDefaultEnvConfig (handleRemote lsOpts) + Local -> handleLocal lsOpts + Remote -> handleRemote lsOpts LsDependencies depOpts -> listDependenciesCmd False depOpts - LsStyles stylesOpts -> listStylesCmd stylesOpts + LsStyles stylesOpts -> withConfig $ listStylesCmd stylesOpts -- | List the dependencies -listDependenciesCmd :: Bool -> ListDepsOpts -> RIO Config () +listDependenciesCmd :: Bool -> ListDepsOpts -> RIO Runner () listDependenciesCmd deprecated opts = do when deprecated (logWarn "DEPRECATED: Use ls dependencies instead. Will be removed in next major version.") - withEnvConfigDot (listDepsDotOpts opts) $ listDependencies opts + listDependencies opts lsViewLocalCmd :: OA.Mod OA.CommandFields LsView lsViewLocalCmd = diff --git a/src/Stack/Options/DotParser.hs b/src/Stack/Options/DotParser.hs index ac22d81626..8af0eb8ce5 100644 --- a/src/Stack/Options/DotParser.hs +++ b/src/Stack/Options/DotParser.hs @@ -24,6 +24,7 @@ dotOptsParser externalDefault = <*> flagsParser <*> testTargets <*> benchTargets + <*> globalHints where includeExternal = boolFlags externalDefault "external" "inclusion of external dependencies" @@ -52,6 +53,9 @@ dotOptsParser externalDefault = splitNames :: String -> [String] splitNames = map (takeWhile (not . isSpace) . dropWhile isSpace) . splitOn "," + globalHints = switch (long "global-hints" <> + help "Do not require an install GHC; instead, use a hints file for global packages") + -- | Parser for arguments to `stack list-dependencies`. listDepsOptsParser :: Parser ListDepsOpts listDepsOptsParser = ListDepsOpts diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index 8d7659acd4..aec46fe3fc 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -77,7 +77,7 @@ import qualified RIO.PrettyPrint as PP (Style (Module)) data Ctx = Ctx { ctxFile :: !(Path Abs File) , ctxDistDir :: !(Path Abs Dir) - , ctxEnvConfig :: !EnvConfig + , ctxBuildConfig :: !BuildConfig } instance HasPlatform Ctx @@ -96,9 +96,8 @@ instance HasPantryConfig Ctx where pantryConfigL = configL.pantryConfigL instance HasProcessContext Ctx where processContextL = configL.processContextL -instance HasBuildConfig Ctx -instance HasEnvConfig Ctx where - envConfigL = lens ctxEnvConfig (\x y -> x { ctxEnvConfig = y }) +instance HasBuildConfig Ctx where + buildConfigL = lens ctxBuildConfig (\x y -> x { ctxBuildConfig = y }) -- | Read @.buildinfo@ ancillary files produced by some Setup.hs hooks. -- The file includes Cabal file syntax to be merged into the package description @@ -213,10 +212,10 @@ packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkg \cabalfp -> debugBracket ("getPackageFiles" <+> pretty cabalfp) $ do let pkgDir = parent cabalfp distDir <- distDirFromDir pkgDir - env <- view envConfigL + bc <- view buildConfigL (componentModules,componentFiles,dataFiles',warnings) <- runRIO - (Ctx cabalfp distDir env) + (Ctx cabalfp distDir bc) (packageDescModulesAndFiles pkg) setupFiles <- if buildType pkg == Custom diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs index ba541cb290..beef5e114b 100644 --- a/src/Stack/Runners.hs +++ b/src/Stack/Runners.hs @@ -14,7 +14,6 @@ module Stack.Runners , withEnvConfig , withDefaultEnvConfig , withEnvConfigExt - , withEnvConfigDot , withConfig , loadCompilerVersion , withUserFileLock @@ -38,7 +37,6 @@ import System.Console.ANSI (hSupportsANSIWithoutEmulation) import System.Environment (getEnvironment) import System.FileLock import System.Terminal (getTerminalWidth) -import Stack.Dot -- FIXME it seems wrong that we call loadBuildConfig multiple times loadCompilerVersion :: RIO Config WantedCompiler @@ -110,8 +108,8 @@ withGlobalConfigAndLock inner = -- For now the non-locking version just unlocks immediately. -- That is, there's still a serialization point. withDefaultEnvConfig - :: RIO EnvConfig () - -> RIO Config () + :: RIO EnvConfig a + -> RIO Config a withDefaultEnvConfig inner = withEnvConfigAndLock AllowNoTargets defaultBuildOptsCLI (\lk -> do munlockFile lk inner) @@ -119,23 +117,23 @@ withDefaultEnvConfig inner = withEnvConfig :: NeedTargets -> BuildOptsCLI - -> RIO EnvConfig () - -> RIO Config () + -> RIO EnvConfig a + -> RIO Config a withEnvConfig needTargets boptsCLI inner = withEnvConfigAndLock needTargets boptsCLI (\lk -> do munlockFile lk inner) withDefaultEnvConfigAndLock - :: (Maybe FileLock -> RIO EnvConfig ()) - -> RIO Config () + :: (Maybe FileLock -> RIO EnvConfig a) + -> RIO Config a withDefaultEnvConfigAndLock inner = withEnvConfigExt AllowNoTargets defaultBuildOptsCLI Nothing inner Nothing withEnvConfigAndLock :: NeedTargets -> BuildOptsCLI - -> (Maybe FileLock -> RIO EnvConfig ()) - -> RIO Config () + -> (Maybe FileLock -> RIO EnvConfig a) + -> RIO Config a withEnvConfigAndLock needTargets boptsCLI inner = withEnvConfigExt needTargets boptsCLI Nothing inner Nothing @@ -263,20 +261,3 @@ withRunnerGlobal go inner = do munlockFile :: MonadIO m => Maybe FileLock -> m () munlockFile Nothing = return () munlockFile (Just lk) = liftIO $ unlockFile lk - --- Plumbing for --test and --bench flags -withEnvConfigDot - :: DotOpts - -> RIO EnvConfig () - -> RIO Config () -withEnvConfigDot opts f = - local (over globalOptsL modifyGO) $ - withEnvConfig NeedTargets boptsCLI f - where - boptsCLI = defaultBuildOptsCLI - { boptsCLITargets = dotTargets opts - , boptsCLIFlags = dotFlags opts - } - modifyGO = - (if dotTestTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidTestsL) (Just True) else id) . - (if dotBenchTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidBenchmarksL) (Just True) else id) diff --git a/src/Stack/SourceMap.hs b/src/Stack/SourceMap.hs index d920ddf4e1..785d7ece58 100644 --- a/src/Stack/SourceMap.hs +++ b/src/Stack/SourceMap.hs @@ -14,6 +14,7 @@ module Stack.SourceMap , checkFlagsUsedThrowing , globalCondCheck , pruneGlobals + , globalsFromHints ) where import qualified Data.Conduit.List as CL diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index 45f29827c7..e2c1bab160 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -59,6 +59,7 @@ module Stack.Types.Config ,globalHintsFile -- ** EnvConfig & HasEnvConfig ,EnvConfig(..) + ,HasSourceMap(..) ,HasEnvConfig(..) ,getCompilerPath -- * Details @@ -1822,7 +1823,7 @@ class HasConfig env => HasBuildConfig env where envConfigBuildConfig (\x y -> x { envConfigBuildConfig = y }) -class HasBuildConfig env => HasEnvConfig env where +class (HasBuildConfig env, HasSourceMap env) => HasEnvConfig env where envConfigL :: Lens' env EnvConfig ----------------------------------- @@ -1919,11 +1920,16 @@ stackRootL = configL.lens configStackRoot (\x y -> x { configStackRoot = y }) wantedCompilerVersionL :: HasBuildConfig s => Getting r s WantedCompiler wantedCompilerVersionL = buildConfigL.to (smwCompiler . bcSMWanted) +class HasSourceMap env where + sourceMapL :: Lens' env SourceMap +instance HasSourceMap EnvConfig where + sourceMapL = lens envConfigSourceMap (\x y -> x { envConfigSourceMap = y }) + -- | The version of the compiler which will actually be used. May be -- different than that specified in the 'SnapshotDef' and returned -- by 'wantedCompilerVersionL'. -actualCompilerVersionL :: HasEnvConfig s => SimpleGetter s ActualCompiler -actualCompilerVersionL = envConfigL.to (smCompiler . envConfigSourceMap) +actualCompilerVersionL :: HasSourceMap env => SimpleGetter env ActualCompiler +actualCompilerVersionL = sourceMapL.to smCompiler buildOptsL :: HasConfig s => Lens' s BuildOpts buildOptsL = configL.lens diff --git a/src/Stack/Types/Package.hs b/src/Stack/Types/Package.hs index f1d803e58c..3d5d5a37cf 100644 --- a/src/Stack/Types/Package.hs +++ b/src/Stack/Types/Package.hs @@ -1,6 +1,8 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} @@ -270,19 +272,47 @@ data LocalPackage = LocalPackage -- ^ The .cabal file , lpBuildHaddocks :: !Bool , lpForceDirty :: !Bool - , lpDirtyFiles :: !(Memoized (Maybe (Set FilePath))) + , lpDirtyFiles :: !(MemoizedWith EnvConfig (Maybe (Set FilePath))) -- ^ Nothing == not dirty, Just == dirty. Note that the Set may be empty if -- we forced the build to treat packages as dirty. Also, the Set may not -- include all modified files. - , lpNewBuildCaches :: !(Memoized (Map NamedComponent (Map FilePath FileCacheInfo))) + , lpNewBuildCaches :: !(MemoizedWith EnvConfig (Map NamedComponent (Map FilePath FileCacheInfo))) -- ^ current state of the files - , lpComponentFiles :: !(Memoized (Map NamedComponent (Set (Path Abs File)))) + , lpComponentFiles :: !(MemoizedWith EnvConfig (Map NamedComponent (Set (Path Abs File)))) -- ^ all files used by this package } deriving Show -lpFiles :: MonadIO m => LocalPackage -> m (Set.Set (Path Abs File)) -lpFiles = runMemoized . fmap (Set.unions . M.elems) . lpComponentFiles +newtype MemoizedWith env a = MemoizedWith { unMemoizedWith :: RIO env a } + deriving (Functor, Applicative, Monad) + +memoizeRefWith :: MonadIO m => RIO env a -> m (MemoizedWith env a) +memoizeRefWith action = do + ref <- newIORef Nothing + pure $ MemoizedWith $ do + mres <- readIORef ref + res <- + case mres of + Just res -> pure res + Nothing -> do + res <- tryAny action + writeIORef ref $ Just res + pure res + either throwIO pure res + +runMemoizedWith + :: (HasEnvConfig env, MonadReader env m, MonadIO m) + => MemoizedWith EnvConfig a + -> m a +runMemoizedWith (MemoizedWith action) = do + envConfig <- view envConfigL + runRIO envConfig action + +instance Show (MemoizedWith env a) where + show _ = "<>" + +lpFiles :: HasEnvConfig env => LocalPackage -> RIO env (Set.Set (Path Abs File)) +lpFiles = runMemoizedWith . fmap (Set.unions . M.elems) . lpComponentFiles -- | A location to install a package into, either snapshot or local data InstallLocation = Snap | Local diff --git a/src/main/Main.hs b/src/main/Main.hs index aa0dffa462..c02468358b 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -338,7 +338,7 @@ commandLineHandler currentDir progName isInterpreter = complicatedOptions (sdistOptsParser False) addCommand' "dot" "Visualize your project's dependency graph using Graphviz dot" - dotCmd + dot (dotOptsParser False) -- Default for --external is False. addCommand' "ghc" "Run ghc" @@ -417,7 +417,7 @@ commandLineHandler currentDir progName isInterpreter = complicatedOptions (cleanOptsParser Purge) addCommand' "list-dependencies" "List the dependencies" - (withConfig . listDependenciesCmd True) + (listDependenciesCmd True) listDepsOptsParser addCommand' "query" "Query general build information (experimental)" @@ -1027,10 +1027,6 @@ solverCmd fixStackYaml = withConfig $ withDefaultEnvConfigAndLock (\_ -> solveExtraDeps fixStackYaml) --- | Visualize dependencies -dotCmd :: DotOpts -> RIO Runner () -dotCmd dotOpts = withConfig $ withEnvConfigDot dotOpts $ dot dotOpts - -- | Query build information queryCmd :: [String] -> RIO Runner () queryCmd selectors = withConfig $ withDefaultEnvConfig $ queryBuildInfo $ map T.pack selectors