global -p option

Tristan Webb · Tristan Webb · commit 830ca3d2e82d · 2015-07-07T16:43:00.000-07:00
diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs
@@ -146,9 +146,17 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} =
                 return $ progsDir </> $(mkRelDir stackProgName) </> platform
             _ -> return $ configStackRoot </> $(mkRelDir "programs") </> platform
 
-     configLocalBin <- do
-        localDir <- liftIO (getAppUserDataDirectory "local") >>= parseAbsDir
-        return $ localDir </> $(mkRelDir "bin")
+     configLocalBin <- case configMonoidLocalBin of
+       Nothing -> do
+           localDir <- liftIO (getAppUserDataDirectory "local") >>= parseAbsDir
+           return $ localDir </> $(mkRelDir "bin")
+       Just userPath -> do
+           tryPath <- try (liftIO $ canonicalizePath userPath >>= parseAbsDir)
+           case tryPath of
+               Left (_ :: SomeException) ->
+                   error $ "Could not locate user specified directory \"" ++
+                      userPath ++ "\""
+               Right absPath -> return absPath
 
      configJobs <-
         case configMonoidJobs of
@@ -161,7 +169,7 @@ configFromConfigMonoid configStackRoot mproject configMonoid@ConfigMonoid{..} =
 -- | Command-line arguments parser for configuration.
 configOptsParser :: Bool -> Parser ConfigMonoid
 configOptsParser docker =
-    (\opts systemGHC installGHC arch os jobs includes libs skipGHCCheck skipMsys -> mempty
+    (\opts systemGHC installGHC arch os jobs includes libs skipGHCCheck skipMsys localBin -> mempty
         { configMonoidDockerOpts = opts
         , configMonoidSystemGHC = systemGHC
         , configMonoidInstallGHC = installGHC
@@ -172,6 +180,7 @@ configOptsParser docker =
         , configMonoidExtraIncludeDirs = includes
         , configMonoidExtraLibDirs = libs
         , configMonoidSkipMsys = skipMsys
+        , configMonoidLocalBin = localBin
         })
     <$> Docker.dockerOptsParser docker
     <*> maybeBoolFlags
@@ -216,6 +225,12 @@ configOptsParser docker =
             "skip-msys"
             "skipping the local MSYS installation (Windows only)"
             idm
+    <*> optional (strOption
+             ( long "local-bin-path"
+             <> short 'p'
+             <> metavar "DIR"
+             <> help "Install binaries to DIR"
+              )) 
 
 -- | Get the directory on Windows where we should install extra programs. For
 -- more information, see discussion at:
diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs
@@ -436,6 +436,8 @@ data ConfigMonoid =
     -- ^ See: 'configExtraLibDirs'
     ,configMonoidConcurrentTests     :: !(Maybe Bool)
     -- ^ See: 'configConcurrentTests'
+    ,configMonoidLocalBin            :: !(Maybe FilePath)
+    -- ^ Used to override the binary installation dir
     }
   deriving Show
 
@@ -457,6 +459,7 @@ instance Monoid ConfigMonoid where
     , configMonoidExtraIncludeDirs = Set.empty
     , configMonoidExtraLibDirs = Set.empty
     , configMonoidConcurrentTests = Nothing
+    , configMonoidLocalBin = Nothing
     }
   mappend l r = ConfigMonoid
     { configMonoidDockerOpts = configMonoidDockerOpts l <> configMonoidDockerOpts r
@@ -476,6 +479,7 @@ instance Monoid ConfigMonoid where
     , configMonoidExtraIncludeDirs = Set.union (configMonoidExtraIncludeDirs l) (configMonoidExtraIncludeDirs r)
     , configMonoidExtraLibDirs = Set.union (configMonoidExtraLibDirs l) (configMonoidExtraLibDirs r)
     , configMonoidConcurrentTests = configMonoidConcurrentTests l <|> configMonoidConcurrentTests r
+    , configMonoidLocalBin = configMonoidLocalBin l <|> configMonoidLocalBin r
     }
 
 instance FromJSON ConfigMonoid where
@@ -500,6 +504,7 @@ instance FromJSON ConfigMonoid where
          configMonoidExtraIncludeDirs <- obj .:? "extra-include-dirs" .!= Set.empty
          configMonoidExtraLibDirs <- obj .:? "extra-lib-dirs" .!= Set.empty
          configMonoidConcurrentTests <- obj .:? "concurrent-tests"
+         configMonoidLocalBin <- obj .:? "local-bin"
          return ConfigMonoid {..}
 
 -- | Newtype for non-orphan FromJSON instance.
diff --git a/test/integration/lib/StackTest.hs b/test/integration/lib/StackTest.hs
@@ -7,7 +7,6 @@ import System.Directory
 import System.IO
 import System.Process
 import System.Exit
-import System.Environment
 
 run' :: FilePath -> [String] -> IO ExitCode
 run' cmd args = do
@@ -44,11 +43,26 @@ stackErr args = do
 doesNotExist :: FilePath -> IO ()
 doesNotExist fp = do
     putStrLn $ "doesNotExist " ++ fp
+    exists <- doesFileOrDirExist fp
+    case exists of
+      (Right msg) -> error msg
+      (Left _) -> return ()
+
+doesExist :: FilePath -> IO ()
+doesExist fp = do
+    putStrLn $ "doesExist " ++ fp
+    exists <- doesFileOrDirExist fp
+    case exists of
+      (Right msg) -> return ()
+      (Left _) -> error "No file or directory exists"
+
+doesFileOrDirExist :: FilePath -> IO (Either () String) 
+doesFileOrDirExist fp = do
     isFile <- doesFileExist fp
     if isFile
-        then error $ "File exists: " ++ fp
+        then return (Right ("File exists: " ++ fp))
         else do
             isDir <- doesDirectoryExist fp
             if isDir
-                then error $ "Directory exists: " ++ fp
-                else return ()
+                then return (Right ("Directory exists: " ++ fp))
+                else return (Left ())
