X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Futils%2Fghc-pkg%2FMain.hs;h=1b5f8f75dd509843bc5d01a9c6cda1cb3822b63d;hb=153b9cb9b11e05c4edb1b6bc0a7b972660e41f70;hp=572ecdbf92e43043da4e71ed1491aac801e65c8a;hpb=c10be2dbaf3c3a4137b15ffa582126543b783e44;p=ghc-hetmet.git diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs index 572ecdb..1b5f8f7 100644 --- a/ghc/utils/ghc-pkg/Main.hs +++ b/ghc/utils/ghc-pkg/Main.hs @@ -9,7 +9,6 @@ -- TODO: -- - validate modules --- - expose/hide -- - expanding of variables in new-style package conf -- - version manipulation (checking whether old version exists, -- hiding old version?) @@ -19,20 +18,17 @@ module Main (main) where import Version ( version, targetOS, targetARCH ) import Distribution.InstalledPackageInfo import Distribution.Compat.ReadP +import Distribution.ParseUtils ( showError, ParseResult(..) ) import Distribution.Package -import Distribution.License import Distribution.Version -import Compat.Directory ( getAppUserDataDirectory ) +import Compat.Directory ( getAppUserDataDirectory, createDirectoryIfMissing ) +import Compat.RawSystem ( rawSystem ) import Control.Exception ( evaluate ) import qualified Control.Exception as Exception import Prelude -import Package -- the old package config type - -#if __GLASGOW_HASKELL__ < 603 -#include "config.h" -#endif +#include "../../includes/ghcconfig.h" #if __GLASGOW_HASKELL__ >= 504 import System.Console.GetOpt @@ -47,16 +43,11 @@ import qualified Exception import Data.Char ( isSpace ) import Monad import Directory -import System ( getEnv, getArgs, getProgName, - system, exitWith, - ExitCode(..) +import System ( getArgs, getProgName, + exitWith, ExitCode(..) ) -import IO -import List ( isPrefixOf, isSuffixOf ) - -import ParsePkgConfLite - -#include "../../includes/ghcconfig.h" +import System.IO +import Data.List ( isPrefixOf, isSuffixOf, intersperse ) #ifdef mingw32_HOST_OS import Foreign @@ -81,7 +72,7 @@ main = do bye (usageInfo (usageHeader prog) flags) (cli,_,[]) | FlagVersion `elem` cli -> bye ourCopyright - (cli@(_:_),nonopts,[]) -> + (cli,nonopts,[]) -> runit cli nonopts (_,_,errors) -> tryOldCmdLine errors args @@ -108,6 +99,7 @@ data Flag | FlagConfig FilePath | FlagGlobalConfig FilePath | FlagForce + | FlagAutoGHCiLibs deriving Eq flags :: [OptDescr Flag] @@ -122,6 +114,8 @@ flags = [ "location of the global package config", Option [] ["force"] (NoArg FlagForce) "ignore missing dependencies, directories, and libraries", + Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs) + "automatically build libs for GHCi (with register)", Option ['?'] ["help"] (NoArg FlagHelp) "display this help and exit", Option ['V'] ["version"] (NoArg FlagVersion) @@ -134,14 +128,15 @@ ourCopyright = "GHC package manager version " ++ version ++ "\n" usageHeader :: String -> String usageHeader prog = substProg prog $ "Usage:\n" ++ - " $p {--help | -?}\n" ++ - " Produce this usage message.\n" ++ - "\n" ++ - " $p register {filename | -} [--user | --global]\n" ++ + " $p register {filename | -}\n" ++ " Register the package using the specified installed package\n" ++ " description. The syntax for the latter is given in the $p\n" ++ " documentation.\n" ++ "\n" ++ + " $p update {filename | -}\n" ++ + " Register the package, overwriting any other package with the\n" ++ + " same name.\n" ++ + "\n" ++ " $p unregister {pkg-id}\n" ++ " Unregister the specified package.\n" ++ "\n" ++ @@ -151,7 +146,7 @@ usageHeader prog = substProg prog $ " $p hide {pkg-id}\n" ++ " Hide the specified package.\n" ++ "\n" ++ - " $p list [--global | --user]\n" ++ + " $p list\n" ++ " List all registered packages, both global and user (unless either\n" ++ " --global or --user is specified), and both hidden and exposed.\n" ++ "\n" ++ @@ -162,7 +157,9 @@ usageHeader prog = substProg prog $ "\n" ++ " $p field {pkg-id} {field}\n" ++ " Extract the specified field of the package description for the\n" ++ - " specified package.\n" + " specified package.\n" ++ + "\n" ++ + " The following optional flags are also accepted:\n" substProg :: String -> String -> String substProg _ [] = [] @@ -179,16 +176,17 @@ runit cli nonopts = do db_stack <- mapM readParseDatabase dbs let force = FlagForce `elem` cli + auto_ghci_libs = FlagAutoGHCiLibs `elem` cli -- -- first, parse the command case nonopts of ["register", filename] -> - registerPackage filename [] db_stack False False force + registerPackage filename [] db_stack auto_ghci_libs False force ["update", filename] -> - registerPackage filename [] db_stack False True force + registerPackage filename [] db_stack auto_ghci_libs True force ["unregister", pkgid_str] -> do pkgid <- readPkgId pkgid_str - unregisterPackage db_stack pkgid + unregisterPackage pkgid db_stack ["expose", pkgid_str] -> do pkgid <- readPkgId pkgid_str exposePackage pkgid db_stack @@ -212,8 +210,8 @@ runit cli nonopts = do parseCheck :: ReadP a a -> String -> String -> IO a parseCheck parser str what = - case readP_to_S parser str of - [(x,ys)] | all isSpace ys -> return x + case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of + [x] -> return x _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what) readPkgId :: String -> IO PackageIdentifier @@ -262,11 +260,12 @@ getPkgDatabases flags = do let subdir = targetARCH ++ '-':targetOS ++ '-':version - user_conf = appdir `joinFileName` subdir `joinFileName` "package.conf" + archdir = appdir `joinFileName` subdir + user_conf = archdir `joinFileName` "package.conf" b <- doesFileExist user_conf when (not b) $ do putStrLn ("Creating user package database in " ++ user_conf) - createParents user_conf + createDirectoryIfMissing True archdir writeFile user_conf emptyPackageConfig let @@ -290,7 +289,7 @@ readParseDatabase filename = do let packages = read str evaluate packages `Exception.catch` \_ -> - die (filename ++ ": parse error in package config file\n") + die (filename ++ ": parse error in package config file") return (filename,packages) emptyPackageConfig :: String @@ -308,7 +307,7 @@ registerPackage :: FilePath -> IO () registerPackage input defines db_stack auto_ghci_libs update force = do let - db_to_operate_on = head db_stack + db_to_operate_on = my_head "db" db_stack db_filename = fst db_to_operate_on -- checkConfigAccess db_filename @@ -319,14 +318,14 @@ registerPackage input defines db_stack auto_ghci_libs update force = do putStr "Reading package info from stdin... " getContents f -> do - putStr ("Reading package info from " ++ show f) + putStr ("Reading package info from " ++ show f ++ " ") readFile f pkg <- parsePackageInfo s defines force putStrLn "done." validatePackageConfig pkg db_stack auto_ghci_libs update force - new_details <- updatePackageDB (snd db_to_operate_on) pkg + new_details <- updatePackageDB db_stack (snd db_to_operate_on) pkg savePackageConfig db_filename maybeRestoreOldConfig db_filename $ writeNewConfig db_filename new_details @@ -338,96 +337,44 @@ parsePackageInfo -> IO InstalledPackageInfo parsePackageInfo str defines force = case parseInstalledPackageInfo str of - Right ok -> return ok - Left err -> do - old_pkg <- evaluate (parseOnePackageConfig str) - `Exception.catch` \_ -> parse_failed - putStr "Expanding embedded variables... " - new_old_pkg <- expandEnvVars old_pkg defines force - return (convertOldPackage old_pkg) - where - parse_failed = die "parse error in package info\n" - -convertOldPackage :: PackageConfig -> InstalledPackageInfo -convertOldPackage - Package { - name = name, - auto = auto, - import_dirs = import_dirs, - source_dirs = source_dirs, - library_dirs = library_dirs, - hs_libraries = hs_libraries, - extra_libraries = extra_libraries, - include_dirs = include_dirs, - c_includes = c_includes, - package_deps = package_deps, - extra_ghc_opts = extra_ghc_opts, - extra_cc_opts = extra_cc_opts, - extra_ld_opts = extra_ld_opts, - framework_dirs = framework_dirs, - extra_frameworks= extra_frameworks - } - = InstalledPackageInfo { - package = pkgNameToId name, - license = AllRightsReserved, - copyright = "", - maintainer = "", - author = "", - stability = "", - homepage = "", - pkgUrl = "", - description = "", - category = "", - exposed = auto, - exposedModules = [], - hiddenModules = [], - importDirs = import_dirs, - libraryDirs = library_dirs, - hsLibraries = hs_libraries, - extraLibraries = extra_libraries, - includeDirs = include_dirs, - includes = c_includes, - depends = map pkgNameToId package_deps, - extraHugsOpts = [], - extraCcOpts = extra_cc_opts, - extraLdOpts = extra_ld_opts, - frameworkDirs = framework_dirs, - extraFrameworks = extra_frameworks, - haddockInterfaces = [], - haddockHTMLs = [] - } - - --- Used for converting old versionless package names to new PackageIdentifiers. --- "Version [] []" is special: it means "no version" or "any version" + ParseOk ok -> return ok + ParseFailed err -> die (showError err) + +-- Used for converting versionless package names to new +-- PackageIdentifiers. "Version [] []" is special: it means "no +-- version" or "any version" pkgNameToId :: String -> PackageIdentifier pkgNameToId name = PackageIdentifier name (Version [] []) -- ----------------------------------------------------------------------------- --- Unregistering - -unregisterPackage :: PackageDBStack -> PackageIdentifier -> IO () -unregisterPackage [] _ = error "unregisterPackage" -unregisterPackage ((db_name, pkgs) : _) pkgid = do - checkConfigAccess db_name - when (pkgid `notElem` map package pkgs) - (die (db_name ++ ": package '" ++ showPackageId pkgid - ++ "' not found\n")) - savePackageConfig db_name - maybeRestoreOldConfig db_name $ - writeNewConfig db_name (filter ((/= pkgid) . package) pkgs) - --- ----------------------------------------------------------------------------- --- Exposing +-- Exposing, Hiding, Unregistering are all similar exposePackage :: PackageIdentifier -> PackageDBStack -> IO () -exposePackage = error "TODO" - --- ----------------------------------------------------------------------------- --- Hiding +exposePackage = modifyPackage (\p -> [p{exposed=True}]) hidePackage :: PackageIdentifier -> PackageDBStack -> IO () -hidePackage = error "TODO" +hidePackage = modifyPackage (\p -> [p{exposed=False}]) + +unregisterPackage :: PackageIdentifier -> PackageDBStack -> IO () +unregisterPackage = modifyPackage (\p -> []) + +modifyPackage + :: (InstalledPackageInfo -> [InstalledPackageInfo]) + -> PackageIdentifier + -> PackageDBStack + -> IO () +modifyPackage _ _ [] = error "modifyPackage" +modifyPackage fn pkgid ((db_name, pkgs) : _) = do + checkConfigAccess db_name + p <- findPackage [(db_name,pkgs)] pkgid + let pid = package p + savePackageConfig db_name + let new_config = concat (map modify pkgs) + modify pkg + | package pkg == pid = fn pkg + | otherwise = [pkg] + maybeRestoreOldConfig db_name $ + writeNewConfig db_name new_config -- ----------------------------------------------------------------------------- -- Listing packages @@ -440,8 +387,10 @@ listPackages db_confs = do text (db_name ++ ":") $$ nest 4 packages ) where packages = fsep (punctuate comma (map pp_pkg pkg_confs)) - pp_pkg = text . showPackageId . package - + pp_pkg p + | exposed p = doc + | otherwise = parens doc + where doc = text (showPackageId (package p)) -- ----------------------------------------------------------------------------- -- Describe @@ -453,12 +402,21 @@ describePackage db_stack pkgid = do findPackage :: PackageDBStack -> PackageIdentifier -> IO InstalledPackageInfo findPackage db_stack pkgid - = case [ p | p <- all_pkgs, pkgid == package p ] of - [] -> die ("cannot find package " ++ showPackageId pkgid) - (p:ps) -> return p + = case [ p | p <- all_pkgs, pkgid `matches` p ] of + [] -> die ("cannot find package " ++ showPackageId pkgid) + [p] -> return p + ps -> die ("package " ++ showPackageId pkgid ++ + " matches multiple packages: " ++ + concat (intersperse ", " ( + map (showPackageId.package) ps))) where all_pkgs = concat (map snd db_stack) +matches :: PackageIdentifier -> InstalledPackageInfo -> Bool +pid `matches` p = + pid == package p || + not (realVersion pid) && pkgName pid == pkgName (package p) + -- ----------------------------------------------------------------------------- -- Field @@ -496,7 +454,7 @@ checkConfigAccess :: FilePath -> IO () checkConfigAccess filename = do access <- getPermissions filename when (not (writable access)) - (die (filename ++ ": you don't have permission to modify this file\n")) + (die (filename ++ ": you don't have permission to modify this file")) maybeRestoreOldConfig :: FilePath -> IO () -> IO () maybeRestoreOldConfig filename io @@ -573,7 +531,7 @@ checkDuplicates db_stack pkg update = do -- Check whether this package id already exists in this DB -- when (not update && (package pkg `elem` map package pkgs)) $ - die ("package " ++ showPackageId pkgid ++ " is already installed\n") + die ("package " ++ showPackageId pkgid ++ " is already installed") -- -- if we are exposing this new package, then check that -- there are no other exposed packages with the same name. @@ -581,46 +539,49 @@ checkDuplicates db_stack pkg update = do when (not update && exposed pkg && not (null exposed_pkgs_with_same_name)) $ die ("trying to register " ++ showPackageId pkgid ++ " as exposed, but " - ++ showPackageId (package (head exposed_pkgs_with_same_name)) + ++ showPackageId (package (my_head "when" exposed_pkgs_with_same_name)) ++ " is also exposed.") checkDir :: Bool -> String -> IO () checkDir force d - | "$libdir" `isPrefixOf` d = return () - -- can't check this, because we don't know what $libdir is + | "$topdir" `isPrefixOf` d = return () + -- can't check this, because we don't know what $topdir is | otherwise = do there <- doesDirectoryExist d when (not there) - (dieOrForce force (d ++ " doesn't exist or isn't a directory\n")) + (dieOrForce force (d ++ " doesn't exist or isn't a directory")) checkDep :: PackageDBStack -> Bool -> PackageIdentifier -> IO () checkDep db_stack force pkgid | real_version && pkgid `elem` pkgids = return () | not real_version && pkgName pkgid `elem` pkg_names = return () | otherwise = dieOrForce force ("dependency " ++ showPackageId pkgid - ++ " doesn't exist\n") + ++ " doesn't exist") where -- for backwards compat, we treat 0.0 as a special version, -- and don't check that it actually exists. - real_version = versionBranch (pkgVersion pkgid) /= [] + real_version = realVersion pkgid all_pkgs = concat (map snd db_stack) pkgids = map package all_pkgs pkg_names = map pkgName pkgids +realVersion :: PackageIdentifier -> Bool +realVersion pkgid = versionBranch (pkgVersion pkgid) /= [] + checkHSLib :: [String] -> Bool -> Bool -> String -> IO () checkHSLib dirs auto_ghci_libs force lib = do let batch_lib_file = "lib" ++ lib ++ ".a" bs <- mapM (doesLibExistIn batch_lib_file) dirs case [ dir | (exists,dir) <- zip bs dirs, exists ] of - [] -> dieOrForce force ("cannot find `" ++ batch_lib_file ++ - "' on library path") + [] -> dieOrForce force ("cannot find " ++ batch_lib_file ++ + " on library path") (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs doesLibExistIn :: String -> String -> IO Bool doesLibExistIn lib d - | "$libdir" `isPrefixOf` d = return True + | "$topdir" `isPrefixOf` d = return True | otherwise = doesFileExist (d ++ '/':lib) checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO () @@ -629,7 +590,7 @@ checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build | otherwise = do bs <- mapM (doesLibExistIn ghci_lib_file) dirs case [dir | (exists,dir) <- zip bs dirs, exists] of - [] -> hPutStrLn stderr ("warning: can't find GHCi lib `" ++ ghci_lib_file ++ "'") + [] -> hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file) (_:_) -> return () where ghci_lib_file = lib ++ ".o" @@ -641,31 +602,51 @@ autoBuildGHCiLib :: String -> String -> String -> IO () autoBuildGHCiLib dir batch_file ghci_file = do let ghci_lib_file = dir ++ '/':ghci_file batch_lib_file = dir ++ '/':batch_file - hPutStr stderr ("building GHCi library `" ++ ghci_lib_file ++ "'...") -#ifdef darwin_TARGET_OS - system("ld -r -x -o " ++ ghci_lib_file ++ - " -all_load " ++ batch_lib_file) -#else -#ifdef mingw32_HOST_OS + hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...") +#if defined(darwin_HOST_OS) + r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file] +#elif defined(mingw32_HOST_OS) execDir <- getExecDir "/bin/ghc-pkg.exe" - system (maybe "" (++"/gcc-lib/") execDir++"ld -r -x -o " ++ ghci_lib_file ++ - " --whole-archive " ++ batch_lib_file) + r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] #else - system("ld -r -x -o " ++ ghci_lib_file ++ - " --whole-archive " ++ batch_lib_file) -#endif + r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file] #endif + when (r /= ExitSuccess) $ exitWith r hPutStrLn stderr (" done.") -- ----------------------------------------------------------------------------- -- Updating the DB with the new package. updatePackageDB - :: [InstalledPackageInfo] + :: PackageDBStack + -> [InstalledPackageInfo] -> InstalledPackageInfo -> IO [InstalledPackageInfo] -updatePackageDB pkgs new_pkg = do +updatePackageDB db_stack pkgs new_pkg = do let + -- The input package spec is allowed to give a package dependency + -- without a version number; e.g. + -- depends: base + -- Here, we update these dependencies without version numbers to + -- match the actual versions of the relevant packages installed. + updateDeps p = p{depends = map resolveDep (depends p)} + + resolveDep dep_pkgid + | realVersion dep_pkgid = dep_pkgid + | otherwise = lookupDep dep_pkgid + + lookupDep dep_pkgid + = let + name = pkgName dep_pkgid + in + case [ pid | p <- concat (map snd db_stack), + let pid = package p, + pkgName pid == name ] of + (pid:_) -> pid -- Found installed package, + -- replete with its version + [] -> dep_pkgid -- No installed package; use + -- the version-less one + is_exposed = exposed new_pkg pkgid = package new_pkg name = pkgName pkgid @@ -680,7 +661,45 @@ updatePackageDB pkgs new_pkg = do | is_exposed && pkgName (package p) == name = p{ exposed = False } | otherwise = p -- - return (pkgs'++[new_pkg]) + return (pkgs'++[updateDeps new_pkg]) + +-- ----------------------------------------------------------------------------- +-- Searching for modules + +#if not_yet + +findModules :: [FilePath] -> IO [String] +findModules paths = + mms <- mapM searchDir paths + return (concat mms) + +searchDir path prefix = do + fs <- getDirectoryEntries path `catch` \_ -> return [] + searchEntries path prefix fs + +searchEntries path prefix [] = return [] +searchEntries path prefix (f:fs) + | looks_like_a_module = do + ms <- searchEntries path prefix fs + return (prefix `joinModule` f : ms) + | looks_like_a_component = do + ms <- searchDir (path `joinFilename` f) (prefix `joinModule` f) + ms' <- searchEntries path prefix fs + return (ms ++ ms') + | otherwise + searchEntries path prefix fs + + where + (base,suffix) = splitFileExt f + looks_like_a_module = + suffix `elem` haskell_suffixes && + all okInModuleName base + looks_like_a_component = + null suffix && all okInModuleName base + +okInModuleName c + +#endif -- ----------------------------------------------------------------------------- -- The old command-line syntax, supported for backwards compatibility @@ -757,7 +776,7 @@ oldRunit clis = do let auto_ghci_libs = any isAuto clis where isAuto OF_AutoGHCiLibs = True; isAuto _ = False - input_file = head ([ f | (OF_Input f) <- clis] ++ ["-"]) + input_file = my_head "inp" ([ f | (OF_Input f) <- clis] ++ ["-"]) force = OF_Force `elem` clis @@ -768,15 +787,20 @@ oldRunit clis = do [ OF_ListLocal ] -> listPackages db_stack [ OF_Add upd ] -> registerPackage input_file defines db_stack auto_ghci_libs upd force - [ OF_Remove p ] -> unregisterPackage db_stack (pkgNameToId p) + [ OF_Remove p ] -> unregisterPackage (pkgNameToId p) db_stack [ OF_Show p ] | null fields -> describePackage db_stack (pkgNameToId p) | otherwise -> mapM_ (describeField db_stack (pkgNameToId p)) fields _ -> do prog <- getProgramName die (usageInfo (usageHeader prog) flags) +my_head s [] = error s +my_head s (x:xs) = x + -- --------------------------------------------------------------------------- +#ifdef OLD_STUFF +-- ToDo: reinstate expandEnvVars :: PackageConfig -> [(String, String)] -> Bool -> IO PackageConfig expandEnvVars pkg defines force = do @@ -860,6 +884,7 @@ wordsBy :: (Char -> Bool) -> String -> [String] wordsBy p s = case dropWhile p s of "" -> [] s' -> w : wordsBy p s'' where (w,s'') = break p s' +#endif ----------------------------------------------------------------------------- @@ -876,25 +901,14 @@ die :: String -> IO a die s = do hFlush stdout prog <- getProgramName - hPutStr stderr (prog ++ ": " ++ s) + hPutStrLn stderr (prog ++ ": " ++ s) exitWith (ExitFailure 1) dieOrForce :: Bool -> String -> IO () dieOrForce force s | force = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)") - | otherwise = die (s ++ "\n") - - ------------------------------------------------------------------------------ --- Create a hierarchy of directories + | otherwise = die s -createParents :: FilePath -> IO () -createParents dir = do - let parent = directoryOf dir - b <- doesDirectoryExist parent - when (not b) $ do - createParents parent - createDirectory parent ----------------------------------------- -- Cut and pasted from ghc/compiler/SysTools @@ -926,44 +940,42 @@ getExecDir _ = return Nothing #endif -- ----------------------------------------------------------------------------- --- Utils from Krasimir's FilePath library, copied here for now - -directoryOf :: FilePath -> FilePath -directoryOf = fst.splitFileName - -splitFileName :: FilePath -> (String, String) -splitFileName p = (reverse (path2++drive), reverse fname) - where -#ifdef mingw32_TARGET_OS - (path,drive) = break (== ':') (reverse p) -#else - (path,drive) = (reverse p,"") -#endif - (fname,path1) = break isPathSeparator path - path2 = case path1 of - [] -> "." - [_] -> path1 -- don't remove the trailing slash if - -- there is only one character - (c:path) | isPathSeparator c -> path - _ -> path1 +-- FilePath utils +-- | The 'joinFileName' function is the opposite of 'splitFileName'. +-- It joins directory and file names to form a complete file path. +-- +-- The general rule is: +-- +-- > dir `joinFileName` basename == path +-- > where +-- > (dir,basename) = splitFileName path +-- +-- There might be an exceptions to the rule but in any case the +-- reconstructed path will refer to the same object (file or directory). +-- An example exception is that on Windows some slashes might be converted +-- to backslashes. joinFileName :: String -> String -> FilePath joinFileName "" fname = fname joinFileName "." fname = fname +joinFileName dir "" = dir joinFileName dir fname | isPathSeparator (last dir) = dir++fname | otherwise = dir++pathSeparator:fname +-- | Checks whether the character is a valid path separator for the host +-- platform. The valid character is a 'pathSeparator' but since the Windows +-- operating system also accepts a slash (\"\/\") since DOS 2, the function +-- checks for it on this platform, too. isPathSeparator :: Char -> Bool -isPathSeparator ch = -#ifdef mingw32_TARGET_OS - ch == '/' || ch == '\\' -#else - ch == '/' -#endif +isPathSeparator ch = ch == pathSeparator || ch == '/' +-- | Provides a platform-specific character used to separate directory levels in +-- a path string that reflects a hierarchical file system organization. The +-- separator is a slash (@\"\/\"@) on Unix and Macintosh, and a backslash +-- (@\"\\\"@) on the Windows operating system. pathSeparator :: Char -#ifdef mingw32_TARGET_OS +#ifdef mingw32_HOST_OS pathSeparator = '\\' #else pathSeparator = '/'