Add new option --stack-root, complementing $STACK_ROOT

Fixes commercialhaskell#1148.

ChangeLog.md

@@ -16,7 +16,9 @@ Behavior changes:
 * 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. See
+  `stack-root` flag and output field.
+  Additionally, the stack root can now be specified via the
+  `--stack-yaml` command-line flag. See
   [#1148](https://github.com/commercialhaskell/stack/issues/1148).
 
 Other enhancements:

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,13 +645,18 @@ 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

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

@@ -737,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.
@@ -816,7 +818,8 @@ data ConfigMonoid =
 
 instance Monoid ConfigMonoid where
   mempty = ConfigMonoid
-    { configMonoidWorkDir = Nothing
+    { configMonoidStackRoot = Nothing
+    , configMonoidWorkDir = Nothing
     , configMonoidBuildOpts = mempty
     , configMonoidDockerOpts = mempty
     , configMonoidNixOpts = mempty
@@ -854,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
@@ -901,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)

src/main/Main.hs

@@ -549,13 +549,13 @@ pathCmd keys go =
             localroot <- installationRootLocal
             distDir <- distRelativeDir
             hpcDir <- hpcReportDir
-            when (deprecatedStackRootOptionName `elem` keys) $
+            when (T.pack deprecatedStackRootOptionName `elem` keys) $
                 liftIO $ forM_
                     [ "'--" <> deprecatedStackRootOptionName <> "' will be removed in a future release."
                     , "Please use '--" <> stackRootOptionName <> "' instead."
                     , ""
                     ]
-                    (T.hPutStrLn stderr)
+                    (hPutStrLn stderr)
             forM_
                 -- filter the chosen paths in flags (keys),
                 -- or show all of them if no specific paths chosen.
@@ -608,11 +608,11 @@ data PathInfo = PathInfo
 -- removed, see #506
 paths :: [(String, Text, PathInfo -> Text)]
 paths =
-    [ ( "DEPRECATED: Use '--" <> T.unpack stackRootOptionName <> "' instead"
-      , deprecatedStackRootOptionName
+    [ ( "DEPRECATED: Use '--" <> stackRootOptionName <> "' instead"
+      , T.pack deprecatedStackRootOptionName
       , T.pack . toFilePathNoTrailingSep . configStackRoot . bcConfig . piBuildConfig )
     , ( "Global stack root directory"
-      , stackRootOptionName
+      , T.pack stackRootOptionName
       , T.pack . toFilePathNoTrailingSep . configStackRoot . bcConfig . piBuildConfig )
     , ( "Project root (derived from stack.yaml file)"
       , "project-root"
@@ -666,15 +666,6 @@ paths =
       , "local-hpc-root"
       , T.pack . toFilePathNoTrailingSep . piHpcDir ) ]
 
-stackRootOptionName :: Text
-stackRootOptionName = "stack-root"
-
--- Deprecated since stack-1.0.5.
--- TODO: Remove occurences of this variable and use 'stackRootOptionName' only
--- after an appropriate deprecation period.
-deprecatedStackRootOptionName :: Text
-deprecatedStackRootOptionName = "global-stack-root"
-
 data SetupCmdOpts = SetupCmdOpts
     { scoCompilerVersion :: !(Maybe CompilerVersion)
     , scoForceReinstall  :: !Bool