1 {-# OPTIONS -fglasgow-exts #-}
2 -----------------------------------------------------------------------------
4 -- (c) The University of Glasgow 2004.
6 -- Package management tool
8 -----------------------------------------------------------------------------
13 -- - expanding of variables in new-style package conf
14 -- - version manipulation (checking whether old version exists,
15 -- hiding old version?)
17 module Main (main) where
19 import Version ( version, targetOS, targetARCH )
20 import Distribution.InstalledPackageInfo
21 import Distribution.Compat.ReadP
22 import Distribution.Package
23 import Distribution.License
24 import Distribution.Version
25 import Compat.Directory ( getAppUserDataDirectory )
26 import Control.Exception ( evaluate )
27 import qualified Control.Exception as Exception
31 import Package -- the old package config type
33 #if __GLASGOW_HASKELL__ < 603
37 #if __GLASGOW_HASKELL__ >= 504
38 import System.Console.GetOpt
39 import Text.PrettyPrint
40 import qualified Control.Exception as Exception
44 import qualified Exception
47 import Data.Char ( isSpace )
50 import System ( getEnv, getArgs, getProgName,
55 import List ( isPrefixOf, isSuffixOf )
57 import ParsePkgConfLite
59 #include "../../includes/ghcconfig.h"
61 #ifdef mingw32_HOST_OS
64 #if __GLASGOW_HASKELL__ >= 504
65 import Foreign.C.String
71 -- -----------------------------------------------------------------------------
78 case getOpt Permute flags args of
79 (cli,_,[]) | FlagHelp `elem` cli -> do
80 prog <- getProgramName
81 bye (usageInfo (usageHeader prog) flags)
82 (cli,_,[]) | FlagVersion `elem` cli ->
84 (cli@(_:_),nonopts,[]) ->
86 (_,_,errors) -> tryOldCmdLine errors args
88 -- If the new command-line syntax fails, then we try the old. If that
89 -- fails too, then we output the original errors and the new syntax
90 -- (so the old syntax is still available, but hidden).
91 tryOldCmdLine :: [String] -> [String] -> IO ()
92 tryOldCmdLine errors args = do
93 case getOpt Permute oldFlags args of
97 prog <- getProgramName
98 die (concat errors ++ usageInfo (usageHeader prog) flags)
100 -- -----------------------------------------------------------------------------
101 -- Command-line syntax
108 | FlagConfig FilePath
109 | FlagGlobalConfig FilePath
113 flags :: [OptDescr Flag]
115 Option [] ["user"] (NoArg FlagUser)
116 "use the current user's package database",
117 Option [] ["global"] (NoArg FlagGlobal)
118 "(default) use the global package database",
119 Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
120 "act upon specified package config file (only)",
121 Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
122 "location of the global package config",
123 Option [] ["force"] (NoArg FlagForce)
124 "ignore missing dependencies, directories, and libraries",
125 Option ['?'] ["help"] (NoArg FlagHelp)
126 "display this help and exit",
127 Option ['V'] ["version"] (NoArg FlagVersion)
128 "output version information and exit"
131 ourCopyright :: String
132 ourCopyright = "GHC package manager version " ++ version ++ "\n"
134 usageHeader :: String -> String
135 usageHeader prog = substProg prog $
137 " $p {--help | -?}\n" ++
138 " Produce this usage message.\n" ++
140 " $p register {filename | -} [--user | --global]\n" ++
141 " Register the package using the specified installed package\n" ++
142 " description. The syntax for the latter is given in the $p\n" ++
143 " documentation.\n" ++
145 " $p unregister {pkg-id}\n" ++
146 " Unregister the specified package.\n" ++
148 " $p expose {pkg-id}\n" ++
149 " Expose the specified package.\n" ++
151 " $p hide {pkg-id}\n" ++
152 " Hide the specified package.\n" ++
154 " $p list [--global | --user]\n" ++
155 " List all registered packages, both global and user (unless either\n" ++
156 " --global or --user is specified), and both hidden and exposed.\n" ++
158 " $p describe {pkg-id}\n" ++
159 " Give the registered description for the specified package. The\n" ++
160 " description is returned in precisely the syntax required by $p\n" ++
163 " $p field {pkg-id} {field}\n" ++
164 " Extract the specified field of the package description for the\n" ++
165 " specified package.\n"
167 substProg :: String -> String -> String
169 substProg prog ('$':'p':xs) = prog ++ substProg prog xs
170 substProg prog (c:xs) = c : substProg prog xs
172 -- -----------------------------------------------------------------------------
175 runit :: [Flag] -> [String] -> IO ()
176 runit cli nonopts = do
177 prog <- getProgramName
178 dbs <- getPkgDatabases cli
179 db_stack <- mapM readParseDatabase dbs
181 force = FlagForce `elem` cli
183 -- first, parse the command
185 ["register", filename] ->
186 registerPackage filename [] db_stack False False force
187 ["update", filename] ->
188 registerPackage filename [] db_stack False True force
189 ["unregister", pkgid_str] -> do
190 pkgid <- readPkgId pkgid_str
191 unregisterPackage db_stack pkgid
192 ["expose", pkgid_str] -> do
193 pkgid <- readPkgId pkgid_str
194 exposePackage pkgid db_stack
195 ["hide", pkgid_str] -> do
196 pkgid <- readPkgId pkgid_str
197 hidePackage pkgid db_stack
199 listPackages db_stack
200 ["describe", pkgid_str] -> do
201 pkgid <- readPkgId pkgid_str
202 describePackage db_stack pkgid
203 ["field", pkgid_str, field] -> do
204 pkgid <- readPkgId pkgid_str
205 describeField db_stack pkgid field
207 die ("missing command\n" ++
208 usageInfo (usageHeader prog) flags)
210 die ("command-line syntax error\n" ++
211 usageInfo (usageHeader prog) flags)
213 parseCheck :: ReadP a a -> String -> String -> IO a
214 parseCheck parser str what =
215 case readP_to_S parser str of
216 [(x,ys)] | all isSpace ys -> return x
217 _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
219 readPkgId :: String -> IO PackageIdentifier
220 readPkgId str = parseCheck parsePackageId str "package identifier"
222 -- -----------------------------------------------------------------------------
225 -- Some commands operate on a single database:
226 -- register, unregister, expose, hide
227 -- however these commands also check the union of the available databases
228 -- in order to check consistency. For example, register will check that
229 -- dependencies exist before registering a package.
231 -- Some commands operate on multiple databases, with overlapping semantics:
232 -- list, describe, field
234 type PackageDBName = FilePath
235 type PackageDB = [InstalledPackageInfo]
237 type PackageDBStack = [(PackageDBName,PackageDB)]
238 -- A stack of package databases. Convention: head is the topmost
239 -- in the stack. Earlier entries override later one.
241 -- The output of this function is the list of databases to act upon, with
242 -- the "topmost" overlapped database last. The commands which operate on a
243 -- single database will use the last one. Commands which operate on multiple
244 -- databases will interpret the databases as overlapping.
245 getPkgDatabases :: [Flag] -> IO [PackageDBName]
246 getPkgDatabases flags = do
247 -- first we determine the location of the global package config. On Windows,
248 -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
249 -- location is passed to the binary using the --global-config flag by the
251 let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
253 case [ f | FlagGlobalConfig f <- flags ] of
254 [] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe"
256 Nothing -> die err_msg
257 Just dir -> return (dir `joinFileName` "package.conf")
258 fs -> return (last fs)
260 -- get the location of the user package database, and create it if necessary
261 appdir <- getAppUserDataDirectory "ghc"
264 subdir = targetARCH ++ '-':targetOS ++ '-':version
265 user_conf = appdir `joinFileName` subdir `joinFileName` "package.conf"
266 b <- doesFileExist user_conf
268 putStrLn ("Creating user package database in " ++ user_conf)
269 createParents user_conf
270 writeFile user_conf emptyPackageConfig
273 databases = foldl addDB [global_conf] flags
275 -- implement the following rules:
276 -- global database is the default
277 -- --user means overlap with the user database
278 -- --global means reset to just the global database
279 -- -f <file> means overlap with <file>
280 addDB dbs FlagUser = user_conf : dbs
281 addDB dbs FlagGlobal = [global_conf]
282 addDB dbs (FlagConfig f) = f : dbs
287 readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
288 readParseDatabase filename = do
289 str <- readFile filename
290 let packages = read str
292 `Exception.catch` \_ ->
293 die (filename ++ ": parse error in package config file\n")
294 return (filename,packages)
296 emptyPackageConfig :: String
297 emptyPackageConfig = "[]"
299 -- -----------------------------------------------------------------------------
302 registerPackage :: FilePath
303 -> [(String,String)] -- defines, ToDo: maybe remove?
305 -> Bool -- auto_ghci_libs
309 registerPackage input defines db_stack auto_ghci_libs update force = do
311 db_to_operate_on = head db_stack
312 db_filename = fst db_to_operate_on
314 checkConfigAccess db_filename
319 putStr "Reading package info from stdin... "
322 putStr ("Reading package info from " ++ show f)
325 pkg <- parsePackageInfo s defines force
328 validatePackageConfig pkg db_stack auto_ghci_libs update force
329 new_details <- updatePackageDB (snd db_to_operate_on) pkg
330 savePackageConfig db_filename
331 maybeRestoreOldConfig db_filename $
332 writeNewConfig db_filename new_details
338 -> IO InstalledPackageInfo
339 parsePackageInfo str defines force =
340 case parseInstalledPackageInfo str of
341 Right ok -> return ok
343 old_pkg <- evaluate (parseOnePackageConfig str)
344 `Exception.catch` \_ -> parse_failed
345 putStr "Expanding embedded variables... "
346 new_old_pkg <- expandEnvVars old_pkg defines force
347 return (convertOldPackage old_pkg)
349 parse_failed = die "parse error in package info\n"
351 convertOldPackage :: PackageConfig -> InstalledPackageInfo
356 import_dirs = import_dirs,
357 source_dirs = source_dirs,
358 library_dirs = library_dirs,
359 hs_libraries = hs_libraries,
360 extra_libraries = extra_libraries,
361 include_dirs = include_dirs,
362 c_includes = c_includes,
363 package_deps = package_deps,
364 extra_ghc_opts = extra_ghc_opts,
365 extra_cc_opts = extra_cc_opts,
366 extra_ld_opts = extra_ld_opts,
367 framework_dirs = framework_dirs,
368 extra_frameworks= extra_frameworks
370 = InstalledPackageInfo {
371 package = pkgNameToId name,
372 license = AllRightsReserved,
384 importDirs = import_dirs,
385 libraryDirs = library_dirs,
386 hsLibraries = hs_libraries,
387 extraLibraries = extra_libraries,
388 includeDirs = include_dirs,
389 includes = c_includes,
390 depends = map pkgNameToId package_deps,
392 extraCcOpts = extra_cc_opts,
393 extraLdOpts = extra_ld_opts,
394 frameworkDirs = framework_dirs,
395 extraFrameworks = extra_frameworks,
396 haddockInterfaces = [],
401 -- Used for converting old versionless package names to new PackageIdentifiers.
402 -- "Version [] []" is special: it means "no version" or "any version"
403 pkgNameToId :: String -> PackageIdentifier
404 pkgNameToId name = PackageIdentifier name (Version [] [])
406 -- -----------------------------------------------------------------------------
409 unregisterPackage :: PackageDBStack -> PackageIdentifier -> IO ()
410 unregisterPackage [] _ = error "unregisterPackage"
411 unregisterPackage ((db_name, pkgs) : _) pkgid = do
412 checkConfigAccess db_name
413 when (pkgid `notElem` map package pkgs)
414 (die (db_name ++ ": package '" ++ showPackageId pkgid
416 savePackageConfig db_name
417 maybeRestoreOldConfig db_name $
418 writeNewConfig db_name (filter ((/= pkgid) . package) pkgs)
420 -- -----------------------------------------------------------------------------
423 exposePackage :: PackageIdentifier -> PackageDBStack -> IO ()
424 exposePackage = error "TODO"
426 -- -----------------------------------------------------------------------------
429 hidePackage :: PackageIdentifier -> PackageDBStack -> IO ()
430 hidePackage = error "TODO"
432 -- -----------------------------------------------------------------------------
435 listPackages :: PackageDBStack -> IO ()
436 listPackages db_confs = do
437 mapM_ show_pkgconf (reverse db_confs)
438 where show_pkgconf (db_name,pkg_confs) =
439 hPutStrLn stdout (render $
440 text (db_name ++ ":") $$ nest 4 packages
442 where packages = fsep (punctuate comma (map pp_pkg pkg_confs))
443 pp_pkg = text . showPackageId . package
446 -- -----------------------------------------------------------------------------
449 describePackage :: PackageDBStack -> PackageIdentifier -> IO ()
450 describePackage db_stack pkgid = do
451 p <- findPackage db_stack pkgid
452 putStrLn (showInstalledPackageInfo p)
454 findPackage :: PackageDBStack -> PackageIdentifier -> IO InstalledPackageInfo
455 findPackage db_stack pkgid
456 = case [ p | p <- all_pkgs, pkgid == package p ] of
457 [] -> die ("cannot find package " ++ showPackageId pkgid)
460 all_pkgs = concat (map snd db_stack)
462 -- -----------------------------------------------------------------------------
465 describeField :: PackageDBStack -> PackageIdentifier -> String -> IO ()
466 describeField db_stack pkgid field = do
467 case toField field of
468 Nothing -> die ("unknown field: " ++ field)
470 p <- findPackage db_stack pkgid
473 toField :: String -> Maybe (InstalledPackageInfo -> String)
474 -- backwards compatibility:
475 toField "import_dirs" = Just $ strList . importDirs
476 toField "source_dirs" = Just $ strList . importDirs
477 toField "library_dirs" = Just $ strList . libraryDirs
478 toField "hs_libraries" = Just $ strList . hsLibraries
479 toField "extra_libraries" = Just $ strList . extraLibraries
480 toField "include_dirs" = Just $ strList . includeDirs
481 toField "c_includes" = Just $ strList . includes
482 toField "package_deps" = Just $ strList . map showPackageId. depends
483 toField "extra_cc_opts" = Just $ strList . extraCcOpts
484 toField "extra_ld_opts" = Just $ strList . extraLdOpts
485 toField "framework_dirs" = Just $ strList . frameworkDirs
486 toField "extra_frameworks"= Just $ strList . extraFrameworks
487 toField s = showInstalledPackageInfoField s
489 strList :: [String] -> String
492 -- -----------------------------------------------------------------------------
493 -- Manipulating package.conf files
495 checkConfigAccess :: FilePath -> IO ()
496 checkConfigAccess filename = do
497 access <- getPermissions filename
498 when (not (writable access))
499 (die (filename ++ ": you don't have permission to modify this file\n"))
501 maybeRestoreOldConfig :: FilePath -> IO () -> IO ()
502 maybeRestoreOldConfig filename io
503 = io `catch` \e -> do
504 hPutStrLn stderr (show e)
505 hPutStr stdout ("\nWARNING: an error was encountered while the new \n"++
506 "configuration was being written. Attempting to \n"++
507 "restore the old configuration... ")
508 renameFile (filename ++ ".old") filename
509 hPutStrLn stdout "done."
512 writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
513 writeNewConfig filename packages = do
514 hPutStr stdout "Writing new package config file... "
515 h <- openFile filename WriteMode
516 hPutStrLn h (show packages)
518 hPutStrLn stdout "done."
520 savePackageConfig :: FilePath -> IO ()
521 savePackageConfig filename = do
522 hPutStr stdout "Saving old package config file... "
523 -- mv rather than cp because we've already done an hGetContents
524 -- on this file so we won't be able to open it for writing
525 -- unless we move the old one out of the way...
526 let oldFile = filename ++ ".old"
527 doesExist <- doesFileExist oldFile `catch` (\ _ -> return False)
528 when doesExist (removeFile oldFile `catch` (const $ return ()))
529 catch (renameFile filename oldFile)
531 hPutStrLn stderr (unwords [ "Unable to rename "
537 hPutStrLn stdout "done."
539 -----------------------------------------------------------------------------
540 -- Sanity-check a new package config, and automatically build GHCi libs
543 validatePackageConfig :: InstalledPackageInfo
545 -> Bool -- auto-ghc-libs
549 validatePackageConfig pkg db_stack auto_ghci_libs update force = do
550 checkDuplicates db_stack pkg update
551 mapM_ (checkDep db_stack force) (depends pkg)
552 mapM_ (checkDir force) (importDirs pkg)
553 mapM_ (checkDir force) (libraryDirs pkg)
554 mapM_ (checkDir force) (includeDirs pkg)
555 mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs force) (hsLibraries pkg)
556 -- ToDo: check these somehow?
557 -- extra_libraries :: [String],
558 -- c_includes :: [String],
561 checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> IO ()
562 checkDuplicates db_stack pkg update = do
566 (_top_db_name, pkgs) : _ = db_stack
568 pkgs_with_same_name =
569 [ p | p <- pkgs, pkgName (package p) == pkgName pkgid]
570 exposed_pkgs_with_same_name =
571 filter exposed pkgs_with_same_name
573 -- Check whether this package id already exists in this DB
575 when (not update && (package pkg `elem` map package pkgs)) $
576 die ("package " ++ showPackageId pkgid ++ " is already installed\n")
578 -- if we are exposing this new package, then check that
579 -- there are no other exposed packages with the same name.
581 when (not update && exposed pkg && not (null exposed_pkgs_with_same_name)) $
582 die ("trying to register " ++ showPackageId pkgid
583 ++ " as exposed, but "
584 ++ showPackageId (package (head exposed_pkgs_with_same_name))
585 ++ " is also exposed.")
588 checkDir :: Bool -> String -> IO ()
590 | "$libdir" `isPrefixOf` d = return ()
591 -- can't check this, because we don't know what $libdir is
593 there <- doesDirectoryExist d
595 (dieOrForce force (d ++ " doesn't exist or isn't a directory\n"))
597 checkDep :: PackageDBStack -> Bool -> PackageIdentifier -> IO ()
598 checkDep db_stack force pkgid
599 | real_version && pkgid `elem` pkgids = return ()
600 | not real_version && pkgName pkgid `elem` pkg_names = return ()
601 | otherwise = dieOrForce force ("dependency " ++ showPackageId pkgid
602 ++ " doesn't exist\n")
604 -- for backwards compat, we treat 0.0 as a special version,
605 -- and don't check that it actually exists.
606 real_version = versionBranch (pkgVersion pkgid) /= []
608 all_pkgs = concat (map snd db_stack)
609 pkgids = map package all_pkgs
610 pkg_names = map pkgName pkgids
612 checkHSLib :: [String] -> Bool -> Bool -> String -> IO ()
613 checkHSLib dirs auto_ghci_libs force lib = do
614 let batch_lib_file = "lib" ++ lib ++ ".a"
615 bs <- mapM (doesLibExistIn batch_lib_file) dirs
616 case [ dir | (exists,dir) <- zip bs dirs, exists ] of
617 [] -> dieOrForce force ("cannot find `" ++ batch_lib_file ++
619 (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
621 doesLibExistIn :: String -> String -> IO Bool
623 | "$libdir" `isPrefixOf` d = return True
624 | otherwise = doesFileExist (d ++ '/':lib)
626 checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
627 checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
628 | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
630 bs <- mapM (doesLibExistIn ghci_lib_file) dirs
631 case [dir | (exists,dir) <- zip bs dirs, exists] of
632 [] -> hPutStrLn stderr ("warning: can't find GHCi lib `" ++ ghci_lib_file ++ "'")
635 ghci_lib_file = lib ++ ".o"
637 -- automatically build the GHCi version of a batch lib,
638 -- using ld --whole-archive.
640 autoBuildGHCiLib :: String -> String -> String -> IO ()
641 autoBuildGHCiLib dir batch_file ghci_file = do
642 let ghci_lib_file = dir ++ '/':ghci_file
643 batch_lib_file = dir ++ '/':batch_file
644 hPutStr stderr ("building GHCi library `" ++ ghci_lib_file ++ "'...")
645 #ifdef darwin_TARGET_OS
646 system("ld -r -x -o " ++ ghci_lib_file ++
647 " -all_load " ++ batch_lib_file)
649 #ifdef mingw32_HOST_OS
650 execDir <- getExecDir "/bin/ghc-pkg.exe"
651 system (maybe "" (++"/gcc-lib/") execDir++"ld -r -x -o " ++ ghci_lib_file ++
652 " --whole-archive " ++ batch_lib_file)
654 system("ld -r -x -o " ++ ghci_lib_file ++
655 " --whole-archive " ++ batch_lib_file)
658 hPutStrLn stderr (" done.")
660 -- -----------------------------------------------------------------------------
661 -- Updating the DB with the new package.
664 :: [InstalledPackageInfo]
665 -> InstalledPackageInfo
666 -> IO [InstalledPackageInfo]
667 updatePackageDB pkgs new_pkg = do
669 is_exposed = exposed new_pkg
670 pkgid = package new_pkg
673 pkgs' = [ maybe_hide p | p <- pkgs, package p /= pkgid ]
675 -- When update is on, and we're exposing the new package,
676 -- we hide any packages with the same name (different versions)
677 -- in the current DB. Earlier checks will have failed if
680 | is_exposed && pkgName (package p) == name = p{ exposed = False }
683 return (pkgs'++[new_pkg])
685 -- -----------------------------------------------------------------------------
686 -- The old command-line syntax, supported for backwards compatibility
693 | OF_Add Bool {- True => replace existing info -}
694 | OF_Remove String | OF_Show String
695 | OF_Field String | OF_AutoGHCiLibs | OF_Force
696 | OF_DefinedName String String
697 | OF_GlobalConfig FilePath
700 isAction :: OldFlag -> Bool
701 isAction OF_Config{} = False
702 isAction OF_Field{} = False
703 isAction OF_Input{} = False
704 isAction OF_AutoGHCiLibs{} = False
705 isAction OF_Force{} = False
706 isAction OF_DefinedName{} = False
707 isAction OF_GlobalConfig{} = False
710 oldFlags :: [OptDescr OldFlag]
712 Option ['f'] ["config-file"] (ReqArg OF_Config "FILE")
713 "use the specified package config file",
714 Option ['l'] ["list-packages"] (NoArg OF_List)
715 "list packages in all config files",
716 Option ['L'] ["list-local-packages"] (NoArg OF_ListLocal)
717 "list packages in the specified config file",
718 Option ['a'] ["add-package"] (NoArg (OF_Add False))
720 Option ['u'] ["update-package"] (NoArg (OF_Add True))
721 "update package with new configuration",
722 Option ['i'] ["input-file"] (ReqArg OF_Input "FILE")
723 "read new package info from specified file",
724 Option ['s'] ["show-package"] (ReqArg OF_Show "NAME")
725 "show the configuration for package NAME",
726 Option [] ["field"] (ReqArg OF_Field "FIELD")
727 "(with --show-package) Show field FIELD only",
728 Option [] ["force"] (NoArg OF_Force)
729 "ignore missing directories/libraries",
730 Option ['r'] ["remove-package"] (ReqArg OF_Remove "NAME")
731 "remove an installed package",
732 Option ['g'] ["auto-ghci-libs"] (NoArg OF_AutoGHCiLibs)
733 "automatically build libs for GHCi (with -a)",
734 Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE")
735 "define NAME as VALUE",
736 Option [] ["global-conf"] (ReqArg OF_GlobalConfig "FILE")
737 "location of the global package config"
741 case break (=='=') str of
742 (nm,[]) -> OF_DefinedName nm []
743 (nm,_:val) -> OF_DefinedName nm val
745 oldRunit :: [OldFlag] -> IO ()
747 let config_flags = [ f | Just f <- map conv clis ]
749 conv (OF_GlobalConfig f) = Just (FlagGlobalConfig f)
750 conv (OF_Config f) = Just (FlagConfig f)
753 db_names <- getPkgDatabases config_flags
754 db_stack <- mapM readParseDatabase db_names
756 let fields = [ f | OF_Field f <- clis ]
758 let auto_ghci_libs = any isAuto clis
759 where isAuto OF_AutoGHCiLibs = True; isAuto _ = False
760 input_file = head ([ f | (OF_Input f) <- clis] ++ ["-"])
762 force = OF_Force `elem` clis
764 defines = [ (nm,val) | OF_DefinedName nm val <- clis ]
766 case [ c | c <- clis, isAction c ] of
767 [ OF_List ] -> listPackages db_stack
768 [ OF_ListLocal ] -> listPackages db_stack
769 [ OF_Add upd ] -> registerPackage input_file defines db_stack
770 auto_ghci_libs upd force
771 [ OF_Remove p ] -> unregisterPackage db_stack (pkgNameToId p)
773 | null fields -> describePackage db_stack (pkgNameToId p)
774 | otherwise -> mapM_ (describeField db_stack (pkgNameToId p)) fields
775 _ -> do prog <- getProgramName
776 die (usageInfo (usageHeader prog) flags)
778 -- ---------------------------------------------------------------------------
780 expandEnvVars :: PackageConfig -> [(String, String)]
781 -> Bool -> IO PackageConfig
782 expandEnvVars pkg defines force = do
783 -- permit _all_ strings to contain ${..} environment variable references,
784 -- arguably too flexible.
785 nm <- expandString (name pkg)
786 imp_dirs <- expandStrings (import_dirs pkg)
787 src_dirs <- expandStrings (source_dirs pkg)
788 lib_dirs <- expandStrings (library_dirs pkg)
789 hs_libs <- expandStrings (hs_libraries pkg)
790 ex_libs <- expandStrings (extra_libraries pkg)
791 inc_dirs <- expandStrings (include_dirs pkg)
792 c_incs <- expandStrings (c_includes pkg)
793 p_deps <- expandStrings (package_deps pkg)
794 e_g_opts <- expandStrings (extra_ghc_opts pkg)
795 e_c_opts <- expandStrings (extra_cc_opts pkg)
796 e_l_opts <- expandStrings (extra_ld_opts pkg)
797 f_dirs <- expandStrings (framework_dirs pkg)
798 e_frames <- expandStrings (extra_frameworks pkg)
799 return (pkg { name = nm
800 , import_dirs = imp_dirs
801 , source_dirs = src_dirs
802 , library_dirs = lib_dirs
803 , hs_libraries = hs_libs
804 , extra_libraries = ex_libs
805 , include_dirs = inc_dirs
806 , c_includes = c_incs
807 , package_deps = p_deps
808 , extra_ghc_opts = e_g_opts
809 , extra_cc_opts = e_c_opts
810 , extra_ld_opts = e_l_opts
811 , framework_dirs = f_dirs
812 , extra_frameworks= e_frames
815 expandStrings :: [String] -> IO [String]
816 expandStrings = liftM concat . mapM expandSpecial
818 -- Permit substitutions for list-valued variables (but only when
819 -- they occur alone), e.g., package_deps["${deps}"] where env var
820 -- (say) 'deps' is "base,haskell98,network"
821 expandSpecial :: String -> IO [String]
823 let expand f = liftM f $ expandString str
824 in case splitString str of
825 [Var _] -> expand (wordsBy (== ','))
826 _ -> expand (\x -> [x])
828 expandString :: String -> IO String
829 expandString = liftM concat . mapM expandElem . splitString
831 expandElem :: Elem -> IO String
832 expandElem (String s) = return s
833 expandElem (Var v) = lookupEnvVar v
835 lookupEnvVar :: String -> IO String
837 case lookup nm defines of
838 Just x | not (null x) -> return x
840 catch (System.getEnv nm)
841 (\ _ -> do dieOrForce force ("Unable to expand variable " ++
845 data Elem = String String | Var String
847 splitString :: String -> [Elem]
850 case break (== '$') str of
852 case span (/= '}') xs of
854 (if null pre then id else (String pre :)) (Var var : splitString suf)
855 _ -> [String str] -- no closing brace
856 _ -> [String str] -- no dollar/opening brace combo
858 -- wordsBy isSpace == words
859 wordsBy :: (Char -> Bool) -> String -> [String]
860 wordsBy p s = case dropWhile p s of
862 s' -> w : wordsBy p s'' where (w,s'') = break p s'
864 -----------------------------------------------------------------------------
866 getProgramName :: IO String
867 getProgramName = liftM (`withoutSuffix` ".bin") getProgName
868 where str `withoutSuffix` suff
869 | suff `isSuffixOf` str = take (length str - length suff) str
872 bye :: String -> IO a
873 bye s = putStr s >> exitWith ExitSuccess
875 die :: String -> IO a
878 prog <- getProgramName
879 hPutStr stderr (prog ++ ": " ++ s)
880 exitWith (ExitFailure 1)
882 dieOrForce :: Bool -> String -> IO ()
884 | force = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
885 | otherwise = die (s ++ "\n")
888 -----------------------------------------------------------------------------
889 -- Create a hierarchy of directories
891 createParents :: FilePath -> IO ()
892 createParents dir = do
893 let parent = directoryOf dir
894 b <- doesDirectoryExist parent
897 createDirectory parent
899 -----------------------------------------
900 -- Cut and pasted from ghc/compiler/SysTools
902 #if defined(mingw32_HOST_OS)
903 subst a b ls = map (\ x -> if x == a then b else x) ls
904 unDosifyPath xs = subst '\\' '/' xs
906 getExecDir :: String -> IO (Maybe String)
907 -- (getExecDir cmd) returns the directory in which the current
908 -- executable, which should be called 'cmd', is running
909 -- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
910 -- you'll get "/a/b/c" back as the result
912 = allocaArray len $ \buf -> do
913 ret <- getModuleFileName nullPtr buf len
914 if ret == 0 then return Nothing
915 else do s <- peekCString buf
916 return (Just (reverse (drop (length cmd)
917 (reverse (unDosifyPath s)))))
919 len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.
921 foreign import stdcall unsafe "GetModuleFileNameA"
922 getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
924 getExecDir :: String -> IO (Maybe String)
925 getExecDir _ = return Nothing
928 -- -----------------------------------------------------------------------------
929 -- Utils from Krasimir's FilePath library, copied here for now
931 directoryOf :: FilePath -> FilePath
932 directoryOf = fst.splitFileName
934 splitFileName :: FilePath -> (String, String)
935 splitFileName p = (reverse (path2++drive), reverse fname)
937 #ifdef mingw32_TARGET_OS
938 (path,drive) = break (== ':') (reverse p)
940 (path,drive) = (reverse p,"")
942 (fname,path1) = break isPathSeparator path
943 path2 = case path1 of
945 [_] -> path1 -- don't remove the trailing slash if
946 -- there is only one character
947 (c:path) | isPathSeparator c -> path
950 joinFileName :: String -> String -> FilePath
951 joinFileName "" fname = fname
952 joinFileName "." fname = fname
953 joinFileName dir fname
954 | isPathSeparator (last dir) = dir++fname
955 | otherwise = dir++pathSeparator:fname
957 isPathSeparator :: Char -> Bool
959 #ifdef mingw32_TARGET_OS
960 ch == '/' || ch == '\\'
965 pathSeparator :: Char
966 #ifdef mingw32_TARGET_OS