{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Simple.InstallDirs -- Copyright : Isaac Jones 2003-2004 -- License : BSD3 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- This manages everything to do with where files get installed (though does -- not get involved with actually doing any installation). It provides an -- 'InstallDirs' type which is a set of directories for where to install -- things. It also handles the fact that we use templates in these install -- dirs. For example most install dirs are relative to some @$prefix@ and by -- changing the prefix all other dirs still end up changed appropriately. So it -- provides a 'PathTemplate' type and functions for substituting for these -- templates. module Distribution.Simple.InstallDirs ( InstallDirs(..), InstallDirTemplates, defaultInstallDirs, defaultInstallDirs', combineInstallDirs, absoluteInstallDirs, CopyDest(..), prefixRelativeInstallDirs, substituteInstallDirTemplates, PathTemplate, PathTemplateVariable(..), PathTemplateEnv, toPathTemplate, fromPathTemplate, combinePathTemplate, substPathTemplate, initialPathTemplateEnv, platformTemplateEnv, compilerTemplateEnv, packageTemplateEnv, abiTemplateEnv, installDirsTemplateEnv, ) where import Prelude () import Distribution.Compat.Prelude import Distribution.Compat.Environment (lookupEnv) import Distribution.Pretty import Distribution.Package import Distribution.System import Distribution.Compiler import Distribution.Simple.InstallDirs.Internal import System.Directory (getAppUserDataDirectory) import System.FilePath ( (), isPathSeparator , pathSeparator, dropDrive , takeDirectory ) #ifdef mingw32_HOST_OS import qualified Prelude import Foreign import Foreign.C #endif -- --------------------------------------------------------------------------- -- Installation directories -- | The directories where we will install files for packages. -- -- We have several different directories for different types of files since -- many systems have conventions whereby different types of files in a package -- are installed in different directories. This is particularly the case on -- Unix style systems. -- data InstallDirs dir = InstallDirs { prefix :: dir, bindir :: dir, libdir :: dir, libsubdir :: dir, dynlibdir :: dir, flibdir :: dir, -- ^ foreign libraries libexecdir :: dir, libexecsubdir:: dir, includedir :: dir, datadir :: dir, datasubdir :: dir, docdir :: dir, mandir :: dir, htmldir :: dir, haddockdir :: dir, sysconfdir :: dir } deriving (Eq, Read, Show, Functor, Generic, Typeable) instance Binary dir => Binary (InstallDirs dir) instance Structured dir => Structured (InstallDirs dir) instance (Semigroup dir, Monoid dir) => Monoid (InstallDirs dir) where mempty = gmempty mappend = (<>) instance Semigroup dir => Semigroup (InstallDirs dir) where (<>) = gmappend combineInstallDirs :: (a -> b -> c) -> InstallDirs a -> InstallDirs b -> InstallDirs c combineInstallDirs combine a b = InstallDirs { prefix = prefix a `combine` prefix b, bindir = bindir a `combine` bindir b, libdir = libdir a `combine` libdir b, libsubdir = libsubdir a `combine` libsubdir b, dynlibdir = dynlibdir a `combine` dynlibdir b, flibdir = flibdir a `combine` flibdir b, libexecdir = libexecdir a `combine` libexecdir b, libexecsubdir= libexecsubdir a `combine` libexecsubdir b, includedir = includedir a `combine` includedir b, datadir = datadir a `combine` datadir b, datasubdir = datasubdir a `combine` datasubdir b, docdir = docdir a `combine` docdir b, mandir = mandir a `combine` mandir b, htmldir = htmldir a `combine` htmldir b, haddockdir = haddockdir a `combine` haddockdir b, sysconfdir = sysconfdir a `combine` sysconfdir b } appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a appendSubdirs append dirs = dirs { libdir = libdir dirs `append` libsubdir dirs, libexecdir = libexecdir dirs `append` libexecsubdir dirs, datadir = datadir dirs `append` datasubdir dirs, libsubdir = error "internal error InstallDirs.libsubdir", libexecsubdir = error "internal error InstallDirs.libexecsubdir", datasubdir = error "internal error InstallDirs.datasubdir" } -- | The installation directories in terms of 'PathTemplate's that contain -- variables. -- -- The defaults for most of the directories are relative to each other, in -- particular they are all relative to a single prefix. This makes it -- convenient for the user to override the default installation directory -- by only having to specify --prefix=... rather than overriding each -- individually. This is done by allowing $-style variables in the dirs. -- These are expanded by textual substitution (see 'substPathTemplate'). -- -- A few of these installation directories are split into two components, the -- dir and subdir. The full installation path is formed by combining the two -- together with @\/@. The reason for this is compatibility with other Unix -- build systems which also support @--libdir@ and @--datadir@. We would like -- users to be able to configure @--libdir=\/usr\/lib64@ for example but -- because by default we want to support installing multiple versions of -- packages and building the same package for multiple compilers we append the -- libsubdir to get: @\/usr\/lib64\/$libname\/$compiler@. -- -- An additional complication is the need to support relocatable packages on -- systems which support such things, like Windows. -- type InstallDirTemplates = InstallDirs PathTemplate -- --------------------------------------------------------------------------- -- Default installation directories defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates defaultInstallDirs = defaultInstallDirs' False defaultInstallDirs' :: Bool {- use external internal deps -} -> CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates defaultInstallDirs' True comp userInstall hasLibs = do dflt <- defaultInstallDirs' False comp userInstall hasLibs -- Be a bit more hermetic about per-component installs return dflt { datasubdir = toPathTemplate $ "$abi" "$libname", docdir = toPathTemplate $ "$datadir" "doc" "$abi" "$libname" } defaultInstallDirs' False comp userInstall _hasLibs = do installPrefix <- if userInstall then do mDir <- lookupEnv "CABAL_DIR" case mDir of Nothing -> getAppUserDataDirectory "cabal" Just dir -> return dir else case buildOS of Windows -> do windowsProgramFilesDir <- getWindowsProgramFilesDir return (windowsProgramFilesDir "Haskell") _ -> return "/usr/local" installLibDir <- case buildOS of Windows -> return "$prefix" _ -> return ("$prefix" "lib") return $ fmap toPathTemplate $ InstallDirs { prefix = installPrefix, bindir = "$prefix" "bin", libdir = installLibDir, libsubdir = case comp of UHC -> "$pkgid" _other -> "$abi" "$libname", dynlibdir = "$libdir" case comp of UHC -> "$pkgid" _other -> "$abi", libexecsubdir= "$abi" "$pkgid", flibdir = "$libdir", libexecdir = case buildOS of Windows -> "$prefix" "$libname" _other -> "$prefix" "libexec", includedir = "$libdir" "$libsubdir" "include", datadir = case buildOS of Windows -> "$prefix" _other -> "$prefix" "share", datasubdir = "$abi" "$pkgid", docdir = "$datadir" "doc" "$abi" "$pkgid", mandir = "$datadir" "man", htmldir = "$docdir" "html", haddockdir = "$htmldir", sysconfdir = "$prefix" "etc" } -- --------------------------------------------------------------------------- -- Converting directories, absolute or prefix-relative -- | Substitute the install dir templates into each other. -- -- To prevent cyclic substitutions, only some variables are allowed in -- particular dir templates. If out of scope vars are present, they are not -- substituted for. Checking for any remaining unsubstituted vars can be done -- as a subsequent operation. -- -- The reason it is done this way is so that in 'prefixRelativeInstallDirs' we -- can replace 'prefix' with the 'PrefixVar' and get resulting -- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it -- each to check which paths are relative to the $prefix. -- substituteInstallDirTemplates :: PathTemplateEnv -> InstallDirTemplates -> InstallDirTemplates substituteInstallDirTemplates env dirs = dirs' where dirs' = InstallDirs { -- So this specifies exactly which vars are allowed in each template prefix = subst prefix [], bindir = subst bindir [prefixVar], libdir = subst libdir [prefixVar, bindirVar], libsubdir = subst libsubdir [], dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar], flibdir = subst flibdir [prefixVar, bindirVar, libdirVar], libexecdir = subst libexecdir prefixBinLibVars, libexecsubdir = subst libexecsubdir [], includedir = subst includedir prefixBinLibVars, datadir = subst datadir prefixBinLibVars, datasubdir = subst datasubdir [], docdir = subst docdir prefixBinLibDataVars, mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar]), htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]), haddockdir = subst haddockdir (prefixBinLibDataVars ++ [docdirVar, htmldirVar]), sysconfdir = subst sysconfdir prefixBinLibVars } subst dir env' = substPathTemplate (env'++env) (dir dirs) prefixVar = (PrefixVar, prefix dirs') bindirVar = (BindirVar, bindir dirs') libdirVar = (LibdirVar, libdir dirs') libsubdirVar = (LibsubdirVar, libsubdir dirs') datadirVar = (DatadirVar, datadir dirs') datasubdirVar = (DatasubdirVar, datasubdir dirs') docdirVar = (DocdirVar, docdir dirs') htmldirVar = (HtmldirVar, htmldir dirs') prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar] prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar] -- | Convert from abstract install directories to actual absolute ones by -- substituting for all the variables in the abstract paths, to get real -- absolute path. absoluteInstallDirs :: PackageIdentifier -> UnitId -> CompilerInfo -> CopyDest -> Platform -> InstallDirs PathTemplate -> InstallDirs FilePath absoluteInstallDirs pkgId libname compilerId copydest platform dirs = (case copydest of CopyTo destdir -> fmap ((destdir ) . dropDrive) CopyToDb dbdir -> fmap (substPrefix "${pkgroot}" (takeDirectory dbdir)) _ -> id) . appendSubdirs () . fmap fromPathTemplate $ substituteInstallDirTemplates env dirs where env = initialPathTemplateEnv pkgId libname compilerId platform substPrefix pre root path | pre `isPrefixOf` path = root ++ drop (length pre) path | otherwise = path -- |The location prefix for the /copy/ command. data CopyDest = NoCopyDest | CopyTo FilePath | CopyToDb FilePath -- ^ when using the ${pkgroot} as prefix. The CopyToDb will -- adjust the paths to be relative to the provided package -- database when copying / installing. deriving (Eq, Show, Generic) instance Binary CopyDest -- | Check which of the paths are relative to the installation $prefix. -- -- If any of the paths are not relative, ie they are absolute paths, then it -- prevents us from making a relocatable package (also known as a \"prefix -- independent\" package). -- prefixRelativeInstallDirs :: PackageIdentifier -> UnitId -> CompilerInfo -> Platform -> InstallDirTemplates -> InstallDirs (Maybe FilePath) prefixRelativeInstallDirs pkgId libname compilerId platform dirs = fmap relative . appendSubdirs combinePathTemplate $ -- substitute the path template into each other, except that we map -- \$prefix back to $prefix. We're trying to end up with templates that -- mention no vars except $prefix. substituteInstallDirTemplates env dirs { prefix = PathTemplate [Variable PrefixVar] } where env = initialPathTemplateEnv pkgId libname compilerId platform -- If it starts with $prefix then it's relative and produce the relative -- path by stripping off $prefix/ or $prefix relative dir = case dir of PathTemplate cs -> fmap (fromPathTemplate . PathTemplate) (relative' cs) relative' (Variable PrefixVar : Ordinary (s:rest) : rest') | isPathSeparator s = Just (Ordinary rest : rest') relative' (Variable PrefixVar : rest) = Just rest relative' _ = Nothing -- --------------------------------------------------------------------------- -- Path templates -- | An abstract path, possibly containing variables that need to be -- substituted for to get a real 'FilePath'. -- newtype PathTemplate = PathTemplate [PathComponent] deriving (Eq, Ord, Generic, Typeable) instance Binary PathTemplate instance Structured PathTemplate type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)] -- | Convert a 'FilePath' to a 'PathTemplate' including any template vars. -- toPathTemplate :: FilePath -> PathTemplate toPathTemplate fp = PathTemplate . fromMaybe (error $ "panic! toPathTemplate " ++ show fp) . readMaybe -- TODO: eradicateNoParse $ fp -- | Convert back to a path, any remaining vars are included -- fromPathTemplate :: PathTemplate -> FilePath fromPathTemplate (PathTemplate template) = show template combinePathTemplate :: PathTemplate -> PathTemplate -> PathTemplate combinePathTemplate (PathTemplate t1) (PathTemplate t2) = PathTemplate (t1 ++ [Ordinary [pathSeparator]] ++ t2) substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate substPathTemplate environment (PathTemplate template) = PathTemplate (concatMap subst template) where subst component@(Ordinary _) = [component] subst component@(Variable variable) = case lookup variable environment of Just (PathTemplate components) -> components Nothing -> [component] -- | The initial environment has all the static stuff but no paths initialPathTemplateEnv :: PackageIdentifier -> UnitId -> CompilerInfo -> Platform -> PathTemplateEnv initialPathTemplateEnv pkgId libname compiler platform = packageTemplateEnv pkgId libname ++ compilerTemplateEnv compiler ++ platformTemplateEnv platform ++ abiTemplateEnv compiler platform packageTemplateEnv :: PackageIdentifier -> UnitId -> PathTemplateEnv packageTemplateEnv pkgId uid = [(PkgNameVar, PathTemplate [Ordinary $ prettyShow (packageName pkgId)]) ,(PkgVerVar, PathTemplate [Ordinary $ prettyShow (packageVersion pkgId)]) -- Invariant: uid is actually a HashedUnitId. Hard to enforce because -- it's an API change. ,(LibNameVar, PathTemplate [Ordinary $ prettyShow uid]) ,(PkgIdVar, PathTemplate [Ordinary $ prettyShow pkgId]) ] compilerTemplateEnv :: CompilerInfo -> PathTemplateEnv compilerTemplateEnv compiler = [(CompilerVar, PathTemplate [Ordinary $ prettyShow (compilerInfoId compiler)]) ] platformTemplateEnv :: Platform -> PathTemplateEnv platformTemplateEnv (Platform arch os) = [(OSVar, PathTemplate [Ordinary $ prettyShow os]) ,(ArchVar, PathTemplate [Ordinary $ prettyShow arch]) ] abiTemplateEnv :: CompilerInfo -> Platform -> PathTemplateEnv abiTemplateEnv compiler (Platform arch os) = [(AbiVar, PathTemplate [Ordinary $ prettyShow arch ++ '-':prettyShow os ++ '-':prettyShow (compilerInfoId compiler) ++ case compilerInfoAbiTag compiler of NoAbiTag -> "" AbiTag tag -> '-':tag]) ,(AbiTagVar, PathTemplate [Ordinary $ abiTagString (compilerInfoAbiTag compiler)]) ] installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv installDirsTemplateEnv dirs = [(PrefixVar, prefix dirs) ,(BindirVar, bindir dirs) ,(LibdirVar, libdir dirs) ,(LibsubdirVar, libsubdir dirs) ,(DynlibdirVar, dynlibdir dirs) ,(DatadirVar, datadir dirs) ,(DatasubdirVar, datasubdir dirs) ,(DocdirVar, docdir dirs) ,(HtmldirVar, htmldir dirs) ] -- --------------------------------------------------------------------------- -- Parsing and showing path templates: -- The textual format is that of an ordinary Haskell String, eg -- "$prefix/bin" -- and this gets parsed to the internal representation as a sequence of path -- spans which are either strings or variables, eg: -- PathTemplate [Variable PrefixVar, Ordinary "/bin" ] instance Show PathTemplate where show (PathTemplate template) = show (show template) instance Read PathTemplate where readsPrec p s = [ (PathTemplate template, s') | (path, s') <- readsPrec p s , (template, "") <- reads path ] -- --------------------------------------------------------------------------- -- Internal utilities getWindowsProgramFilesDir :: IO FilePath getWindowsProgramFilesDir = do #ifdef mingw32_HOST_OS m <- shGetFolderPath csidl_PROGRAM_FILES #else let m = Nothing #endif return (fromMaybe "C:\\Program Files" m) #ifdef mingw32_HOST_OS shGetFolderPath :: CInt -> IO (Maybe FilePath) shGetFolderPath n = allocaArray long_path_size $ \pPath -> do r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath if (r /= 0) then return Nothing else do s <- peekCWString pPath; return (Just s) where long_path_size = 1024 -- MAX_PATH is 260, this should be plenty csidl_PROGRAM_FILES :: CInt csidl_PROGRAM_FILES = 0x0026 -- csidl_PROGRAM_FILES_COMMON :: CInt -- csidl_PROGRAM_FILES_COMMON = 0x002b #ifdef x86_64_HOST_ARCH #define CALLCONV ccall #else #define CALLCONV stdcall #endif foreign import CALLCONV unsafe "shlobj.h SHGetFolderPathW" c_SHGetFolderPath :: Ptr () -> CInt -> Ptr () -> CInt -> CWString -> Prelude.IO CInt #endif