[project @ 2005-01-10 23:48:07 by krasimir]

[ghc-hetmet.git] / ghc / utils / ghc-pkg / Main.hs

diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs
index 13a4d85..b455d68 100644 (file)
--- a/ghc/utils/ghc-pkg/Main.hs
+++ b/ghc/utils/ghc-pkg/Main.hs
@@ -22,10 +22,11 @@ import Distribution.Compat.ReadP
 import Distribution.ParseUtils ( showError )
 import Distribution.Package
 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 System.FilePath         ( joinFileName )
 
 import Prelude
 
@@ -52,9 +53,7 @@ import System ( getArgs, getProgName,
 import System.IO
 import Data.List ( isPrefixOf, isSuffixOf, intersperse )
 
-#include "../../includes/ghcconfig.h"
-
-#ifdef mingw32_HOST_OS
+#ifdef mingw32_TARGET_OS
 import Foreign
 
 #if __GLASGOW_HASKELL__ >= 504
@@ -77,7 +76,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
 
@@ -262,11 +261,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
@@ -896,21 +896,10 @@ dieOrForce force s
   | otherwise = die s
 
 
------------------------------------------------------------------------------
--- Create a hierarchy of directories
-
-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
 
-#if defined(mingw32_HOST_OS)
+#if defined(mingw32_TARGET_OS)
 subst a b ls = map (\ x -> if x == a then b else x) ls
 unDosifyPath xs = subst '\\' '/' xs
 
@@ -935,47 +924,3 @@ foreign import stdcall unsafe  "GetModuleFileNameA"
 getExecDir :: String -> IO (Maybe String) 
 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
-
-joinFileName :: String -> String -> FilePath
-joinFileName ""  fname = fname
-joinFileName "." fname = fname
-joinFileName dir fname
-  | isPathSeparator (last dir) = dir++fname
-  | otherwise                  = dir++pathSeparator:fname
-
-isPathSeparator :: Char -> Bool
-isPathSeparator ch =
-#ifdef mingw32_TARGET_OS
-  ch == '/' || ch == '\\'
-#else
-  ch == '/'
-#endif
-
-pathSeparator :: Char
-#ifdef mingw32_TARGET_OS
-pathSeparator = '\\'
-#else
-pathSeparator = '/'
-#endif