stack freeze command

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

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

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)

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 =

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")
+

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 ","

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

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
-

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
+  }

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