[project @ 2005-01-28 12:55:17 by simonmar]
[ghc-hetmet.git] / ghc / utils / ghc-pkg / Main.hs
index 81c0a57..1b5f8f7 100644 (file)
@@ -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,19 +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 Control.Exception       ( catch, throw, evaluate )
-
-import Prelude hiding ( catch )
+import Compat.Directory        ( getAppUserDataDirectory, createDirectoryIfMissing )
+import Compat.RawSystem        ( rawSystem )
+import Control.Exception       ( evaluate )
+import qualified Control.Exception as Exception
 
-import Package -- the old package config type
+import Prelude
 
-#if __GLASGOW_HASKELL__ < 603
-#include "config.h"
-#endif
+#include "../../includes/ghcconfig.h"
 
 #if __GLASGOW_HASKELL__ >= 504
 import System.Console.GetOpt
@@ -46,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 hiding ( catch )
-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
@@ -80,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
 
@@ -107,6 +99,7 @@ data Flag
   | FlagConfig FilePath
   | FlagGlobalConfig FilePath
   | FlagForce
+  | FlagAutoGHCiLibs
   deriving Eq
 
 flags :: [OptDescr Flag]
@@ -121,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)
@@ -133,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" ++
@@ -150,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" ++
@@ -161,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 _ [] = []
@@ -178,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
@@ -211,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
@@ -261,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
@@ -288,7 +288,8 @@ readParseDatabase filename = do
   str <- readFile filename
   let packages = read str
   evaluate packages
-    `catch` \_ -> die (filename ++ ": parse error in package config file\n")
+    `Exception.catch` \_ -> 
+       die (filename ++ ": parse error in package config file")
   return (filename,packages)
 
 emptyPackageConfig :: String
@@ -306,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
@@ -317,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
@@ -336,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)
-                           `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
@@ -438,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
@@ -451,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
 
@@ -494,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
@@ -505,7 +465,7 @@ maybeRestoreOldConfig filename io
                          "restore the old configuration... ")
        renameFile (filename ++ ".old")  filename
         hPutStrLn stdout "done."
-       throw e
+       ioError e
 
 writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
 writeNewConfig filename packages = do
@@ -571,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.
@@ -579,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 ()
@@ -627,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"
@@ -639,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
@@ -678,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
@@ -755,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
       
@@ -766,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
@@ -858,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
 
 -----------------------------------------------------------------------------
 
@@ -874,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")
-
+  | 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
@@ -924,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 = '/'