Cabal/src/Distribution/Simple/InstallDirs.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE DeriveDataTypeable #-}
   3 {-# LANGUAGE DeriveFunctor #-}
   4 {-# LANGUAGE DeriveGeneric #-}
   5 {-# LANGUAGE FlexibleContexts #-}
   6 {-# LANGUAGE RankNTypes #-}
   7
   8 -----------------------------------------------------------------------------
   9
  10 -- |
  11 -- Module      :  Distribution.Simple.InstallDirs
  12 -- Copyright   :  Isaac Jones 2003-2004
  13 -- License     :  BSD3
  14 --
  15 -- Maintainer  :  cabal-devel@haskell.org
  16 -- Portability :  portable
  17 --
  18 -- This manages everything to do with where files get installed (though does
  19 -- not get involved with actually doing any installation). It provides an
  20 -- 'InstallDirs' type which is a set of directories for where to install
  21 -- things. It also handles the fact that we use templates in these install
  22 -- dirs. For example most install dirs are relative to some @$prefix@ and by
  23 -- changing the prefix all other dirs still end up changed appropriately. So it
  24 -- provides a 'PathTemplate' type and functions for substituting for these
  25 -- templates.
  26 module Distribution.Simple.InstallDirs
  27   ( InstallDirs (..)
  28   , InstallDirTemplates
  29   , defaultInstallDirs
  30   , defaultInstallDirs'
  31   , combineInstallDirs
  32   , absoluteInstallDirs
  33   , CopyDest (..)
  34   , prefixRelativeInstallDirs
  35   , substituteInstallDirTemplates
  36   , PathTemplate
  37   , PathTemplateVariable (..)
  38   , PathTemplateEnv
  39   , toPathTemplate
  40   , fromPathTemplate
  41   , combinePathTemplate
  42   , substPathTemplate
  43   , initialPathTemplateEnv
  44   , platformTemplateEnv
  45   , compilerTemplateEnv
  46   , packageTemplateEnv
  47   , abiTemplateEnv
  48   , installDirsTemplateEnv
  49   ) where
  50
  51 import Distribution.Compat.Prelude
  52 import Prelude ()
  53
  54 import Distribution.Compat.Environment (lookupEnv)
  55 import Distribution.Compiler
  56 import Distribution.Package
  57 import Distribution.Pretty
  58 import Distribution.Simple.InstallDirs.Internal
  59 import Distribution.System
  60
  61 import System.Directory (getAppUserDataDirectory)
  62 import System.FilePath
  63   ( dropDrive
  64   , isPathSeparator
  65   , pathSeparator
  66   , takeDirectory
  67   , (</>)
  68   )
  69
  70 #ifdef mingw32_HOST_OS
  71 import qualified Prelude
  72 import Foreign
  73 import Foreign.C
  74 #endif
  75
  76 -- ---------------------------------------------------------------------------
  77 -- Installation directories
  78
  79 -- | The directories where we will install files for packages.
  80 --
  81 -- We have several different directories for different types of files since
  82 -- many systems have conventions whereby different types of files in a package
  83 -- are installed in different directories. This is particularly the case on
  84 -- Unix style systems.
  85 data InstallDirs dir = InstallDirs
  86   { prefix :: dir
  87   , bindir :: dir
  88   , libdir :: dir
  89   , libsubdir :: dir
  90   , dynlibdir :: dir
  91   , flibdir :: dir
  92   -- ^ foreign libraries
  93   , libexecdir :: dir
  94   , libexecsubdir :: dir
  95   , includedir :: dir
  96   , datadir :: dir
  97   , datasubdir :: dir
  98   , docdir :: dir
  99   , mandir :: dir
 100   , htmldir :: dir
 101   , haddockdir :: dir
 102   , sysconfdir :: dir
 103   }
 104   deriving (Eq, Read, Show, Functor, Generic, Typeable)
 105
 106 instance Binary dir => Binary (InstallDirs dir)
 107 instance Structured dir => Structured (InstallDirs dir)
 108
 109 instance (Semigroup dir, Monoid dir) => Monoid (InstallDirs dir) where
 110   mempty = gmempty
 111   mappend = (<>)
 112
 113 instance Semigroup dir => Semigroup (InstallDirs dir) where
 114   (<>) = gmappend
 115
 116 combineInstallDirs
 117   :: (a -> b -> c)
 118   -> InstallDirs a
 119   -> InstallDirs b
 120   -> InstallDirs c
 121 combineInstallDirs combine a b =
 122   InstallDirs
 123     { prefix = prefix a `combine` prefix b
 124     , bindir = bindir a `combine` bindir b
 125     , libdir = libdir a `combine` libdir b
 126     , libsubdir = libsubdir a `combine` libsubdir b
 127     , dynlibdir = dynlibdir a `combine` dynlibdir b
 128     , flibdir = flibdir a `combine` flibdir b
 129     , libexecdir = libexecdir a `combine` libexecdir b
 130     , libexecsubdir = libexecsubdir a `combine` libexecsubdir b
 131     , includedir = includedir a `combine` includedir b
 132     , datadir = datadir a `combine` datadir b
 133     , datasubdir = datasubdir a `combine` datasubdir b
 134     , docdir = docdir a `combine` docdir b
 135     , mandir = mandir a `combine` mandir b
 136     , htmldir = htmldir a `combine` htmldir b
 137     , haddockdir = haddockdir a `combine` haddockdir b
 138     , sysconfdir = sysconfdir a `combine` sysconfdir b
 139     }
 140
 141 appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a
 142 appendSubdirs append dirs =
 143   dirs
 144     { libdir = libdir dirs `append` libsubdir dirs
 145     , libexecdir = libexecdir dirs `append` libexecsubdir dirs
 146     , datadir = datadir dirs `append` datasubdir dirs
 147     , libsubdir = error "internal error InstallDirs.libsubdir"
 148     , libexecsubdir = error "internal error InstallDirs.libexecsubdir"
 149     , datasubdir = error "internal error InstallDirs.datasubdir"
 150     }
 151
 152 -- | The installation directories in terms of 'PathTemplate's that contain
 153 -- variables.
 154 --
 155 -- The defaults for most of the directories are relative to each other, in
 156 -- particular they are all relative to a single prefix. This makes it
 157 -- convenient for the user to override the default installation directory
 158 -- by only having to specify --prefix=... rather than overriding each
 159 -- individually. This is done by allowing $-style variables in the dirs.
 160 -- These are expanded by textual substitution (see 'substPathTemplate').
 161 --
 162 -- A few of these installation directories are split into two components, the
 163 -- dir and subdir. The full installation path is formed by combining the two
 164 -- together with @\/@. The reason for this is compatibility with other Unix
 165 -- build systems which also support @--libdir@ and @--datadir@. We would like
 166 -- users to be able to configure @--libdir=\/usr\/lib64@ for example but
 167 -- because by default we want to support installing multiple versions of
 168 -- packages and building the same package for multiple compilers we append the
 169 -- libsubdir to get: @\/usr\/lib64\/$libname\/$compiler@.
 170 --
 171 -- An additional complication is the need to support relocatable packages on
 172 -- systems which support such things, like Windows.
 173 type InstallDirTemplates = InstallDirs PathTemplate
 174
 175 -- ---------------------------------------------------------------------------
 176 -- Default installation directories
 177
 178 defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
 179 defaultInstallDirs = defaultInstallDirs' False
 180
 181 defaultInstallDirs'
 182   :: Bool {- use external internal deps -}
 183   -> CompilerFlavor
 184   -> Bool
 185   -> Bool
 186   -> IO InstallDirTemplates
 187 defaultInstallDirs' True comp userInstall hasLibs = do
 188   dflt <- defaultInstallDirs' False comp userInstall hasLibs
 189   -- Be a bit more hermetic about per-component installs
 190   return
 191     dflt
 192       { datasubdir = toPathTemplate $ "$abi" </> "$libname"
 193       , docdir = toPathTemplate $ "$datadir" </> "doc" </> "$abi" </> "$libname"
 194       }
 195 defaultInstallDirs' False comp userInstall _hasLibs = do
 196   installPrefix <-
 197     if userInstall
 198       then do
 199         mDir <- lookupEnv "CABAL_DIR"
 200         case mDir of
 201           Nothing -> getAppUserDataDirectory "cabal"
 202           Just dir -> return dir
 203       else case buildOS of
 204         Windows -> do
 205           windowsProgramFilesDir <- getWindowsProgramFilesDir
 206           return (windowsProgramFilesDir </> "Haskell")
 207         Haiku -> return "/boot/system/non-packaged"
 208         _ -> return "/usr/local"
 209   installLibDir <-
 210     case buildOS of
 211       Windows -> return "$prefix"
 212       _ -> return ("$prefix" </> "lib")
 213   return $
 214     fmap toPathTemplate $
 215       InstallDirs
 216         { prefix = installPrefix
 217         , bindir = "$prefix" </> "bin"
 218         , libdir = installLibDir
 219         , libsubdir = case comp of
 220             UHC -> "$pkgid"
 221             _other -> "$abi" </> "$libname"
 222         , dynlibdir =
 223             "$libdir" </> case comp of
 224               UHC -> "$pkgid"
 225               _other -> "$abi"
 226         , libexecsubdir = "$abi" </> "$pkgid"
 227         , flibdir = "$libdir"
 228         , libexecdir = case buildOS of
 229             Windows -> "$prefix" </> "$libname"
 230             Haiku -> "$libdir"
 231             _other -> "$prefix" </> "libexec"
 232         , includedir = case buildOS of
 233             Haiku -> "$prefix" </> "develop" </> "headers"
 234             _other -> "$libdir" </> "$libsubdir" </> "include"
 235         , datadir = case buildOS of
 236             Windows -> "$prefix"
 237             Haiku -> "$prefix" </> "data"
 238             _other -> "$prefix" </> "share"
 239         , datasubdir = "$abi" </> "$pkgid"
 240         , docdir = case buildOS of
 241             Haiku -> "$prefix" </> "documentation"
 242             _other -> "$datadir" </> "doc" </> "$abi" </> "$pkgid"
 243         , mandir = case buildOS of
 244             Haiku -> "$docdir" </> "man"
 245             _other -> "$datadir" </> "man"
 246         , htmldir = "$docdir" </> "html"
 247         , haddockdir = "$htmldir"
 248         , sysconfdir = case buildOS of
 249             Haiku -> "boot" </> "system" </> "settings"
 250             _other -> "$prefix" </> "etc"
 251         }
 252
 253 -- ---------------------------------------------------------------------------
 254 -- Converting directories, absolute or prefix-relative
 255
 256 -- | Substitute the install dir templates into each other.
 257 --
 258 -- To prevent cyclic substitutions, only some variables are allowed in
 259 -- particular dir templates. If out of scope vars are present, they are not
 260 -- substituted for. Checking for any remaining unsubstituted vars can be done
 261 -- as a subsequent operation.
 262 --
 263 -- The reason it is done this way is so that in 'prefixRelativeInstallDirs' we
 264 -- can replace 'prefix' with the 'PrefixVar' and get resulting
 265 -- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it
 266 -- each to check which paths are relative to the $prefix.
 267 substituteInstallDirTemplates
 268   :: PathTemplateEnv
 269   -> InstallDirTemplates
 270   -> InstallDirTemplates
 271 substituteInstallDirTemplates env dirs = dirs'
 272   where
 273     dirs' =
 274       InstallDirs
 275         { -- So this specifies exactly which vars are allowed in each template
 276           prefix = subst prefix []
 277         , bindir = subst bindir [prefixVar]
 278         , libdir = subst libdir [prefixVar, bindirVar]
 279         , libsubdir = subst libsubdir []
 280         , dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar]
 281         , flibdir = subst flibdir [prefixVar, bindirVar, libdirVar]
 282         , libexecdir = subst libexecdir prefixBinLibVars
 283         , libexecsubdir = subst libexecsubdir []
 284         , includedir = subst includedir prefixBinLibVars
 285         , datadir = subst datadir prefixBinLibVars
 286         , datasubdir = subst datasubdir []
 287         , docdir = subst docdir prefixBinLibDataVars
 288         , mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar])
 289         , htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar])
 290         , haddockdir =
 291             subst
 292               haddockdir
 293               ( prefixBinLibDataVars
 294                   ++ [docdirVar, htmldirVar]
 295               )
 296         , sysconfdir = subst sysconfdir prefixBinLibVars
 297         }
 298     subst dir env' = substPathTemplate (env' ++ env) (dir dirs)
 299
 300     prefixVar = (PrefixVar, prefix dirs')
 301     bindirVar = (BindirVar, bindir dirs')
 302     libdirVar = (LibdirVar, libdir dirs')
 303     libsubdirVar = (LibsubdirVar, libsubdir dirs')
 304     datadirVar = (DatadirVar, datadir dirs')
 305     datasubdirVar = (DatasubdirVar, datasubdir dirs')
 306     docdirVar = (DocdirVar, docdir dirs')
 307     htmldirVar = (HtmldirVar, htmldir dirs')
 308     prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar]
 309     prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar]
 310
 311 -- | Convert from abstract install directories to actual absolute ones by
 312 -- substituting for all the variables in the abstract paths, to get real
 313 -- absolute path.
 314 absoluteInstallDirs
 315   :: PackageIdentifier
 316   -> UnitId
 317   -> CompilerInfo
 318   -> CopyDest
 319   -> Platform
 320   -> InstallDirs PathTemplate
 321   -> InstallDirs FilePath
 322 absoluteInstallDirs pkgId libname compilerId copydest platform dirs =
 323   ( case copydest of
 324       CopyTo destdir -> fmap ((destdir </>) . dropDrive)
 325       CopyToDb dbdir -> fmap (substPrefix "${pkgroot}" (takeDirectory dbdir))
 326       _ -> id
 327   )
 328     . appendSubdirs (</>)
 329     . fmap fromPathTemplate
 330     $ substituteInstallDirTemplates env dirs
 331   where
 332     env = initialPathTemplateEnv pkgId libname compilerId platform
 333     substPrefix pre root path
 334       | pre `isPrefixOf` path = root ++ drop (length pre) path
 335       | otherwise = path
 336
 337 -- | The location prefix for the /copy/ command.
 338 data CopyDest
 339   = NoCopyDest
 340   | CopyTo FilePath
 341   | -- | when using the ${pkgroot} as prefix. The CopyToDb will
 342     --   adjust the paths to be relative to the provided package
 343     --   database when copying / installing.
 344     CopyToDb FilePath
 345   deriving (Eq, Show, Generic)
 346
 347 instance Binary CopyDest
 348
 349 -- | Check which of the paths are relative to the installation $prefix.
 350 --
 351 -- If any of the paths are not relative, ie they are absolute paths, then it
 352 -- prevents us from making a relocatable package (also known as a \"prefix
 353 -- independent\" package).
 354 prefixRelativeInstallDirs
 355   :: PackageIdentifier
 356   -> UnitId
 357   -> CompilerInfo
 358   -> Platform
 359   -> InstallDirTemplates
 360   -> InstallDirs (Maybe FilePath)
 361 prefixRelativeInstallDirs pkgId libname compilerId platform dirs =
 362   fmap relative
 363     . appendSubdirs combinePathTemplate
 364     $ substituteInstallDirTemplates -- substitute the path template into each other, except that we map
 365     -- \$prefix back to $prefix. We're trying to end up with templates that
 366     -- mention no vars except $prefix.
 367       env
 368       dirs
 369         { prefix = PathTemplate [Variable PrefixVar]
 370         }
 371   where
 372     env = initialPathTemplateEnv pkgId libname compilerId platform
 373
 374     -- If it starts with $prefix then it's relative and produce the relative
 375     -- path by stripping off $prefix/ or $prefix
 376     relative dir = case dir of
 377       PathTemplate cs -> fmap (fromPathTemplate . PathTemplate) (relative' cs)
 378     relative' (Variable PrefixVar : Ordinary (s : rest) : rest')
 379       | isPathSeparator s = Just (Ordinary rest : rest')
 380     relative' (Variable PrefixVar : rest) = Just rest
 381     relative' _ = Nothing
 382
 383 -- ---------------------------------------------------------------------------
 384 -- Path templates
 385
 386 -- | An abstract path, possibly containing variables that need to be
 387 -- substituted for to get a real 'FilePath'.
 388 newtype PathTemplate = PathTemplate [PathComponent]
 389   deriving (Eq, Ord, Generic, Typeable)
 390
 391 instance Binary PathTemplate
 392 instance Structured PathTemplate
 393
 394 type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)]
 395
 396 -- | Convert a 'FilePath' to a 'PathTemplate' including any template vars.
 397 toPathTemplate :: FilePath -> PathTemplate
 398 toPathTemplate fp =
 399   PathTemplate
 400     . fromMaybe (error $ "panic! toPathTemplate " ++ show fp)
 401     . readMaybe -- TODO: eradicateNoParse
 402     $ fp
 403
 404 -- | Convert back to a path, any remaining vars are included
 405 fromPathTemplate :: PathTemplate -> FilePath
 406 fromPathTemplate (PathTemplate template) = show template
 407
 408 combinePathTemplate :: PathTemplate -> PathTemplate -> PathTemplate
 409 combinePathTemplate (PathTemplate t1) (PathTemplate t2) =
 410   PathTemplate (t1 ++ [Ordinary [pathSeparator]] ++ t2)
 411
 412 substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate
 413 substPathTemplate environment (PathTemplate template) =
 414   PathTemplate (concatMap subst template)
 415   where
 416     subst component@(Ordinary _) = [component]
 417     subst component@(Variable variable) =
 418       case lookup variable environment of
 419         Just (PathTemplate components) -> components
 420         Nothing -> [component]
 421
 422 -- | The initial environment has all the static stuff but no paths
 423 initialPathTemplateEnv
 424   :: PackageIdentifier
 425   -> UnitId
 426   -> CompilerInfo
 427   -> Platform
 428   -> PathTemplateEnv
 429 initialPathTemplateEnv pkgId libname compiler platform =
 430   packageTemplateEnv pkgId libname
 431     ++ compilerTemplateEnv compiler
 432     ++ platformTemplateEnv platform
 433     ++ abiTemplateEnv compiler platform
 434
 435 packageTemplateEnv :: PackageIdentifier -> UnitId -> PathTemplateEnv
 436 packageTemplateEnv pkgId uid =
 437   [ (PkgNameVar, PathTemplate [Ordinary $ prettyShow (packageName pkgId)])
 438   , (PkgVerVar, PathTemplate [Ordinary $ prettyShow (packageVersion pkgId)])
 439   , -- Invariant: uid is actually a HashedUnitId.  Hard to enforce because
 440     -- it's an API change.
 441     (LibNameVar, PathTemplate [Ordinary $ prettyShow uid])
 442   , (PkgIdVar, PathTemplate [Ordinary $ prettyShow pkgId])
 443   ]
 444
 445 compilerTemplateEnv :: CompilerInfo -> PathTemplateEnv
 446 compilerTemplateEnv compiler =
 447   [ (CompilerVar, PathTemplate [Ordinary $ prettyShow (compilerInfoId compiler)])
 448   ]
 449
 450 platformTemplateEnv :: Platform -> PathTemplateEnv
 451 platformTemplateEnv (Platform arch os) =
 452   [ (OSVar, PathTemplate [Ordinary $ prettyShow os])
 453   , (ArchVar, PathTemplate [Ordinary $ prettyShow arch])
 454   ]
 455
 456 abiTemplateEnv :: CompilerInfo -> Platform -> PathTemplateEnv
 457 abiTemplateEnv compiler (Platform arch os) =
 458   [
 459     ( AbiVar
 460     , PathTemplate
 461         [ Ordinary $
 462             prettyShow arch
 463               ++ '-'
 464               : prettyShow os
 465               ++ '-'
 466               : prettyShow (compilerInfoId compiler)
 467               ++ case compilerInfoAbiTag compiler of
 468                 NoAbiTag -> ""
 469                 AbiTag tag -> '-' : tag
 470         ]
 471     )
 472   , (AbiTagVar, PathTemplate [Ordinary $ abiTagString (compilerInfoAbiTag compiler)])
 473   ]
 474
 475 installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv
 476 installDirsTemplateEnv dirs =
 477   [ (PrefixVar, prefix dirs)
 478   , (BindirVar, bindir dirs)
 479   , (LibdirVar, libdir dirs)
 480   , (LibsubdirVar, libsubdir dirs)
 481   , (DynlibdirVar, dynlibdir dirs)
 482   , (DatadirVar, datadir dirs)
 483   , (DatasubdirVar, datasubdir dirs)
 484   , (DocdirVar, docdir dirs)
 485   , (HtmldirVar, htmldir dirs)
 486   ]
 487
 488 -- ---------------------------------------------------------------------------
 489 -- Parsing and showing path templates:
 490
 491 -- The textual format is that of an ordinary Haskell String, eg
 492 -- "$prefix/bin"
 493 -- and this gets parsed to the internal representation as a sequence of path
 494 -- spans which are either strings or variables, eg:
 495 -- PathTemplate [Variable PrefixVar, Ordinary "/bin" ]
 496
 497 instance Show PathTemplate where
 498   show (PathTemplate template) = show (show template)
 499
 500 instance Read PathTemplate where
 501   readsPrec p s =
 502     [ (PathTemplate template, s')
 503     | (path, s') <- readsPrec p s
 504     , (template, "") <- reads path
 505     ]
 506
 507 -- ---------------------------------------------------------------------------
 508 -- Internal utilities
 509
 510 {- FOURMOLU_DISABLE -}
 511 getWindowsProgramFilesDir :: IO FilePath
 512 getWindowsProgramFilesDir = do
 513 #ifdef mingw32_HOST_OS
 514   m <- shGetFolderPath csidl_PROGRAM_FILES
 515 #else
 516   let m = Nothing
 517 #endif
 518   return (fromMaybe "C:\\Program Files" m)
 519 {- FOURMOLU_ENABLE -}
 520
 521 #ifdef mingw32_HOST_OS
 522 shGetFolderPath :: CInt -> IO (Maybe FilePath)
 523 shGetFolderPath n =
 524   allocaArray long_path_size $ \pPath -> do
 525      r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath
 526      if (r /= 0)
 527         then return Nothing
 528         else do s <- peekCWString pPath; return (Just s)
 529   where
 530     long_path_size      = 1024 -- MAX_PATH is 260, this should be plenty
 531
 532 csidl_PROGRAM_FILES :: CInt
 533 csidl_PROGRAM_FILES = 0x0026
 534 -- csidl_PROGRAM_FILES_COMMON :: CInt
 535 -- csidl_PROGRAM_FILES_COMMON = 0x002b
 536
 537 {- FOURMOLU_DISABLE -}
 538 #ifdef x86_64_HOST_ARCH
 539 #define CALLCONV ccall
 540 #else
 541 #define CALLCONV stdcall
 542 #endif
 543
 544 foreign import CALLCONV unsafe "shlobj.h SHGetFolderPathW"
 545             c_SHGetFolderPath :: Ptr ()
 546                               -> CInt
 547                               -> Ptr ()
 548                               -> CInt
 549                               -> CWString
 550                               -> Prelude.IO CInt
 551 #endif
 552 {- FOURMOLU_ENABLE -}