extra-path setting

ChangeLog.md

@@ -7,6 +7,7 @@ Major changes:
 Other enhancements:
 
 * Added the `ghc-options` field to stack.yaml [#796](https://github.com/commercialhaskell/stack/issues/796)
+* Added the `extra-path` field to stack.yaml
 
 Bug fixes:
 

src/Stack/Config.hs

@@ -29,6 +29,7 @@ module Stack.Config
 import qualified Codec.Archive.Tar as Tar
 import qualified Codec.Compression.GZip as GZip
 import           Control.Applicative
+import           Control.Arrow ((***))
 import           Control.Exception (IOException)
 import           Control.Monad
 import           Control.Monad.Catch (Handler(..), MonadCatch, MonadThrow, catches, throwM)
@@ -67,7 +68,7 @@ import           Stack.Types.Internal
 import           System.Directory (getAppUserDataDirectory, createDirectoryIfMissing, canonicalizePath)
 import           System.Environment
 import           System.IO
-import           System.Process.Read (getEnvOverride, EnvOverride, unEnvOverride, readInNull)
+import           System.Process.Read
 
 -- | Get the latest snapshot resolver available.
 getLatestResolver
@@ -139,7 +140,11 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} =
 
          configCompilerCheck = fromMaybe MatchMinor configMonoidCompilerCheck
 
-     origEnv <- getEnvOverride configPlatform
+     rawEnv <- liftIO getEnvironment
+     origEnv <- mkEnvOverride configPlatform
+              $ augmentPathMap (map toFilePath configMonoidExtraPath)
+              $ Map.fromList
+              $ map (T.pack *** T.pack) rawEnv
      let configEnvOverride _ = return origEnv
 
      platform <- runReaderT platformRelDir configPlatform

src/Stack/Setup.hs

@@ -152,20 +152,15 @@ setupEnv mResolveMissingGHC = do
             , soptsUpgradeCabal = False
             , soptsResolveMissingGHC = mResolveMissingGHC
             }
+
     mghcBin <- ensureGHC sopts
-    menv0 <- getMinimalEnvOverride
 
     -- Modify the initial environment to include the GHC path, if a local GHC
     -- is being used
-    let env = removeHaskellEnvVars $ case mghcBin of
-            Nothing -> unEnvOverride menv0
-            Just ghcBin ->
-                let x = unEnvOverride menv0
-                    mpath = Map.lookup "PATH" x
-                    path = T.intercalate (T.singleton searchPathSeparator)
-                        $ map (stripTrailingSlashT . T.pack) ghcBin
-                       ++ maybe [] return mpath
-                 in Map.insert "PATH" path x
+    menv0 <- getMinimalEnvOverride
+    let env = removeHaskellEnvVars
+            $ augmentPathMap (fromMaybe [] mghcBin)
+            $ unEnvOverride menv0
 
     menv <- mkEnvOverride platform env
     ghcVer <- getGhcVersion menv
@@ -246,19 +241,6 @@ setupEnv mResolveMissingGHC = do
         , envConfigPackages = envConfigPackages envConfig0
         }
 
--- | Augment the PATH environment variable with the given extra paths
-augmentPath :: [FilePath] -> Maybe Text -> Text
-augmentPath dirs mpath =
-    T.pack $ intercalate [searchPathSeparator]
-        (map stripTrailingSlashS dirs ++ maybe [] (return . T.unpack) mpath)
-  where
-    stripTrailingSlashS = T.unpack . stripTrailingSlashT . T.pack
-
-stripTrailingSlashT :: Text -> Text
-stripTrailingSlashT t = fromMaybe t $ T.stripSuffix
-        (T.singleton FP.pathSeparator)
-        t
-
 -- | Ensure GHC is installed and provide the PATHs to add if necessary
 ensureGHC :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
           => SetupOpts

src/Stack/Types/Config.hs

@@ -13,7 +13,7 @@ module Stack.Types.Config where
 
 import           Control.Applicative
 import           Control.Exception
-import           Control.Monad (liftM, mzero)
+import           Control.Monad (liftM, mzero, forM)
 import           Control.Monad.Catch (MonadThrow, throwM)
 import           Control.Monad.Logger (LogLevel(..))
 import           Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO)
@@ -522,6 +522,8 @@ data ConfigMonoid =
     -- ^ Initialize SCM (e.g. git init) when making new projects?
     ,configMonoidGhcOptions          :: !(Map (Maybe PackageName) [Text])
     -- ^ See 'configGhcOptions'
+    ,configMonoidExtraPath           :: ![Path Abs Dir]
+    -- ^ Additional paths to search for executables in
     }
   deriving Show
 
@@ -549,6 +551,7 @@ instance Monoid ConfigMonoid where
     , configMonoidScmInit = Nothing
     , configMonoidCompilerCheck = Nothing
     , configMonoidGhcOptions = mempty
+    , configMonoidExtraPath = []
     }
   mappend l r = ConfigMonoid
     { configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r
@@ -574,6 +577,7 @@ instance Monoid ConfigMonoid where
     , configMonoidScmInit = configMonoidScmInit l <|> configMonoidScmInit r
     , configMonoidCompilerCheck = configMonoidCompilerCheck l <|> configMonoidCompilerCheck r
     , configMonoidGhcOptions = Map.unionWith (++) (configMonoidGhcOptions l) (configMonoidGhcOptions r)
+    , configMonoidExtraPath = configMonoidExtraPath l ++ configMonoidExtraPath r
     }
 
 instance FromJSON (ConfigMonoid, [JSONWarning]) where
@@ -620,6 +624,10 @@ parseConfigMonoidJSON obj = do
             Nothing -> return mempty
             Just m -> fmap Map.fromList $ mapM handleGhcOptions $ Map.toList m
 
+    extraPath <- obj ..:? "extra-path" ..!= []
+    configMonoidExtraPath <- forM extraPath $
+        either (fail . show) return . parseAbsDir . T.unpack
+
     return ConfigMonoid {..}
   where
     handleGhcOptions :: Monad m => (Text, Text) -> m (Maybe PackageName, [Text])

src/System/Process/Read.hs

@@ -27,6 +27,8 @@ module System.Process.Read
   ,readInNull
   ,logProcessRun
   ,ReadProcessException (..)
+  ,augmentPath
+  ,augmentPathMap
   )
   where
 
@@ -49,7 +51,7 @@ import           Data.Foldable (forM_)
 import           Data.IORef
 import           Data.Map (Map)
 import qualified Data.Map as Map
-import           Data.Maybe (isJust)
+import           Data.Maybe (fromMaybe, isJust)
 import           Data.Monoid
 import           Data.Text (Text)
 import qualified Data.Text as T
@@ -327,3 +329,23 @@ getEnvOverride platform =
     getEnvironment >>=
           mkEnvOverride platform
         . Map.fromList . map (T.pack *** T.pack)
+
+-- | Augment the PATH environment variable with the given extra paths
+augmentPath :: [FilePath] -> Maybe Text -> Text
+augmentPath dirs mpath =
+    T.intercalate (T.singleton FP.searchPathSeparator)
+    $ map (stripTrailingSlashT . T.pack) dirs
+   ++ maybe [] return mpath
+
+stripTrailingSlashT :: Text -> Text
+stripTrailingSlashT t = fromMaybe t $ T.stripSuffix
+        (T.singleton FP.pathSeparator)
+        t
+
+-- | Apply 'augmentPath' on the PATH value in the given Map.
+augmentPathMap :: [FilePath] -> Map Text Text -> Map Text Text
+augmentPathMap paths origEnv =
+    Map.insert "PATH" path origEnv
+  where
+    mpath = Map.lookup "PATH" origEnv
+    path = augmentPath paths mpath