diff --git a/src/Options/Applicative/Builder/Extra.hs b/src/Options/Applicative/Builder/Extra.hs index 2bafb552f2..2037bfe202 100644 --- a/src/Options/Applicative/Builder/Extra.hs +++ b/src/Options/Applicative/Builder/Extra.hs @@ -12,7 +12,10 @@ module Options.Applicative.Builder.Extra ,textOption ,textArgument ,optionalFirst - ,eitherReader' + ,absFileOption + ,relFileOption + ,absDirOption + ,relDirOption ) where import Control.Monad (when) @@ -20,6 +23,7 @@ import Data.Either.Combinators import Data.Monoid import Options.Applicative import Options.Applicative.Types (readerAsk) +import Path import System.Environment (withArgs) import System.FilePath (takeBaseName) import Data.Text (Text) @@ -139,6 +143,18 @@ textArgument = argument (T.pack <$> readerAsk) optionalFirst :: Alternative f => f a -> f (First a) optionalFirst = fmap First . optional +absFileOption :: Mod OptionFields (Path Abs File) -> Parser (Path Abs File) +absFileOption = option (eitherReader' parseAbsFile) + +relFileOption :: Mod OptionFields (Path Rel File) -> Parser (Path Rel File) +relFileOption = option (eitherReader' parseRelFile) + +absDirOption :: Mod OptionFields (Path Abs Dir) -> Parser (Path Abs Dir) +absDirOption = option (eitherReader' parseAbsDir) + +relDirOption :: Mod OptionFields (Path Rel Dir) -> Parser (Path Rel Dir) +relDirOption = option (eitherReader' parseRelDir) + -- | Like 'eitherReader', but accepting any @'Show' e@ on the 'Left'. eitherReader' :: Show e => (String -> Either e a) -> ReadM a eitherReader' f = eitherReader (mapLeft show . f) diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs index 68b90cb84f..2a1f150162 100644 --- a/src/Stack/Config.hs +++ b/src/Stack/Config.hs @@ -258,7 +258,7 @@ configFromConfigMonoid configStackRoot configUserConfigPath mresolver mproject C configNix <- nixOptsFromMonoid configMonoidNixOpts os rawEnv <- liftIO getEnvironment - pathsEnv <- augmentPathMap (map toFilePath configMonoidExtraPath) + pathsEnv <- augmentPathMap configMonoidExtraPath (Map.fromList (map (T.pack *** T.pack) rawEnv)) origEnv <- mkEnvOverride configPlatform pathsEnv let configEnvOverride _ = return origEnv diff --git a/src/Stack/Docker.hs b/src/Stack/Docker.hs index 5091c41060..b3cc2f1ebc 100644 --- a/src/Stack/Docker.hs +++ b/src/Stack/Docker.hs @@ -189,7 +189,7 @@ reexecWithOptionalContainer mprojectRoot = exePath <- ensureDockerStackExe dockerContainerPlatform cmdArgs args (toFilePath exePath) cmdArgs args exePath = do - let mountPath = hostBinDir FP. FP.takeBaseName exePath + let mountPath = toFilePath hostBinDir FP. FP.takeBaseName exePath return (mountPath, args, [], [Mount exePath mountPath]) -- | If Docker is enabled, re-runs the OS command returned by the second argument in a @@ -299,8 +299,7 @@ runContainerAndExit getCmdArgs (isTerm || (isNothing bamboo && isNothing jenkins)) newPathEnv <- augmentPath [ hostBinDir - , toFilePathNoTrailingSep $ sandboxHomeDir - $(mkRelDir ".local/bin")] + , sandboxHomeDir $(mkRelDir ".local/bin")] (T.pack <$> lookupImageEnv "PATH" imageEnvVars) (cmnd,args,envVars,extraMount) <- getCmdArgs docker envOverride imageInfo isRemoteDocker pwd <- getCurrentDir @@ -862,8 +861,8 @@ homeDirName :: Path Rel Dir homeDirName = $(mkRelDir "_home/") -- | Directory where 'stack' executable is bind-mounted in Docker container -hostBinDir :: FilePath -hostBinDir = "/opt/host/bin" +hostBinDir :: Path Abs Dir +hostBinDir = $(mkAbsDir "/opt/host/bin") -- | Convenience function to decode ByteString to String. decodeUtf8 :: BS.ByteString -> String diff --git a/src/Stack/Options.hs b/src/Stack/Options.hs index d1f211c478..c41f3a035f 100644 --- a/src/Stack/Options.hs +++ b/src/Stack/Options.hs @@ -46,7 +46,6 @@ 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) @@ -224,14 +223,14 @@ configOptsParser hide0 = , configMonoidModifyCodePage = modifyCodePage , configMonoidAllowDifferentUser = allowDifferentUser }) - <$> optionalFirst (option (eitherReader' parseAbsDir) + <$> optionalFirst (absDirOption ( long stackRootOptionName <> metavar (map toUpper stackRootOptionName) <> help ("Absolute path to the global stack root directory " ++ "(Overrides any STACK_ROOT environment variable)") <> hide )) - <*> optionalFirst (option (eitherReader' parseRelDir) + <*> optionalFirst (relDirOption ( long "work-dir" <> metavar "WORK-DIR" <> help "Override work directory (default: .stack-work)" @@ -268,13 +267,13 @@ configOptsParser hide0 = <> help "Number of concurrent jobs to run" <> hide )) - <*> fmap Set.fromList (many (textOption + <*> fmap Set.fromList (many (absDirOption ( long "extra-include-dirs" <> metavar "DIR" <> help "Extra directories to check for C header files" <> hide ))) - <*> fmap Set.fromList (many (textOption + <*> fmap Set.fromList (many (absDirOption ( long "extra-lib-dirs" <> metavar "DIR" <> help "Extra directories to check for libraries" diff --git a/src/Stack/Package.hs b/src/Stack/Package.hs index b3ce2bb256..9040b81bdb 100644 --- a/src/Stack/Package.hs +++ b/src/Stack/Package.hs @@ -340,8 +340,8 @@ data BioInput = BioInput , biAddPackages :: ![PackageName] , biBuildInfo :: !BuildInfo , biDotCabalPaths :: !(Set DotCabalPath) - , biConfigLibDirs :: !(Set Text) - , biConfigIncludeDirs :: !(Set Text) + , biConfigLibDirs :: !(Set (Path Abs Dir)) + , biConfigIncludeDirs :: !(Set (Path Abs Dir)) , biComponentName :: !NamedComponent } @@ -403,7 +403,7 @@ generateBuildInfoOpts BioInput {..} = includeOpts = map ("-I" <>) (configExtraIncludeDirs <> pkgIncludeOpts) configExtraIncludeDirs = - map T.unpack (S.toList biConfigIncludeDirs) + map toFilePathNoTrailingSep (S.toList biConfigIncludeDirs) pkgIncludeOpts = [ toFilePathNoTrailingSep absDir | dir <- includeDirs biBuildInfo @@ -413,7 +413,7 @@ generateBuildInfoOpts BioInput {..} = map ("-l" <>) (extraLibs biBuildInfo) <> map ("-L" <>) (configExtraLibDirs <> pkgLibDirs) configExtraLibDirs = - map T.unpack (S.toList biConfigLibDirs) + map toFilePathNoTrailingSep (S.toList biConfigLibDirs) pkgLibDirs = [ toFilePathNoTrailingSep absDir | dir <- extraLibDirs biBuildInfo diff --git a/src/Stack/Path.hs b/src/Stack/Path.hs index 6304c45aac..cc3bfb744f 100644 --- a/src/Stack/Path.hs +++ b/src/Stack/Path.hs @@ -151,10 +151,10 @@ paths = , T.pack . toFilePathNoTrailingSep . configLocalBin . bcConfig . piBuildConfig ) , ( "Extra include directories" , "extra-include-dirs" - , T.intercalate ", " . Set.elems . configExtraIncludeDirs . bcConfig . piBuildConfig ) + , T.intercalate ", " . map (T.pack . toFilePathNoTrailingSep) . Set.elems . configExtraIncludeDirs . bcConfig . piBuildConfig ) , ( "Extra library directories" , "extra-library-dirs" - , T.intercalate ", " . Set.elems . configExtraLibDirs . bcConfig . piBuildConfig ) + , T.intercalate ", " . map (T.pack . toFilePathNoTrailingSep) . Set.elems . configExtraLibDirs . bcConfig . piBuildConfig ) , ( "Snapshot package database" , "snapshot-pkg-db" , T.pack . toFilePathNoTrailingSep . piSnapDb ) diff --git a/src/Stack/Setup.hs b/src/Stack/Setup.hs index d7efa9e970..e1d156cc27 100644 --- a/src/Stack/Setup.hs +++ b/src/Stack/Setup.hs @@ -232,9 +232,8 @@ setupEnv mResolveMissingGHC = do -- extra installation bin directories mkDirs <- runReaderT extraBinDirs envConfig0 let mpath = Map.lookup "PATH" env - mkDirs' = map toFilePath . mkDirs - depsPath <- augmentPath (mkDirs' False) mpath - localsPath <- augmentPath (mkDirs' True) mpath + depsPath <- augmentPath (mkDirs False) mpath + localsPath <- augmentPath (mkDirs True) mpath deps <- runReaderT packageDatabaseDeps envConfig0 createDatabase menv wc deps @@ -314,10 +313,10 @@ addIncludeLib :: ExtraDirs -> Config -> Config addIncludeLib (ExtraDirs _bins includes libs) config = config { configExtraIncludeDirs = Set.union (configExtraIncludeDirs config) - (Set.fromList $ map T.pack includes) + (Set.fromList includes) , configExtraLibDirs = Set.union (configExtraLibDirs config) - (Set.fromList $ map T.pack libs) + (Set.fromList libs) } -- | Ensure compiler (ghc or ghcjs) is installed and provide the PATHs to add if necessary @@ -1113,8 +1112,7 @@ installMsys2Windows osKey si archiveFile archiveType destDir = do platform <- asks getPlatform menv0 <- getMinimalEnvOverride newEnv0 <- modifyEnvOverride menv0 $ Map.insert "MSYSTEM" "MSYS" - newEnv <- augmentPathMap [toFilePath $ destDir $(mkRelDir "usr") - $(mkRelDir "bin")] + newEnv <- augmentPathMap [destDir $(mkRelDir "usr") $(mkRelDir "bin")] (unEnvOverride newEnv0) menv <- mkEnvOverride platform newEnv runCmd (Cmd (Just destDir) "sh" menv ["--login", "-c", "true"]) Nothing diff --git a/src/Stack/Setup/Installed.hs b/src/Stack/Setup/Installed.hs index ccfc1bee7d..137e0abf32 100644 --- a/src/Stack/Setup/Installed.hs +++ b/src/Stack/Setup/Installed.hs @@ -37,7 +37,6 @@ import qualified Distribution.System as Cabal import GHC.Generics (Generic) import Generics.Deriving.Monoid (mappenddefault, memptydefault) import Path -import Path.Extra (toFilePathNoTrailingSep) import Path.IO import Prelude hiding (concat, elem) -- Fix AMP warning import Stack.Types @@ -120,44 +119,44 @@ extraDirs tool = do dir <- installDir (configLocalPrograms config) tool case (configPlatform config, toolNameString tool) of (Platform _ Cabal.Windows, isGHC -> True) -> return mempty - { edBins = goList + { edBins = [ dir $(mkRelDir "bin") , dir $(mkRelDir "mingw") $(mkRelDir "bin") ] } (Platform Cabal.I386 Cabal.Windows, "msys2") -> return mempty - { edBins = goList + { edBins = [ dir $(mkRelDir "mingw32") $(mkRelDir "bin") , dir $(mkRelDir "usr") $(mkRelDir "bin") , dir $(mkRelDir "usr") $(mkRelDir "local") $(mkRelDir "bin") ] - , edInclude = goList + , edInclude = [ dir $(mkRelDir "mingw32") $(mkRelDir "include") ] - , edLib = goList + , edLib = [ dir $(mkRelDir "mingw32") $(mkRelDir "lib") ] } (Platform Cabal.X86_64 Cabal.Windows, "msys2") -> return mempty - { edBins = goList + { edBins = [ dir $(mkRelDir "mingw64") $(mkRelDir "bin") , dir $(mkRelDir "usr") $(mkRelDir "bin") , dir $(mkRelDir "usr") $(mkRelDir "local") $(mkRelDir "bin") ] - , edInclude = goList + , edInclude = [ dir $(mkRelDir "mingw64") $(mkRelDir "include") ] - , edLib = goList + , edLib = [ dir $(mkRelDir "mingw64") $(mkRelDir "lib") ] } (_, isGHC -> True) -> return mempty - { edBins = goList + { edBins = [ dir $(mkRelDir "bin") ] } (_, isGHCJS -> True) -> return mempty - { edBins = goList + { edBins = [ dir $(mkRelDir "bin") ] } @@ -165,14 +164,13 @@ extraDirs tool = do $logWarn $ "binDirs: unexpected OS/tool combo: " <> T.pack (show (x, toolName)) return mempty where - goList = map toFilePathNoTrailingSep isGHC n = "ghc" == n || "ghc-" `isPrefixOf` n isGHCJS n = "ghcjs" == n data ExtraDirs = ExtraDirs - { edBins :: ![FilePath] - , edInclude :: ![FilePath] - , edLib :: ![FilePath] + { edBins :: ![Path Abs Dir] + , edInclude :: ![Path Abs Dir] + , edLib :: ![Path Abs Dir] } deriving (Show, Generic) instance Monoid ExtraDirs where mempty = memptydefault diff --git a/src/Stack/Types/Build.hs b/src/Stack/Types/Build.hs index db66cd0922..b18a376a2f 100644 --- a/src/Stack/Types/Build.hs +++ b/src/Stack/Types/Build.hs @@ -630,8 +630,8 @@ configureOptsNoDir econfig bco deps isLocal package = concat flagNameString name) (Map.toList flags) , concatMap (\x -> ["--ghc-options", T.unpack x]) (packageGhcOptions package) - , map (("--extra-include-dirs=" ++) . T.unpack) (Set.toList (configExtraIncludeDirs config)) - , map (("--extra-lib-dirs=" ++) . T.unpack) (Set.toList (configExtraLibDirs config)) + , map (("--extra-include-dirs=" ++) . toFilePathNoTrailingSep) (Set.toList (configExtraIncludeDirs config)) + , map (("--extra-lib-dirs=" ++) . toFilePathNoTrailingSep) (Set.toList (configExtraLibDirs config)) , maybe [] (\customGcc -> ["--with-gcc=" ++ T.unpack customGcc]) (configOverrideGccPath config) , ["--ghcjs" | whichCompiler (envConfigCompilerVersion econfig) == Ghcjs] , ["--exact-configuration" | useExactConf] diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs index f4a263ac64..903f5b890c 100644 --- a/src/Stack/Types/Config.hs +++ b/src/Stack/Types/Config.hs @@ -287,9 +287,9 @@ data Config = -- ^ How many concurrent jobs to run, defaults to number of capabilities ,configOverrideGccPath :: !(Maybe Text) -- ^ Optional gcc override path - ,configExtraIncludeDirs :: !(Set Text) + ,configExtraIncludeDirs :: !(Set (Path Abs Dir)) -- ^ --extra-include-dirs arguments - ,configExtraLibDirs :: !(Set Text) + ,configExtraLibDirs :: !(Set (Path Abs Dir)) -- ^ --extra-lib-dirs arguments ,configConcurrentTests :: !Bool -- ^ Run test suites concurrently @@ -848,9 +848,9 @@ data ConfigMonoid = -- ^ Used for overriding the GHC variant ,configMonoidJobs :: !(First Int) -- ^ See: 'configJobs' - ,configMonoidExtraIncludeDirs :: !(Set Text) + ,configMonoidExtraIncludeDirs :: !(Set (Path Abs Dir)) -- ^ See: 'configExtraIncludeDirs' - ,configMonoidExtraLibDirs :: !(Set Text) + ,configMonoidExtraLibDirs :: !(Set (Path Abs Dir)) -- ^ See: 'configExtraLibDirs' , configMonoidOverrideGccPath :: !(First Text) -- ^ Allow users to override the path to gcc diff --git a/src/System/Process/Read.hs b/src/System/Process/Read.hs index 89c5b89973..82d574db4d 100644 --- a/src/System/Process/Read.hs +++ b/src/System/Process/Read.hs @@ -67,6 +67,7 @@ import Data.Typeable (Typeable) import Distribution.System (OS (Windows), Platform (Platform)) import Language.Haskell.TH as TH (location) import Path +import Path.Extra import Path.IO hiding (findExecutable) import Prelude -- Fix AMP warning import qualified System.Directory as D @@ -404,16 +405,16 @@ instance Show PathException where ] ++ paths -- | Augment the PATH environment variable with the given extra paths. -augmentPath :: MonadThrow m => [FilePath] -> Maybe Text -> m Text +augmentPath :: MonadThrow m => [Path Abs Dir] -> Maybe Text -> m Text augmentPath dirs mpath = - do let illegal = filter (FP.searchPathSeparator `elem`) dirs + do let illegal = filter (FP.searchPathSeparator `elem`) (map toFilePath dirs) unless (null illegal) (throwM $ PathsInvalidInPath illegal) return $ T.intercalate (T.singleton FP.searchPathSeparator) - $ map (T.pack . FP.dropTrailingPathSeparator) dirs + $ map (T.pack . toFilePathNoTrailingSep) dirs ++ maybeToList mpath -- | Apply 'augmentPath' on the PATH value in the given Map. -augmentPathMap :: MonadThrow m => [FilePath] -> Map Text Text +augmentPathMap :: MonadThrow m => [Path Abs Dir] -> Map Text Text -> m (Map Text Text) augmentPathMap dirs origEnv = do path <- augmentPath dirs mpath