-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
module SysTools (
touch, -- String -> String -> IO ()
copy,
copyWithHeader,
- normalisePath, -- FilePath -> FilePath
getExtraViaCOpts,
-- Temporary-file management
import Control.Monad
import System.Exit
import System.Environment
+import System.FilePath
import System.IO
import SYSTEM_IO_ERROR as IO
import System.Directory
import CString ( CString, peekCString )
#endif
-#if __GLASGOW_HASKELL__ < 603
--- rawSystem comes from libghccompat.a in stage1
-import Compat.RawSystem ( rawSystem )
-import System.Cmd ( system )
-import GHC.IOBase ( IOErrorType(..) )
-#else
import System.Process ( runInteractiveProcess, getProcessExitCode )
import Control.Concurrent( forkIO, newChan, readChan, writeChan )
-import FastString ( mkFastString )
+import FastString
import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
-#endif
\end{code}
-- format, '/' separated
; let installed, installed_bin :: FilePath -> FilePath
- installed_bin pgm = pgmPath top_dir pgm
- installed file = pgmPath top_dir file
- inplace dir pgm = pgmPath (top_dir `joinFileName`
- cPROJECT_DIR `joinFileName` dir) pgm
+ installed_bin pgm = top_dir </> pgm
+ installed file = top_dir </> file
+ inplace dir pgm = top_dir </>
+#ifndef darwin_TARGET_OS
+-- Not sure where cPROJECT_DIR makes sense, on Mac OS, building with
+-- xcodebuild, it surely is a *bad* idea! -=chak
+ cPROJECT_DIR </>
+#endif
+ dir </> pgm
; let pkgconfig_path
| am_installed = installed "package.conf"
| otherwise = "windres"
; let dflags0 = defaultDynFlags
-#ifndef mingw32_HOST_OS
- -- check whether TMPDIR is set in the environment
- ; e_tmpdir <- IO.try (getEnv "TMPDIR") -- fails if not set
-#else
- -- On Win32, consult GetTempPath() for a temp dir.
- -- => it first tries TMP, TEMP, then finally the
- -- Windows directory(!). The directory is in short-path
- -- form.
- ; e_tmpdir <-
- IO.try (do
- let len = (2048::Int)
- buf <- mallocArray len
- ret <- getTempPath len buf
- if ret == 0 then do
- -- failed, consult TMPDIR.
- free buf
- getEnv "TMPDIR"
- else do
- s <- peekCString buf
- free buf
- return s)
-#endif
- ; let dflags1 = case e_tmpdir of
- Left _ -> dflags0
- Right d -> setTmpDir d dflags0
+
+ ; tmpdir <- getTemporaryDirectory
+ ; let dflags1 = setTmpDir tmpdir dflags0
-- Check that the package config exists
; config_exists <- doesFileExist pkgconfig_path
-- later on; although gcc_args are in NATIVE format,
-- gcc can cope
-- (see comments with declarations of global variables)
- --
- -- The quotes round the -B argument are in case TopDir
- -- has spaces in it
perl_path | am_installed = installed_bin cGHC_PERL
| otherwise = cGHC_PERL
; let (mkdll_prog, mkdll_args)
| am_installed =
- (pgmPath (installed "gcc-lib/") cMKDLL,
+ (installed "gcc-lib/" </> cMKDLL,
[ Option "--dlltool-name",
- Option (pgmPath (installed "gcc-lib/") "dlltool"),
+ Option (installed "gcc-lib/" </> "dlltool"),
Option "--driver-name",
Option gcc_prog, gcc_b_arg ])
| otherwise = (cMKDLL, [])
= do { top_dir <- get_proto
-- Discover whether we're running in a build tree or in an installation,
-- by looking for the package configuration file.
- ; am_installed <- doesFileExist (top_dir `joinFileName` "package.conf")
+ ; am_installed <- doesFileExist (top_dir </> "package.conf")
; return (am_installed, top_dir)
}
where
-- get_proto returns a Unix-format path (relying on getBaseDir to do so too)
get_proto = case mbMinusB of
- Just minusb -> return (normalisePath minusb)
+ Just minusb -> return (normalise minusb)
Nothing
-> do maybe_exec_dir <- getBaseDir -- Get directory of executable
case maybe_exec_dir of -- (only works on Windows;
runCpp :: DynFlags -> [Option] -> IO ()
runCpp dflags args = do
let (p,args0) = pgm_P dflags
- runSomething dflags "C pre-processor" p (args0 ++ args)
+ args1 = args0 ++ args
+ mb_env <- getGccEnv args1
+ runSomethingFiltered dflags id "C pre-processor" p args1 mb_env
runPp :: DynFlags -> [Option] -> IO ()
runPp dflags args = do
-- binaries (see bug #1110).
getGccEnv :: [Option] -> IO (Maybe [(String,String)])
getGccEnv opts =
-#if __GLASGOW_HASKELL__ < 603
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
return Nothing
#else
if null b_dirs
mb_env <- getGccEnv gcc_args
runSomethingFiltered dflags id "Windres" windres
-- we must tell windres where to find gcc: it might not be on PATH
- (Option ("--preprocessor=" ++ gcc ++ " " ++
- unwords (map showOpt gcc_args) ++
- " -E -xc -DRC_INVOKED")
- : args)
+ (Option ("--preprocessor=" ++
+ unwords (map quote (gcc : map showOpt gcc_args ++
+ ["-E", "-xc", "-DRC_INVOKED"])))
+ -- -- use-temp-file is required for windres to interpret the
+ -- quoting in the preprocessor arg above correctly. Without
+ -- this, windres calls the preprocessor with popen, which gets
+ -- the quoting wrong (discovered by experimentation and
+ -- reading the windres sources). See #1828.
+ : Option "--use-temp-file"
+ : args)
-- we must use the PATH workaround here too, since windres invokes gcc
mb_env
+ where
+ quote x = '\"' : x ++ "\""
touch :: DynFlags -> String -> String -> IO ()
touch dflags purpose arg =
getExtraViaCOpts :: DynFlags -> IO [String]
getExtraViaCOpts dflags = do
- f <- readFile (topDir dflags `joinFileName` "extra-gcc-opts")
+ f <- readFile (topDir dflags </> "extra-gcc-opts")
return (words f)
\end{code}
where
findTempName :: FilePath -> Integer -> IO FilePath
findTempName prefix x
- = do let filename = (prefix ++ show x) `joinFileExt` extn
- b <- doesFileExist filename
- if b then findTempName prefix (x+1)
- else do consIORef v_FilesToClean filename -- clean it up later
- return filename
+ = do let filename = (prefix ++ show x) <.> extn
+ b <- doesFileExist filename
+ if b then findTempName prefix (x+1)
+ else do consIORef v_FilesToClean filename -- clean it up later
+ return filename
-- return our temporary directory within tmp_dir, creating one if we
-- don't have one yet
-#if __GLASGOW_HASKELL__ < 603
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
builderMainLoop dflags filter_fn pgm real_args mb_env = do
rawSystem pgm real_args
#else
| EOF
#endif
-showOpt (FileOption pre f) = pre ++ platformPath f
-showOpt (Option "") = ""
+showOpt (FileOption pre f) = pre ++ f
showOpt (Option s) = s
traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
free buf
return (Just (rootDir s))
where
- rootDir s = reverse (dropList "/bin/ghc.exe" (reverse (normalisePath s)))
+ rootDir s = case splitFileName $ normalise s of
+ (d, "ghc.exe") ->
+ case splitFileName $ takeDirectory d of
+ (d', "bin") -> takeDirectory d'
+ _ -> panic ("Expected \"bin\" in " ++ show s)
+ _ -> panic ("Expected \"ghc.exe\" in " ++ show s)
foreign import stdcall unsafe "GetModuleFileNameA"
getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
projects / ghc-hetmet.git / blobdiff