`IO.catch` \_ -> do
#if mingw32_HOST_OS
win <- System.Win32.getWindowsDirectory
- return (win `joinFileName` "notepad.exe")
+ return (win </> "notepad.exe")
#else
return ""
#endif
import Data.List
import Foreign
+import System.FilePath
import System.IO
import System.Directory
return lnk
adjust_ul osuf (DotO file) = do
- let new_file = replaceFilenameSuffix file osuf
+ let new_file = replaceExtension file osuf
ok <- doesFileExist new_file
if (not ok)
then dieWith span $
Just lib_path -> return (DLL (lib ++ "-ghc" ++ cProjectVersion))
Nothing -> return (DLL lib) }} -- We assume
where
- mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o")
- mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "-ghc" ++ cProjectVersion)
+ mk_obj_path dir = dir </> lib <.> "o"
+ mk_dyn_lib_path dir = dir </> mkSOName (lib ++ "-ghc" ++ cProjectVersion)
#else
-- When the GHC package was compiled as dynamic library (=__PIC__ set),
-- we search for .so libraries first.
Just obj_path -> return (Object obj_path)
Nothing -> return (DLL lib) }} -- We assume
where
- mk_obj_path dir = dir `joinFileName` (lib `joinFileExt` "o")
- mk_dyn_lib_path dir = dir `joinFileName` mkSOName (lib ++ "-ghc" ++ cProjectVersion)
+ mk_obj_path dir = dir </> (lib <.> "o")
+ mk_dyn_lib_path dir = dir </> mkSOName (lib ++ "-ghc" ++ cProjectVersion)
#endif
-- ----------------------------------------------------------------------------
-- Tried all our known library paths, so let
-- dlopen() search its own builtin paths now.
where
- mk_dll_path dir = dir `joinFileName` mkSOName rootname
+ mk_dll_path dir = dir </> mkSOName rootname
#if defined(darwin_TARGET_OS)
-mkSOName root = ("lib" ++ root) `joinFileExt` "dylib"
+mkSOName root = ("lib" ++ root) <.> "dylib"
#elif defined(mingw32_TARGET_OS)
-- Win32 DLLs have no .dll extension here, because addDLL tries
-- both foo.dll and foo.drv
mkSOName root = root
#else
-mkSOName root = ("lib" ++ root) `joinFileExt` "so"
+mkSOName root = ("lib" ++ root) <.> "so"
#endif
-- Darwin / MacOS X only: load a framework
-- Tried all our known library paths, but dlopen()
-- has no built-in paths for frameworks: give up
where
- mk_fwk dir = dir `joinFileName` (rootname ++ ".framework/" ++ rootname)
+ mk_fwk dir = dir </> (rootname ++ ".framework/" ++ rootname)
-- sorry for the hardcoded paths, I hope they won't change anytime soon:
defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
#endif
import Control.Monad
import Data.List
import Data.IORef
+import System.FilePath
\end{code}
-----------------------------
writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO ()
writeIfaceFile dflags location new_iface
- = do createDirectoryHierarchy (directoryOf hi_file_path)
+ = do createDirectoryHierarchy (takeDirectory hi_file_path)
writeBinIface dflags hi_file_path new_iface
where hi_file_path = ml_hi_file location
import Directory ( doesFileExist )
import Monad ( when )
import IO
+import System.FilePath
\end{code}
%************************************************************************
stub_h_output_w = showSDoc stub_h_output_d
-- in
- createDirectoryHierarchy (directoryOf stub_c)
+ createDirectoryHierarchy (takeDirectory stub_c)
dumpIfSet_dyn dflags Opt_D_dump_foreign
"Foreign export header file" stub_h_output_d
import qualified GHC
import GHC ( Session, ModSummary(..) )
import DynFlags
-import Util ( escapeSpaces, splitFilename, joinFileExt )
+import Util ( escapeSpaces )
import HscTypes ( HscEnv, IsBootInterface, msObjFilePath, msHsFilePath )
import SysTools ( newTempName )
import qualified SysTools
import Control.Exception
import System.Exit ( ExitCode(..), exitWith )
import System.Directory
+import System.FilePath
import System.IO
import SYSTEM_IO_ERROR ( isEOFError )
import Control.Monad ( when )
-- Lots of other things will break first!
insertSuffixes file_name extras
- = file_name : [ basename `joinFileExt` (extra ++ "_" ++ suffix) | extra <- extras ]
+ = file_name : [ basename <.> (extra ++ "_" ++ suffix) | extra <- extras ]
where
- (basename, suffix) = splitFilename file_name
+ (basename, suffix) = splitExtension file_name
-----------------------------------------------------------------
isSourceFilename -- :: FilePath -> Bool
) where
-import Util ( suffixOf )
import Panic ( panic )
+import System.FilePath
-----------------------------------------------------------------------------
-- Phases
isExtCoreSuffix s = s `elem` extcoreish_suffixes
isObjectSuffix s = s `elem` objish_suffixes
isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes
-isDynLibSuffix s = s `elem` dynlib_suffixes
+isDynLibSuffix s = s `elem` dynlib_suffixes
isSourceSuffix suff = isHaskellishSuffix suff || isCishSuffix suff
-isHaskellishFilename f = isHaskellishSuffix (suffixOf f)
-isHaskellSrcFilename f = isHaskellSrcSuffix (suffixOf f)
-isCishFilename f = isCishSuffix (suffixOf f)
-isExtCoreFilename f = isExtCoreSuffix (suffixOf f)
-isObjectFilename f = isObjectSuffix (suffixOf f)
-isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (suffixOf f)
-isDynLibFilename f = isDynLibSuffix (suffixOf f)
-isSourceFilename f = isSourceSuffix (suffixOf f)
+-- takeExtension return .foo, so we drop 1 to get rid of the .
+isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f)
+isHaskellSrcFilename f = isHaskellSrcSuffix (drop 1 $ takeExtension f)
+isCishFilename f = isCishSuffix (drop 1 $ takeExtension f)
+isExtCoreFilename f = isExtCoreSuffix (drop 1 $ takeExtension f)
+isObjectFilename f = isObjectSuffix (drop 1 $ takeExtension f)
+isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f)
+isDynLibFilename f = isDynLibSuffix (drop 1 $ takeExtension f)
+isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f)
import Data.IORef ( readIORef, writeIORef, IORef )
import GHC.Exts ( Int(..) )
import System.Directory
+import System.FilePath
import System.IO
import SYSTEM_IO_ERROR as IO
import Control.Monad
import Data.Maybe
import System.Exit
import System.Environment
+import System.FilePath
-- ---------------------------------------------------------------------------
-- Pre-process
debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp)
- let (basename, _) = splitFilename input_fn
+ let basename = dropExtension input_fn
-- We add the directory in which the .hs files resides) to the import path.
-- This is needed when we try to compile the .hc file later, if it
-- imports a _stub.h file that we created here.
- let current_dir = directoryOf basename
+ let current_dir = case takeDirectory basename of
+ "" -> "." -- XXX Hack
+ d -> d
old_paths = includePaths dflags0
dflags = dflags0 { includePaths = current_dir : old_paths }
compileStub :: DynFlags -> Module -> ModLocation -> IO FilePath
compileStub dflags mod location = do
- let (o_base, o_ext) = splitFilename (ml_obj_file location)
- stub_o = o_base ++ "_stub" `joinFileExt` o_ext
+ let (o_base, o_ext) = splitExtension (ml_obj_file location)
+ stub_o = (o_base ++ "_stub") <.> o_ext
-- compile the _stub.c file w/ gcc
let (stub_c,_,_) = mkStubPaths dflags (moduleName mod) location
runPipeline stop_phase dflags0 (input_fn, mb_phase) mb_basename output maybe_loc
= do
let
- (input_basename, suffix) = splitFilename input_fn
+ (input_basename, suffix) = splitExtension input_fn
+ suffix' = drop 1 suffix -- strip off the .
basename | Just b <- mb_basename = b
| otherwise = input_basename
dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }
-- If we were given a -x flag, then use that phase to start from
- start_phase = fromMaybe (startPhase suffix) mb_phase
+ start_phase = fromMaybe (startPhase suffix') mb_phase
-- We want to catch cases of "you can't get there from here" before
-- we start the pipeline, because otherwise it will just run off the
-- Execute the pipeline...
(dflags', output_fn, maybe_loc) <-
pipeLoop dflags start_phase stop_phase input_fn
- basename suffix get_output_fn maybe_loc
+ basename suffix' get_output_fn maybe_loc
-- Sometimes, a compilation phase doesn't actually generate any output
-- (eg. the CPP phase when -fcpp is not turned on). If we end on this
| StopLn <- next_phase = return odir_persistent
| otherwise = return persistent
- persistent = basename `joinFileExt` suffix
+ persistent = basename <.> suffix
odir_persistent
| Just loc <- maybe_location = ml_obj_file loc
- | Just d <- odir = d `joinFileName` persistent
+ | Just d <- odir = d </> persistent
| otherwise = persistent
runPhase (Cpp sf) _stop dflags0 basename suff input_fn get_output_fn maybe_loc
= do src_opts <- getOptionsFromFile input_fn
(dflags,unhandled_flags) <- parseDynamicFlags dflags0 (map unLoc src_opts)
- checkProcessArgsResult unhandled_flags (basename `joinFileExt` suff)
+ checkProcessArgsResult unhandled_flags (basename <.> suff)
if not (dopt Opt_Cpp dflags) then
-- no need to preprocess CPP, just pass input file along
return (Hsc sf, dflags, maybe_loc, input_fn)
else do
let hspp_opts = getOpts dflags opt_F
- let orig_fn = basename `joinFileExt` suff
+ let orig_fn = basename <.> suff
output_fn <- get_output_fn dflags (Hsc sf) maybe_loc
SysTools.runPp dflags
( [ SysTools.Option orig_fn
-- we add the current directory (i.e. the directory in which
-- the .hs files resides) to the include path, since this is
-- what gcc does, and it's probably what you want.
- let current_dir = directoryOf basename
+ let current_dir = case takeDirectory basename of
+ "" -> "." -- XXX Hack
+ d -> d
paths = includePaths dflags0
dflags = dflags0 { includePaths = current_dir : paths }
; return (Nothing, mkModuleName m, [], []) }
_ -> do { buf <- hGetStringBuffer input_fn
- ; (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename `joinFileExt` suff)
+ ; (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
; return (Just buf, mod_name, imps, src_imps) }
-- Build a ModLocation to pass to hscMain.
-- changed (which the compiler itself figures out).
-- Setting source_unchanged to False tells the compiler that M.o is out of
-- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
- src_timestamp <- getModificationTime (basename `joinFileExt` suff)
+ src_timestamp <- getModificationTime (basename <.> suff)
let force_recomp = dopt Opt_ForceRecomp dflags
source_unchanged <-
-- we create directories for the object file, because it
-- might be a hierarchical module.
- createDirectoryHierarchy (directoryOf output_fn)
+ createDirectoryHierarchy (takeDirectory output_fn)
SysTools.runAs dflags
(map SysTools.Option as_opts
runPhase SplitAs _stop dflags _basename _suff _input_fn get_output_fn maybe_loc
- = do
- output_fn <- get_output_fn dflags StopLn maybe_loc
-
- let (base_o, _) = splitFilename output_fn
- split_odir = base_o ++ "_split"
- osuf = objectSuf dflags
-
- createDirectoryHierarchy split_odir
-
- -- remove M_split/ *.o, because we're going to archive M_split/ *.o
- -- later and we don't want to pick up any old objects.
- fs <- getDirectoryContents split_odir
- mapM_ removeFile $ map (split_odir `joinFileName`)
- $ filter (osuf `isSuffixOf`) fs
-
- let as_opts = getOpts dflags opt_a
-
- (split_s_prefix, n) <- readIORef v_Split_info
-
- let split_s n = split_s_prefix ++ "__" ++ show n `joinFileExt` "s"
- split_obj n = split_odir `joinFileName`
- filenameOf base_o ++ "__" ++ show n
- `joinFileExt` osuf
-
- let assemble_file n
- = SysTools.runAs dflags
- (map SysTools.Option as_opts ++
- [ SysTools.Option "-c"
- , SysTools.Option "-o"
- , SysTools.FileOption "" (split_obj n)
- , SysTools.FileOption "" (split_s n)
- ])
-
- mapM_ assemble_file [1..n]
-
- -- and join the split objects into a single object file:
- let ld_r args = SysTools.runLink dflags ([
- SysTools.Option "-nostdlib",
- SysTools.Option "-nodefaultlibs",
- SysTools.Option "-Wl,-r",
- SysTools.Option ld_x_flag,
- SysTools.Option "-o",
- SysTools.FileOption "" output_fn ] ++ args)
+ = do
+ output_fn <- get_output_fn dflags StopLn maybe_loc
+
+ let base_o = dropExtension output_fn
+ split_odir = base_o ++ "_split"
+ osuf = objectSuf dflags
+
+ createDirectoryHierarchy split_odir
+
+ -- remove M_split/ *.o, because we're going to archive M_split/ *.o
+ -- later and we don't want to pick up any old objects.
+ fs <- getDirectoryContents split_odir
+ mapM_ removeFile $ map (split_odir </>) $ filter (osuf `isSuffixOf`) fs
+
+ let as_opts = getOpts dflags opt_a
+
+ (split_s_prefix, n) <- readIORef v_Split_info
+
+ let split_s n = split_s_prefix ++ "__" ++ show n <.> "s"
+ split_obj n = split_odir </>
+ takeFileName base_o ++ "__" ++ show n <.> osuf
+
+ let assemble_file n
+ = SysTools.runAs dflags
+ (map SysTools.Option as_opts ++
+ [ SysTools.Option "-c"
+ , SysTools.Option "-o"
+ , SysTools.FileOption "" (split_obj n)
+ , SysTools.FileOption "" (split_s n)
+ ])
+
+ mapM_ assemble_file [1..n]
+
+ -- and join the split objects into a single object file:
+ let ld_r args = SysTools.runLink dflags ([
+ SysTools.Option "-nostdlib",
+ SysTools.Option "-nodefaultlibs",
+ SysTools.Option "-Wl,-r",
+ SysTools.Option ld_x_flag,
+ SysTools.Option "-o",
+ SysTools.FileOption "" output_fn ] ++ args)
ld_x_flag | null cLD_X = ""
- | otherwise = "-Wl,-x"
+ | otherwise = "-Wl,-x"
- if cLdIsGNULd == "YES"
- then do
- let script = split_odir `joinFileName` "ld.script"
- writeFile script $
- "INPUT(" ++ unwords (map split_obj [1..n]) ++ ")"
- ld_r [SysTools.FileOption "" script]
- else do
- ld_r (map (SysTools.FileOption "" . split_obj) [1..n])
+ if cLdIsGNULd == "YES"
+ then do
+ let script = split_odir </> "ld.script"
+ writeFile script $
+ "INPUT(" ++ unwords (map split_obj [1..n]) ++ ")"
+ ld_r [SysTools.FileOption "" script]
+ else do
+ ld_r (map (SysTools.FileOption "" . split_obj) [1..n])
- return (StopLn, dflags, maybe_loc, output_fn)
+ return (StopLn, dflags, maybe_loc, output_fn)
-- warning suppression
runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc =
exeFileName :: DynFlags -> FilePath
exeFileName dflags
- | Just s <- outputFile dflags =
+ | Just s <- outputFile dflags =
#if defined(mingw32_HOST_OS)
- if null (suffixOf s)
- then s `joinFileExt` "exe"
+ if null (takeExtension s)
+ then s <.> "exe"
else s
#else
s
maybeCreateManifest dflags exe_filename = do
if not (dopt Opt_GenManifest dflags) then return [] else do
- let manifest_filename = exe_filename `joinFileExt` "manifest"
+ let manifest_filename = exe_filename <.> "manifest"
writeFile manifest_filename $
"<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++
" <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++
" <assemblyIdentity version=\"1.0.0.0\"\n"++
" processorArchitecture=\"X86\"\n"++
- " name=\"" ++ basenameOf exe_filename ++ "\"\n"++
+ " name=\"" ++ dropExtension exe_filename ++ "\"\n"++
" type=\"win32\"/>\n\n"++
" <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++
" <security>\n"++
++ map SysTools.Option (
md_c_flags
++ o_files
- ++ [ "-undefined", "dynamic_lookup", "-single_module", "-Wl,-macosx_version_min","-Wl,10.3", "-install_name " ++ (pwd `joinFileName` output_fn) ]
+ ++ [ "-undefined", "dynamic_lookup", "-single_module", "-Wl,-macosx_version_min","-Wl,10.3", "-install_name " ++ (pwd </> output_fn) ]
++ extra_ld_inputs
++ lib_path_opts
++ extra_ld_opts
#endif
import Data.Char
+import System.FilePath
import System.IO ( hPutStrLn, stderr )
-- -----------------------------------------------------------------------------
setTmpDir dir dflags = dflags{ tmpDir = canonicalise dir }
where
#if !defined(mingw32_HOST_OS)
- canonicalise p = normalisePath p
+ canonicalise p = normalise p
#else
- -- Canonicalisation of temp path under win32 is a bit more
- -- involved: (a) strip trailing slash,
- -- (b) normalise slashes
- -- (c) just in case, if there is a prefix /cygdrive/x/, change to x:
- --
- canonicalise path = normalisePath (xltCygdrive (removeTrailingSlash path))
-
- -- if we're operating under cygwin, and TMP/TEMP is of
- -- the form "/cygdrive/drive/path", translate this to
- -- "drive:/path" (as GHC isn't a cygwin app and doesn't
- -- understand /cygdrive paths.)
- xltCygdrive path
- | "/cygdrive/" `isPrefixOf` path =
- case drop (length "/cygdrive/") path of
- drive:xs@('/':_) -> drive:':':xs
- _ -> path
- | otherwise = path
-
- -- strip the trailing backslash (awful, but we only do this once).
- removeTrailingSlash path =
- case last path of
- '/' -> init path
- '\\' -> init path
- _ -> path
+ -- Canonicalisation of temp path under win32 is a bit more
+ -- involved: (a) strip trailing slash,
+ -- (b) normalise slashes
+ -- (c) just in case, if there is a prefix /cygdrive/x/, change to x:
+ canonicalise path = removeTrailingSlash $ normalise $ xltCygdrive path
+
+ -- if we're operating under cygwin, and TMP/TEMP is of
+ -- the form "/cygdrive/drive/path", translate this to
+ -- "drive:/path" (as GHC isn't a cygwin app and doesn't
+ -- understand /cygdrive paths.)
+ cygdrivePrefix = [pathSeparator] ++ "/cygdrive/" ++ [pathSeparator]
+ xltCygdrive path = case maybePrefixMatch cygdrivePrefix path of
+ Just (drive:sep:xs))
+ | isPathSeparator sep -> drive:':':pathSeparator:xs
+ _ -> path
+
+ -- strip the trailing backslash (awful, but we only do this once).
+ removeTrailingSlash path
+ | isPathSeparator (last path) = init path
+ | othwerwise = path
#endif
-----------------------------------------------------------------------------
import Data.IORef ( IORef, writeIORef, readIORef, modifyIORef )
import Data.List
import System.Directory
+import System.FilePath
import System.IO
import Control.Monad
import System.Time ( ClockTime )
| path <- paths,
(ext,fn) <- exts,
let base | path == "." = basename
- | otherwise = path `joinFileName` basename
- file = base `joinFileExt` ext
+ | otherwise = path </> basename
+ file = base <.> ext
]
search [] = return (NotFound (map fst to_search) (Just (modulePackageId mod)))
mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt
-> FilePath -> BaseName -> IO ModLocation
mkHomeModLocationSearched dflags mod suff path basename = do
- mkHomeModLocation2 dflags mod (path `joinFileName` basename) suff
+ mkHomeModLocation2 dflags mod (path </> basename) suff
-- -----------------------------------------------------------------------------
-- Constructing a home module location
mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation
mkHomeModLocation dflags mod src_filename = do
- let (basename,extension) = splitFilename src_filename
+ let (basename,extension) = splitExtension src_filename
mkHomeModLocation2 dflags mod basename extension
mkHomeModLocation2 :: DynFlags
obj_fn <- mkObjPath dflags src_basename mod_basename
hi_fn <- mkHiPath dflags src_basename mod_basename
- return (ModLocation{ ml_hs_file = Just (src_basename `joinFileExt` ext),
+ return (ModLocation{ ml_hs_file = Just (src_basename <.> ext),
ml_hi_file = hi_fn,
ml_obj_file = obj_fn })
mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String
-> IO ModLocation
mkHiOnlyModLocation dflags hisuf path basename
- = do let full_basename = path `joinFileName` basename
+ = do let full_basename = path </> basename
obj_fn <- mkObjPath dflags full_basename basename
return ModLocation{ ml_hs_file = Nothing,
- ml_hi_file = full_basename `joinFileExt` hisuf,
+ ml_hi_file = full_basename <.> hisuf,
-- Remove the .hi-boot suffix from
-- hi_file, if it had one. We always
-- want the name of the real .hi file
odir = objectDir dflags
osuf = objectSuf dflags
- obj_basename | Just dir <- odir = dir `joinFileName` mod_basename
+ obj_basename | Just dir <- odir = dir </> mod_basename
| otherwise = basename
- return (obj_basename `joinFileExt` osuf)
+ return (obj_basename <.> osuf)
-- | Constructs the filename of a .hi file for a given source file.
-- Does /not/ check whether the .hi file exists
hidir = hiDir dflags
hisuf = hiSuf dflags
- hi_basename | Just dir <- hidir = dir `joinFileName` mod_basename
+ hi_basename | Just dir <- hidir = dir </> mod_basename
| otherwise = basename
- return (hi_basename `joinFileExt` hisuf)
+ return (hi_basename <.> hisuf)
-- -----------------------------------------------------------------------------
mkStubPaths dflags mod location
= let
- stubdir = stubDir dflags
+ stubdir = stubDir dflags
- mod_basename = moduleNameSlashes mod
+ mod_basename = dots_to_slashes (moduleNameString mod)
src_basename = basenameOf (expectJust "mkStubPaths"
(ml_hs_file location))
- stub_basename0
- | Just dir <- stubdir = dir `joinFileName` mod_basename
- | otherwise = src_basename
-
- stub_basename = stub_basename0 ++ "_stub"
-
- -- this is the filename we're going to use when
- -- #including the stub_h file from the .hc file.
- -- Without -stubdir, we just #include the basename
- -- (eg. for a module A.B, we #include "B_stub.h"),
- -- relying on the fact that we add an implicit -I flag
- -- for the directory in which the source file resides
- -- (see DriverPipeline.hs). With -stubdir, we
- -- #include "A/B.h", assuming that the user has added
- -- -I<dir> along with -stubdir <dir>.
- include_basename
- | Just _ <- stubdir = mod_basename
- | otherwise = filenameOf src_basename
+ stub_basename0
+ | Just dir <- stubdir = dir </> mod_basename
+ | otherwise = src_basename
+
+ stub_basename = stub_basename0 ++ "_stub"
+
+ -- this is the filename we're going to use when
+ -- #including the stub_h file from the .hc file.
+ -- Without -stubdir, we just #include the basename
+ -- (eg. for a module A.B, we #include "B_stub.h"),
+ -- relying on the fact that we add an implicit -I flag
+ -- for the directory in which the source file resides
+ -- (see DriverPipeline.hs). With -stubdir, we
+ -- #include "A/B.h", assuming that the user has added
+ -- -I<dir> along with -stubdir <dir>.
+ include_basename
+ | Just _ <- stubdir = mod_basename
+ | otherwise = takeFileName src_basename
in
- (stub_basename `joinFileExt` "c",
- stub_basename `joinFileExt` "h",
- (include_basename ++ "_stub") `joinFileExt` "h")
- -- the _stub.o filename is derived from the ml_obj_file.
+ (stub_basename <.> "c",
+ stub_basename <.> "h",
+ (include_basename ++ "_stub") <.> "h")
+ -- the _stub.o filename is derived from the ml_obj_file.
-- -----------------------------------------------------------------------------
-- findLinkable isn't related to the other stuff in here,
-- its modification time.
findObjectLinkable :: Module -> FilePath -> ClockTime -> IO Linkable
findObjectLinkable mod obj_fn obj_time = do
- let stub_fn = case splitFilename3 obj_fn of
- (dir, base, _ext) -> dir ++ "/" ++ base ++ "_stub.o"
+ let stub_fn = (dropExtension obj_fn ++ "_stub") <.> "o"
stub_exist <- doesFileExist stub_fn
if stub_exist
then return (LM obj_time mod [DotO obj_fn, DotO stub_fn])
else return (LM obj_time mod [DotO obj_fn])
-- -----------------------------------------------------------------------------
+-- Utils
+
+dots_to_slashes :: String -> String
+dots_to_slashes = map (\c -> if c == '.' then '/' else c)
+
+-- -----------------------------------------------------------------------------
-- Error messages
cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc
import Packages
import NameSet
import RdrName
-import HsSyn
+import qualified HsSyn -- hack as we want to reexport the whole module
+import HsSyn hiding ((<.>))
import Type hiding (typeKind)
import TcType hiding (typeKind)
import Id
import System.Time ( ClockTime, getClockTime )
import Control.Exception as Exception hiding (handle)
import Data.IORef
+import System.FilePath
import System.IO
import System.IO.Error ( try, isDoesNotExistError )
import Prelude hiding (init)
let isMain = (== mainModIs dflags) . ms_mod
[ms] <- return (filter isMain mod_graph)
ml_hs_file (ms_location ms)
- guessedName = fmap basenameOf mainModuleSrcPath
+ guessedName = fmap dropExtension mainModuleSrcPath
in
case outputFile dflags of
Just _ -> env
else do
return (Target (TargetModule (mkModuleName file)) Nothing)
where
- hs_file = file `joinFileExt` "hs"
- lhs_file = file `joinFileExt` "lhs"
+ hs_file = file <.> "hs"
+ lhs_file = file <.> "lhs"
-- -----------------------------------------------------------------------------
-- Extending the program scope
import System.Directory ( doesDirectoryExist )
import System.Environment
import System.Exit
+import System.FilePath
import Control.Monad
import Data.List
import Data.Maybe
-- To simplify the handling of filepaths, we normalise all filepaths right
-- away - e.g., for win32 platforms, backslashes are converted
-- into forward slashes.
- normal_fileish_paths = map normalisePath fileish_args
+ normal_fileish_paths = map normalise fileish_args
(srcs, objs) = partition_args normal_fileish_paths [] []
-- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on
import ErrUtils ( debugTraceMsg, putMsg, Message )
import System.Directory
+import System.FilePath
import Data.Maybe
import Control.Monad
import Data.List
-- to maintain the package database on systems with a package
-- management system, or systems that don't want to run ghc-pkg
-- to register or unregister packages. Undocumented feature for now.
- let system_pkgconf_dir = system_pkgconf ++ ".d"
+ let system_pkgconf_dir = system_pkgconf <.> "d"
system_pkgconf_dir_exists <- doesDirectoryExist system_pkgconf_dir
system_pkgconfs <-
if system_pkgconf_dir_exists
then do files <- getDirectoryContents system_pkgconf_dir
- return [ system_pkgconf_dir ++ '/' : file
+ return [ system_pkgconf_dir </> file
| file <- files
- , isSuffixOf ".conf" file]
+ , takeExtension file == ".conf" ]
else return []
-- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf)
appdir <- getAppUserDataDirectory "ghc"
let
pkgconf = appdir
- `joinFileName` (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
- `joinFileName` "package.conf"
+ </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
+ </> "package.conf"
flg <- doesFileExist pkgconf
if (flg && dopt Opt_ReadUserPackageConf dflags)
then return [pkgconf]
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
-- 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 </> cPROJECT_DIR </> dir </> pgm
; let pkgconfig_path
| am_installed = installed "package.conf"
; 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;
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
| EOF
#endif
-showOpt (FileOption pre f) = pre ++ platformPath f
+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
later, handleDyn, handle,
-- Filename utils
- Suffix,
- splitFilename, suffixOf, basenameOf, joinFileExt,
- splitFilenameDir, joinFileName,
- splitFilename3,
+ Suffix,
splitLongestPrefix,
- replaceFilenameSuffix, directoryOf, filenameOf,
- replaceFilenameDirectory,
- escapeSpaces, isPathSeparator,
+ escapeSpaces,
parseSearchPath,
- normalisePath, platformPath, pgmPath,
) where
#include "HsVersions.h"
import qualified Data.List as List ( notElem )
#endif
-import Control.Monad ( when )
+import Control.Monad ( unless )
import SYSTEM_IO_ERROR as IO ( catch, isDoesNotExistError )
import System.Directory ( doesDirectoryExist, createDirectory,
getModificationTime )
+import System.FilePath hiding ( searchPathSeparator )
import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit )
import Data.Ratio ( (%) )
import System.Time ( ClockTime )
-- Create a hierarchy of directories
createDirectoryHierarchy :: FilePath -> IO ()
+createDirectoryHierarchy dir | isDrive dir = return () -- XXX Hack
createDirectoryHierarchy dir = do
b <- doesDirectoryExist dir
- when (not b) $ do
- createDirectoryHierarchy (directoryOf dir)
+ unless b $ do
+ createDirectoryHierarchy (takeDirectory dir)
createDirectory dir
-----------------------------------------------------------------------------
-- Verify that the 'dirname' portion of a FilePath exists.
--
doesDirNameExist :: FilePath -> IO Bool
-doesDirNameExist fpath = doesDirectoryExist (directoryOf fpath)
+doesDirNameExist fpath = case takeDirectory fpath of
+ "" -> return True -- XXX Hack
+ dir -> doesDirectoryExist (takeDirectory fpath)
-- -----------------------------------------------------------------------------
-- Exception utils
then return Nothing
else ioError e
--- --------------------------------------------------------------
--- Filename manipulation
-
--- Filenames are kept "normalised" inside GHC, using '/' as the path
--- separator. On Windows these functions will also recognise '\\' as
--- the path separator, but will generally construct paths using '/'.
-
-type Suffix = String
-
-splitFilename :: String -> (String,Suffix)
-splitFilename f = splitLongestPrefix f (=='.')
-
-basenameOf :: FilePath -> String
-basenameOf = fst . splitFilename
-
-suffixOf :: FilePath -> Suffix
-suffixOf = snd . splitFilename
-
-joinFileExt :: String -> String -> FilePath
-joinFileExt path "" = path
-joinFileExt path ext = path ++ '.':ext
-
--- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy.ext")
-splitFilenameDir :: String -> (String,String)
-splitFilenameDir str
- = let (dir, rest) = splitLongestPrefix str isPathSeparator
- (dir', rest') | null rest = (".", dir)
- | otherwise = (dir, rest)
- in (dir', rest')
-
--- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
-splitFilename3 :: String -> (String,String,Suffix)
-splitFilename3 str
- = let (dir, rest) = splitFilenameDir str
- (name, ext) = splitFilename rest
- in (dir, name, ext)
-
-joinFileName :: String -> String -> FilePath
-joinFileName "" fname = fname
-joinFileName "." fname = fname
-joinFileName dir "" = dir
-joinFileName dir fname = dir ++ '/':fname
-
-- split a string at the last character where 'pred' is True,
-- returning a pair of strings. The first component holds the string
-- up (but not including) the last character for which 'pred' returned
where
(r_suf, r_pre) = break pred (reverse str)
-replaceFilenameSuffix :: FilePath -> Suffix -> FilePath
-replaceFilenameSuffix file suf = basenameOf file `joinFileExt` suf
-
--- directoryOf strips the filename off the input string, returning
--- the directory.
-directoryOf :: FilePath -> String
-directoryOf = fst . splitFilenameDir
-
--- filenameOf strips the directory off the input string, returning
--- the filename.
-filenameOf :: FilePath -> String
-filenameOf = snd . splitFilenameDir
-
-replaceFilenameDirectory :: FilePath -> String -> FilePath
-replaceFilenameDirectory path dir = dir `joinFileName` filenameOf path
-
escapeSpaces :: String -> String
escapeSpaces = foldr (\c s -> if isSpace c then '\\':c:s else c:s) ""
-isPathSeparator :: Char -> Bool
-isPathSeparator ch =
-#ifdef mingw32_TARGET_OS
- ch == '/' || ch == '\\'
-#else
- ch == '/'
-#endif
+type Suffix = String
--------------------------------------------------------------
-- * Search path
#else
searchPathSeparator = ':'
#endif
-
------------------------------------------------------------------------------
--- Convert filepath into platform / MSDOS form.
-
--- We maintain path names in Unix form ('/'-separated) right until
--- the last moment. On Windows we dos-ify them just before passing them
--- to the Windows command.
---
--- The alternative, of using '/' consistently on Unix and '\' on Windows,
--- proved quite awkward. There were a lot more calls to platformPath,
--- and even on Windows we might invoke a unix-like utility (eg 'sh'), which
--- interpreted a command line 'foo\baz' as 'foobaz'.
-
-normalisePath :: String -> String
--- Just changes '\' to '/'
-
-pgmPath :: String -- Directory string in Unix format
- -> String -- Program name with no directory separators
- -- (e.g. copy /y)
- -> String -- Program invocation string in native format
-
-#if defined(mingw32_HOST_OS)
---------------------- Windows version ------------------
-normalisePath xs = subst '\\' '/' xs
-pgmPath dir pgm = platformPath dir ++ '\\' : pgm
-platformPath p = subst '/' '\\' p
-
-subst a b ls = map (\ x -> if x == a then b else x) ls
-#else
---------------------- Non-Windows version --------------
-normalisePath xs = xs
-pgmPath dir pgm = dir ++ '/' : pgm
-platformPath stuff = stuff
---------------------------------------------------------
-#endif
\end{code}