module SysTools.BaseDir
( expandTopDir, expandToolDir
, findTopDir, findToolDir
) where
#include "HsVersions.h"
import GhcPrelude
import Panic
import System.FilePath
import Data.List
#if defined(darwin_HOST_OS) || defined(linux_HOST_OS)
import System.Environment (getExecutablePath)
#endif
#if defined(mingw32_HOST_OS)
import qualified System.Win32.Types as Win32
import Exception
import Foreign
import Foreign.C.String
import System.Directory
import System.Win32.Types (DWORD, LPTSTR, HANDLE)
import System.Win32.Types (failIfNull, failIf, iNVALID_HANDLE_VALUE)
import System.Win32.File (createFile,closeHandle, gENERIC_READ, fILE_SHARE_READ, oPEN_EXISTING, fILE_ATTRIBUTE_NORMAL, fILE_FLAG_BACKUP_SEMANTICS )
import System.Win32.DLL (loadLibrary, getProcAddress)
#endif
#if defined(mingw32_HOST_OS)
# if defined(i386_HOST_ARCH)
# define WINDOWS_CCONV stdcall
# elif defined(x86_64_HOST_ARCH)
# define WINDOWS_CCONV ccall
# else
# error Unknown mingw32 arch
# endif
#endif
expandTopDir :: FilePath -> String -> String
expandTopDir = expandPathVar "topdir"
expandToolDir :: Maybe FilePath -> String -> String
#if defined(mingw32_HOST_OS)
expandToolDir (Just tool_dir) s = expandPathVar "tooldir" tool_dir s
expandToolDir Nothing _ = panic "Could not determine $tooldir"
#else
expandToolDir _ s = s
#endif
expandPathVar :: String -> FilePath -> String -> String
expandPathVar var value str
| Just str' <- stripPrefix ('$':var) str
, null str' || isPathSeparator (head str')
= value ++ expandPathVar var value str'
expandPathVar var value (x:xs) = x : expandPathVar var value xs
expandPathVar _ _ [] = []
findTopDir :: Maybe String
-> IO String
findTopDir (Just minusb) = return (normalise minusb)
findTopDir Nothing
= do
maybe_exec_dir <- getBaseDir
case maybe_exec_dir of
Nothing -> throwGhcExceptionIO (InstallationError "missing -B<dir> option")
Just dir -> return dir
getBaseDir :: IO (Maybe String)
#if defined(mingw32_HOST_OS)
getBaseDir = try_size 2048
where
try_size size = allocaArray (fromIntegral size) $ \buf -> do
ret <- c_GetModuleFileName nullPtr buf size
case ret of
0 -> return Nothing
_ | ret < size -> do
path <- peekCWString buf
real <- getFinalPath path
let libdir = (buildLibDir . sanitize . maybe path id) real
exists <- doesDirectoryExist libdir
if exists
then return $ Just libdir
else fail path
| otherwise -> try_size (size * 2)
sanitize s = if "\\\\?\\" `isPrefixOf` s
then drop 4 s
else s
buildLibDir :: FilePath -> FilePath
buildLibDir s =
(takeDirectory . takeDirectory . normalise $ s) </> "lib"
fail s = panic ("can't decompose ghc.exe path: " ++ show s)
foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"
c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
getFinalPath :: FilePath -> IO (Maybe FilePath)
getFinalPath name = do
dllHwnd <- failIfNull "LoadLibrary" $ loadLibrary "kernel32.dll"
addr_m <- (fmap Just $ failIfNull "getProcAddress" $ getProcAddress dllHwnd "GetFinalPathNameByHandleW")
`catch` (\(_ :: SomeException) -> return Nothing)
case addr_m of
Nothing -> return Nothing
Just addr -> do handle <- failIf (==iNVALID_HANDLE_VALUE) "CreateFile"
$ createFile name
gENERIC_READ
fILE_SHARE_READ
Nothing
oPEN_EXISTING
(fILE_ATTRIBUTE_NORMAL .|. fILE_FLAG_BACKUP_SEMANTICS)
Nothing
let fnPtr = makeGetFinalPathNameByHandle $ castPtrToFunPtr addr
path <- (Win32.try "GetFinalPathName"
(\buf len -> fnPtr handle buf len 0) 512
`finally` closeHandle handle)
`catch`
(\(_ :: IOException) -> return name)
return $ Just path
type GetFinalPath = HANDLE -> LPTSTR -> DWORD -> DWORD -> IO DWORD
foreign import WINDOWS_CCONV unsafe "dynamic"
makeGetFinalPathNameByHandle :: FunPtr GetFinalPath -> GetFinalPath
#elif defined(darwin_HOST_OS) || defined(linux_HOST_OS)
getBaseDir = Just . (\p -> p </> "lib") . takeDirectory . takeDirectory <$> getExecutablePath
#else
getBaseDir = return Nothing
#endif
findToolDir
:: FilePath
-> IO (Maybe FilePath)
#if defined(mingw32_HOST_OS)
findToolDir top_dir = go 0 (top_dir </> "..")
where maxDepth = 2
go :: Int -> FilePath -> IO (Maybe FilePath)
go k path
| k == maxDepth = throwGhcExceptionIO $
InstallationError "could not detect mingw toolchain"
| otherwise = do
oneLevel <- doesDirectoryExist (path </> "mingw")
if oneLevel
then return (Just path)
else go (k+1) (path </> "..")
#else
findToolDir _ = return Nothing
#endif