Replace FilePath in PackageDB with SymbolicPath in Cabal

This refactoring enforces a simple property

* We use symbolic paths in Cabal in order to represent that paths to
  package databases. These paths is relative to the package root.
* We use normal filepaths in cabal-install to represent the path to a
  package database. These are relative to the current working directory.

Paths are explicitly converted from one type to the other at the
interface of `cabal-install` and `Cabal`, see `setupHsConfigureArgs` for
where this happens.

In order to achieve this `PackageDB` is abstracted over what the type of
filepaths a specific package db points to.

```
type PackageDBX fp = ... | SpecificPackageDB fp | ...
```

If you are using the Cabal library then you probably want to migrate to
use `PackageDBCWD` and `PackageDBStackCWD`.

```
type PackageDBCWD = PackageDBX FilePath
type PackageDBStackCWD = [PackageDBCWD]
```

Then at the point where you call commands in the `Cabal` library convert
these paths into paths relative to the root of the relevant package.
The easiest way to do this is convert any paths into an absolute path.

This patch fixes a double interpretation issue when the `--working-dir`
option was used and package db paths were offset incorrectly.

Author: mpickering

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

@@ -60,7 +60,7 @@ module Distribution.Utils.Path
     -- ** Working directory handling
   , interpretSymbolicPathCWD
   , absoluteWorkingDir
-  , tryMakeRelativeToWorkingDir
+  , tryMakeRelative
 
     -- ** Module names
   , moduleNameSymbolicPath
@@ -290,7 +290,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@.
@@ -317,7 +317,7 @@ 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
 
 -- | Change what a symbolic path is pointing to.
@@ -347,11 +347,13 @@ absoluteWorkingDir :: Maybe (SymbolicPath CWD to) -> IO FilePath
 absoluteWorkingDir Nothing = Directory.getCurrentDirectory
 absoluteWorkingDir (Just wd) = 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
+tryMakeRelative :: Maybe (SymbolicPath CWD (Dir dir)) -> SymbolicPath dir to -> IO (SymbolicPath dir to)
+tryMakeRelative mbWorkDir (SymbolicPath fp) = do
   wd <- absoluteWorkingDir mbWorkDir
   return $ SymbolicPath (FilePath.makeRelative wd fp)
 

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/Simple/Build.hs

@@ -911,7 +911,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
 
 -- ------------------------------------------------------------
 

Cabal/src/Distribution/Simple/Configure.hs

@@ -2036,8 +2036,8 @@ reportFailedDependencies verbosity failed =
 getInstalledPackages
   :: Verbosity
   -> Compiler
-  -> Maybe (SymbolicPath CWD (Dir Pkg))
-  -> PackageDBStack
+  -> Maybe (SymbolicPath CWD (Dir from))
+  -> PackageDBStackX (SymbolicPath from (Dir PkgDB))
   -- ^ The stack of package databases.
   -> ProgramDb
   -> IO InstalledPackageIndex
@@ -2051,14 +2051,14 @@ getInstalledPackages verbosity comp mbWorkDir packageDBs progdb = do
   case compilerFlavor comp of
     GHC -> GHC.getInstalledPackages verbosity comp mbWorkDir packageDBs' progdb
     GHCJS -> GHCJS.getInstalledPackages verbosity mbWorkDir packageDBs' progdb
-    UHC -> UHC.getInstalledPackages verbosity comp packageDBs' progdb
+    UHC -> UHC.getInstalledPackages verbosity comp mbWorkDir packageDBs' progdb
     HaskellSuite{} ->
       HaskellSuite.getInstalledPackages verbosity packageDBs' progdb
     flv ->
       dieWithException verbosity $ HowToFindInstalledPackages flv
   where
     packageDBExists (SpecificPackageDB path0) = do
-      let path = interpretSymbolicPath mbWorkDir $ makeSymbolicPath path0
+      let path = interpretSymbolicPath mbWorkDir path0
       exists <- doesPathExist path
       unless exists $
         warn verbosity $
@@ -2096,8 +2096,8 @@ getPackageDBContents verbosity comp mbWorkDir packageDB progdb = do
 getInstalledPackagesMonitorFiles
   :: Verbosity
   -> Compiler
-  -> Maybe (SymbolicPath CWD ('Dir Pkg))
-  -> PackageDBStack
+  -> Maybe (SymbolicPath CWD ('Dir from))
+  -> PackageDBStackS from
   -> ProgramDb
   -> Platform
   -> IO [FilePath]
@@ -2144,7 +2144,7 @@ getInstalledPackagesById verbosity lbi@LocalBuildInfo{compiler = comp, withPacka
 -- @--global@, @--user@ and @--package-db=global|user|clear|$file@.
 -- This function combines the global/user flag and interprets the package-db
 -- flag into a single package db stack.
-interpretPackageDbFlags :: Bool -> [Maybe PackageDB] -> PackageDBStack
+interpretPackageDbFlags :: Bool -> [Maybe (PackageDBX fp)] -> PackageDBStackX fp
 interpretPackageDbFlags userInstall specificDBs =
   extra initialStack specificDBs
   where