Introduce AbsolutePath to symbolic path abstraction

There are a few places where paths are known to be absolute. This
enforces that in the type system by introducing a simple wrapper to
`Distribution.Utils.Path`.

```
newtype AbsolutePath (to :: FileOrDir) = AbsolutePath (forall from . SymbolicPath from to)
```

The nice thing about this abstraction is when when a path is unwrapped,
due to the universally quantified `from` type, the resulting
`SymbolicPath` can be used with any API which expects a path to point
`from` a specific directory.

Author: mpickering

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

@@ -35,10 +35,12 @@ module Distribution.Utils.Path
     -- * Symbolic paths
   , RelativePath
   , SymbolicPath
+  , AbsolutePath (..)
   , SymbolicPathX -- NB: constructor not exposed, to retain type safety.
 
     -- ** Symbolic path API
   , getSymbolicPath
+  , getAbsolutePath
   , sameDirectory
   , makeRelativePathEx
   , makeSymbolicPath
@@ -48,6 +50,7 @@ module Distribution.Utils.Path
   , relativeSymbolicPath
   , symbolicPathRelative_maybe
   , interpretSymbolicPath
+  , interpretSymbolicPathAbsolute
 
     -- ** General filepath API
   , (</>)
@@ -215,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)
@@ -320,6 +328,12 @@ interpretSymbolicPath mbWorkDir (SymbolicPath p) =
 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
@@ -343,9 +357,9 @@ 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 symbolic path relative.
 --
@@ -354,8 +368,8 @@ absoluteWorkingDir (Just wd) = Directory.makeAbsolute $ getSymbolicPath wd
 -- NB: this function may fail to make the path relative.
 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)
+  AbsolutePath wd <- absoluteWorkingDir mbWorkDir
+  return $ SymbolicPath (FilePath.makeRelative (getSymbolicPath wd) fp)
 
 -------------------------------------------------------------------------------
 
@@ -425,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.
 

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/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

Cabal/src/Distribution/Simple/LocalBuildInfo.hs

@@ -162,7 +162,7 @@ mbWorkDirLBI =
   flagToMaybe . setupWorkingDir . configCommonFlags . configFlags
 
 -- | Absolute path to the current working directory.
-absoluteWorkingDirLBI :: LocalBuildInfo -> IO FilePath
+absoluteWorkingDirLBI :: LocalBuildInfo -> IO (AbsolutePath (Dir Pkg))
 absoluteWorkingDirLBI lbi = absoluteWorkingDir (mbWorkDirLBI lbi)
 
 -- | Perform the action on each enabled 'library' in the package

Cabal/src/Distribution/Simple/PreProcess.hs

@@ -347,8 +347,8 @@ preprocessFile mbWorkDir searchLoc buildLoc forSDist baseFile verbosity builtinS
           createDirectoryIfMissingVerbose verbosity True destDir
           runPreProcessorWithHsBootHack
             pp
-            (i psrcLoc, getSymbolicPath $ psrcRelFile)
-            (i buildLoc, srcStem <.> "hs")
+            (getSymbolicPath $ psrcLoc, getSymbolicPath $ psrcRelFile)
+            (getSymbolicPath $ buildLoc, srcStem <.> "hs")
   where
     i = interpretSymbolicPath mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path
     buildAsSrcLoc :: SymbolicPath Pkg (Dir Source)

Cabal/src/Distribution/Simple/Register.hs

@@ -609,8 +609,7 @@ generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDi
 --
 -- This function knows about the layout of in place packages.
 inplaceInstalledPackageInfo
-  :: FilePath
-  -- ^ top of the build tree (absolute path)
+  :: AbsolutePath (Dir Pkg)
   -> SymbolicPath Pkg (Dir Dist)
   -- ^ location of the dist tree
   -> PackageDescription
@@ -629,7 +628,7 @@ inplaceInstalledPackageInfo inplaceDir distPref pkg abi_hash lib lbi clbi =
     clbi
     installDirs
   where
-    i = interpretSymbolicPath (Just $ makeSymbolicPath inplaceDir) -- See Note [Symbolic paths] in Distribution.Utils.Path
+    i = interpretSymbolicPathAbsolute inplaceDir -- See Note [Symbolic paths] in Distribution.Utils.Path
     adjustRelativeIncludeDirs = concatMap $ \d ->
       [ i $ makeRelativePathEx d -- local include-dir
       , i $ libTargetDir </> makeRelativePathEx d -- autogen include-dir

Cabal/src/Distribution/Simple/ShowBuildInfo.hs

@@ -91,7 +91,7 @@ import Distribution.Verbosity
 -- | Construct a JSON document describing the build information for a
 -- package.
 mkBuildInfo
-  :: FilePath
+  :: AbsolutePath (Dir Pkg)
   -- ^ The source directory of the package
   -> PackageDescription
   -- ^ Mostly information from the .cabal file
@@ -139,7 +139,7 @@ mkCompilerInfo compilerProgram compilerInfo =
     , "path" .= JsonString (programPath compilerProgram)
     ]
 
-mkComponentInfo :: FilePath -> PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> ([String], Json)
+mkComponentInfo :: AbsolutePath (Dir Pkg) -> PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> ([String], Json)
 mkComponentInfo wdir pkg_descr lbi clbi =
   ( warnings
   , JsonObject $
@@ -150,7 +150,7 @@ mkComponentInfo wdir pkg_descr lbi clbi =
       , "modules" .= JsonArray (map (JsonString . display) modules)
       , "src-files" .= JsonArray (map (JsonString . getSymbolicPath) sourceFiles)
       , "hs-src-dirs" .= JsonArray (map (JsonString . prettyShow) $ hsSourceDirs bi)
-      , "src-dir" .= JsonString (addTrailingPathSeparator wdir)
+      , "src-dir" .= JsonString (addTrailingPathSeparator (getAbsolutePath wdir))
       ]
         <> cabalFile
   )