From efc7c2f08884a44b620e5f2bfa1c059ac9745030 Mon Sep 17 00:00:00 2001 From: Kirill Zaborsky Date: Fri, 10 Aug 2018 16:34:38 +0300 Subject: [PATCH] `stack freeze` command --- package.yaml | 2 ++ src/Stack/Dot.hs | 6 ++-- src/Stack/Freeze.hs | 52 +++++++++++++++++++++++++++++++ src/Stack/Ls.hs | 4 +-- src/Stack/Options/BuildParser.hs | 9 ++++++ src/Stack/Options/DotParser.hs | 7 +---- src/Stack/Options/FreezeParser.hs | 15 +++++++++ src/Stack/Runners.hs | 12 +++---- src/Stack/Types/Config/Build.hs | 6 ++++ src/main/Main.hs | 12 ++++++- 10 files changed, 105 insertions(+), 20 deletions(-) create mode 100644 src/Stack/Freeze.hs create mode 100644 src/Stack/Options/FreezeParser.hs diff --git a/package.yaml b/package.yaml index d6b7f2fbbb..4b0a3ae45f 100644 --- a/package.yaml +++ b/package.yaml @@ -185,6 +185,7 @@ library: - Stack.Docker.GlobalDB - Stack.Dot - Stack.FileWatch + - Stack.Freeze - Stack.GhcPkg - Stack.Ghci - Stack.Ghci.Script @@ -204,6 +205,7 @@ library: - Stack.Options.DockerParser - Stack.Options.DotParser - Stack.Options.ExecParser + - Stack.Options.FreezeParser - Stack.Options.GhcBuildParser - Stack.Options.GhciParser - Stack.Options.GhcVariantParser diff --git a/src/Stack/Dot.hs b/src/Stack/Dot.hs index 774c1af2eb..49081c3ad6 100644 --- a/src/Stack/Dot.hs +++ b/src/Stack/Dot.hs @@ -54,10 +54,8 @@ data DotOpts = DotOpts -- ^ stack TARGETs to trace dependencies for , dotFlags :: !(Map (Maybe PackageName) (Map FlagName Bool)) -- ^ Flags to apply when calculating dependencies - , dotTestTargets :: Bool - -- ^ Like the "--test" flag for build, affects the meaning of 'dotTargets'. - , dotBenchTargets :: Bool - -- ^ Like the "--bench" flag for build, affects the meaning of 'dotTargets'. + , dotExtraTargets :: !ExtraTargets + -- ^ Like the "--test" / "--bench" flag for build, affects the meaning of 'dotTargets'. } data ListDepsOpts = ListDepsOpts diff --git a/src/Stack/Freeze.hs b/src/Stack/Freeze.hs new file mode 100644 index 0000000000..9865230850 --- /dev/null +++ b/src/Stack/Freeze.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +module Stack.Freeze + ( freeze + , FreezeOpts (..) + ) where + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Yaml as Yaml +import qualified RIO.ByteString as B +import Stack.Prelude +import Stack.Build.Target +import Stack.Types.Config +import Stack.Types.Package +import Stack.Build.Source + + +data FreezeOpts = FreezeOpts + { freezeTargets :: [Text] + -- ^ stack TARGETs to trace dependencies for + , freezeFlags :: !(Map (Maybe PackageName) (Map FlagName Bool)) + -- ^ Flags to apply when calculating dependencies + , freezeExtraTargets :: !ExtraTargets + -- ^ Like the "--test" / "--bench" flag for build, affects the meaning of 'dotTargets'. + } + +freeze :: HasEnvConfig env => FreezeOpts -> RIO env () +freeze freezeOpts = do + (locals, sourceMap) <- loadSourceMap NeedTargets defaultBuildOptsCLI + { boptsCLITargets = freezeTargets freezeOpts + , boptsCLIFlags = freezeFlags freezeOpts + } + let graph = Map.fromList (localDependencies (filter lpWanted locals)) + toPackageLocImmutable (PSRemote _ _ _ pli _) = Just $ mkUnresolvedPackageLocationImmutable pli + toPackageLocImmutable (PSFilePath _ _) = Nothing + sources = Set.unions $ Map.elems graph + locations = mapMaybe (fmap toPackageLocImmutable . flip Map.lookup sourceMap) $ Set.toList sources + liftIO $ B.putStr $ Yaml.encode locations + + +-- | Resolve the direct (depth 0) external dependencies of the given local packages +localDependencies :: [LocalPackage] -> [(PackageName, Set PackageName)] +localDependencies locals = + map (\lp -> let pkg = localPackageToPackage lp + in (packageName pkg, deps pkg)) + locals + where deps pkg = + Set.delete (packageName pkg) (packageAllDeps pkg) + localPackageToPackage lp = + fromMaybe (lpPackage lp) (lpTestBench lp) diff --git a/src/Stack/Ls.hs b/src/Stack/Ls.hs index f97a0cb60f..53551d9d86 100644 --- a/src/Stack/Ls.hs +++ b/src/Stack/Ls.hs @@ -29,7 +29,7 @@ import Network.HTTP.StackClient (httpJSON, getGlobalManager, addRequestHeader, g import qualified Options.Applicative as OA import Options.Applicative ((<|>)) import Path -import Stack.Runners (withBuildConfig, withBuildConfigDot) +import Stack.Runners (withBuildConfig, withBuildConfigExtraTargets) import Stack.Types.Config import Stack.Dot import Stack.Options.DotParser (listDepsOptsParser) @@ -248,7 +248,7 @@ listDependenciesCmd deprecated opts go = do (hPutStrLn stderr "DEPRECATED: Use ls dependencies instead. Will be removed in next major version.") - withBuildConfigDot (listDepsDotOpts opts) go $ listDependencies opts + withBuildConfigExtraTargets (dotExtraTargets $ listDepsDotOpts opts) go $ listDependencies opts lsViewLocalCmd :: OA.Mod OA.CommandFields LsView lsViewLocalCmd = diff --git a/src/Stack/Options/BuildParser.hs b/src/Stack/Options/BuildParser.hs index e2036520c6..f382cd124e 100644 --- a/src/Stack/Options/BuildParser.hs +++ b/src/Stack/Options/BuildParser.hs @@ -104,3 +104,12 @@ flagsParser = help ("Override flags set in stack.yaml " <> "(applies to local packages and extra-deps)"))) + +extraTargetsParser :: Parser ExtraTargets +extraTargetsParser = ExtraTargets <$> testTargets <*> benchTargets + where + testTargets = switch (long "test" <> + help "Consider dependencies of test components") + benchTargets = switch (long "bench" <> + help "Consider dependencies of benchmark components") + diff --git a/src/Stack/Options/DotParser.hs b/src/Stack/Options/DotParser.hs index 351ec1ec63..d30690127b 100644 --- a/src/Stack/Options/DotParser.hs +++ b/src/Stack/Options/DotParser.hs @@ -22,8 +22,7 @@ dotOptsParser externalDefault = <*> fmap (maybe Set.empty Set.fromList . fmap splitNames) prunedPkgs <*> targetsParser <*> flagsParser - <*> testTargets - <*> benchTargets + <*> extraTargetsParser where includeExternal = boolFlags externalDefault "external" "inclusion of external dependencies" @@ -44,10 +43,6 @@ dotOptsParser externalDefault = help ("Prune each package name " <> "from the comma separated list " <> "of package names PACKAGES"))) - testTargets = switch (long "test" <> - help "Consider dependencies of test components") - benchTargets = switch (long "bench" <> - help "Consider dependencies of benchmark components") splitNames :: String -> [String] splitNames = map (takeWhile (not . isSpace) . dropWhile isSpace) . splitOn "," diff --git a/src/Stack/Options/FreezeParser.hs b/src/Stack/Options/FreezeParser.hs new file mode 100644 index 0000000000..429ed100bf --- /dev/null +++ b/src/Stack/Options/FreezeParser.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Stack.Options.FreezeParser where + +import Options.Applicative +import Stack.Freeze +import Stack.Options.BuildParser + + +-- | Parser for arguments to `stack freeze` +freezeOptsParser :: Parser FreezeOpts +freezeOptsParser = + FreezeOpts <$> targetsParser + <*> flagsParser + <*> extraTargetsParser diff --git a/src/Stack/Runners.hs b/src/Stack/Runners.hs index b4b67fe29d..55ddf77a44 100644 --- a/src/Stack/Runners.hs +++ b/src/Stack/Runners.hs @@ -14,7 +14,7 @@ module Stack.Runners , withBuildConfigAndLockNoDocker , withBuildConfig , withBuildConfigExt - , withBuildConfigDot + , withBuildConfigExtraTargets , loadConfigWithOpts , loadCompilerVersion , withUserFileLock @@ -33,7 +33,6 @@ import Stack.Types.Runner import System.Environment (getEnvironment) import System.IO import System.FileLock -import Stack.Dot -- FIXME it seems wrong that we call lcLoadBuildConfig multiple times loadCompilerVersion :: GlobalOpts @@ -234,11 +233,10 @@ munlockFile Nothing = return () munlockFile (Just lk) = liftIO $ unlockFile lk -- Plumbing for --test and --bench flags -withBuildConfigDot :: DotOpts -> GlobalOpts -> RIO EnvConfig () -> IO () -withBuildConfigDot opts go f = withBuildConfig go' f +withBuildConfigExtraTargets :: ExtraTargets -> GlobalOpts -> RIO EnvConfig () -> IO () +withBuildConfigExtraTargets extraTargets go f = withBuildConfig go' f where go' = - (if dotTestTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidTestsL) (Just True) else id) $ - (if dotBenchTargets opts then set (globalOptsBuildOptsMonoidL.buildOptsMonoidBenchmarksL) (Just True) else id) + (if extraTestTargets extraTargets then set (globalOptsBuildOptsMonoidL.buildOptsMonoidTestsL) (Just True) else id) $ + (if extraBenchTargets extraTargets then set (globalOptsBuildOptsMonoidL.buildOptsMonoidBenchmarksL) (Just True) else id) go - diff --git a/src/Stack/Types/Config/Build.hs b/src/Stack/Types/Config/Build.hs index 29e63eda98..2452cbbe68 100644 --- a/src/Stack/Types/Config/Build.hs +++ b/src/Stack/Types/Config/Build.hs @@ -25,6 +25,7 @@ module Stack.Types.Config.Build , BenchmarkOptsMonoid(..) , FileWatchOpts(..) , BuildSubset(..) + , ExtraTargets(..) ) where @@ -437,3 +438,8 @@ data FileWatchOpts | FileWatch | FileWatchPoll deriving (Show,Eq) + +data ExtraTargets = ExtraTargets + { extraTestTargets :: !Bool + , extraBenchTargets :: !Bool + } diff --git a/src/main/Main.hs b/src/main/Main.hs index 3c9772ddcf..395dad3ba0 100644 --- a/src/main/Main.hs +++ b/src/main/Main.hs @@ -63,6 +63,7 @@ import Stack.Dot import Stack.GhcPkg (findGhcPkgField) import qualified Stack.Nix as Nix import Stack.FileWatch +import Stack.Freeze import Stack.Ghci import Stack.Hoogle import Stack.Ls @@ -77,6 +78,7 @@ import Stack.Options.DotParser import Stack.Options.ExecParser import Stack.Options.GhciParser import Stack.Options.GlobalParser +import Stack.Options.FreezeParser import Stack.Options.HpcReportParser import Stack.Options.NewParser @@ -387,6 +389,10 @@ commandLineHandler currentDir progName isInterpreter = complicatedOptions "Run a Stack Script" scriptCmd scriptOptsParser + addCommand' "freeze" + "List frozen dependencies" + freezeCmd + freezeOptsParser unless isInterpreter (do addCommand' "eval" @@ -993,7 +999,7 @@ solverCmd fixStackYaml go = -- | Visualize dependencies dotCmd :: DotOpts -> GlobalOpts -> IO () -dotCmd dotOpts go = withBuildConfigDot dotOpts go $ dot dotOpts +dotCmd dotOpts go = withBuildConfigExtraTargets (dotExtraTargets dotOpts) go $ dot dotOpts -- | Query build information queryCmd :: [String] -> GlobalOpts -> IO () @@ -1003,6 +1009,10 @@ queryCmd selectors go = withBuildConfig go $ queryBuildInfo $ map T.pack selecto hpcReportCmd :: HpcReportOpts -> GlobalOpts -> IO () hpcReportCmd hropts go = withBuildConfig go $ generateHpcReportForTargets hropts +freezeCmd :: FreezeOpts -> GlobalOpts -> IO () +freezeCmd freezeOpts go = + withBuildConfigExtraTargets (freezeExtraTargets freezeOpts) go $ freeze freezeOpts + data MainException = InvalidReExecVersion String String | UpgradeCabalUnusable | InvalidPathForExec FilePath