Merge pull request #10256 from mpickering/wip/working-dir-path-mp

Collection of patches to do with --working-dir

Cabal-QuickCheck/src/Test/QuickCheck/Instances/Cabal.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE CPP           #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Test.QuickCheck.Instances.Cabal () where
 
@@ -18,7 +19,7 @@ import Distribution.Compat.NonEmptySet             (NonEmptySet)
 import Distribution.Compiler
 import Distribution.FieldGrammar.Newtypes
 import Distribution.ModuleName
-import Distribution.Simple.Compiler                (DebugInfoLevel (..), OptimisationLevel (..), PackageDB (..), ProfDetailLevel (..), knownProfDetailLevels)
+import Distribution.Simple.Compiler
 import Distribution.Simple.Flag                    (Flag (..))
 import Distribution.Simple.InstallDirs
 import Distribution.Simple.Setup                   (HaddockTarget (..), TestShowDetails (..), DumpBuildInfo)
@@ -476,7 +477,7 @@ instance Arbitrary TestShowDetails where
 -- PackageDB
 -------------------------------------------------------------------------------
 
-instance Arbitrary PackageDB where
+instance Arbitrary (PackageDBX FilePath) where
     arbitrary = oneof [ pure GlobalPackageDB
                       , pure UserPackageDB
                       , SpecificPackageDB <$> arbitraryShortPath

Cabal-syntax/src/Distribution/Utils/Path.hs

@@ -30,14 +30,17 @@ module Distribution.Utils.Path
   , Tix
   , Tmp
   , Response
+  , PkgConf
 
     -- * Symbolic paths
   , RelativePath
   , SymbolicPath
+  , AbsolutePath (..)
   , SymbolicPathX -- NB: constructor not exposed, to retain type safety.
 
     -- ** Symbolic path API
   , getSymbolicPath
+  , getAbsolutePath
   , sameDirectory
   , makeRelativePathEx
   , makeSymbolicPath
@@ -47,6 +50,7 @@ module Distribution.Utils.Path
   , relativeSymbolicPath
   , symbolicPathRelative_maybe
   , interpretSymbolicPath
+  , interpretSymbolicPathAbsolute
 
     -- ** General filepath API
   , (</>)
@@ -59,7 +63,7 @@ module Distribution.Utils.Path
     -- ** Working directory handling
   , interpretSymbolicPathCWD
   , absoluteWorkingDir
-  , tryMakeRelativeToWorkingDir
+  , tryMakeRelative
 
     -- ** Module names
   , moduleNameSymbolicPath
@@ -214,6 +218,11 @@ type RelativePath = SymbolicPathX 'OnlyRelative
 -- until we interpret them (using e.g. 'interpretSymbolicPath').
 type SymbolicPath = SymbolicPathX 'AllowAbsolute
 
+newtype AbsolutePath (to :: FileOrDir) = AbsolutePath (forall from. SymbolicPath from to)
+
+unsafeMakeAbsolutePath :: FilePath -> AbsolutePath to
+unsafeMakeAbsolutePath fp = AbsolutePath (makeSymbolicPath fp)
+
 instance Binary (SymbolicPathX allowAbsolute from to)
 instance
   (Typeable allowAbsolute, Typeable from, Typeable to)
@@ -289,7 +298,7 @@ moduleNameSymbolicPath modNm = SymbolicPath $ ModuleName.toFilePath modNm
 -- (because the program might expect certain paths to be relative).
 --
 -- See Note [Symbolic paths] in Distribution.Utils.Path.
-interpretSymbolicPath :: Maybe (SymbolicPath CWD (Dir Pkg)) -> SymbolicPathX allowAbsolute Pkg to -> FilePath
+interpretSymbolicPath :: Maybe (SymbolicPath CWD (Dir from)) -> SymbolicPathX allowAbsolute from to -> FilePath
 interpretSymbolicPath mbWorkDir (SymbolicPath p) =
   -- Note that this properly handles an absolute symbolic path,
   -- because if @q@ is absolute, then @p </> q = q@.
@@ -316,9 +325,15 @@ interpretSymbolicPath mbWorkDir (SymbolicPath p) =
 -- appropriate to use 'interpretSymbolicPathCWD' to provide its arguments.
 --
 -- See Note [Symbolic paths] in Distribution.Utils.Path.
-interpretSymbolicPathCWD :: SymbolicPathX allowAbsolute Pkg to -> FilePath
+interpretSymbolicPathCWD :: SymbolicPathX allowAbsolute from to -> FilePath
 interpretSymbolicPathCWD (SymbolicPath p) = p
 
+getAbsolutePath :: AbsolutePath to -> FilePath
+getAbsolutePath (AbsolutePath p) = getSymbolicPath p
+
+interpretSymbolicPathAbsolute :: AbsolutePath (Dir Pkg) -> SymbolicPathX allowAbsolute Pkg to -> FilePath
+interpretSymbolicPathAbsolute (AbsolutePath p) sym = interpretSymbolicPath (Just p) sym
+
 -- | Change what a symbolic path is pointing to.
 coerceSymbolicPath :: SymbolicPathX allowAbsolute from to1 -> SymbolicPathX allowAbsolute from to2
 coerceSymbolicPath = coerce
@@ -342,17 +357,19 @@ symbolicPathRelative_maybe (SymbolicPath fp) =
     else Just $ SymbolicPath fp
 
 -- | Absolute path to the current working directory.
-absoluteWorkingDir :: Maybe (SymbolicPath CWD to) -> IO FilePath
-absoluteWorkingDir Nothing = Directory.getCurrentDirectory
-absoluteWorkingDir (Just wd) = Directory.makeAbsolute $ getSymbolicPath wd
+absoluteWorkingDir :: Maybe (SymbolicPath CWD to) -> IO (AbsolutePath to)
+absoluteWorkingDir Nothing = unsafeMakeAbsolutePath <$> Directory.getCurrentDirectory
+absoluteWorkingDir (Just wd) = unsafeMakeAbsolutePath <$> Directory.makeAbsolute (getSymbolicPath wd)
 
--- | Try to make a path relative to the current working directory.
+-- | Try to make a symbolic path relative.
+--
+-- This function does nothing if the path is already relative.
 --
 -- NB: this function may fail to make the path relative.
-tryMakeRelativeToWorkingDir :: Maybe (SymbolicPath CWD (Dir dir)) -> SymbolicPath dir to -> IO (SymbolicPath dir to)
-tryMakeRelativeToWorkingDir mbWorkDir (SymbolicPath fp) = do
-  wd <- absoluteWorkingDir mbWorkDir
-  return $ SymbolicPath (FilePath.makeRelative wd fp)
+tryMakeRelative :: Maybe (SymbolicPath CWD (Dir dir)) -> SymbolicPath dir to -> IO (SymbolicPath dir to)
+tryMakeRelative mbWorkDir (SymbolicPath fp) = do
+  AbsolutePath wd <- absoluteWorkingDir mbWorkDir
+  return $ SymbolicPath (FilePath.makeRelative (getSymbolicPath wd) fp)
 
 -------------------------------------------------------------------------------
 
@@ -422,6 +439,16 @@ instance
   where
   SymbolicPath p1 </> SymbolicPath p2 = SymbolicPath (p1 </> p2)
 
+instance
+  (b1 ~ 'Dir b2, c2 ~ c3, midAbsolute ~ OnlyRelative)
+  => PathLike
+      (AbsolutePath b1)
+      (SymbolicPathX midAbsolute b2 c2)
+      (AbsolutePath c3)
+  where
+  AbsolutePath (SymbolicPath p1) </> SymbolicPath p2 =
+    unsafeMakeAbsolutePath (p1 </> p2)
+
 --------------------------------------------------------------------------------
 -- Abstract directory locations.
 
@@ -499,3 +526,8 @@ data Tmp
 --
 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 data Response
+
+-- | Abstract directory: directory for pkg-config files.
+--
+-- See Note [Symbolic paths] in Distribution.Utils.Path.
+data PkgConf

Cabal-tests/tests/UnitTests/Distribution/Utils/Structured.hs

@@ -34,4 +34,4 @@ md5CheckGenericPackageDescription proxy = md5Check proxy
 
 md5CheckLocalBuildInfo :: Proxy LocalBuildInfo -> Assertion
 md5CheckLocalBuildInfo proxy = md5Check proxy
-    0x2c8550e1552f68bf169fafbfcd8f845a
+    0x94827844fdb1afedee525061749fb16f

Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs

@@ -103,7 +103,7 @@ import Distribution.Simple
        (UserHooks (..), autoconfUserHooks, defaultMainWithHooks,
        simpleUserHooks)
 import Distribution.Simple.Compiler
-       (CompilerFlavor (GHC), CompilerId (..), PackageDB (..), compilerId)
+       (CompilerFlavor (GHC), CompilerId (..), PackageDB, PackageDBX (..), compilerId)
 import Distribution.Simple.LocalBuildInfo
        (ComponentLocalBuildInfo (componentPackageDeps), LocalBuildInfo,
        compiler, withExeLBI, withLibLBI, withPackageDB, withTestLBI
@@ -119,8 +119,6 @@ import Distribution.Simple.Utils
 import Distribution.Text
        (display)
 import Distribution.Verbosity
-import System.FilePath
-       ((</>))
 
 import qualified Data.Foldable    as F
                  (for_)
@@ -160,7 +158,9 @@ import Distribution.Package
 import Distribution.Utils.Path
        ( SymbolicPathX
        , makeSymbolicPath
-       , makeRelativePathEx )
+       , makeRelativePathEx
+       , interpretSymbolicPathCWD
+       , (</>))
 import qualified Distribution.Utils.Path as Cabal
        (getSymbolicPath)
 import Distribution.Simple.Utils
@@ -336,7 +336,7 @@ generateBuildModule testSuiteName flags pkg lbi = do
   let distPref = fromFlag (buildDistPref flags)
 
   -- Package DBs & environments
-  let dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ toFilePath distPref </> "package.conf.inplace" ]
+  let dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref </>  makeRelativePathEx "package.conf.inplace" ]
   let dbFlags = "-hide-all-packages" : packageDbArgs dbStack
   let envFlags
         | ghcCanBeToldToIgnorePkgEnvs = [ "-package-env=-" ]
@@ -539,7 +539,7 @@ generateBuildModule testSuiteName flags pkg lbi = do
                                            : concatMap specific dbs
       _ -> ierror
       where
-        specific (SpecificPackageDB db) = [ "-package-conf=" ++ db ]
+        specific (SpecificPackageDB db) = [ "-package-conf=" ++ interpretSymbolicPathCWD db ]
         specific _                      = ierror
         ierror = error $ "internal error: unexpected package db stack: "
                       ++ show dbstack
@@ -557,7 +557,7 @@ generateBuildModule testSuiteName flags pkg lbi = do
       dbs                                 -> "-clear-package-db"
                                            : concatMap single dbs
      where
-       single (SpecificPackageDB db) = [ "-package-db=" ++ db ]
+       single (SpecificPackageDB db) = [ "-package-db=" ++ interpretSymbolicPathCWD db ]
        single GlobalPackageDB        = [ "-global-package-db" ]
        single UserPackageDB          = [ "-user-package-db" ]
        isSpecific (SpecificPackageDB _) = True

Cabal/src/Distribution/PackageDescription/Check/Warning.hs

@@ -47,7 +47,7 @@ import Distribution.Types.PackageName (PackageName)
 import Distribution.Types.TestType (TestType, knownTestTypes)
 import Distribution.Types.UnqualComponentName
 import Distribution.Types.Version (Version)
-import Distribution.Utils.Path
+import Distribution.Utils.Path (FileOrDir (..), Pkg, RelativePath, getSymbolicPath)
 import Language.Haskell.Extension (Extension)
 
 import qualified Data.Either as Either

Cabal/src/Distribution/Simple.hs

@@ -550,7 +550,7 @@ cleanAction globalFlags hooks flags args = do
       flags' =
         flags{cleanCommonFlags = common'}
 
-      mbWorkDirFlag = cleanWorkingDir flags
+      mbWorkDirFlag = cleanWorkingDir flags'
       mbWorkDir = flagToMaybe mbWorkDirFlag
 
   pbi <- preClean hooks args flags'

Cabal/src/Distribution/Simple/Build.hs

@@ -275,7 +275,6 @@ dumpBuildInfo
   -- ^ Flags that the user passed to build
   -> IO ()
 dumpBuildInfo verbosity distPref dumpBuildInfoFlag pkg_descr lbi flags = do
-  let mbWorkDir = flagToMaybe $ buildWorkingDir flags
   when shouldDumpBuildInfo $ do
     -- Changing this line might break consumers of the dumped build info.
     -- Announce changes on mailing lists!
@@ -289,13 +288,12 @@ dumpBuildInfo verbosity distPref dumpBuildInfoFlag pkg_descr lbi flags = do
               activeTargets
           )
 
-    wdir <- absoluteWorkingDir mbWorkDir
-
     (compilerProg, _) <- case flavorToProgram (compilerFlavor (compiler lbi)) of
       Nothing ->
         dieWithException verbosity $ UnknownCompilerFlavor (compilerFlavor (compiler lbi))
       Just program -> requireProgram verbosity program (withPrograms lbi)
 
+    wdir <- absoluteWorkingDirLBI lbi
     let (warns, json) = mkBuildInfo wdir pkg_descr lbi flags (compilerProg, compiler lbi) activeTargets
         buildInfoText = renderJson json
     unless (null warns) $
@@ -791,7 +789,7 @@ testSuiteLibV09AsLibAndExe
   -> TestSuite
   -> ComponentLocalBuildInfo
   -> LocalBuildInfo
-  -> FilePath
+  -> AbsolutePath (Dir Pkg)
   -- ^ absolute inplace dir
   -> SymbolicPath Pkg (Dir Dist)
   -> ( PackageDescription
@@ -911,7 +909,7 @@ createInternalPackageDB verbosity lbi distPref = do
   existsAlready <- doesPackageDBExist dbPath
   when existsAlready $ deletePackageDB dbPath
   createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath
-  return (SpecificPackageDB dbPath)
+  return (SpecificPackageDB dbRelPath)
   where
     dbRelPath = internalPackageDBPath lbi distPref
     dbPath = interpretSymbolicPathLBI lbi dbRelPath

Cabal/src/Distribution/Simple/Compiler.hs

@@ -1,6 +1,9 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
 
 -----------------------------------------------------------------------------
 
@@ -35,11 +38,21 @@ module Distribution.Simple.Compiler
   , compilerInfo
 
     -- * Support for package databases
-  , PackageDB (..)
+  , PackageDB
   , PackageDBStack
+  , PackageDBCWD
+  , PackageDBStackCWD
+  , PackageDBX (..)
+  , PackageDBStackX
+  , PackageDBS
+  , PackageDBStackS
   , registrationPackageDB
   , absolutePackageDBPaths
   , absolutePackageDBPath
+  , interpretPackageDB
+  , interpretPackageDBStack
+  , coercePackageDB
+  , coercePackageDBStack
 
     -- * Support for optimisation levels
   , OptimisationLevel (..)
@@ -95,7 +108,6 @@ import Language.Haskell.Extension
 
 import qualified Data.Map as Map (lookup)
 import System.Directory (canonicalizePath)
-import System.FilePath (isRelative)
 
 data Compiler = Compiler
   { compilerId :: CompilerId
@@ -181,15 +193,17 @@ compilerInfo c =
 --  the file system. This can be used to build isolated environments of
 --  packages, for example to build a collection of related packages
 --  without installing them globally.
-data PackageDB
+--
+--  Abstracted over
+data PackageDBX fp
   = GlobalPackageDB
   | UserPackageDB
   | -- | NB: the path might be relative or it might be absolute
-    SpecificPackageDB FilePath
-  deriving (Eq, Generic, Ord, Show, Read, Typeable)
+    SpecificPackageDB fp
+  deriving (Eq, Generic, Ord, Show, Read, Typeable, Functor, Foldable, Traversable)
 
-instance Binary PackageDB
-instance Structured PackageDB
+instance Binary fp => Binary (PackageDBX fp)
+instance Structured fp => Structured (PackageDBX fp)
 
 -- | We typically get packages from several databases, and stack them
 -- together. This type lets us be explicit about that stacking. For example
@@ -206,11 +220,20 @@ instance Structured PackageDB
 -- we can use several custom package dbs and the user package db together.
 --
 -- When it comes to writing, the top most (last) package is used.
-type PackageDBStack = [PackageDB]
+type PackageDBStackX from = [PackageDBX from]
+
+type PackageDB = PackageDBX (SymbolicPath Pkg (Dir PkgDB))
+type PackageDBStack = PackageDBStackX (SymbolicPath Pkg (Dir PkgDB))
+
+type PackageDBS from = PackageDBX (SymbolicPath from (Dir PkgDB))
+type PackageDBStackS from = PackageDBStackX (SymbolicPath from (Dir PkgDB))
+
+type PackageDBCWD = PackageDBX FilePath
+type PackageDBStackCWD = PackageDBStackX FilePath
 
 -- | Return the package that we should register into. This is the package db at
 -- the top of the stack.
-registrationPackageDB :: PackageDBStack -> PackageDB
+registrationPackageDB :: PackageDBStackX from -> PackageDBX from
 registrationPackageDB dbs = case safeLast dbs of
   Nothing -> error "internal error: empty package db set"
   Just p -> p
@@ -230,10 +253,30 @@ absolutePackageDBPath _ GlobalPackageDB = return GlobalPackageDB
 absolutePackageDBPath _ UserPackageDB = return UserPackageDB
 absolutePackageDBPath mbWorkDir (SpecificPackageDB db) = do
   let db' =
-        if isRelative db
-          then interpretSymbolicPath mbWorkDir (makeRelativePathEx db)
-          else db
-  SpecificPackageDB <$> canonicalizePath db'
+        case symbolicPathRelative_maybe db of
+          Nothing -> getSymbolicPath db
+          Just rel_path -> interpretSymbolicPath mbWorkDir rel_path
+  SpecificPackageDB . makeSymbolicPath <$> canonicalizePath db'
+
+interpretPackageDB :: Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDB -> PackageDBCWD
+interpretPackageDB _ GlobalPackageDB = GlobalPackageDB
+interpretPackageDB _ UserPackageDB = UserPackageDB
+interpretPackageDB mbWorkDir (SpecificPackageDB db) =
+  SpecificPackageDB (interpretSymbolicPath mbWorkDir db)
+
+interpretPackageDBStack :: Maybe (SymbolicPath CWD (Dir Pkg)) -> PackageDBStack -> PackageDBStackCWD
+interpretPackageDBStack mbWorkDir = map (interpretPackageDB mbWorkDir)
+
+-- | Transform a package db using a FilePath into one using symbolic paths.
+coercePackageDB :: PackageDBCWD -> PackageDBX (SymbolicPath CWD (Dir PkgDB))
+coercePackageDB GlobalPackageDB = GlobalPackageDB
+coercePackageDB UserPackageDB = UserPackageDB
+coercePackageDB (SpecificPackageDB db) = SpecificPackageDB (makeSymbolicPath db)
+
+coercePackageDBStack
+  :: [PackageDBCWD]
+  -> [PackageDBX (SymbolicPath CWD (Dir PkgDB))]
+coercePackageDBStack = map coercePackageDB
 
 -- ------------------------------------------------------------