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
data InstallDirs dir = InstallDirs {
prefix :: dir,
bindir :: dir,
libdir :: dir,
libsubdir :: dir,
dynlibdir :: dir,
flibdir :: dir,
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"
}
type InstallDirTemplates = InstallDirs PathTemplate
defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
defaultInstallDirs = defaultInstallDirs' False
defaultInstallDirs' :: Bool
-> CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
defaultInstallDirs' True comp userInstall hasLibs = do
dflt <- defaultInstallDirs' False comp userInstall hasLibs
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"
}
substituteInstallDirTemplates :: PathTemplateEnv
-> InstallDirTemplates -> InstallDirTemplates
substituteInstallDirTemplates env dirs = dirs'
where
dirs' = InstallDirs {
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]
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
data CopyDest
= NoCopyDest
| CopyTo FilePath
| CopyToDb FilePath
deriving (Eq, Show, Generic)
instance Binary CopyDest
prefixRelativeInstallDirs :: PackageIdentifier
-> UnitId
-> CompilerInfo
-> Platform
-> InstallDirTemplates
-> InstallDirs (Maybe FilePath)
prefixRelativeInstallDirs pkgId libname compilerId platform dirs =
fmap relative
. appendSubdirs combinePathTemplate
$
substituteInstallDirTemplates env dirs {
prefix = PathTemplate [Variable PrefixVar]
}
where
env = initialPathTemplateEnv pkgId libname compilerId platform
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
newtype PathTemplate = PathTemplate [PathComponent]
deriving (Eq, Ord, Generic, Typeable)
instance Binary PathTemplate
instance Structured PathTemplate
type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)]
toPathTemplate :: FilePath -> PathTemplate
toPathTemplate fp = PathTemplate
. fromMaybe (error $ "panic! toPathTemplate " ++ show fp)
. readMaybe
$ fp
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]
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)])
,(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)
]
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 ]
getWindowsProgramFilesDir :: NoCallStackIO 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 -> NoCallStackIO (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
csidl_PROGRAM_FILES :: CInt
csidl_PROGRAM_FILES = 0x0026
#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