{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
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.Package
import Distribution.System
import Distribution.Compiler
import Distribution.Text
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)
instance Binary dir => Binary (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 getAppUserDataDirectory "cabal"
else case buildOS of
Windows -> do windowsProgramFilesDir <- getWindowsProgramFilesDir
return (windowsProgramFilesDir </> "Haskell")
_ -> return "/usr/local"
installLibDir <-
case buildOS of
Windows -> return "$prefix"
_ -> case comp of
LHC | userInstall -> getAppUserDataDirectory "lhc"
_ -> return ("$prefix" </> "lib")
return $ fmap toPathTemplate $ InstallDirs {
prefix = installPrefix,
bindir = "$prefix" </> "bin",
libdir = installLibDir,
libsubdir = case comp of
JHC -> "$compiler"
LHC -> "$compiler"
UHC -> "$pkgid"
_other -> "$abi" </> "$libname",
dynlibdir = "$libdir" </> case comp of
JHC -> "$compiler"
LHC -> "$compiler"
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)
instance Binary PathTemplate
data PathComponent =
Ordinary FilePath
| Variable PathTemplateVariable
deriving (Eq, Ord, Generic)
instance Binary PathComponent
data PathTemplateVariable =
PrefixVar
| BindirVar
| LibdirVar
| LibsubdirVar
| DynlibdirVar
| DatadirVar
| DatasubdirVar
| DocdirVar
| HtmldirVar
| PkgNameVar
| PkgVerVar
| PkgIdVar
| LibNameVar
| CompilerVar
| OSVar
| ArchVar
| AbiVar
| AbiTagVar
| ExecutableNameVar
| TestSuiteNameVar
| TestSuiteResultVar
| BenchmarkNameVar
deriving (Eq, Ord, Generic)
instance Binary PathTemplateVariable
type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)]
toPathTemplate :: FilePath -> PathTemplate
toPathTemplate = PathTemplate . read
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 $ display (packageName pkgId)])
,(PkgVerVar, PathTemplate [Ordinary $ display (packageVersion pkgId)])
,(LibNameVar, PathTemplate [Ordinary $ display uid])
,(PkgIdVar, PathTemplate [Ordinary $ display pkgId])
]
compilerTemplateEnv :: CompilerInfo -> PathTemplateEnv
compilerTemplateEnv compiler =
[(CompilerVar, PathTemplate [Ordinary $ display (compilerInfoId compiler)])
]
platformTemplateEnv :: Platform -> PathTemplateEnv
platformTemplateEnv (Platform arch os) =
[(OSVar, PathTemplate [Ordinary $ display os])
,(ArchVar, PathTemplate [Ordinary $ display arch])
]
abiTemplateEnv :: CompilerInfo -> Platform -> PathTemplateEnv
abiTemplateEnv compiler (Platform arch os) =
[(AbiVar, PathTemplate [Ordinary $ display arch ++ '-':display os ++
'-':display (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 PathTemplateVariable where
show PrefixVar = "prefix"
show LibNameVar = "libname"
show BindirVar = "bindir"
show LibdirVar = "libdir"
show LibsubdirVar = "libsubdir"
show DynlibdirVar = "dynlibdir"
show DatadirVar = "datadir"
show DatasubdirVar = "datasubdir"
show DocdirVar = "docdir"
show HtmldirVar = "htmldir"
show PkgNameVar = "pkg"
show PkgVerVar = "version"
show PkgIdVar = "pkgid"
show CompilerVar = "compiler"
show OSVar = "os"
show ArchVar = "arch"
show AbiTagVar = "abitag"
show AbiVar = "abi"
show ExecutableNameVar = "executablename"
show TestSuiteNameVar = "test-suite"
show TestSuiteResultVar = "result"
show BenchmarkNameVar = "benchmark"
instance Read PathTemplateVariable where
readsPrec _ s =
take 1
[ (var, drop (length varStr) s)
| (varStr, var) <- vars
, varStr `isPrefixOf` s ]
where vars = [("prefix", PrefixVar)
,("bindir", BindirVar)
,("libdir", LibdirVar)
,("libsubdir", LibsubdirVar)
,("dynlibdir", DynlibdirVar)
,("datadir", DatadirVar)
,("datasubdir", DatasubdirVar)
,("docdir", DocdirVar)
,("htmldir", HtmldirVar)
,("pkgid", PkgIdVar)
,("libname", LibNameVar)
,("pkgkey", LibNameVar)
,("pkg", PkgNameVar)
,("version", PkgVerVar)
,("compiler", CompilerVar)
,("os", OSVar)
,("arch", ArchVar)
,("abitag", AbiTagVar)
,("abi", AbiVar)
,("executablename", ExecutableNameVar)
,("test-suite", TestSuiteNameVar)
,("result", TestSuiteResultVar)
,("benchmark", BenchmarkNameVar)]
instance Show PathComponent where
show (Ordinary path) = path
show (Variable var) = '$':show var
showList = foldr (\x -> (shows x .)) id
instance Read PathComponent where
readsPrec _ = lex0
where lex0 [] = []
lex0 ('$':'$':s') = lex0 ('$':s')
lex0 ('$':s') = case [ (Variable var, s'')
| (var, s'') <- reads s' ] of
[] -> lex1 "$" s'
ok -> ok
lex0 s' = lex1 [] s'
lex1 "" "" = []
lex1 acc "" = [(Ordinary (reverse acc), "")]
lex1 acc ('$':'$':s) = lex1 acc ('$':s)
lex1 acc ('$':s) = [(Ordinary (reverse acc), '$':s)]
lex1 acc (c:s) = lex1 (c:acc) s
readList [] = [([],"")]
readList s = [ (component:components, s'')
| (component, s') <- reads s
, (components, s'') <- readList s' ]
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