Make Cabal agnostic about working directory

This commit makes the library functions in Cabal agnostic of the working
directory. In practice, this means that we distinguish `FilePath`s
from un-interpreted `SymbolicPath`s. The latter may be paths that are
relative to the working directory, and need to be interpreted with
respect to a passed-in argument specifying the working directory,
instead of using the working directory of the current process.
See Note [Symbolic paths] in Distribution.Utils.Path.

In particular, paths in the package description now use the SymbolicPath
abstraction, which allows specifying whether they are allowed to be
absolute, and, if they are relative, what they are relative to.
For example, source files are relative to a source search directory,
data files are relative to the data directory, and doc files are
relative to the package root.

Fixes #9702

Author: sheaf

Cabal-described/src/Distribution/Described.hs

@@ -68,7 +68,7 @@ import Distribution.Utils.GrammarRegex
 -- Types
 import Distribution.Compat.Newtype
 import Distribution.Compiler                       (CompilerFlavor, CompilerId, knownCompilerFlavors)
-import Distribution.PackageDescription.FieldGrammar (CompatFilePath, CompatLicenseFile)
+import Distribution.PackageDescription.FieldGrammar (CompatLicenseFile, CompatDataDir)
 import Distribution.FieldGrammar.Newtypes
 import Distribution.ModuleName                     (ModuleName)
 import Distribution.System                         (Arch, OS, knownArches, knownOSs)
@@ -99,7 +99,7 @@ import Distribution.Types.SourceRepo               (RepoType)
 import Distribution.Types.TestType                 (TestType)
 import Distribution.Types.UnitId                   (UnitId)
 import Distribution.Types.UnqualComponentName      (UnqualComponentName)
-import Distribution.Utils.Path                     (LicenseFile, PackageDir, SourceDir, SymbolicPath)
+import Distribution.Utils.Path                     (SymbolicPath, RelativePath)
 import Distribution.Verbosity                      (Verbosity)
 import Distribution.Version                        (Version, VersionRange)
 import Language.Haskell.Extension                  (Extension, Language, knownLanguages)
@@ -578,17 +578,24 @@ instance Described SpecLicense where
 instance Described TestedWith where
     describe _ = RETodo
 
-instance Described FilePathNT where
+
+instance Described (SymbolicPath from to) where
+    describe _ = describe ([] :: [Token])
+
+instance Described (RelativePath from to) where
     describe _ = describe ([] :: [Token])
 
-instance Described (SymbolicPath PackageDir SourceDir) where
+instance Described (SymbolicPathNT from to) where
     describe _ = describe ([] :: [Token])
 
-instance Described (SymbolicPath PackageDir LicenseFile) where
+instance Described (RelativePathNT from to) where
     describe _ = describe ([] :: [Token])
 
 instance Described CompatLicenseFile where
     describe _ = describe ([] :: [Token])
 
-instance Described CompatFilePath where
-    describe _ = describe ([] :: [Token]) 
+instance Described CompatDataDir where
+    describe _ = describe ([] :: [Token])
+
+instance Described FilePathNT where
+    describe _ = describe ([] :: [Token])

Cabal-syntax/Cabal-syntax.cabal

@@ -45,7 +45,13 @@ library
     -- See also https://github.com/ekmett/transformers-compat/issues/35
     transformers (>= 0.3      && < 0.4) || (>=0.4.1.0 && <0.7)
 
-  ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates
+  ghc-options:
+    -Wall
+    -fno-ignore-asserts
+    -fwarn-tabs
+    -fwarn-incomplete-uni-patterns
+    -fwarn-incomplete-record-updates
+    -fno-warn-unticked-promoted-constructors
 
   if impl(ghc >= 8.0)
     ghc-options: -Wcompat -Wnoncanonical-monad-instances

Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs

@@ -1,6 +1,8 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -42,6 +44,8 @@ module Distribution.FieldGrammar.Newtypes
   , Token' (..)
   , MQuoted (..)
   , FilePathNT (..)
+  , SymbolicPathNT (..)
+  , RelativePathNT (..)
   ) where
 
 import Distribution.Compat.Newtype
@@ -53,6 +57,7 @@ import Distribution.Compiler (CompilerFlavor)
 import Distribution.License (License)
 import Distribution.Parsec
 import Distribution.Pretty
+import Distribution.Utils.Path
 import Distribution.Version
   ( LowerBound (..)
   , Version
@@ -277,6 +282,41 @@ instance Parsec FilePathNT where
 instance Pretty FilePathNT where
   pretty = showFilePath . unpack
 
+-- | Newtype for 'SymbolicPath', with a different 'Parsec' instance
+-- to disallow empty paths.
+newtype SymbolicPathNT from to = SymbolicPathNT {getSymbolicPathNT :: SymbolicPath from to}
+
+instance Newtype (SymbolicPath from to) (SymbolicPathNT from to)
+
+instance Parsec (SymbolicPathNT from to) where
+  parsec = do
+    token <- parsecToken
+    if null token
+      then P.unexpected "empty FilePath"
+      else return (SymbolicPathNT $ makeSymbolicPath token)
+
+instance Pretty (SymbolicPathNT from to) where
+  pretty = showFilePath . getSymbolicPath . getSymbolicPathNT
+
+-- | Newtype for 'RelativePath', with a different 'Parsec' instance
+-- to disallow empty paths but allow non-relative paths (which get rejected
+-- later with a different error message, see 'Distribution.PackageDescription.Check.Paths.checkPath')
+newtype RelativePathNT from to = RelativePathNT {getRelativePathNT :: RelativePath from to}
+
+instance Newtype (RelativePath from to) (RelativePathNT from to)
+
+-- NB: we don't reject non-relative paths here; we allow them here and reject
+-- later (see 'Distribution.PackageDescription.Check.Paths.checkPath').
+instance Parsec (RelativePathNT from to) where
+  parsec = do
+    token <- parsecToken
+    if null token
+      then P.unexpected "empty FilePath"
+      else return (RelativePathNT $ unsafeMakeSymbolicPath token)
+
+instance Pretty (RelativePathNT from to) where
+  pretty = showFilePath . getSymbolicPath . getRelativePathNT
+
 -------------------------------------------------------------------------------
 -- SpecVersion
 -------------------------------------------------------------------------------