Parse extra-lib-dirs and extra-include-dirs as Path Abs Dirs

commercialhaskell · Jul 21, 2016 · 679e3ed · 679e3ed
1 parent 7369fd3
commit 679e3ed
Show file tree

Hide file tree

Showing 11 changed files with 60 additions and 49 deletions.
diff --git a/src/Options/Applicative/Builder/Extra.hs b/src/Options/Applicative/Builder/Extra.hs
@@ -12,14 +12,18 @@ module Options.Applicative.Builder.Extra
   ,textOption
   ,textArgument
   ,optionalFirst
-  ,eitherReader'
+  ,absFileOption
+  ,relFileOption
+  ,absDirOption
+  ,relDirOption
   ) where
 
 import Control.Monad (when)
 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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,59 +119,58 @@ 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")
                 ]
             }
         (Platform _ x, toolName) -> 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
@@ -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
@@ -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
@@ -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