module Distribution.Simple.InstallDirs (
InstallDirs(..), haddockdir, haddockinterfacedir,
InstallDirTemplates(..),
defaultInstallDirs,
absoluteInstallDirs,
prefixRelativeInstallDirs,
PathTemplate,
PathTemplateVariable(..),
toPathTemplate,
fromPathTemplate,
substPathTemplate,
initialPathTemplateEnv,
) where
import Data.List (isPrefixOf)
import Data.Maybe (fromMaybe)
import System.FilePath ((</>), isPathSeparator)
#if __HUGS__ || __GLASGOW_HASKELL__ > 606
import System.FilePath (dropDrive)
#endif
import Distribution.Package (PackageIdentifier(..), showPackageId)
import Distribution.PackageDescription (PackageDescription(package))
import Distribution.Version (showVersion)
import Distribution.System (OS(..), os)
import Distribution.Simple.Compiler (CompilerFlavor(..))
import Distribution.Simple.Setup (CopyDest(..))
#if mingw32_HOST_OS || mingw32_TARGET_OS
import Foreign
import Foreign.C
#endif
data InstallDirs dir = InstallDirs {
prefix :: dir,
bindir :: dir,
libdir :: dir,
dynlibdir :: dir,
libexecdir :: dir,
progdir :: dir,
includedir :: dir,
datadir :: dir,
docdir :: dir,
htmldir :: dir,
interfacedir :: dir
} deriving (Read, Show)
data InstallDirTemplates = InstallDirTemplates {
prefixDirTemplate :: PathTemplate,
binDirTemplate :: PathTemplate,
libDirTemplate :: PathTemplate,
libSubdirTemplate :: PathTemplate,
libexecDirTemplate :: PathTemplate,
progDirTemplate :: PathTemplate,
includeDirTemplate :: PathTemplate,
dataDirTemplate :: PathTemplate,
dataSubdirTemplate :: PathTemplate,
docDirTemplate :: PathTemplate,
htmlDirTemplate :: PathTemplate,
interfaceDirTemplate :: PathTemplate
} deriving (Read, Show)
defaultInstallDirs :: CompilerFlavor -> Bool -> IO InstallDirTemplates
defaultInstallDirs comp hasLibs = do
windowsProgramFilesDir <- getWindowsProgramFilesDir
let prefixDir = case os of
Windows _ -> windowsProgramFilesDir </> "Haskell"
_other -> "/usr/local"
binDir = "$prefix" </> "bin"
libDir = case os of
Windows _ -> "$prefix"
_other -> "$prefix" </> "lib"
libSubdir = case comp of
Hugs -> "hugs" </> "packages" </> "$pkg"
JHC -> "$compiler"
_other -> "$pkgid" </> "$compiler"
libexecDir = case os of
Windows _ -> "$prefix" </> "$pkgid"
_other -> "$prefix" </> "libexec"
progDir = "$libdir" </> "hugs" </> "programs"
includeDir = "$libdir" </> "$libsubdir" </> "include"
dataDir = case os of
Windows _ | hasLibs -> windowsProgramFilesDir </> "Haskell"
| otherwise -> "$prefix"
_other -> "$prefix" </> "share"
dataSubdir = "$pkgid"
docDir = case os of
Windows _ -> "$prefix" </> "doc" </> "$pkgid"
_other -> "$datadir" </> "doc" </> "$pkgid"
htmlDir = "$docdir" </> "html"
interfaceDir = "$docdir" </> "html"
return InstallDirTemplates {
prefixDirTemplate = toPathTemplate prefixDir,
binDirTemplate = toPathTemplate binDir,
libDirTemplate = toPathTemplate libDir,
libSubdirTemplate = toPathTemplate libSubdir,
libexecDirTemplate = toPathTemplate libexecDir,
progDirTemplate = toPathTemplate progDir,
includeDirTemplate = toPathTemplate includeDir,
dataDirTemplate = toPathTemplate dataDir,
dataSubdirTemplate = toPathTemplate dataSubdir,
docDirTemplate = toPathTemplate docDir,
htmlDirTemplate = toPathTemplate htmlDir,
interfaceDirTemplate = toPathTemplate interfaceDir
}
haddockdir :: InstallDirs FilePath -> PackageDescription -> FilePath
haddockdir installDirs pkg_descr =
htmldir installDirs
haddockinterfacedir :: InstallDirs FilePath -> PackageDescription -> FilePath
haddockinterfacedir installDirs pkg_descr =
interfacedir installDirs
substituteTemplates :: PackageIdentifier -> PackageIdentifier
-> InstallDirTemplates -> InstallDirTemplates
substituteTemplates pkgId compilerId dirs = dirs'
where
dirs' = InstallDirTemplates {
prefixDirTemplate = subst prefixDirTemplate [],
binDirTemplate = subst binDirTemplate [prefixDirVar],
libDirTemplate = subst libDirTemplate [prefixDirVar, binDirVar],
libSubdirTemplate = subst libSubdirTemplate [],
libexecDirTemplate = subst libexecDirTemplate prefixBinLibVars,
progDirTemplate = subst progDirTemplate prefixBinLibVars,
includeDirTemplate = subst includeDirTemplate prefixBinLibVars,
dataDirTemplate = subst dataDirTemplate prefixBinLibVars,
dataSubdirTemplate = subst dataSubdirTemplate [],
docDirTemplate = subst docDirTemplate $ prefixBinLibVars
++ [dataDirVar, dataSubdirVar],
htmlDirTemplate = subst htmlDirTemplate $ prefixBinLibVars
++ [dataDirVar, dataSubdirVar, docDirVar],
interfaceDirTemplate = subst interfaceDirTemplate $ prefixBinLibVars
++ [dataDirVar, dataSubdirVar, docDirVar]
}
env = initialPathTemplateEnv pkgId compilerId
subst dir env' = substPathTemplate (env'++env) (dir dirs)
prefixDirVar = (PrefixVar, prefixDirTemplate dirs')
binDirVar = (BinDirVar, binDirTemplate dirs')
libDirVar = (LibDirVar, libDirTemplate dirs')
libSubdirVar = (LibSubdirVar, libSubdirTemplate dirs')
dataDirVar = (DataDirVar, dataDirTemplate dirs')
dataSubdirVar = (DataSubdirVar, dataSubdirTemplate dirs')
docDirVar = (DocDirVar, docDirTemplate dirs')
prefixBinLibVars = [prefixDirVar, binDirVar, libDirVar, libSubdirVar]
absoluteInstallDirs :: PackageIdentifier -> PackageIdentifier -> CopyDest
-> InstallDirTemplates -> InstallDirs FilePath
absoluteInstallDirs pkgId compilerId copydest dirs =
InstallDirs {
prefix = copy $ path prefixDirTemplate,
bindir = copy $ path binDirTemplate,
libdir = copy $ path libDirTemplate </> path libSubdirTemplate,
dynlibdir = copy $ path libDirTemplate,
libexecdir = copy $ path libexecDirTemplate,
progdir = copy $ path progDirTemplate,
includedir = copy $ path includeDirTemplate,
datadir = copy $ path dataDirTemplate </> path dataSubdirTemplate,
docdir = copy $ path docDirTemplate,
htmldir = copy $ path htmlDirTemplate,
interfacedir = copy $ path interfaceDirTemplate
}
where
dirs' = substituteTemplates pkgId compilerId dirs {
prefixDirTemplate = case copydest of
CopyPrefix p -> toPathTemplate p
_ -> prefixDirTemplate dirs
}
path dir = case dir dirs' of
PathTemplate cs -> concat [ c | Ordinary c <- cs ]
copy dir = case copydest of
CopyTo destdir -> destdir </> dropDrive dir
_ -> dir
prefixRelativeInstallDirs :: PackageIdentifier -> PackageIdentifier
-> InstallDirTemplates
-> InstallDirs (Maybe FilePath)
prefixRelativeInstallDirs pkgId compilerId dirs =
InstallDirs {
prefix = relative prefixDirTemplate,
bindir = relative binDirTemplate,
libdir = (flip fmap) (relative libDirTemplate) (</> path libSubdirTemplate),
dynlibdir = (relative libDirTemplate),
libexecdir = relative libexecDirTemplate,
progdir = relative progDirTemplate,
includedir = relative includeDirTemplate,
datadir = (flip fmap) (relative dataDirTemplate) (</> path dataSubdirTemplate),
docdir = relative docDirTemplate,
htmldir = relative htmlDirTemplate,
interfacedir = relative interfaceDirTemplate
}
where
dirs' = substituteTemplates pkgId compilerId dirs {
prefixDirTemplate = PathTemplate [Variable PrefixVar]
}
relative dir = case dir dirs' 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 dir = fromPathTemplate (dir dirs')
newtype PathTemplate = PathTemplate [PathComponent]
data PathComponent =
Ordinary FilePath
| Variable PathTemplateVariable
data PathTemplateVariable =
PrefixVar
| BinDirVar
| LibDirVar
| LibSubdirVar
| DataDirVar
| DataSubdirVar
| DocDirVar
| PkgNameVar
| PkgVerVar
| PkgIdVar
| CompilerVar
deriving Eq
toPathTemplate :: FilePath -> PathTemplate
toPathTemplate = PathTemplate . read
fromPathTemplate :: PathTemplate -> FilePath
fromPathTemplate (PathTemplate cs) = concat [ c | Ordinary c <- cs ]
substPathTemplate :: [(PathTemplateVariable, PathTemplate)]
-> 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 -> PackageIdentifier
-> [(PathTemplateVariable, PathTemplate)]
initialPathTemplateEnv pkgId compilerId =
map (\(v,s) -> (v, PathTemplate [Ordinary s]))
[(PkgNameVar, pkgName pkgId)
,(PkgVerVar, showVersion (pkgVersion pkgId))
,(PkgIdVar, showPackageId pkgId)
,(CompilerVar, showPackageId compilerId)]
instance Show PathTemplateVariable where
show PrefixVar = "prefix"
show BinDirVar = "bindir"
show LibDirVar = "libdir"
show LibSubdirVar = "libsubdir"
show DataDirVar = "datadir"
show DataSubdirVar = "datasubdir"
show DocDirVar = "docdir"
show PkgNameVar = "pkg"
show PkgVerVar = "version"
show PkgIdVar = "pkgid"
show CompilerVar = "compiler"
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)
,("datadir", DataDirVar)
,("datasubdir", DataSubdirVar)
,("docdir", DocDirVar)
,("pkgid", PkgIdVar)
,("pkg", PkgNameVar)
,("version", PkgVerVar)
,("compiler", CompilerVar)]
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 :: IO FilePath
getWindowsProgramFilesDir = do
#if mingw32_HOST_OS || mingw32_TARGET_OS
m <- shGetFolderPath csidl_PROGRAM_FILES
#else
let m = Nothing
#endif
return (fromMaybe "C:\\Program Files" m)
#if mingw32_HOST_OS || mingw32_TARGET_OS
shGetFolderPath :: CInt -> IO (Maybe FilePath)
shGetFolderPath n =
# if __HUGS__
return Nothing
# else
allocaBytes long_path_size $ \pPath -> do
r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath
if (r /= 0)
then return Nothing
else do s <- peekCString pPath; return (Just s)
where
long_path_size = 1024
# endif
csidl_PROGRAM_FILES :: CInt
csidl_PROGRAM_FILES = 0x0026
foreign import stdcall unsafe "shlobj.h SHGetFolderPathA"
c_SHGetFolderPath :: Ptr ()
-> CInt
-> Ptr ()
-> CInt
-> CString
-> IO CInt
#endif
#if !(__HUGS__ || __GLASGOW_HASKELL__ > 606)
dropDrive :: FilePath -> FilePath
dropDrive (c:cs) | isPathSeparator c = cs
dropDrive (_:':':c:cs) | isWindows
&& isPathSeparator c = cs
dropDrive (_:':':cs) | isWindows = cs
dropDrive cs = cs
isWindows :: Bool
isWindows = case os of
Windows _ -> True
_ -> False
#endif