1 {-# OPTIONS -fglasgow-exts -cpp #-}
2 -----------------------------------------------------------------------------
4 -- (c) The University of Glasgow 2004-2009.
6 -- Package management tool
8 -----------------------------------------------------------------------------
10 module Main (main) where
12 import Version ( version, targetOS, targetARCH )
13 import qualified Distribution.Simple.PackageIndex as PackageIndex
14 import Distribution.ModuleName hiding (main)
15 import Distribution.InstalledPackageInfo
16 import Distribution.Compat.ReadP
17 import Distribution.ParseUtils
18 import Distribution.Package hiding (depends)
19 import Distribution.Text
20 import Distribution.Version
21 import System.FilePath
22 import System.Cmd ( rawSystem )
23 import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
27 #include "../../includes/ghcconfig.h"
29 import System.Console.GetOpt
30 import Text.PrettyPrint
31 #if __GLASGOW_HASKELL__ >= 609
32 import qualified Control.Exception as Exception
34 import qualified Control.Exception.Extensible as Exception
38 import Data.Char ( isSpace, toLower )
40 import System.Directory ( doesDirectoryExist, getDirectoryContents,
41 doesFileExist, renameFile, removeFile )
42 import System.Exit ( exitWith, ExitCode(..) )
43 import System.Environment ( getArgs, getProgName, getEnv )
45 import System.IO.Error (try)
47 import Control.Concurrent
51 #ifdef mingw32_HOST_OS
52 import GHC.ConsoleHandler
54 import System.Posix hiding (fdToHandle)
57 import IO ( isPermissionError )
58 import System.Posix.Internals
59 #if __GLASGOW_HASKELL__ >= 611
60 import GHC.IO.Handle.FD (fdToHandle)
62 import GHC.Handle (fdToHandle)
66 import System.Process(runInteractiveCommand)
67 import qualified System.Info(os)
70 -- -----------------------------------------------------------------------------
77 case getOpt Permute (flags ++ deprecFlags) args of
78 (cli,_,[]) | FlagHelp `elem` cli -> do
79 prog <- getProgramName
80 bye (usageInfo (usageHeader prog) flags)
81 (cli,_,[]) | FlagVersion `elem` cli ->
84 case getVerbosity Normal cli of
85 Right v -> runit v cli nonopts
88 prog <- getProgramName
89 die (concat errors ++ usageInfo (usageHeader prog) flags)
91 -- -----------------------------------------------------------------------------
92 -- Command-line syntax
100 | FlagGlobalConfig FilePath
108 | FlagVerbosity (Maybe String)
111 flags :: [OptDescr Flag]
113 Option [] ["user"] (NoArg FlagUser)
114 "use the current user's package database",
115 Option [] ["global"] (NoArg FlagGlobal)
116 "use the global package database",
117 Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
118 "use the specified package config file",
119 Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
120 "location of the global package config",
121 Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
122 "never read the user package database",
123 Option [] ["force"] (NoArg FlagForce)
124 "ignore missing dependencies, directories, and libraries",
125 Option [] ["force-files"] (NoArg FlagForceFiles)
126 "ignore missing directories and libraries only",
127 Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
128 "automatically build libs for GHCi (with register)",
129 Option ['?'] ["help"] (NoArg FlagHelp)
130 "display this help and exit",
131 Option ['V'] ["version"] (NoArg FlagVersion)
132 "output version information and exit",
133 Option [] ["simple-output"] (NoArg FlagSimpleOutput)
134 "print output in easy-to-parse format for some commands",
135 Option [] ["names-only"] (NoArg FlagNamesOnly)
136 "only print package names, not versions; can only be used with list --simple-output",
137 Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
138 "ignore case for substring matching",
139 Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
140 "verbosity level (0-2, default 1)"
143 data Verbosity = Silent | Normal | Verbose
144 deriving (Show, Eq, Ord)
146 getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
147 getVerbosity v [] = Right v
148 getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs
149 getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs
150 getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs
151 getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
152 getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
153 getVerbosity v (_ : fs) = getVerbosity v fs
155 deprecFlags :: [OptDescr Flag]
157 -- put deprecated flags here
160 ourCopyright :: String
161 ourCopyright = "GHC package manager version " ++ Version.version ++ "\n"
163 usageHeader :: String -> String
164 usageHeader prog = substProg prog $
166 " $p register {filename | -}\n" ++
167 " Register the package using the specified installed package\n" ++
168 " description. The syntax for the latter is given in the $p\n" ++
169 " documentation.\n" ++
171 " $p update {filename | -}\n" ++
172 " Register the package, overwriting any other package with the\n" ++
175 " $p unregister {pkg-id}\n" ++
176 " Unregister the specified package.\n" ++
178 " $p expose {pkg-id}\n" ++
179 " Expose the specified package.\n" ++
181 " $p hide {pkg-id}\n" ++
182 " Hide the specified package.\n" ++
184 " $p list [pkg]\n" ++
185 " List registered packages in the global database, and also the\n" ++
186 " user database if --user is given. If a package name is given\n" ++
187 " all the registered versions will be listed in ascending order.\n" ++
188 " Accepts the --simple-output flag.\n" ++
191 " Generate a graph of the package dependencies in a form suitable\n" ++
192 " for input for the graphviz tools. For example, to generate a PDF" ++
193 " of the dependency graph: ghc-pkg dot | tred | dot -Tpdf >pkgs.pdf" ++
195 " $p find-module {module}\n" ++
196 " List registered packages exposing module {module} in the global\n" ++
197 " database, and also the user database if --user is given.\n" ++
198 " All the registered versions will be listed in ascending order.\n" ++
199 " Accepts the --simple-output flag.\n" ++
201 " $p latest {pkg-id}\n" ++
202 " Prints the highest registered version of a package.\n" ++
205 " Check the consistency of package depenencies and list broken packages.\n" ++
206 " Accepts the --simple-output flag.\n" ++
208 " $p describe {pkg}\n" ++
209 " Give the registered description for the specified package. The\n" ++
210 " description is returned in precisely the syntax required by $p\n" ++
213 " $p field {pkg} {field}\n" ++
214 " Extract the specified field of the package description for the\n" ++
215 " specified package. Accepts comma-separated multiple fields.\n" ++
218 " Dump the registered description for every package. This is like\n" ++
219 " \"ghc-pkg describe '*'\", except that it is intended to be used\n" ++
220 " by tools that parse the results, rather than humans.\n" ++
222 " Substring matching is supported for {module} in find-module and\n" ++
223 " for {pkg} in list, describe, and field, where a '*' indicates\n" ++
224 " open substring ends (prefix*, *suffix, *infix*).\n" ++
226 " When asked to modify a database (register, unregister, update,\n"++
227 " hide, expose, and also check), ghc-pkg modifies the global database by\n"++
228 " default. Specifying --user causes it to act on the user database,\n"++
229 " or --package-conf can be used to act on another database\n"++
230 " entirely. When multiple of these options are given, the rightmost\n"++
231 " one is used as the database to act upon.\n"++
233 " Commands that query the package database (list, tree, latest, describe,\n"++
234 " field) operate on the list of databases specified by the flags\n"++
235 " --user, --global, and --package-conf. If none of these flags are\n"++
236 " given, the default is --global --user.\n"++
238 " The following optional flags are also accepted:\n"
240 substProg :: String -> String -> String
242 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
243 substProg prog (c:xs) = c : substProg prog xs
245 -- -----------------------------------------------------------------------------
248 data Force = NoForce | ForceFiles | ForceAll | CannotForce
251 data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
253 runit :: Verbosity -> [Flag] -> [String] -> IO ()
254 runit verbosity cli nonopts = do
255 installSignalHandlers -- catch ^C and clean up
256 prog <- getProgramName
259 | FlagForce `elem` cli = ForceAll
260 | FlagForceFiles `elem` cli = ForceFiles
261 | otherwise = NoForce
262 auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
263 splitFields fields = unfoldr splitComma (',':fields)
264 where splitComma "" = Nothing
265 splitComma fs = Just $ break (==',') (tail fs)
267 substringCheck :: String -> Maybe (String -> Bool)
268 substringCheck "" = Nothing
269 substringCheck "*" = Just (const True)
270 substringCheck [_] = Nothing
271 substringCheck (h:t) =
272 case (h, init t, last t) of
273 ('*',s,'*') -> Just (isInfixOf (f s) . f)
274 ('*',_, _ ) -> Just (isSuffixOf (f t) . f)
275 ( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
277 where f | FlagIgnoreCase `elem` cli = map toLower
280 glob x | System.Info.os=="mingw32" = do
281 -- glob echoes its argument, after win32 filename globbing
282 (_,o,_,_) <- runInteractiveCommand ("glob "++x)
283 txt <- hGetContents o
285 glob x | otherwise = return [x]
288 -- first, parse the command
291 -- dummy command to demonstrate usage and permit testing
292 -- without messing things up; use glob to selectively enable
293 -- windows filename globbing for file parameters
294 -- register, update, FlagGlobalConfig, FlagConfig; others?
295 ["glob", filename] -> do
297 glob filename >>= print
299 ["register", filename] ->
300 registerPackage filename verbosity cli auto_ghci_libs False force
301 ["update", filename] ->
302 registerPackage filename verbosity cli auto_ghci_libs True force
303 ["unregister", pkgid_str] -> do
304 pkgid <- readGlobPkgId pkgid_str
305 unregisterPackage pkgid verbosity cli force
306 ["expose", pkgid_str] -> do
307 pkgid <- readGlobPkgId pkgid_str
308 exposePackage pkgid verbosity cli force
309 ["hide", pkgid_str] -> do
310 pkgid <- readGlobPkgId pkgid_str
311 hidePackage pkgid verbosity cli force
313 listPackages verbosity cli Nothing Nothing
314 ["list", pkgid_str] ->
315 case substringCheck pkgid_str of
316 Nothing -> do pkgid <- readGlobPkgId pkgid_str
317 listPackages verbosity cli (Just (Id pkgid)) Nothing
318 Just m -> listPackages verbosity cli (Just (Substring pkgid_str m)) Nothing
320 showPackageDot verbosity cli
321 ["find-module", moduleName] -> do
322 let match = maybe (==moduleName) id (substringCheck moduleName)
323 listPackages verbosity cli Nothing (Just match)
324 ["latest", pkgid_str] -> do
325 pkgid <- readGlobPkgId pkgid_str
326 latestPackage cli pkgid
327 ["describe", pkgid_str] ->
328 case substringCheck pkgid_str of
329 Nothing -> do pkgid <- readGlobPkgId pkgid_str
330 describePackage cli (Id pkgid)
331 Just m -> describePackage cli (Substring pkgid_str m)
332 ["field", pkgid_str, fields] ->
333 case substringCheck pkgid_str of
334 Nothing -> do pkgid <- readGlobPkgId pkgid_str
335 describeField cli (Id pkgid) (splitFields fields)
336 Just m -> describeField cli (Substring pkgid_str m)
345 die ("missing command\n" ++
346 usageInfo (usageHeader prog) flags)
348 die ("command-line syntax error\n" ++
349 usageInfo (usageHeader prog) flags)
351 parseCheck :: ReadP a a -> String -> String -> IO a
352 parseCheck parser str what =
353 case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
355 _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
357 readGlobPkgId :: String -> IO PackageIdentifier
358 readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
360 parseGlobPackageId :: ReadP r PackageIdentifier
366 return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))
368 -- globVersion means "all versions"
369 globVersion :: Version
370 globVersion = Version{ versionBranch=[], versionTags=["*"] }
372 -- -----------------------------------------------------------------------------
375 -- Some commands operate on a single database:
376 -- register, unregister, expose, hide
377 -- however these commands also check the union of the available databases
378 -- in order to check consistency. For example, register will check that
379 -- dependencies exist before registering a package.
381 -- Some commands operate on multiple databases, with overlapping semantics:
382 -- list, describe, field
384 type PackageDBName = FilePath
385 type PackageDB = [InstalledPackageInfo]
387 type NamedPackageDB = (PackageDBName, PackageDB)
388 type PackageDBStack = [NamedPackageDB]
389 -- A stack of package databases. Convention: head is the topmost
390 -- in the stack. Earlier entries override later one.
392 allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
393 allPackagesInStack = concatMap snd
395 getPkgDatabases :: Bool -> [Flag] -> IO (PackageDBStack, Maybe PackageDBName)
396 getPkgDatabases modify my_flags = do
397 -- first we determine the location of the global package config. On Windows,
398 -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
399 -- location is passed to the binary using the --global-config flag by the
401 let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
403 case [ f | FlagGlobalConfig f <- my_flags ] of
404 [] -> do mb_dir <- getLibDir
406 Nothing -> die err_msg
408 do let path = dir </> "package.conf"
409 exists <- doesFileExist path
410 unless exists $ die "Can't find package.conf"
412 fs -> return (last fs)
414 let global_conf_dir = global_conf ++ ".d"
415 global_conf_dir_exists <- doesDirectoryExist global_conf_dir
417 if global_conf_dir_exists
418 then do files <- getDirectoryContents global_conf_dir
419 return [ global_conf_dir ++ '/' : file
421 , isSuffixOf ".conf" file]
424 let no_user_db = FlagNoUserDb `elem` my_flags
426 -- get the location of the user package database, and create it if necessary
427 -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
428 appdir <- try $ getAppUserDataDirectory "ghc"
431 if no_user_db then return Nothing else
434 let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
435 user_conf = dir </> subdir </> "package.conf"
436 user_exists <- doesFileExist user_conf
437 return (Just (user_conf,user_exists))
441 -- If the user database doesn't exist, and this command isn't a
442 -- "modify" command, then we won't attempt to create or use it.
444 | Just (user_conf,user_exists) <- mb_user_conf,
445 modify || user_exists = user_conf : global_confs ++ [global_conf]
446 | otherwise = global_confs ++ [global_conf]
448 e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
451 Left _ -> sys_databases
453 | last cs == "" -> init cs ++ sys_databases
455 where cs = parseSearchPath path
457 -- The "global" database is always the one at the bottom of the stack.
458 -- This is the database we modify by default.
459 virt_global_conf = last env_stack
461 let db_flags = [ f | Just f <- map is_db_flag my_flags ]
462 where is_db_flag FlagUser
463 | Just (user_conf, _user_exists) <- mb_user_conf
465 is_db_flag FlagGlobal = Just virt_global_conf
466 is_db_flag (FlagConfig f) = Just f
467 is_db_flag _ = Nothing
469 (final_stack, to_modify) <-
471 then -- For a "read" command, we use all the databases
472 -- specified on the command line. If there are no
473 -- command-line flags specifying databases, the default
474 -- is to use all the ones we know about.
475 if null db_flags then return (env_stack, Nothing)
476 else return (reverse (nub db_flags), Nothing)
478 -- For a "modify" command, treat all the databases as
479 -- a stack, where we are modifying the top one, but it
480 -- can refer to packages in databases further down the
483 -- -f flags on the command line add to the database
484 -- stack, unless any of them are present in the stack
486 flag_stack = filter (`notElem` env_stack)
487 [ f | FlagConfig f <- reverse my_flags ]
490 -- the database we actually modify is the one mentioned
491 -- rightmost on the command-line.
492 to_modify = if null db_flags
493 then Just virt_global_conf
494 else Just (last db_flags)
496 return (flag_stack, to_modify)
498 db_stack <- mapM (readParseDatabase mb_user_conf) final_stack
499 return (db_stack, to_modify)
501 readParseDatabase :: Maybe (PackageDBName,Bool)
503 -> IO (PackageDBName,PackageDB)
504 readParseDatabase mb_user_conf filename
505 -- the user database (only) is allowed to be non-existent
506 | Just (user_conf,False) <- mb_user_conf, filename == user_conf
507 = return (filename, [])
509 = do str <- readFile filename
510 let packages = map convertPackageInfoIn $ read str
511 _ <- Exception.evaluate packages
513 die ("error while parsing " ++ filename ++ ": " ++ show e)
514 return (filename,packages)
516 -- -----------------------------------------------------------------------------
519 registerPackage :: FilePath
522 -> Bool -- auto_ghci_libs
526 registerPackage input verbosity my_flags auto_ghci_libs update force = do
527 (db_stack, Just to_modify) <- getPkgDatabases True my_flags
529 db_to_operate_on = my_head "register" $
530 filter ((== to_modify).fst) db_stack
535 when (verbosity >= Normal) $
536 putStr "Reading package info from stdin ... "
539 when (verbosity >= Normal) $
540 putStr ("Reading package info from " ++ show f ++ " ... ")
543 expanded <- expandEnvVars s force
545 pkg <- parsePackageInfo expanded
546 when (verbosity >= Normal) $
549 let truncated_stack = dropWhile ((/= to_modify).fst) db_stack
550 -- truncate the stack for validation, because we don't allow
551 -- packages lower in the stack to refer to those higher up.
552 validatePackageConfig pkg truncated_stack auto_ghci_libs update force
553 let new_details = filter not_this (snd db_to_operate_on) ++ [pkg]
554 not_this p = package p /= package pkg
555 writeNewConfig verbosity to_modify new_details
559 -> IO InstalledPackageInfo
560 parsePackageInfo str =
561 case parseInstalledPackageInfo str of
562 ParseOk _warns ok -> return ok
563 ParseFailed err -> case locatedErrorMsg err of
564 (Nothing, s) -> die s
565 (Just l, s) -> die (show l ++ ": " ++ s)
567 -- -----------------------------------------------------------------------------
568 -- Exposing, Hiding, Unregistering are all similar
570 exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
571 exposePackage = modifyPackage (\p -> [p{exposed=True}])
573 hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
574 hidePackage = modifyPackage (\p -> [p{exposed=False}])
576 unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO ()
577 unregisterPackage = modifyPackage (\_ -> [])
580 :: (InstalledPackageInfo -> [InstalledPackageInfo])
586 modifyPackage fn pkgid verbosity my_flags force = do
587 (db_stack, Just _to_modify) <- getPkgDatabases True{-modify-} my_flags
588 ((db_name, pkgs), ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid)
589 -- let ((db_name, pkgs) : rest_of_stack) = db_stack
590 -- ps <- findPackages [(db_name,pkgs)] (Id pkgid)
592 pids = map package ps
594 | package pkg `elem` pids = fn pkg
596 new_config = concat (map modify pkgs)
599 old_broken = brokenPackages (allPackagesInStack db_stack)
600 rest_of_stack = [ (nm, mypkgs)
601 | (nm, mypkgs) <- db_stack, nm /= db_name ]
602 new_stack = (db_name,new_config) : rest_of_stack
603 new_broken = map package (brokenPackages (allPackagesInStack new_stack))
604 newly_broken = filter (`notElem` map package old_broken) new_broken
606 when (not (null newly_broken)) $
607 dieOrForceAll force ("unregistering " ++ display pkgid ++
608 " would break the following packages: "
609 ++ unwords (map display newly_broken))
611 writeNewConfig verbosity db_name new_config
613 -- -----------------------------------------------------------------------------
616 listPackages :: Verbosity -> [Flag] -> Maybe PackageArg
617 -> Maybe (String->Bool)
619 listPackages verbosity my_flags mPackageName mModuleName = do
620 let simple_output = FlagSimpleOutput `elem` my_flags
621 (db_stack, _) <- getPkgDatabases False my_flags
622 let db_stack_filtered -- if a package is given, filter out all other packages
623 | Just this <- mPackageName =
624 map (\(conf,pkgs) -> (conf, filter (this `matchesPkg`) pkgs))
626 | Just match <- mModuleName = -- packages which expose mModuleName
627 map (\(conf,pkgs) -> (conf, filter (match `exposedInPkg`) pkgs))
629 | otherwise = db_stack
632 = [ (db, sort_pkgs pkgs) | (db,pkgs) <- db_stack_filtered ]
633 where sort_pkgs = sortBy cmpPkgIds
634 cmpPkgIds pkg1 pkg2 =
635 case pkgName p1 `compare` pkgName p2 of
638 EQ -> pkgVersion p1 `compare` pkgVersion p2
639 where (p1,p2) = (package pkg1, package pkg2)
641 match `exposedInPkg` pkg = any match (map display $ exposedModules pkg)
643 pkg_map = allPackagesInStack db_stack
644 broken = map package (brokenPackages pkg_map)
646 show_func = if simple_output then show_simple else mapM_ show_normal
648 show_normal (db_name,pkg_confs) =
649 hPutStrLn stdout (render $
650 text db_name <> colon $$ nest 4 packages
653 | verbosity >= Verbose = vcat (map pp_pkg pkg_confs)
654 | otherwise = fsep (punctuate comma (map pp_pkg pkg_confs))
656 | package p `elem` broken = braces doc
658 | otherwise = parens doc
659 where doc | verbosity >= Verbose = pkg <+> parens ipid
662 InstalledPackageId ipid_str = installedPackageId p
664 pkg = text (display (package p))
666 show_simple = simplePackageList my_flags . allPackagesInStack
668 when (not (null broken) && verbosity /= Silent) $ do
669 prog <- getProgramName
670 putStrLn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.")
672 show_func (reverse db_stack_sorted)
674 simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
675 simplePackageList my_flags pkgs = do
676 let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
678 strs = map showPkg $ sortBy compPkgIdVer $ map package pkgs
679 when (not (null pkgs)) $
680 hPutStrLn stdout $ concat $ intersperse " " strs
682 showPackageDot :: Verbosity -> [Flag] -> IO ()
683 showPackageDot _verbosity myflags = do
684 (db_stack, _) <- getPkgDatabases False myflags
685 let all_pkgs = allPackagesInStack db_stack
686 ipix = PackageIndex.listToInstalledPackageIndex all_pkgs
689 let quote s = '"':s ++ "\""
690 mapM_ putStrLn [ quote from ++ " -> " ++ quote to
692 let from = display (package p),
694 Just dep <- [PackageIndex.lookupInstalledPackage ipix depid],
695 let to = display (package dep)
699 -- -----------------------------------------------------------------------------
700 -- Prints the highest (hidden or exposed) version of a package
702 latestPackage :: [Flag] -> PackageIdentifier -> IO ()
703 latestPackage my_flags pkgid = do
704 (db_stack, _) <- getPkgDatabases False my_flags
705 ps <- findPackages db_stack (Id pkgid)
706 show_pkg (sortBy compPkgIdVer (map package ps))
708 show_pkg [] = die "no matches"
709 show_pkg pids = hPutStrLn stdout (display (last pids))
711 -- -----------------------------------------------------------------------------
714 describePackage :: [Flag] -> PackageArg -> IO ()
715 describePackage my_flags pkgarg = do
716 (db_stack, _) <- getPkgDatabases False my_flags
717 ps <- findPackages db_stack pkgarg
720 dumpPackages :: [Flag] -> IO ()
721 dumpPackages my_flags = do
722 (db_stack, _) <- getPkgDatabases False my_flags
723 doDump (allPackagesInStack db_stack)
725 doDump :: [InstalledPackageInfo] -> IO ()
726 doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo
728 -- PackageId is can have globVersion for the version
729 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
730 findPackages db_stack pkgarg
731 = fmap (concatMap snd) $ findPackagesByDB db_stack pkgarg
733 findPackagesByDB :: PackageDBStack -> PackageArg
734 -> IO [(NamedPackageDB, [InstalledPackageInfo])]
735 findPackagesByDB db_stack pkgarg
736 = case [ (db, matched)
737 | db@(_, pkgs) <- db_stack,
738 let matched = filter (pkgarg `matchesPkg`) pkgs,
739 not (null matched) ] of
740 [] -> die ("cannot find package " ++ pkg_msg pkgarg)
743 pkg_msg (Id pkgid) = display pkgid
744 pkg_msg (Substring pkgpat _) = "matching " ++ pkgpat
746 matches :: PackageIdentifier -> PackageIdentifier -> Bool
748 = (pkgName pid == pkgName pid')
749 && (pkgVersion pid == pkgVersion pid' || not (realVersion pid))
751 realVersion :: PackageIdentifier -> Bool
752 realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
753 -- when versionBranch == [], this is a glob
755 matchesPkg :: PackageArg -> InstalledPackageInfo -> Bool
756 (Id pid) `matchesPkg` pkg = pid `matches` package pkg
757 (Substring _ m) `matchesPkg` pkg = m (display (package pkg))
759 compPkgIdVer :: PackageIdentifier -> PackageIdentifier -> Ordering
760 compPkgIdVer p1 p2 = pkgVersion p1 `compare` pkgVersion p2
762 -- -----------------------------------------------------------------------------
765 describeField :: [Flag] -> PackageArg -> [String] -> IO ()
766 describeField my_flags pkgarg fields = do
767 (db_stack, _) <- getPkgDatabases False my_flags
768 fns <- toFields fields
769 ps <- findPackages db_stack pkgarg
770 let top_dir = takeDirectory (fst (last db_stack))
771 mapM_ (selectFields fns) (mungePackagePaths top_dir ps)
772 where toFields [] = return []
773 toFields (f:fs) = case toField f of
774 Nothing -> die ("unknown field: " ++ f)
775 Just fn -> do fns <- toFields fs
777 selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns
779 mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo]
780 -- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path
781 -- with the current topdir (obtained from the -B option).
782 mungePackagePaths top_dir ps = map munge_pkg ps
784 munge_pkg p = p{ importDirs = munge_paths (importDirs p),
785 includeDirs = munge_paths (includeDirs p),
786 libraryDirs = munge_paths (libraryDirs p),
787 frameworkDirs = munge_paths (frameworkDirs p),
788 haddockInterfaces = munge_paths (haddockInterfaces p),
789 haddockHTMLs = munge_paths (haddockHTMLs p)
792 munge_paths = map munge_path
795 | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
796 | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
799 toHttpPath p = "file:///" ++ p
801 maybePrefixMatch :: String -> String -> Maybe String
802 maybePrefixMatch [] rest = Just rest
803 maybePrefixMatch (_:_) [] = Nothing
804 maybePrefixMatch (p:pat) (r:rest)
805 | p == r = maybePrefixMatch pat rest
806 | otherwise = Nothing
808 toField :: String -> Maybe (InstalledPackageInfo -> String)
809 -- backwards compatibility:
810 toField "import_dirs" = Just $ strList . importDirs
811 toField "source_dirs" = Just $ strList . importDirs
812 toField "library_dirs" = Just $ strList . libraryDirs
813 toField "hs_libraries" = Just $ strList . hsLibraries
814 toField "extra_libraries" = Just $ strList . extraLibraries
815 toField "include_dirs" = Just $ strList . includeDirs
816 toField "c_includes" = Just $ strList . includes
817 toField "package_deps" = Just $ strList . map display. depends
818 toField "extra_cc_opts" = Just $ strList . ccOptions
819 toField "extra_ld_opts" = Just $ strList . ldOptions
820 toField "framework_dirs" = Just $ strList . frameworkDirs
821 toField "extra_frameworks"= Just $ strList . frameworks
822 toField s = showInstalledPackageInfoField s
824 strList :: [String] -> String
828 -- -----------------------------------------------------------------------------
829 -- Check: Check consistency of installed packages
831 checkConsistency :: [Flag] -> IO ()
832 checkConsistency my_flags = do
833 (db_stack, _) <- getPkgDatabases True my_flags
834 -- check behaves like modify for the purposes of deciding which
835 -- databases to use, because ordering is important.
837 let simple_output = FlagSimpleOutput `elem` my_flags
839 let pkgs = allPackagesInStack db_stack
842 (_,es) <- runValidate $ checkPackageConfig p db_stack False True
846 when (not simple_output) $ do
847 reportError ("There are problems in package " ++ display (package p) ++ ":")
848 _ <- reportValidateErrors es " " Nothing
852 broken_pkgs <- concat `fmap` mapM checkPackage pkgs
854 let filterOut pkgs1 pkgs2 = filter not_in pkgs2
855 where not_in p = package p `notElem` all_ps
856 all_ps = map package pkgs1
858 let not_broken_pkgs = filterOut broken_pkgs pkgs
859 (_, trans_broken_pkgs) = closure [] not_broken_pkgs
860 all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
862 when (not (null all_broken_pkgs)) $ do
864 then simplePackageList my_flags all_broken_pkgs
866 reportError ("\nThe following packages are broken, either because they have a problem\n"++
867 "listed above, or because they depend on a broken package.")
868 mapM_ (hPutStrLn stderr . display . package) all_broken_pkgs
870 when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
873 closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
874 -> ([InstalledPackageInfo], [InstalledPackageInfo])
875 closure pkgs db_stack = go pkgs db_stack
878 case partition (depsAvailable avail) not_avail of
879 ([], not_avail') -> (avail, not_avail')
880 (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
882 depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
884 depsAvailable pkgs_ok pkg = null dangling
885 where dangling = filter (`notElem` pids) (depends pkg)
886 pids = map installedPackageId pkgs_ok
888 -- we want mutually recursive groups of package to show up
889 -- as broken. (#1750)
891 brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
892 brokenPackages pkgs = snd (closure [] pkgs)
894 -- -----------------------------------------------------------------------------
895 -- Manipulating package.conf files
897 type InstalledPackageInfoString = InstalledPackageInfo_ String
899 convertPackageInfoOut :: InstalledPackageInfo -> InstalledPackageInfoString
900 convertPackageInfoOut
901 (pkgconf@(InstalledPackageInfo { exposedModules = e,
902 hiddenModules = h })) =
903 pkgconf{ exposedModules = map display e,
904 hiddenModules = map display h }
906 convertPackageInfoIn :: InstalledPackageInfoString -> InstalledPackageInfo
908 (pkgconf@(InstalledPackageInfo { exposedModules = e,
909 hiddenModules = h })) =
910 pkgconf{ exposedModules = map convert e,
911 hiddenModules = map convert h }
912 where convert = fromJust . simpleParse
914 writeNewConfig :: Verbosity -> FilePath -> [InstalledPackageInfo] -> IO ()
915 writeNewConfig verbosity filename packages = do
916 when (verbosity >= Normal) $
917 hPutStr stdout "Writing new package config file... "
918 createDirectoryIfMissing True $ takeDirectory filename
919 let shown = concat $ intersperse ",\n "
920 $ map (show . convertPackageInfoOut) packages
921 fileContents = "[" ++ shown ++ "\n]"
922 writeFileAtomic filename fileContents
924 if isPermissionError e
925 then die (filename ++ ": you don't have permission to modify this file")
927 when (verbosity >= Normal) $
928 hPutStrLn stdout "done."
930 -----------------------------------------------------------------------------
931 -- Sanity-check a new package config, and automatically build GHCi libs
934 type ValidateError = (Force,String)
936 newtype Validate a = V { runValidate :: IO (a, [ValidateError]) }
938 instance Monad Validate where
939 return a = V $ return (a, [])
941 (a, es) <- runValidate m
942 (b, es') <- runValidate (k a)
945 verror :: Force -> String -> Validate ()
946 verror f s = V (return ((),[(f,s)]))
948 liftIO :: IO a -> Validate a
949 liftIO k = V (k >>= \a -> return (a,[]))
951 -- returns False if we should die
952 reportValidateErrors :: [ValidateError] -> String -> Maybe Force -> IO Bool
953 reportValidateErrors es prefix mb_force = do
954 oks <- mapM report es
958 | Just force <- mb_force
960 then do reportError (prefix ++ s ++ " (ignoring)")
962 else if f < CannotForce
963 then do reportError (prefix ++ s ++ " (use --force to override)")
965 else do reportError err
967 | otherwise = do reportError err
972 validatePackageConfig :: InstalledPackageInfo
974 -> Bool -- auto-ghc-libs
975 -> Bool -- update, or check
978 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
979 (_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
980 ok <- reportValidateErrors es (display (package pkg) ++ ": ") (Just force)
981 when (not ok) $ exitWith (ExitFailure 1)
983 checkPackageConfig :: InstalledPackageInfo
985 -> Bool -- auto-ghc-libs
986 -> Bool -- update, or check
988 checkPackageConfig pkg db_stack auto_ghci_libs update = do
989 checkInstalledPackageId pkg db_stack update
991 checkDuplicates db_stack pkg update
992 mapM_ (checkDep db_stack) (depends pkg)
993 checkDuplicateDepends (depends pkg)
994 mapM_ (checkDir "import-dirs") (importDirs pkg)
995 mapM_ (checkDir "library-dirs") (libraryDirs pkg)
996 mapM_ (checkDir "include-dirs") (includeDirs pkg)
998 mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
999 -- ToDo: check these somehow?
1000 -- extra_libraries :: [String],
1001 -- c_includes :: [String],
1003 checkInstalledPackageId :: InstalledPackageInfo -> PackageDBStack -> Bool
1005 checkInstalledPackageId ipi db_stack update = do
1006 let ipid@(InstalledPackageId str) = installedPackageId ipi
1007 when (null str) $ verror CannotForce "missing id field"
1008 let dups = [ p | p <- allPackagesInStack db_stack,
1009 installedPackageId p == ipid ]
1010 when (not update && not (null dups)) $
1011 verror CannotForce $
1012 "package(s) with this id already exist: " ++
1013 unwords (map (display.packageId) dups)
1015 -- When the package name and version are put together, sometimes we can
1016 -- end up with a package id that cannot be parsed. This will lead to
1017 -- difficulties when the user wants to refer to the package later, so
1018 -- we check that the package id can be parsed properly here.
1019 checkPackageId :: InstalledPackageInfo -> Validate ()
1020 checkPackageId ipi =
1021 let str = display (package ipi) in
1022 case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
1024 [] -> verror CannotForce ("invalid package identifier: " ++ str)
1025 _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
1027 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
1028 checkDuplicates db_stack pkg update = do
1031 (_top_db_name, pkgs) : _ = db_stack
1033 -- Check whether this package id already exists in this DB
1035 when (not update && (pkgid `elem` map package pkgs)) $
1036 verror CannotForce $
1037 "package " ++ display pkgid ++ " is already installed"
1040 uncasep = map toLower . display
1041 dups = filter ((== uncasep pkgid) . uncasep) (map package pkgs)
1043 when (not update && not (null dups)) $ verror ForceAll $
1044 "Package names may be treated case-insensitively in the future.\n"++
1045 "Package " ++ display pkgid ++
1046 " overlaps with: " ++ unwords (map display dups)
1049 checkDir :: String -> String -> Validate ()
1050 checkDir thisfield d
1051 | "$topdir" `isPrefixOf` d = return ()
1052 | "$httptopdir" `isPrefixOf` d = return ()
1053 -- can't check these, because we don't know what $(http)topdir is
1055 there <- liftIO $ doesDirectoryExist d
1057 verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory")
1059 checkDep :: PackageDBStack -> InstalledPackageId -> Validate ()
1060 checkDep db_stack pkgid
1061 | pkgid `elem` pkgids = return ()
1062 | otherwise = verror ForceAll ("dependency \"" ++ display pkgid
1063 ++ "\" doesn't exist")
1065 all_pkgs = allPackagesInStack db_stack
1066 pkgids = map installedPackageId all_pkgs
1068 checkDuplicateDepends :: [InstalledPackageId] -> Validate ()
1069 checkDuplicateDepends deps
1070 | null dups = return ()
1071 | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
1072 unwords (map display dups))
1074 dups = [ p | (p:_:_) <- group (sort deps) ]
1076 checkHSLib :: [String] -> Bool -> String -> Validate ()
1077 checkHSLib dirs auto_ghci_libs lib = do
1078 let batch_lib_file = "lib" ++ lib ++ ".a"
1079 m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
1081 Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++
1083 Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
1085 doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
1086 doesFileExistOnPath file path = go path
1087 where go [] = return Nothing
1088 go (p:ps) = do b <- doesFileExistIn file p
1089 if b then return (Just p) else go ps
1091 doesFileExistIn :: String -> String -> IO Bool
1092 doesFileExistIn lib d
1093 | "$topdir" `isPrefixOf` d = return True
1094 | "$httptopdir" `isPrefixOf` d = return True
1095 | otherwise = doesFileExist (d </> lib)
1097 checkModules :: InstalledPackageInfo -> Validate ()
1098 checkModules pkg = do
1099 mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
1101 findModule modl = do
1102 -- there's no .hi file for GHC.Prim
1103 if modl == fromString "GHC.Prim" then return () else do
1104 let file = toFilePath modl <.> "hi"
1105 m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
1106 when (isNothing m) $
1107 verror ForceFiles ("file " ++ file ++ " is missing")
1109 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
1110 checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
1111 | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
1113 m <- doesFileExistOnPath ghci_lib_file dirs
1114 when (isNothing m && ghci_lib_file /= "HSrts.o") $
1115 hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
1117 ghci_lib_file = lib <.> "o"
1119 -- automatically build the GHCi version of a batch lib,
1120 -- using ld --whole-archive.
1122 autoBuildGHCiLib :: String -> String -> String -> IO ()
1123 autoBuildGHCiLib dir batch_file ghci_file = do
1124 let ghci_lib_file = dir ++ '/':ghci_file
1125 batch_lib_file = dir ++ '/':batch_file
1126 hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
1127 #if defined(darwin_HOST_OS)
1128 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
1129 #elif defined(mingw32_HOST_OS)
1130 execDir <- getLibDir
1131 r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1133 r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
1135 when (r /= ExitSuccess) $ exitWith r
1136 hPutStrLn stderr (" done.")
1138 -- -----------------------------------------------------------------------------
1139 -- Searching for modules
1143 findModules :: [FilePath] -> IO [String]
1145 mms <- mapM searchDir paths
1148 searchDir path prefix = do
1149 fs <- getDirectoryEntries path `catch` \_ -> return []
1150 searchEntries path prefix fs
1152 searchEntries path prefix [] = return []
1153 searchEntries path prefix (f:fs)
1154 | looks_like_a_module = do
1155 ms <- searchEntries path prefix fs
1156 return (prefix `joinModule` f : ms)
1157 | looks_like_a_component = do
1158 ms <- searchDir (path </> f) (prefix `joinModule` f)
1159 ms' <- searchEntries path prefix fs
1162 searchEntries path prefix fs
1165 (base,suffix) = splitFileExt f
1166 looks_like_a_module =
1167 suffix `elem` haskell_suffixes &&
1168 all okInModuleName base
1169 looks_like_a_component =
1170 null suffix && all okInModuleName base
1176 -- ---------------------------------------------------------------------------
1177 -- expanding environment variables in the package configuration
1179 expandEnvVars :: String -> Force -> IO String
1180 expandEnvVars str0 force = go str0 ""
1182 go "" acc = return $! reverse acc
1183 go ('$':'{':str) acc | (var, '}':rest) <- break close str
1184 = do value <- lookupEnvVar var
1185 go rest (reverse value ++ acc)
1186 where close c = c == '}' || c == '\n' -- don't span newlines
1190 lookupEnvVar :: String -> IO String
1192 catch (System.Environment.getEnv nm)
1193 (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
1197 -----------------------------------------------------------------------------
1199 getProgramName :: IO String
1200 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
1201 where str `withoutSuffix` suff
1202 | suff `isSuffixOf` str = take (length str - length suff) str
1205 bye :: String -> IO a
1206 bye s = putStr s >> exitWith ExitSuccess
1208 die :: String -> IO a
1211 dieWith :: Int -> String -> IO a
1214 prog <- getProgramName
1215 hPutStrLn stderr (prog ++ ": " ++ s)
1216 exitWith (ExitFailure ec)
1218 dieOrForceAll :: Force -> String -> IO ()
1219 dieOrForceAll ForceAll s = ignoreError s
1220 dieOrForceAll _other s = dieForcible s
1222 ignoreError :: String -> IO ()
1223 ignoreError s = reportError (s ++ " (ignoring)")
1225 reportError :: String -> IO ()
1226 reportError s = do hFlush stdout; hPutStrLn stderr s
1228 dieForcible :: String -> IO ()
1229 dieForcible s = die (s ++ " (use --force to override)")
1231 my_head :: String -> [a] -> a
1232 my_head s [] = error s
1233 my_head _ (x : _) = x
1235 -----------------------------------------
1236 -- Cut and pasted from ghc/compiler/main/SysTools
1238 #if defined(mingw32_HOST_OS)
1239 subst :: Char -> Char -> String -> String
1240 subst a b ls = map (\ x -> if x == a then b else x) ls
1242 unDosifyPath :: FilePath -> FilePath
1243 unDosifyPath xs = subst '\\' '/' xs
1245 getLibDir :: IO (Maybe String)
1246 getLibDir = fmap (fmap (</> "lib")) $ getExecDir "/bin/ghc-pkg.exe"
1248 -- (getExecDir cmd) returns the directory in which the current
1249 -- executable, which should be called 'cmd', is running
1250 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
1251 -- you'll get "/a/b/c" back as the result
1252 getExecDir :: String -> IO (Maybe String)
1254 getExecPath >>= maybe (return Nothing) removeCmdSuffix
1255 where initN n = reverse . drop n . reverse
1256 removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
1258 getExecPath :: IO (Maybe String)
1260 allocaArray len $ \buf -> do
1261 ret <- getModuleFileName nullPtr buf len
1262 if ret == 0 then return Nothing
1263 else liftM Just $ peekCString buf
1264 where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
1266 foreign import stdcall unsafe "GetModuleFileNameA"
1267 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
1270 getLibDir :: IO (Maybe String)
1271 getLibDir = return Nothing
1274 -----------------------------------------
1275 -- Adapted from ghc/compiler/utils/Panic
1277 installSignalHandlers :: IO ()
1278 installSignalHandlers = do
1279 threadid <- myThreadId
1281 interrupt = Exception.throwTo threadid
1282 (Exception.ErrorCall "interrupted")
1284 #if !defined(mingw32_HOST_OS)
1285 _ <- installHandler sigQUIT (Catch interrupt) Nothing
1286 _ <- installHandler sigINT (Catch interrupt) Nothing
1288 #elif __GLASGOW_HASKELL__ >= 603
1289 -- GHC 6.3+ has support for console events on Windows
1290 -- NOTE: running GHCi under a bash shell for some reason requires
1291 -- you to press Ctrl-Break rather than Ctrl-C to provoke
1292 -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
1293 -- why --SDM 17/12/2004
1294 let sig_handler ControlC = interrupt
1295 sig_handler Break = interrupt
1296 sig_handler _ = return ()
1298 _ <- installHandler (Catch sig_handler)
1301 return () -- nothing
1304 #if __GLASGOW_HASKELL__ <= 604
1305 isInfixOf :: (Eq a) => [a] -> [a] -> Bool
1306 isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
1309 #if mingw32_HOST_OS || mingw32_TARGET_OS
1310 throwIOIO :: Exception.IOException -> IO a
1311 throwIOIO = Exception.throwIO
1313 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
1314 catchIO = Exception.catch
1317 catchError :: IO a -> (String -> IO a) -> IO a
1318 catchError io handler = io `Exception.catch` handler'
1319 where handler' (Exception.ErrorCall err) = handler err
1322 -- copied from Cabal's Distribution.Simple.Utils, except that we want
1323 -- to use text files here, rather than binary files.
1324 writeFileAtomic :: FilePath -> String -> IO ()
1325 writeFileAtomic targetFile content = do
1326 (newFile, newHandle) <- openNewFile targetDir template
1327 do hPutStr newHandle content
1329 #if mingw32_HOST_OS || mingw32_TARGET_OS
1330 renameFile newFile targetFile
1331 -- If the targetFile exists then renameFile will fail
1332 `catchIO` \err -> do
1333 exists <- doesFileExist targetFile
1335 then do removeFile targetFile
1336 -- Big fat hairy race condition
1337 renameFile newFile targetFile
1338 -- If the removeFile succeeds and the renameFile fails
1339 -- then we've lost the atomic property.
1342 renameFile newFile targetFile
1344 `Exception.onException` do hClose newHandle
1347 template = targetName <.> "tmp"
1348 targetDir | null targetDir_ = "."
1349 | otherwise = targetDir_
1350 --TODO: remove this when takeDirectory/splitFileName is fixed
1351 -- to always return a valid dir
1352 (targetDir_,targetName) = splitFileName targetFile
1354 -- Ugh, this is a copy/paste of code from the base library, but
1355 -- if uses 666 rather than 600 for the permissions.
1356 openNewFile :: FilePath -> String -> IO (FilePath, Handle)
1357 openNewFile dir template = do
1361 -- We split off the last extension, so we can use .foo.ext files
1362 -- for temporary files (hidden on Unix OSes). Unfortunately we're
1363 -- below filepath in the hierarchy here.
1365 case break (== '.') $ reverse template of
1366 -- First case: template contains no '.'s. Just re-reverse it.
1367 (rev_suffix, "") -> (reverse rev_suffix, "")
1368 -- Second case: template contains at least one '.'. Strip the
1369 -- dot from the prefix and prepend it to the suffix (if we don't
1370 -- do this, the unique number will get added after the '.' and
1371 -- thus be part of the extension, which is wrong.)
1372 (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
1373 -- Otherwise, something is wrong, because (break (== '.')) should
1374 -- always return a pair with either the empty string or a string
1375 -- beginning with '.' as the second component.
1376 _ -> error "bug in System.IO.openTempFile"
1378 oflags = rw_flags .|. o_EXCL
1380 #if __GLASGOW_HASKELL__ < 611
1381 withFilePath = withCString
1385 fd <- withFilePath filepath $ \ f ->
1386 c_open f oflags 0o666
1391 then findTempName (x+1)
1392 else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
1394 -- XXX We want to tell fdToHandle what the filepath is,
1395 -- as any exceptions etc will only be able to report the
1398 #if __GLASGOW_HASKELL__ >= 609
1401 fdToHandle (fromIntegral fd)
1403 `Exception.onException` c_close fd
1404 return (filepath, h)
1406 filename = prefix ++ show x ++ suffix
1407 filepath = dir `combine` filename
1409 -- XXX Copied from GHC.Handle
1410 std_flags, output_flags, rw_flags :: CInt
1411 std_flags = o_NONBLOCK .|. o_NOCTTY
1412 output_flags = std_flags .|. o_CREAT
1413 rw_flags = output_flags .|. o_RDWR
1415 -- | The function splits the given string to substrings
1416 -- using 'isSearchPathSeparator'.
1417 parseSearchPath :: String -> [FilePath]
1418 parseSearchPath path = split path
1420 split :: String -> [String]
1424 _:rest -> chunk : split rest
1428 #ifdef mingw32_HOST_OS
1429 ('\"':xs@(_:_)) | last xs == '\"' -> init xs
1433 (chunk', rest') = break isSearchPathSeparator s