Merge pull request #1983 from sjakobi/1148-stack-root

Deprecate 'stack path --global-stack-root', add '--stack-root' options – #1148

ChangeLog.md

@@ -20,6 +20,13 @@ Behavior changes:
   `-rtsopts` was enabled, stack would process `+RTS` options even when intended
   for some other program, such as when used with `stack exec -- prog +RTS`.
   See [#2022](https://github.com/commercialhaskell/stack/issues/2022).
+* For consistency with the `$STACK_ROOT` environment variable, the
+  `stack path --global-stack-root` flag and the `global-stack-root` field
+  in the output of `stack path` are being deprecated and replaced with the
+  `stack-root` flag and output field.
+  Additionally, the stack root can now be specified via the
+  `--stack-root` command-line flag. See
+  [#1148](https://github.com/commercialhaskell/stack/issues/1148).
 
 Other enhancements:
 

doc/GUIDE.md

@@ -1470,6 +1470,7 @@ useful.
 ```
 michael@d30748af6d3d:~/wai$ stack path
 global-stack-root: /home/michael/.stack
+stack-root: /home/michael/.stack
 project-root: /home/michael/wai
 config-location: /home/michael/wai/stack.yaml
 bin-path: /home/michael/.stack/snapshots/x86_64-linux/lts-2.17/7.8.4/bin:/home/michael/.stack/programs/x86_64-linux/ghc-7.8.4/bin:/home/michael/.stack/programs/x86_64-linux/ghc-7.10.2/bin:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin
@@ -1480,11 +1481,14 @@ extra-include-dirs:
 extra-library-dirs:
 snapshot-pkg-db: /home/michael/.stack/snapshots/x86_64-linux/lts-2.17/7.8.4/pkgdb
 local-pkg-db: /home/michael/wai/.stack-work/install/x86_64-linux/lts-2.17/7.8.4/pkgdb
+global-pkg-db: /home/michael/.stack/programs/x86_64-linux/ghc-7.8.4/lib/ghc-7.8.4/package.conf.d
+ghc-package-path: /home/michael/wai/.stack-work/install/x86_64-linux/lts-2.17/7.8.4/pkgdb:/home/michael/.stack/snapshots/x86_64-linux/lts-2.17/7.8.4/pkgdb:/home/michael/.stack/programs/x86_64-linux/ghc-7.8.4/lib/ghc-7.8.4/package.conf.d
 snapshot-install-root: /home/michael/.stack/snapshots/x86_64-linux/lts-2.17/7.8.4
 local-install-root: /home/michael/wai/.stack-work/install/x86_64-linux/lts-2.17/7.8.4
 snapshot-doc-root: /home/michael/.stack/snapshots/x86_64-linux/lts-2.17/7.8.4/doc
 local-doc-root: /home/michael/wai/.stack-work/install/x86_64-linux/lts-2.17/7.8.4/doc
 dist-dir: .stack-work/dist/x86_64-linux/Cabal-1.18.1.5
+local-hpc-root: /home/michael/wai/.stack-work/install/x86_64-linux/lts-2.17/7.8.4/hpc
 ```
 
 In addition, `stack path` accepts command line arguments to state which of
@@ -1504,7 +1508,7 @@ what needs to be removed:
 
 1. The stack executable itself
 2. The stack root, e.g. `$HOME/.stack` on non-Windows systems.
-    * See `stack path --global-stack-root`
+    * See `stack path --stack-root`
     * On Windows, you will also need to delete `stack path --programs-paths`
 3. Any local `.stack-work` directories inside a project
 

src/Stack/Config.hs

@@ -391,7 +391,7 @@ loadConfig :: (MonadLogger m,MonadIO m,MonadMask m,MonadThrow m,MonadBaseControl
            -- ^ Override resolver
            -> m (LoadConfig m)
 loadConfig configArgs mstackYaml mresolver = do
-    (stackRoot, userOwnsStackRoot) <- determineStackRootAndOwnership
+    (stackRoot, userOwnsStackRoot) <- determineStackRootAndOwnership configArgs
     userConfigPath <- getDefaultUserConfigPath stackRoot
     extraConfigs0 <- getExtraConfigs userConfigPath >>= mapM loadYaml
     let extraConfigs =
@@ -645,19 +645,24 @@ resolvePackageLocation menv projRoot (PLRemote url remotePackageType) = do
 -- On Windows, the second value is always 'True'.
 determineStackRootAndOwnership
     :: (MonadIO m, MonadCatch m)
-    => m (Path Abs Dir, Bool)
-determineStackRootAndOwnership = do
+    => ConfigMonoid
+    -- ^ Parsed command-line arguments
+    -> m (Path Abs Dir, Bool)
+determineStackRootAndOwnership clArgs = do
     stackRoot <- do
-        mstackRoot <- liftIO $ lookupEnv stackRootEnvVar
-        case mstackRoot of
-            Nothing -> getAppUserDataDir stackProgName
-            Just x -> parseAbsDir x
+        case configMonoidStackRoot clArgs of
+            Just x -> return x
+            Nothing -> do
+                mstackRoot <- liftIO $ lookupEnv stackRootEnvVar
+                case mstackRoot of
+                    Nothing -> getAppUserDataDir stackProgName
+                    Just x -> parseAbsDir x
 
     (existingStackRootOrParentDir, userOwnsIt) <- do
         mdirAndOwnership <- findInParents getDirAndOwnership stackRoot
         case mdirAndOwnership of
             Just x -> return x
-            Nothing -> throwM (BadStackRootEnvVar stackRoot)
+            Nothing -> throwM (BadStackRoot stackRoot)
 
     when (existingStackRootOrParentDir /= stackRoot) $
         if userOwnsIt

src/Stack/Constants.hs

@@ -14,6 +14,8 @@ module Stack.Constants
     ,rawGithubUrl
     ,stackDotYaml
     ,stackRootEnvVar
+    ,stackRootOptionName
+    ,deprecatedStackRootOptionName
     ,inContainerEnvVar
     ,configCacheFile
     ,configCabalMod
@@ -220,6 +222,19 @@ stackDotYaml = $(mkRelFile "stack.yaml")
 stackRootEnvVar :: String
 stackRootEnvVar = "STACK_ROOT"
 
+-- | Option name for the global stack root.
+stackRootOptionName :: String
+stackRootOptionName = "stack-root"
+
+-- | Deprecated option name for the global stack root.
+--
+-- Deprecated since stack-1.0.5.
+--
+-- TODO: Remove occurences of this variable and use 'stackRootOptionName' only
+-- after an appropriate deprecation period.
+deprecatedStackRootOptionName :: String
+deprecatedStackRootOptionName = "global-stack-root"
+
 -- | Environment variable used to indicate stack is running in container.
 inContainerEnvVar :: String
 inContainerEnvVar = stackProgNameUpper ++ "_IN_CONTAINER"

src/Stack/Options.hs

@@ -29,7 +29,7 @@ module Stack.Options
     ) where
 
 import           Control.Monad.Logger              (LogLevel (..))
-import           Data.Char                         (isSpace, toLower)
+import           Data.Char                         (isSpace, toLower, toUpper)
 import           Data.List                         (intercalate)
 import           Data.List.Split                   (splitOn)
 import qualified Data.Map                          as Map
@@ -45,11 +45,12 @@ import           Options.Applicative
 import           Options.Applicative.Args
 import           Options.Applicative.Builder.Extra
 import           Options.Applicative.Types         (fromM, oneM, readerAsk)
+import           Path
 import           Stack.Build                       (splitObjsWarning)
 import           Stack.Clean                       (CleanOpts (..))
 import           Stack.Config                      (packagesParser)
 import           Stack.ConfigCmd
-import           Stack.Constants                   (stackProgName)
+import           Stack.Constants
 import           Stack.Coverage                    (HpcReportOpts (..))
 import           Stack.Docker
 import qualified Stack.Docker                      as Docker
@@ -201,8 +202,9 @@ cleanOptsParser = CleanShallow <$> packages <|> doFullClean
 -- | Command-line arguments parser for configuration.
 configOptsParser :: GlobalOptsContext -> Parser ConfigMonoid
 configOptsParser hide0 =
-    (\workDir buildOpts dockerOpts nixOpts systemGHC installGHC arch os ghcVariant jobs includes libs skipGHCCheck skipMsys localBin modifyCodePage allowDifferentUser -> mempty
-        { configMonoidWorkDir = workDir
+    (\stackRoot workDir buildOpts dockerOpts nixOpts systemGHC installGHC arch os ghcVariant jobs includes libs skipGHCCheck skipMsys localBin modifyCodePage allowDifferentUser -> mempty
+        { configMonoidStackRoot = stackRoot
+        , configMonoidWorkDir = workDir
         , configMonoidBuildOpts = buildOpts
         , configMonoidDockerOpts = dockerOpts
         , configMonoidNixOpts = nixOpts
@@ -220,7 +222,14 @@ configOptsParser hide0 =
         , configMonoidModifyCodePage = modifyCodePage
         , configMonoidAllowDifferentUser = allowDifferentUser
         })
-    <$> optional (strOption
+    <$> optional (option readAbsDir
+            ( long stackRootOptionName
+            <> metavar (map toUpper stackRootOptionName)
+            <> help ("Absolute path to the global stack root directory " ++
+                     "(Overrides any STACK_ROOT environment variable)")
+            <> hide
+            ))
+    <*> optional (strOption
             ( long "work-dir"
             <> metavar "WORK-DIR"
             <> help "Override work directory (default: .stack-work)"
@@ -294,6 +303,15 @@ configOptsParser hide0 =
             hide
   where hide = hideMods (hide0 /= OuterGlobalOpts)
 
+readAbsDir :: ReadM (Path Abs Dir)
+readAbsDir = do
+    s <- readerAsk
+    case parseAbsDir s of
+        Just p -> return p
+        Nothing ->
+            readerError
+                ("Failed to parse absolute path to directory: '" ++ s ++ "'")
+
 buildOptsMonoidParser :: Bool -> Parser BuildOptsMonoid
 buildOptsMonoidParser hide0 =
     transform <$> trace <*> profile <*> options

src/Stack/Types/Config.hs

@@ -162,7 +162,6 @@ import           Distribution.Version (anyVersion)
 import           Network.HTTP.Client (parseUrl)
 import           Path
 import qualified Paths_stack as Meta
-import           {-# SOURCE #-} Stack.Constants (stackRootEnvVar)
 import           Stack.Types.BuildPlan (SnapName, renderSnapName, parseSnapName)
 import           Stack.Types.Compiler
 import           Stack.Types.Docker
@@ -738,7 +737,9 @@ instance HasBuildConfig BuildConfig where
 -- Configurations may be "cascaded" using mappend (left-biased).
 data ConfigMonoid =
   ConfigMonoid
-    { configMonoidWorkDir            :: !(Maybe FilePath)
+    { configMonoidStackRoot          :: !(Maybe (Path Abs Dir))
+    -- ^ See: 'configStackRoot'
+    , configMonoidWorkDir            :: !(Maybe FilePath)
     -- ^ See: 'configWorkDir'.
     , configMonoidBuildOpts          :: !BuildOptsMonoid
     -- ^ build options.
@@ -817,7 +818,8 @@ data ConfigMonoid =
 
 instance Monoid ConfigMonoid where
   mempty = ConfigMonoid
-    { configMonoidWorkDir = Nothing
+    { configMonoidStackRoot = Nothing
+    , configMonoidWorkDir = Nothing
     , configMonoidBuildOpts = mempty
     , configMonoidDockerOpts = mempty
     , configMonoidNixOpts = mempty
@@ -855,7 +857,8 @@ instance Monoid ConfigMonoid where
     , configMonoidAllowDifferentUser = Nothing
     }
   mappend l r = ConfigMonoid
-    { configMonoidWorkDir = configMonoidWorkDir l <|> configMonoidWorkDir r
+    { configMonoidStackRoot = configMonoidStackRoot l <|> configMonoidStackRoot r
+    , configMonoidWorkDir = configMonoidWorkDir l <|> configMonoidWorkDir r
     , configMonoidBuildOpts = configMonoidBuildOpts l <> configMonoidBuildOpts r
     , configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r
     , configMonoidNixOpts = configMonoidNixOpts l <> configMonoidNixOpts r
@@ -902,6 +905,8 @@ instance FromJSON (WithJSONWarnings ConfigMonoid) where
 -- warnings for missing fields.
 parseConfigMonoidJSON :: Object -> WarningParser ConfigMonoid
 parseConfigMonoidJSON obj = do
+    -- Parsing 'stackRoot' from 'stackRoot'/config.yaml would be nonsensical
+    let configMonoidStackRoot = Nothing
     configMonoidWorkDir <- obj ..:? configMonoidWorkDirName
     configMonoidBuildOpts <- jsonSubWarnings (obj ..:? configMonoidBuildOptsName ..!= mempty)
     configMonoidDockerOpts <- jsonSubWarnings (obj ..:? configMonoidDockerOptsName ..!= mempty)
@@ -1104,7 +1109,7 @@ data ConfigException
   | ResolverPartial Resolver String
   | NoSuchDirectory FilePath
   | ParseGHCVariantException String
-  | BadStackRootEnvVar (Path Abs Dir)
+  | BadStackRoot (Path Abs Dir)
   | Won'tCreateStackRootInDirectoryOwnedByDifferentUser (Path Abs Dir) (Path Abs Dir) -- ^ @$STACK_ROOT@, parent dir
   | UserDoesn'tOwnDirectory (Path Abs Dir)
   deriving Typeable
@@ -1182,17 +1187,13 @@ instance Show ConfigException where
         [ "Invalid ghc-variant value: "
         , v
         ]
-    show (BadStackRootEnvVar envStackRoot) = concat
-        [ "Invalid $"
-        , stackRootEnvVar
-        , ": '"
-        , toFilePath envStackRoot
+    show (BadStackRoot stackRoot) = concat
+        [ "Invalid stack root: '"
+        , toFilePath stackRoot
         , "'. Please provide a valid absolute path."
         ]
     show (Won'tCreateStackRootInDirectoryOwnedByDifferentUser envStackRoot parentDir) = concat
-        [ "Preventing creation of $"
-        , stackRootEnvVar
-        , " '"
+        [ "Preventing creation of stack root '"
         , toFilePath envStackRoot
         , "'. Parent directory '"
         , toFilePath parentDir

src/main/Main.hs

@@ -537,12 +537,20 @@ pathCmd keys go =
             distDir <- distRelativeDir
             hpcDir <- hpcReportDir
             compilerPath <- getCompilerPath =<< getWhichCompiler
+            when (T.pack deprecatedStackRootOptionName `elem` keys) $
+                liftIO $ forM_
+                    [ ""
+                    , "'--" <> deprecatedStackRootOptionName <> "' will be removed in a future release."
+                    , "Please use '--" <> stackRootOptionName <> "' instead."
+                    , ""
+                    ]
+                    (hPutStrLn stderr)
             forM_
                 -- filter the chosen paths in flags (keys),
                 -- or show all of them if no specific paths chosen.
                 (filter
                      (\(_,key,_) ->
-                           null keys || elem key keys)
+                           (null keys && key /= T.pack deprecatedStackRootOptionName) || elem key keys)
                      paths)
                 (\(_,key,path) ->
                       liftIO $ T.putStrLn
@@ -583,7 +591,7 @@ data PathInfo = PathInfo
 -- | The paths of interest to a user. The first tuple string is used
 -- for a description that the optparse flag uses, and the second
 -- string as a machine-readable key and also for @--foo@ flags. The user
--- can choose a specific path to list like @--global-stack-root@. But
+-- can choose a specific path to list like @--stack-root@. But
 -- really it's mainly for the documentation aspect.
 --
 -- When printing output we generate @PathInfo@ and pass it to the
@@ -592,7 +600,7 @@ data PathInfo = PathInfo
 paths :: [(String, Text, PathInfo -> Text)]
 paths =
     [ ( "Global stack root directory"
-      , "global-stack-root"
+      , T.pack stackRootOptionName
       , T.pack . toFilePathNoTrailingSep . configStackRoot . bcConfig . piBuildConfig )
     , ( "Project root (derived from stack.yaml file)"
       , "project-root"
@@ -647,7 +655,11 @@ paths =
       , T.pack . toFilePathNoTrailingSep . piDistDir )
     , ( "Where HPC reports and tix files are stored"
       , "local-hpc-root"
-      , T.pack . toFilePathNoTrailingSep . piHpcDir ) ]
+      , T.pack . toFilePathNoTrailingSep . piHpcDir )
+    , ( "DEPRECATED: Use '--" <> stackRootOptionName <> "' instead"
+      , T.pack deprecatedStackRootOptionName
+      , T.pack . toFilePathNoTrailingSep . configStackRoot . bcConfig . piBuildConfig )
+    ]
 
 data SetupCmdOpts = SetupCmdOpts
     { scoCompilerVersion :: !(Maybe CompilerVersion)