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

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE DeriveDataTypeable #-}
   3 {-# LANGUAGE DeriveGeneric #-}
   4 {-# LANGUAGE FlexibleInstances #-}
   5 {-# LANGUAGE FunctionalDependencies #-}
   6 {-# LANGUAGE RankNTypes #-}
   7 {-# LANGUAGE RoleAnnotations #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9 {-# LANGUAGE TypeOperators #-}
  10 {-# LANGUAGE UndecidableInstances #-}
  11
  12 module Distribution.Utils.Path
  13   ( -- * Symbolic path endpoints
  14     FileOrDir (..)
  15   , AllowAbsolute (..)
  16
  17     -- ** Abstract directory locations
  18   , CWD
  19   , Pkg
  20   , Dist
  21   , Source
  22   , Include
  23   , Lib
  24   , Framework
  25   , Build
  26   , Artifacts
  27   , PkgDB
  28   , DataDir
  29   , Mix
  30   , Tix
  31   , Tmp
  32   , Response
  33   , PkgConf
  34
  35     -- * Symbolic paths
  36   , RelativePath
  37   , SymbolicPath
  38   , AbsolutePath (..)
  39   , SymbolicPathX -- NB: constructor not exposed, to retain type safety.
  40
  41     -- ** Symbolic path API
  42   , getSymbolicPath
  43   , getAbsolutePath
  44   , sameDirectory
  45   , makeRelativePathEx
  46   , makeSymbolicPath
  47   , unsafeMakeSymbolicPath
  48   , coerceSymbolicPath
  49   , unsafeCoerceSymbolicPath
  50   , relativeSymbolicPath
  51   , symbolicPathRelative_maybe
  52   , interpretSymbolicPath
  53   , interpretSymbolicPathAbsolute
  54
  55     -- ** General filepath API
  56   , (</>)
  57   , (<.>)
  58   , takeDirectorySymbolicPath
  59   , dropExtensionsSymbolicPath
  60   , replaceExtensionSymbolicPath
  61   , normaliseSymbolicPath
  62
  63     -- ** Working directory handling
  64   , interpretSymbolicPathCWD
  65   , absoluteWorkingDir
  66   , tryMakeRelative
  67
  68     -- ** Module names
  69   , moduleNameSymbolicPath
  70   ) where
  71
  72 import Distribution.Compat.Prelude
  73 import Prelude ()
  74
  75 import Data.Coerce
  76
  77 import Distribution.ModuleName (ModuleName)
  78 import qualified Distribution.ModuleName as ModuleName
  79   ( toFilePath
  80   )
  81 import Distribution.Parsec
  82 import Distribution.Pretty
  83 import Distribution.Utils.Generic (isAbsoluteOnAnyPlatform)
  84
  85 import qualified Distribution.Compat.CharParsing as P
  86
  87 import qualified System.Directory as Directory
  88 import qualified System.FilePath as FilePath
  89
  90 import Data.Kind
  91   ( Type
  92   )
  93 import GHC.Stack
  94   ( HasCallStack
  95   )
  96
  97 -------------------------------------------------------------------------------
  98
  99 -- * SymbolicPath
 100
 101 -------------------------------------------------------------------------------
 102
 103 {- Note [Symbolic paths]
 104 ~~~~~~~~~~~~~~~~~~~~~~~~
 105 We want functions within the Cabal library to support getting the working
 106 directory from their arguments, rather than retrieving it from the current
 107 directory, which depends on the the state of the current process
 108 (via getCurrentDirectory).
 109
 110 With such a constraint, to ensure correctness we need to know, for each relative
 111 filepath, whether it is relative to the passed in working directory or to the
 112 current working directory. We achieve this with the following API:
 113
 114   - newtype SymbolicPath from to
 115   - getSymbolicPath :: SymbolicPath from to -> FilePath
 116   - interpretSymbolicPath
 117       :: Maybe (SymbolicPath CWD (Dir from)) -> SymbolicPath from to -> FilePath
 118
 119 Note that, in the type @SymbolicPath from to@, @from@ is the name of a directory,
 120 whereas @to@ is either @Dir toDir@ or @File@. For example, a source directory
 121 typically has the type @SymbolicPath Pkg (Dir Source)@, while a source
 122 file has a type such as @SymbolicPath "Source" File@.
 123
 124 Here, a symbolic path refers to an **uninterpreted** file path, i.e. any
 125 passed in working directory **has not** been taken into account.
 126 Whenever we see a symbolic path, it is a sign we must take into account this
 127 working directory in some way.
 128 Thus, whenever we interact with the file system, we do the following:
 129
 130   - in a direct interaction (e.g. `doesFileExist`), we interpret the
 131     path relative to a working directory argument, e.g.
 132
 133       doCheck :: Maybe (SymbolicPath CWD (Dir from))
 134               -> SymbolicPath from File
 135               -> Bool
 136       doCheck mbWorkDir file = doesFileExist $ interpretSymbolicPath mbWorkDir file
 137
 138   - when invoking a sub-process (such as GHC), we ensure that the working directory
 139     of the sub-process is the same as the passed-in working directory, in which
 140     case we interpret the symbolic paths by using `interpretSymbolicPathCWD`:
 141
 142       callGhc :: Maybe (SymbolicPath CWD (Dir Pkg))
 143               -> SymbolicPath (Dir Pkg) File
 144               -> IO ()
 145       callGhc mbWorkDir inputFile =
 146         runProgramInvocation $
 147           programInvocationCwd mbWorkDir ghcProg [interpretSymbolicPathCWD inputFile]
 148
 149 In practice, we often use:
 150
 151   -- Interpret a symbolic path with respect to the working directory argument
 152   -- @'mbWorkDir' :: Maybe (SymbolicPath CWD (Dir Pkg))@.
 153   i :: SymbolicPath Pkg to -> FilePath
 154   i = interpretSymbolicPath mbWorkDir
 155
 156   -- Interpret a symbolic path, provided that the current working directory
 157   -- is the package directory.
 158   u :: SymbolicPath Pkg to -> FilePath
 159   u = interpretSymbolicPathCWD
 160
 161 Note [Symbolic relative paths]
 162 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 163 This module defines:
 164
 165   data kind AllowAbsolute = AllowAbsolute | OnlyRelative
 166   data kind FileOrDir = File | Dir Symbol
 167
 168   type SymbolicPathX :: AllowAbsolute -> Symbol -> FileOrDir -> Type
 169   newtype SymbolicPathX allowAbsolute from to = SymbolicPath FilePath
 170
 171   type RelativePath = SymbolicPathX 'OnlyRelative
 172   type SymbolicPath = SymbolicPathX 'AllowAbsolute
 173
 174 A 'SymbolicPath' is thus a symbolic path that is allowed to be absolute, whereas
 175 a 'RelativePath' is a symbolic path that is additionally required to be relative.
 176
 177 This distinction allows us to keep track of which filepaths must be kept
 178 relative.
 179 -}
 180
 181 -- | A type-level symbolic name, to an abstract file or directory
 182 -- (e.g. the Cabal package directory).
 183 data FileOrDir
 184   = -- | A file (with no further information).
 185     File
 186   | -- | The abstract name of a directory or category of directories,
 187     -- e.g. the package directory or a source directory.
 188     Dir Type
 189
 190 -- | Is this symbolic path allowed to be absolute, or must it be relative?
 191 data AllowAbsolute
 192   = -- | The path may be absolute, or it may be relative.
 193     AllowAbsolute
 194   | -- | The path must be relative.
 195     OnlyRelative
 196
 197 -- | A symbolic path, possibly relative to an abstract location specified
 198 -- by the @from@ type parameter.
 199 --
 200 -- They are *symbolic*, which means we cannot perform any 'IO'
 201 -- until we interpret them (using e.g. 'interpretSymbolicPath').
 202 newtype SymbolicPathX (allowAbsolute :: AllowAbsolute) (from :: Type) (to :: FileOrDir)
 203   = SymbolicPath FilePath
 204   deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
 205
 206 type role SymbolicPathX nominal nominal nominal
 207
 208 -- | A symbolic relative path, relative to an abstract location specified
 209 -- by the @from@ type parameter.
 210 --
 211 -- They are *symbolic*, which means we cannot perform any 'IO'
 212 -- until we interpret them (using e.g. 'interpretSymbolicPath').
 213 type RelativePath = SymbolicPathX 'OnlyRelative
 214
 215 -- | A symbolic path which is allowed to be absolute.
 216 --
 217 -- They are *symbolic*, which means we cannot perform any 'IO'
 218 -- until we interpret them (using e.g. 'interpretSymbolicPath').
 219 type SymbolicPath = SymbolicPathX 'AllowAbsolute
 220
 221 newtype AbsolutePath (to :: FileOrDir) = AbsolutePath (forall from. SymbolicPath from to)
 222
 223 unsafeMakeAbsolutePath :: FilePath -> AbsolutePath to
 224 unsafeMakeAbsolutePath fp = AbsolutePath (makeSymbolicPath fp)
 225
 226 instance Binary (SymbolicPathX allowAbsolute from to)
 227 instance
 228   (Typeable allowAbsolute, Typeable from, Typeable to)
 229   => Structured (SymbolicPathX allowAbsolute from to)
 230 instance NFData (SymbolicPathX allowAbsolute from to) where rnf = genericRnf
 231
 232 -- | Extract the 'FilePath' underlying a 'SymbolicPath' or 'RelativePath',
 233 -- without interpreting it.
 234 --
 235 -- Use this function e.g. to validate the underlying filepath.
 236 --
 237 -- When interacting with the file system, you should instead use
 238 -- 'interpretSymbolicPath' or 'interpretSymbolicPathCWD'.
 239 --
 240 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 241 getSymbolicPath :: SymbolicPathX allowAbsolute from to -> FilePath
 242 getSymbolicPath (SymbolicPath p) = p
 243
 244 -- | A symbolic path from a directory to itself.
 245 sameDirectory :: SymbolicPathX allowAbsolute from (Dir to)
 246 sameDirectory = SymbolicPath "."
 247
 248 -- | Make a 'RelativePath', ensuring the path is not absolute,
 249 -- but performing no further checks.
 250 makeRelativePathEx :: HasCallStack => FilePath -> RelativePath from to
 251 makeRelativePathEx fp
 252   | isAbsoluteOnAnyPlatform fp =
 253       error $ "Cabal internal error: makeRelativePathEx: absolute path " ++ fp
 254   | otherwise =
 255       SymbolicPath fp
 256
 257 -- | Make a 'SymbolicPath', which may be relative or absolute.
 258 makeSymbolicPath :: FilePath -> SymbolicPath from to
 259 makeSymbolicPath fp = SymbolicPath fp
 260
 261 -- | Make a 'SymbolicPath' which may be relative or absolute,
 262 -- without performing any checks.
 263 --
 264 -- Avoid using this function in new code.
 265 unsafeMakeSymbolicPath :: FilePath -> SymbolicPathX allowAbs from to
 266 unsafeMakeSymbolicPath fp = SymbolicPath fp
 267
 268 -- | Like 'System.FilePath.takeDirectory', for symbolic paths.
 269 takeDirectorySymbolicPath :: SymbolicPathX allowAbsolute from File -> SymbolicPathX allowAbsolute from (Dir to')
 270 takeDirectorySymbolicPath (SymbolicPath fp) = SymbolicPath (FilePath.takeDirectory fp)
 271
 272 -- | Like 'System.FilePath.dropExtensions', for symbolic paths.
 273 dropExtensionsSymbolicPath :: SymbolicPathX allowAbsolute from File -> SymbolicPathX allowAbsolute from File
 274 dropExtensionsSymbolicPath (SymbolicPath fp) = SymbolicPath (FilePath.dropExtensions fp)
 275
 276 -- | Like 'System.FilePath.replaceExtension', for symbolic paths.
 277 replaceExtensionSymbolicPath :: SymbolicPathX allowAbsolute from File -> String -> SymbolicPathX allowAbsolute from File
 278 replaceExtensionSymbolicPath (SymbolicPath fp) ext = SymbolicPath (FilePath.replaceExtension fp ext)
 279
 280 -- | Like 'System.FilePath.normalise', for symbolic paths.
 281 normaliseSymbolicPath :: SymbolicPathX allowAbsolute from to -> SymbolicPathX allowAbsolute from to
 282 normaliseSymbolicPath (SymbolicPath fp) = SymbolicPath (FilePath.normalise fp)
 283
 284 -- | Retrieve the relative symbolic path to a Haskell module.
 285 moduleNameSymbolicPath :: ModuleName -> SymbolicPathX allowAbsolute Source File
 286 moduleNameSymbolicPath modNm = SymbolicPath $ ModuleName.toFilePath modNm
 287
 288 -- | Interpret a symbolic path with respect to the given directory.
 289 --
 290 -- Use this function before directly interacting with the file system in order
 291 -- to take into account a working directory argument.
 292 --
 293 -- NB: when invoking external programs (such as @GHC@), it is preferable to set
 294 -- the working directory of the process and use 'interpretSymbolicPathCWD'
 295 -- rather than calling this function, as this function will turn relative paths
 296 -- into absolute paths if the working directory is an absolute path.
 297 -- This can degrade error messages, or worse, break the behaviour entirely
 298 -- (because the program might expect certain paths to be relative).
 299 --
 300 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 301 interpretSymbolicPath :: Maybe (SymbolicPath CWD (Dir from)) -> SymbolicPathX allowAbsolute from to -> FilePath
 302 interpretSymbolicPath mbWorkDir (SymbolicPath p) =
 303   -- Note that this properly handles an absolute symbolic path,
 304   -- because if @q@ is absolute, then @p </> q = q@.
 305   maybe p ((</> p) . getSymbolicPath) mbWorkDir
 306
 307 -- | Interpret a symbolic path, **under the assumption that the working
 308 -- directory is the package directory**.
 309 --
 310 -- Use 'interpretSymbolicPath' instead if you need to take into account a
 311 -- working directory argument before directly interacting with the file system.
 312 --
 313 -- Use this function instead of 'interpretSymbolicPath' when invoking a child
 314 -- process: set the working directory of the sub-process, and use this function,
 315 -- e.g.:
 316 --
 317 -- > callGhc :: Maybe (SymbolicPath CWD (Dir Pkg))
 318 -- >         -> SymbolicPath (Dir Pkg) File
 319 -- >         -> IO ()
 320 -- > callGhc mbWorkDir inputFile =
 321 -- >   runProgramInvocation $
 322 -- >     programInvocationCwd mbWorkDir ghcProg [interpretSymbolicPathCWD inputFile]
 323 --
 324 -- In this example, 'programInvocationCwd' sets the working directory, so it is
 325 -- appropriate to use 'interpretSymbolicPathCWD' to provide its arguments.
 326 --
 327 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 328 interpretSymbolicPathCWD :: SymbolicPathX allowAbsolute from to -> FilePath
 329 interpretSymbolicPathCWD (SymbolicPath p) = p
 330
 331 getAbsolutePath :: AbsolutePath to -> FilePath
 332 getAbsolutePath (AbsolutePath p) = getSymbolicPath p
 333
 334 interpretSymbolicPathAbsolute :: AbsolutePath (Dir Pkg) -> SymbolicPathX allowAbsolute Pkg to -> FilePath
 335 interpretSymbolicPathAbsolute (AbsolutePath p) sym = interpretSymbolicPath (Just p) sym
 336
 337 -- | Change what a symbolic path is pointing to.
 338 coerceSymbolicPath :: SymbolicPathX allowAbsolute from to1 -> SymbolicPathX allowAbsolute from to2
 339 coerceSymbolicPath = coerce
 340
 341 -- | Change both what a symbolic path is pointing from and pointing to.
 342 --
 343 -- Avoid using this in new code.
 344 unsafeCoerceSymbolicPath :: SymbolicPathX allowAbsolute from1 to1 -> SymbolicPathX allowAbsolute from2 to2
 345 unsafeCoerceSymbolicPath = coerce
 346
 347 -- | Weakening: convert a relative symbolic path to a symbolic path,
 348 -- \"forgetting\" that it is relative.
 349 relativeSymbolicPath :: RelativePath from to -> SymbolicPath from to
 350 relativeSymbolicPath (SymbolicPath fp) = SymbolicPath fp
 351
 352 -- | Is this symbolic path a relative symbolic path?
 353 symbolicPathRelative_maybe :: SymbolicPath from to -> Maybe (RelativePath from to)
 354 symbolicPathRelative_maybe (SymbolicPath fp) =
 355   if isAbsoluteOnAnyPlatform fp
 356     then Nothing
 357     else Just $ SymbolicPath fp
 358
 359 -- | Absolute path to the current working directory.
 360 absoluteWorkingDir :: Maybe (SymbolicPath CWD to) -> IO (AbsolutePath to)
 361 absoluteWorkingDir Nothing = unsafeMakeAbsolutePath <$> Directory.getCurrentDirectory
 362 absoluteWorkingDir (Just wd) = unsafeMakeAbsolutePath <$> Directory.makeAbsolute (getSymbolicPath wd)
 363
 364 -- | Try to make a symbolic path relative.
 365 --
 366 -- This function does nothing if the path is already relative.
 367 --
 368 -- NB: this function may fail to make the path relative.
 369 tryMakeRelative :: Maybe (SymbolicPath CWD (Dir dir)) -> SymbolicPath dir to -> IO (SymbolicPath dir to)
 370 tryMakeRelative mbWorkDir (SymbolicPath fp) = do
 371   AbsolutePath wd <- absoluteWorkingDir mbWorkDir
 372   return $ SymbolicPath (FilePath.makeRelative (getSymbolicPath wd) fp)
 373
 374 -------------------------------------------------------------------------------
 375
 376 -- ** Parsing and pretty printing
 377
 378 -------------------------------------------------------------------------------
 379
 380 instance Parsec (SymbolicPathX 'OnlyRelative from to) where
 381   parsec = do
 382     token <- parsecToken
 383     if null token
 384       then P.unexpected "empty FilePath"
 385       else
 386         if isAbsoluteOnAnyPlatform token
 387           then P.unexpected "absolute FilePath"
 388           else return (SymbolicPath token)
 389
 390 instance Parsec (SymbolicPathX 'AllowAbsolute from to) where
 391   parsec = do
 392     token <- parsecToken
 393     if null token
 394       then P.unexpected "empty FilePath"
 395       else return (SymbolicPath token)
 396
 397 instance Pretty (SymbolicPathX allowAbsolute from to) where
 398   pretty = showFilePath . getSymbolicPath
 399
 400 -------------------------------------------------------------------------------
 401
 402 -- * Composition
 403
 404 -------------------------------------------------------------------------------
 405
 406 infixr 7 <.>
 407
 408 -- | Types that support 'System.FilePath.<.>'.
 409 class FileLike p where
 410   -- | Like 'System.FilePath.<.>', but also supporting symbolic paths.
 411   (<.>) :: p -> String -> p
 412
 413 instance FileLike FilePath where
 414   (<.>) = (FilePath.<.>)
 415
 416 instance p ~ File => FileLike (SymbolicPathX allowAbsolute dir p) where
 417   SymbolicPath p <.> ext = SymbolicPath (p <.> ext)
 418
 419 infixr 5 </>
 420
 421 -- | Types that support 'System.FilePath.</>'.
 422 class PathLike p q r | q r -> p, p r -> q, p q -> r where
 423   -- | Like 'System.FilePath.</>', but also supporting symbolic paths.
 424   (</>) :: p -> q -> r
 425
 426 instance PathLike FilePath FilePath FilePath where
 427   (</>) = (FilePath.</>)
 428
 429 -- | This instance ensures we don't accidentally discard a symbolic path
 430 -- in a 'System.FilePath.</>' operation due to the second path being absolute.
 431 --
 432 -- (Recall that @a </> b = b@ whenever @b@ is absolute.)
 433 instance
 434   (b1 ~ 'Dir b2, a3 ~ a1, c2 ~ c3, midAbsolute ~ OnlyRelative)
 435   => PathLike
 436       (SymbolicPathX allowAbsolute a1 b1)
 437       (SymbolicPathX midAbsolute b2 c2)
 438       (SymbolicPathX allowAbsolute a3 c3)
 439   where
 440   SymbolicPath p1 </> SymbolicPath p2 = SymbolicPath (p1 </> p2)
 441
 442 instance
 443   (b1 ~ 'Dir b2, c2 ~ c3, midAbsolute ~ OnlyRelative)
 444   => PathLike
 445       (AbsolutePath b1)
 446       (SymbolicPathX midAbsolute b2 c2)
 447       (AbsolutePath c3)
 448   where
 449   AbsolutePath (SymbolicPath p1) </> SymbolicPath p2 =
 450     unsafeMakeAbsolutePath (p1 </> p2)
 451
 452 --------------------------------------------------------------------------------
 453 -- Abstract directory locations.
 454
 455 -- | Abstract directory: current working directory.
 456 --
 457 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 458 data CWD
 459
 460 -- | Abstract directory: package directory (e.g. a directory containing the @.cabal@ file).
 461 --
 462 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 463 data Pkg
 464
 465 -- | Abstract directory: dist directory (e.g. @dist-newstyle@).
 466 --
 467 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 468 data Dist
 469
 470 -- | Abstract directory: source directory (a search directory for source files).
 471 --
 472 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 473 data Source
 474
 475 -- | Abstract directory: include directory (a search directory for CPP includes like header files, e.g. with @ghc -I@).
 476 --
 477 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 478 data Include
 479
 480 -- | Abstract directory: search directory for extra libraries.
 481 --
 482 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 483 data Lib
 484
 485 -- | Abstract directory: MacOS framework directory.
 486 --
 487 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 488 data Framework
 489
 490 -- | Abstract directory: build directory.
 491 --
 492 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 493 data Build
 494
 495 -- | Abstract directory: directory for build artifacts, such as documentation or @.hie@ files.
 496 --
 497 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 498 data Artifacts
 499
 500 -- | Abstract directory: package database directory.
 501 --
 502 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 503 data PkgDB
 504
 505 -- | Abstract directory: data files directory.
 506 --
 507 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 508 data DataDir
 509
 510 -- | Abstract directory: directory for HPC @.mix@ files.
 511 --
 512 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 513 data Mix
 514
 515 -- | Abstract directory: directory for HPC @.tix@ files.
 516 --
 517 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 518 data Tix
 519
 520 -- | Abstract directory: a temporary directory.
 521 --
 522 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 523 data Tmp
 524
 525 -- | Abstract directory: directory for response files.
 526 --
 527 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 528 data Response
 529
 530 -- | Abstract directory: directory for pkg-config files.
 531 --
 532 -- See Note [Symbolic paths] in Distribution.Utils.Path.
 533 data PkgConf