From 7eb5e29b4a7b6fef55512bc7bf3308e712ca3eba Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Sat, 12 Jan 2008 15:44:59 +0000 Subject: [PATCH] Use System.FilePath --- compiler/ghci/InteractiveUI.hs | 2 +- compiler/ghci/Linker.lhs | 19 ++--- compiler/iface/MkIface.lhs | 3 +- compiler/main/CodeOutput.lhs | 3 +- compiler/main/DriverMkDepend.hs | 7 +- compiler/main/DriverPhases.hs | 21 +++--- compiler/main/DriverPipeline.hs | 153 ++++++++++++++++++++------------------- compiler/main/DynFlags.hs | 47 ++++++------ compiler/main/Finder.lhs | 80 ++++++++++---------- compiler/main/GHC.hs | 10 ++- compiler/main/Main.hs | 3 +- compiler/main/Packages.lhs | 11 +-- compiler/main/SysTools.lhs | 38 +++++----- compiler/utils/Util.lhs | 124 +++---------------------------- 14 files changed, 220 insertions(+), 301 deletions(-) diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index a0c76ec..11c57aa 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -264,7 +264,7 @@ findEditor = do `IO.catch` \_ -> do #if mingw32_HOST_OS win <- System.Win32.getWindowsDirectory - return (win `joinFileName` "notepad.exe") + return (win "notepad.exe") #else return "" #endif diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index 272d571..5ab7416 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -73,6 +73,7 @@ import Data.IORef import Data.List import Foreign +import System.FilePath import System.IO import System.Directory @@ -657,7 +658,7 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods 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 $ @@ -1080,8 +1081,8 @@ locateOneObj dirs lib 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. @@ -1096,8 +1097,8 @@ locateOneObj dirs lib 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 -- ---------------------------------------------------------------------------- @@ -1112,16 +1113,16 @@ loadDynamic paths rootname -- 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 @@ -1141,7 +1142,7 @@ loadFramework extraPaths rootname -- 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 diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index a7bf168..43bae8f 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -233,6 +233,7 @@ import ListSetOps import Control.Monad import Data.List import Data.IORef +import System.FilePath \end{code} @@ -465,7 +466,7 @@ mkIface_ hsc_env maybe_old_iface ----------------------------- 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 diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index e7e818f..d6e1309 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -39,6 +39,7 @@ import Distribution.Package ( showPackageId ) import Directory ( doesFileExist ) import Monad ( when ) import IO +import System.FilePath \end{code} %************************************************************************ @@ -235,7 +236,7 @@ outputForeignStubs dflags mod location stubs 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 diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index a97101b..aad9b8a 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -22,7 +22,7 @@ module DriverMkDepend ( 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 @@ -42,6 +42,7 @@ import Data.IORef ( IORef, readIORef, writeIORef ) 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 ) @@ -272,9 +273,9 @@ insertSuffixes -- 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 ----------------------------------------------------------------- diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs index 5efb46f..99f6089 100644 --- a/compiler/main/DriverPhases.hs +++ b/compiler/main/DriverPhases.hs @@ -40,8 +40,8 @@ module DriverPhases ( isSourceFilename -- :: FilePath -> Bool ) where -import Util ( suffixOf ) import Panic ( panic ) +import System.FilePath ----------------------------------------------------------------------------- -- Phases @@ -220,17 +220,18 @@ isCishSuffix s = s `elem` cish_suffixes 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) diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 6c86cbf..ef2c239 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -50,6 +50,7 @@ import Control.Exception as Exception 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 @@ -57,6 +58,7 @@ import Data.List ( isSuffixOf ) import Data.Maybe import System.Exit import System.Environment +import System.FilePath -- --------------------------------------------------------------------------- -- Pre-process @@ -103,12 +105,14 @@ compile hsc_env summary mod_index nmods mb_old_iface maybe_old_linkable 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 } @@ -227,8 +231,8 @@ compile hsc_env summary mod_index nmods mb_old_iface maybe_old_linkable 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 @@ -420,7 +424,8 @@ runPipeline 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 @@ -428,7 +433,7 @@ runPipeline stop_phase dflags0 (input_fn, mb_phase) mb_basename output maybe_loc 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 @@ -449,7 +454,7 @@ runPipeline stop_phase dflags0 (input_fn, mb_phase) mb_basename output maybe_loc -- 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 @@ -538,11 +543,11 @@ getOutputFilename stop_phase output basename | 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 @@ -599,7 +604,7 @@ runPhase (Unlit sf) _stop dflags _basename _suff input_fn get_output_fn maybe_lo 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 @@ -620,7 +625,7 @@ runPhase (HsPp sf) _stop dflags basename suff input_fn get_output_fn maybe_loc 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 @@ -642,7 +647,9 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma -- 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 } @@ -655,7 +662,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma ; 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. @@ -699,7 +706,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma -- 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 <- @@ -970,7 +977,7 @@ runPhase As _stop dflags _basename _suff input_fn get_output_fn maybe_loc -- 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 @@ -995,62 +1002,60 @@ runPhase As _stop dflags _basename _suff input_fn get_output_fn maybe_loc 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 = @@ -1279,10 +1284,10 @@ linkBinary dflags o_files dep_packages = do 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 @@ -1305,14 +1310,14 @@ maybeCreateManifest _ _ = do 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 $ "\n"++ " \n"++ " \n\n"++ " \n"++ " \n"++ @@ -1433,7 +1438,7 @@ linkDynLib dflags o_files dep_packages = do ++ 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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 2afa91d..7d692ec 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -93,6 +93,7 @@ import Util ( split ) #endif import Data.Char +import System.FilePath import System.IO ( hPutStrLn, stderr ) -- ----------------------------------------------------------------------------- @@ -1573,32 +1574,28 @@ setTmpDir :: FilePath -> DynFlags -> DynFlags 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 ----------------------------------------------------------------------------- diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs index 206d118..61bf196 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.lhs @@ -42,6 +42,7 @@ import Maybes ( expectJust ) 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 ) @@ -346,8 +347,8 @@ searchPathExts paths mod exts | 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))) @@ -360,7 +361,7 @@ searchPathExts paths mod exts 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 @@ -397,7 +398,7 @@ mkHomeModLocationSearched dflags mod suff path basename = do 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 @@ -411,17 +412,17 @@ mkHomeModLocation2 dflags mod src_basename ext = do 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 @@ -441,10 +442,10 @@ mkObjPath dflags basename mod_basename 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 @@ -458,10 +459,10 @@ mkHiPath dflags basename mod_basename 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) -- ----------------------------------------------------------------------------- @@ -478,35 +479,35 @@ mkStubPaths 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 along with -stubdir . - 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 along with -stubdir . + 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, @@ -524,14 +525,19 @@ findObjectLinkableMaybe mod locn -- 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 diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index c44cc83..ec62de5 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -218,7 +218,8 @@ import TcRnMonad ( initIfaceCheck ) 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 @@ -277,6 +278,7 @@ import System.Exit ( exitWith, ExitCode(..) ) 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) @@ -395,7 +397,7 @@ guessOutputFile s = modifySession s $ \env -> 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 @@ -456,8 +458,8 @@ guessTarget file Nothing 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 diff --git a/compiler/main/Main.hs b/compiler/main/Main.hs index f96b085..7c77caf 100644 --- a/compiler/main/Main.hs +++ b/compiler/main/Main.hs @@ -54,6 +54,7 @@ import System.IO import System.Directory ( doesDirectoryExist ) import System.Environment import System.Exit +import System.FilePath import Control.Monad import Data.List import Data.Maybe @@ -147,7 +148,7 @@ main = -- 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 diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 0b77983..d5cfbd1 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -66,6 +66,7 @@ import FastString import ErrUtils ( debugTraceMsg, putMsg, Message ) import System.Directory +import System.FilePath import Data.Maybe import Control.Monad import Data.List @@ -210,14 +211,14 @@ getSystemPackageConfigs dflags = do -- 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) @@ -228,8 +229,8 @@ getSystemPackageConfigs dflags = do 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] diff --git a/compiler/main/SysTools.lhs b/compiler/main/SysTools.lhs index f5812f4..41421d6 100644 --- a/compiler/main/SysTools.lhs +++ b/compiler/main/SysTools.lhs @@ -29,7 +29,6 @@ module SysTools ( touch, -- String -> String -> IO () copy, copyWithHeader, - normalisePath, -- FilePath -> FilePath getExtraViaCOpts, -- Temporary-file management @@ -58,6 +57,7 @@ import Data.IORef import Control.Monad import System.Exit import System.Environment +import System.FilePath import System.IO import SYSTEM_IO_ERROR as IO import System.Directory @@ -172,10 +172,9 @@ initSysTools mbMinusB dflags -- 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" @@ -281,9 +280,9 @@ initSysTools mbMinusB dflags ; 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, []) @@ -374,14 +373,14 @@ findTopDir mbMinusB = 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; @@ -573,7 +572,7 @@ copyWithHeader dflags purpose maybe_header from to = do 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} @@ -621,11 +620,11 @@ newTempName dflags extn 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 @@ -862,7 +861,7 @@ data BuildMessage | 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 () @@ -908,7 +907,12 @@ getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32. 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 diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 6cefad6..862b46a 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -73,16 +73,10 @@ module Util ( 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" @@ -106,10 +100,11 @@ import qualified Data.List as List ( elem ) 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 ) @@ -761,17 +756,20 @@ readRational top_s -- 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 @@ -796,49 +794,6 @@ modificationTimeIfExists f = do 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 @@ -856,32 +811,10 @@ splitLongestPrefix str pred 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 @@ -916,39 +849,4 @@ searchPathSeparator = ';' #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} -- 1.7.10.4