Main.hs 33.9 KB
Newer Older
1
{-# OPTIONS -fglasgow-exts #-}
2
-----------------------------------------------------------------------------
3
4
5
--
-- (c) The University of Glasgow 2004.
--
6
-- Package management tool
7
--
8
9
-----------------------------------------------------------------------------

10
11
12
13
14
15
16
17
18
19
20
-- TODO:
--	- validate modules
--	- expanding of variables in new-style package conf
--	- version manipulation (checking whether old version exists,
--	  hiding old version?)

module Main (main) where

import Version	( version, targetOS, targetARCH )
import Distribution.InstalledPackageInfo
import Distribution.Compat.ReadP
21
import Distribution.ParseUtils	( showError, ParseResult(..) )
22
23
import Distribution.Package
import Distribution.Version
24
import Compat.Directory 	( getAppUserDataDirectory, createDirectoryIfMissing )
25
import Compat.RawSystem 	( rawSystem )
26
import Control.Exception	( evaluate )
27

28
import Prelude
29

30
#include "../../includes/ghcconfig.h"
31

32
33
34
35
36
#if __GLASGOW_HASKELL__ >= 504
import System.Console.GetOpt
import Text.PrettyPrint
import qualified Control.Exception as Exception
#else
37
38
import GetOpt
import Pretty
39
40
41
import qualified Exception
#endif

42
import Data.Char	( isSpace )
43
44
import Monad
import Directory
45
import System	( getArgs, getProgName,
46
		  exitWith, ExitCode(..)
sof's avatar
sof committed
47
		)
48
49
import System.IO
import Data.List ( isPrefixOf, isSuffixOf, intersperse )
50

51
#ifdef mingw32_HOST_OS
52
import Foreign
53
54
55
56
57
58

#if __GLASGOW_HASKELL__ >= 504
import Foreign.C.String
#else
import CString
#endif
rrt's avatar
rrt committed
59
60
#endif

61
62
63
-- -----------------------------------------------------------------------------
-- Entry point

64
main :: IO ()
65
66
67
68
main = do
  args <- getArgs

  case getOpt Permute flags args of
69
	(cli,_,[]) | FlagHelp `elem` cli -> do
70
71
	   prog <- getProgramName
	   bye (usageInfo (usageHeader prog) flags)
72
73
	(cli,_,[]) | FlagVersion `elem` cli ->
	   bye ourCopyright
74
	(cli,nonopts,[]) ->
75
76
77
78
79
80
81
82
83
84
85
86
	   runit cli nonopts
	(_,_,errors) -> tryOldCmdLine errors args

-- If the new command-line syntax fails, then we try the old.  If that
-- fails too, then we output the original errors and the new syntax
-- (so the old syntax is still available, but hidden).
tryOldCmdLine :: [String] -> [String] -> IO ()
tryOldCmdLine errors args = do
  case getOpt Permute oldFlags args of
	(cli@(_:_),[],[]) -> 
	   oldRunit cli
	_failed -> do
87
88
	   prog <- getProgramName
	   die (concat errors ++ usageInfo (usageHeader prog) flags)
89

90
91
-- -----------------------------------------------------------------------------
-- Command-line syntax
92

93
94
95
96
97
98
99
100
data Flag
  = FlagUser
  | FlagGlobal
  | FlagHelp
  | FlagVersion
  | FlagConfig	FilePath
  | FlagGlobalConfig FilePath
  | FlagForce
101
  | FlagAutoGHCiLibs
102
  deriving Eq
103

104
flags :: [OptDescr Flag]
105
flags = [
106
107
108
109
110
111
112
113
114
115
  Option [] ["user"] (NoArg FlagUser)
	"use the current user's package database",
  Option [] ["global"] (NoArg FlagGlobal)
	"(default) use the global package database",
  Option ['f'] ["package-conf"] (ReqArg FlagConfig "FILE")
	"act upon specified package config file (only)",
  Option [] ["global-conf"] (ReqArg FlagGlobalConfig "FILE")
	"location of the global package config",
  Option [] ["force"] (NoArg FlagForce)
 	"ignore missing dependencies, directories, and libraries",
116
117
  Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs)
	"automatically build libs for GHCi (with register)",
118
  Option ['?'] ["help"] (NoArg FlagHelp)
119
	"display this help and exit",
120
   Option ['V'] ["version"] (NoArg FlagVersion)
121
	"output version information and exit"
122
  ]
123
124
125
126
127
128
129

ourCopyright :: String
ourCopyright = "GHC package manager version " ++ version ++ "\n"

usageHeader :: String -> String
usageHeader prog = substProg prog $
  "Usage:\n" ++
130
  "  $p register {filename | -}\n" ++
131
132
133
134
  "    Register the package using the specified installed package\n" ++
  "    description. The syntax for the latter is given in the $p\n" ++
  "    documentation.\n" ++
  "\n" ++
135
136
137
138
  "  $p update {filename | -}\n" ++
  "    Register the package, overwriting any other package with the\n" ++
  "    same name.\n" ++
  "\n" ++
139
140
141
142
143
144
145
146
147
  "  $p unregister {pkg-id}\n" ++
  "    Unregister the specified package.\n" ++
  "\n" ++
  "  $p expose {pkg-id}\n" ++
  "    Expose the specified package.\n" ++
  "\n" ++
  "  $p hide {pkg-id}\n" ++
  "    Hide the specified package.\n" ++
  "\n" ++
148
  "  $p list\n" ++
149
150
  "    List registered packages in the global database, and also the" ++
  "    user database if --user is given.\n" ++
151
152
153
154
155
156
157
158
  "\n" ++
  "  $p describe {pkg-id}\n" ++
  "    Give the registered description for the specified package. The\n" ++
  "    description is returned in precisely the syntax required by $p\n" ++
  "    register.\n" ++
  "\n" ++
  "  $p field {pkg-id} {field}\n" ++
  "    Extract the specified field of the package description for the\n" ++
159
160
161
  "    specified package.\n" ++
  "\n" ++
  " The following optional flags are also accepted:\n"
162
163
164
165
166
167
168
169
170
171
172
173
174
175

substProg :: String -> String -> String
substProg _ [] = []
substProg prog ('$':'p':xs) = prog ++ substProg prog xs
substProg prog (c:xs) = c : substProg prog xs

-- -----------------------------------------------------------------------------
-- Do the business

runit :: [Flag] -> [String] -> IO ()
runit cli nonopts = do
  prog <- getProgramName
  let
	force = FlagForce `elem` cli
176
	auto_ghci_libs = FlagAutoGHCiLibs `elem` cli
177
178
179
180
  --
  -- first, parse the command
  case nonopts of
    ["register", filename] -> 
181
	registerPackage filename [] cli auto_ghci_libs False force
182
    ["update", filename] -> 
183
	registerPackage filename [] cli auto_ghci_libs True force
184
    ["unregister", pkgid_str] -> do
185
186
	pkgid <- readGlobPkgId pkgid_str
	unregisterPackage pkgid cli
187
    ["expose", pkgid_str] -> do
188
189
	pkgid <- readGlobPkgId pkgid_str
	exposePackage pkgid cli
190
    ["hide",   pkgid_str] -> do
191
192
	pkgid <- readGlobPkgId pkgid_str
	hidePackage pkgid cli
193
    ["list"] -> do
194
	listPackages cli
195
    ["describe", pkgid_str] -> do
196
197
	pkgid <- readGlobPkgId pkgid_str
	describePackage cli pkgid
198
    ["field", pkgid_str, field] -> do
199
200
	pkgid <- readGlobPkgId pkgid_str
	describeField cli pkgid field
201
202
203
204
205
206
207
208
209
    [] -> do
	die ("missing command\n" ++ 
		usageInfo (usageHeader prog) flags)
    (_cmd:_) -> do
	die ("command-line syntax error\n" ++ 
		usageInfo (usageHeader prog) flags)

parseCheck :: ReadP a a -> String -> String -> IO a
parseCheck parser str what = 
210
211
  case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
    [x] -> return x
212
213
214
215
216
    _ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)

readPkgId :: String -> IO PackageIdentifier
readPkgId str = parseCheck parsePackageId str "package identifier"

217
218
219
220
221
222
223
224
225
226
227
228
229
readGlobPkgId :: String -> IO PackageIdentifier
readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"

parseGlobPackageId :: ReadP r PackageIdentifier
parseGlobPackageId = 
  parsePackageId
     +++
  (do n <- parsePackageName; string "-*"
      return (PackageIdentifier{ pkgName = n, pkgVersion = globVersion }))

-- globVersion means "all versions"
globVersion = Version{ versionBranch=[], versionTags=["*"] }

230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
-- -----------------------------------------------------------------------------
-- Package databases

-- Some commands operate on a single database:
--	register, unregister, expose, hide
-- however these commands also check the union of the available databases
-- in order to check consistency.  For example, register will check that
-- dependencies exist before registering a package.
--
-- Some commands operate  on multiple databases, with overlapping semantics:
--	list, describe, field

type PackageDBName  = FilePath
type PackageDB      = [InstalledPackageInfo]

type PackageDBStack = [(PackageDBName,PackageDB)]
	-- A stack of package databases.  Convention: head is the topmost
	-- in the stack.  Earlier entries override later one.

249
250
getPkgDatabases :: Bool -> [Flag] -> IO PackageDBStack
getPkgDatabases modify flags = do
251
252
253
254
255
256
257
  -- first we determine the location of the global package config.  On Windows,
  -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
  -- location is passed to the binary using the --global-config flag by the
  -- wrapper script.
  let err_msg = "missing --global-conf option, location of global package.conf unknown\n"
  global_conf <- 
     case [ f | FlagGlobalConfig f <- flags ] of
258
259
260
	[] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe"
		 case mb_dir of
			Nothing  -> die err_msg
261
262
263
264
265
266
267
268
			Just dir -> return (dir `joinFileName` "package.conf")
        fs -> return (last fs)

  -- get the location of the user package database, and create it if necessary
  appdir <- getAppUserDataDirectory "ghc"

  let
	subdir = targetARCH ++ '-':targetOS ++ '-':version
269
270
	archdir   = appdir `joinFileName` subdir
	user_conf = archdir `joinFileName` "package.conf"
271
272
273
  b <- doesFileExist user_conf
  when (not b) $ do
	putStrLn ("Creating user package database in " ++ user_conf)
274
	createDirectoryIfMissing True archdir
275
276
277
	writeFile user_conf emptyPackageConfig

  let
278
279
280
281
282
283
284
285
	-- The semantics here are slightly strange.  If we are
	-- *modifying* the database, then the default is to modify
	-- the global database by default, unless you say --user.
	-- If we are not modifying (eg. list, describe etc.) then
	-- the user database is included by default.
	databases
	  | modify     = foldl addDB [global_conf] flags
	  | not modify = foldl addDB [user_conf,global_conf] flags
286
287
288
289
290

	-- implement the following rules:
	-- 	--user means overlap with the user database
	-- 	--global means reset to just the global database
	--	-f <file> means overlap with <file>
291
292
293
	addDB dbs FlagUser       = if user_conf `elem` dbs 
					then dbs 
					else user_conf : dbs
294
295
296
297
	addDB dbs FlagGlobal     = [global_conf]
	addDB dbs (FlagConfig f) = f : dbs
	addDB dbs _		 = dbs

298
299
  db_stack <- mapM readParseDatabase databases
  return db_stack
300
301
302
303
304
305

readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
readParseDatabase filename = do
  str <- readFile filename
  let packages = read str
  evaluate packages
306
    `Exception.catch` \_ -> 
307
	die (filename ++ ": parse error in package config file")
308
309
310
311
312
313
314
315
316
317
  return (filename,packages)

emptyPackageConfig :: String
emptyPackageConfig = "[]"

-- -----------------------------------------------------------------------------
-- Registering

registerPackage :: FilePath
		-> [(String,String)] --  defines, ToDo: maybe remove?
318
	        -> [Flag]
319
320
321
322
		-> Bool		-- auto_ghci_libs
		-> Bool		-- update
		-> Bool		-- force
		-> IO ()
323
324
registerPackage input defines flags auto_ghci_libs update force = do
  db_stack <- getPkgDatabases True flags
325
  let
326
	db_to_operate_on = my_head "db" db_stack
327
328
329
	db_filename	 = fst db_to_operate_on
  --
  checkConfigAccess db_filename
330

sof's avatar
sof committed
331
  s <-
332
    case input of
sof's avatar
sof committed
333
      "-" -> do
334
	putStr "Reading package info from stdin... "
sof's avatar
sof committed
335
336
        getContents
      f   -> do
337
        putStr ("Reading package info from " ++ show f ++ " ")
sof's avatar
sof committed
338
	readFile f
339
340
341
342
343

  pkg <- parsePackageInfo s defines force
  putStrLn "done."

  validatePackageConfig pkg db_stack auto_ghci_libs update force
344
  new_details <- updatePackageDB db_stack (snd db_to_operate_on) pkg
345
346
347
348
349
350
351
352
353
354
355
  savePackageConfig db_filename
  maybeRestoreOldConfig db_filename $
    writeNewConfig db_filename new_details

parsePackageInfo
	:: String
	-> [(String,String)]
	-> Bool
	-> IO InstalledPackageInfo
parsePackageInfo str defines force =
  case parseInstalledPackageInfo str of
356
357
    ParseOk ok -> return ok
    ParseFailed err -> die (showError err)
358

359
-- -----------------------------------------------------------------------------
360
-- Exposing, Hiding, Unregistering are all similar
361

362
exposePackage :: PackageIdentifier ->  [Flag] -> IO ()
363
364
exposePackage = modifyPackage (\p -> [p{exposed=True}])

365
hidePackage :: PackageIdentifier ->  [Flag] -> IO ()
366
367
hidePackage = modifyPackage (\p -> [p{exposed=False}])

368
unregisterPackage :: PackageIdentifier ->  [Flag] -> IO ()
369
370
371
372
373
unregisterPackage = modifyPackage (\p -> [])

modifyPackage
  :: (InstalledPackageInfo -> [InstalledPackageInfo])
  -> PackageIdentifier
374
  -> [Flag]
375
  -> IO ()
376
377
378
modifyPackage fn pkgid flags  = do
  db_stack <- getPkgDatabases True{-modify-} flags
  let ((db_name, pkgs) : _) = db_stack
379
  checkConfigAccess db_name
380
381
  ps <- findPackages [(db_name,pkgs)] pkgid
  let pids = map package ps
382
  savePackageConfig db_name
383
384
  let new_config = concat (map modify pkgs)
      modify pkg
385
386
  	  | package pkg `elem` pids = fn pkg
  	  | otherwise               = [pkg]
387
  maybeRestoreOldConfig db_name $
388
      writeNewConfig db_name new_config
389
390
391
392

-- -----------------------------------------------------------------------------
-- Listing packages

393
394
395
396
listPackages ::  [Flag] -> IO ()
listPackages flags = do
  db_stack <- getPkgDatabases False flags
  mapM_ show_pkgconf (reverse db_stack)
397
398
399
400
401
  where show_pkgconf (db_name,pkg_confs) =
	  hPutStrLn stdout (render $
		text (db_name ++ ":") $$ nest 4 packages
		)
	   where packages = fsep (punctuate comma (map pp_pkg pkg_confs))
402
403
404
405
		 pp_pkg p
		   | exposed p = doc
		   | otherwise = parens doc
		   where doc = text (showPackageId (package p))
406
407
408
409

-- -----------------------------------------------------------------------------
-- Describe

410
411
412
413
414
describePackage :: [Flag] -> PackageIdentifier -> IO ()
describePackage flags pkgid = do
  db_stack <- getPkgDatabases False flags
  ps <- findPackages db_stack pkgid
  mapM_ (putStrLn . showInstalledPackageInfo) ps
415

416
417
418
-- PackageId is can have globVersion for the version
findPackages :: PackageDBStack -> PackageIdentifier -> IO [InstalledPackageInfo]
findPackages db_stack pkgid
419
420
  = case [ p | p <- all_pkgs, pkgid `matches` p ] of
	[]  -> die ("cannot find package " ++ showPackageId pkgid)
421
422
423
424
425
	[p] -> return [p]
	 -- if the version is globVersion, then we are allowed to match
	 -- multiple packages.  So eg. "Cabal-*" matches all Cabal packages,
	 -- but "Cabal" matches just one Cabal package - if there are more,
	 -- you get an error.
426
	ps | versionTags (pkgVersion pkgid) == versionTags globVersion
427
428
429
	   -> return ps
	   | otherwise
	   -> die ("package " ++ showPackageId pkgid ++ 
430
431
432
			" matches multiple packages: " ++ 
			concat (intersperse ", " (
				 map (showPackageId.package) ps)))
433
  where
434
435
436
437
	pid `matches` pkg
	  = (pkgName pid == pkgName p)
	    && (pkgVersion pid == pkgVersion p || not (realVersion pid))
	  where p = package pkg
438

439
	all_pkgs = concat (map snd db_stack)
440

441
442
443
-- -----------------------------------------------------------------------------
-- Field

444
445
446
describeField :: [Flag] -> PackageIdentifier -> String -> IO ()
describeField flags pkgid field = do
  db_stack <- getPkgDatabases False flags
447
448
449
  case toField field of
    Nothing -> die ("unknown field: " ++ field)
    Just fn -> do
450
451
	ps <- findPackages db_stack pkgid 
	mapM_ (putStrLn.fn) ps
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473

toField :: String -> Maybe (InstalledPackageInfo -> String)
-- backwards compatibility:
toField "import_dirs"     = Just $ strList . importDirs
toField "source_dirs"     = Just $ strList . importDirs
toField "library_dirs"    = Just $ strList . libraryDirs
toField "hs_libraries"    = Just $ strList . hsLibraries
toField "extra_libraries" = Just $ strList . extraLibraries
toField "include_dirs"    = Just $ strList . includeDirs
toField "c_includes"      = Just $ strList . includes
toField "package_deps"    = Just $ strList . map showPackageId. depends
toField "extra_cc_opts"   = Just $ strList . extraCcOpts
toField "extra_ld_opts"   = Just $ strList . extraLdOpts  
toField "framework_dirs"  = Just $ strList . frameworkDirs  
toField "extra_frameworks"= Just $ strList . extraFrameworks  
toField s 	 	  = showInstalledPackageInfoField s

strList :: [String] -> String
strList = show

-- -----------------------------------------------------------------------------
-- Manipulating package.conf files
474
475

checkConfigAccess :: FilePath -> IO ()
476
477
checkConfigAccess filename = do
  access <- getPermissions filename
478
  when (not (writable access))
479
      (die (filename ++ ": you don't have permission to modify this file"))
480

481
482
maybeRestoreOldConfig :: FilePath -> IO () -> IO ()
maybeRestoreOldConfig filename io
483
484
  = io `catch` \e -> do
	hPutStrLn stderr (show e)
485
486
487
        hPutStr stdout ("\nWARNING: an error was encountered while the new \n"++
        	          "configuration was being written.  Attempting to \n"++
        	          "restore the old configuration... ")
488
	renameFile (filename ++ ".old")  filename
489
        hPutStrLn stdout "done."
490
	ioError e
491

492
writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
493
writeNewConfig filename packages = do
494
  hPutStr stdout "Writing new package config file... "
495
  h <- openFile filename WriteMode
496
  hPutStrLn h (show packages)
497
498
499
  hClose h
  hPutStrLn stdout "done."

500
501
savePackageConfig :: FilePath -> IO ()
savePackageConfig filename = do
502
503
504
505
  hPutStr stdout "Saving old package config file... "
    -- mv rather than cp because we've already done an hGetContents
    -- on this file so we won't be able to open it for writing
    -- unless we move the old one out of the way...
506
  let oldFile = filename ++ ".old"
sof's avatar
sof committed
507
508
  doesExist <- doesFileExist oldFile  `catch` (\ _ -> return False)
  when doesExist (removeFile oldFile `catch` (const $ return ()))
509
  catch (renameFile filename oldFile)
sof's avatar
sof committed
510
  	(\ err -> do
sof's avatar
sof committed
511
		hPutStrLn stderr (unwords [ "Unable to rename "
512
					  , show filename
sof's avatar
sof committed
513
514
515
516
					  , " to "
					  , show oldFile
					  ])
		ioError err)
517
518
  hPutStrLn stdout "done."

519
520
521
522
-----------------------------------------------------------------------------
-- Sanity-check a new package config, and automatically build GHCi libs
-- if requested.

523
524
525
526
527
528
529
validatePackageConfig :: InstalledPackageInfo
		      -> PackageDBStack
		      -> Bool	-- auto-ghc-libs
		      -> Bool	-- update
		      -> Bool	-- force
		      -> IO ()
validatePackageConfig pkg db_stack auto_ghci_libs update force = do
530
  checkPackageId pkg
531
532
533
534
535
536
  checkDuplicates db_stack pkg update
  mapM_	(checkDep db_stack force) (depends pkg)
  mapM_	(checkDir force) (importDirs pkg)
  mapM_	(checkDir force) (libraryDirs pkg)
  mapM_	(checkDir force) (includeDirs pkg)
  mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs force) (hsLibraries pkg)
537
538
539
  -- ToDo: check these somehow?
  --	extra_libraries :: [String],
  --	c_includes      :: [String],
540

541
542
543
544
545
546
547
548
549
550
551
-- When the package name and version are put together, sometimes we can
-- end up with a package id that cannot be parsed.  This will lead to 
-- difficulties when the user wants to refer to the package later, so
-- we check that the package id can be parsed properly here.
checkPackageId :: InstalledPackageInfo -> IO ()
checkPackageId ipi =
  let str = showPackageId (package ipi) in
  case [ x | (x,ys) <- readP_to_S parsePackageId str, all isSpace ys ] of
    [_] -> return ()
    []  -> die ("invalid package identifier: " ++ str)
    _   -> die ("ambiguous package identifier: " ++ str)
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567

checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> IO ()
checkDuplicates db_stack pkg update = do
  let
	pkgid = package pkg

	(_top_db_name, pkgs) : _  = db_stack

	pkgs_with_same_name = 
		[ p | p <- pkgs, pkgName (package p) == pkgName pkgid]
	exposed_pkgs_with_same_name =
		filter exposed pkgs_with_same_name
  --
  -- Check whether this package id already exists in this DB
  --
  when (not update && (package pkg `elem` map package pkgs)) $
568
       die ("package " ++ showPackageId pkgid ++ " is already installed")
569
570
571
572
573
574
575
  --
  -- if we are exposing this new package, then check that
  -- there are no other exposed packages with the same name.
  --
  when (not update && exposed pkg && not (null exposed_pkgs_with_same_name)) $
	die ("trying to register " ++ showPackageId pkgid 
		  ++ " as exposed, but "
576
		  ++ showPackageId (package (my_head "when" exposed_pkgs_with_same_name))
577
578
		  ++ " is also exposed.")

579

580
checkDir :: Bool -> String -> IO ()
581
checkDir force d
582
583
 | "$topdir" `isPrefixOf` d = return ()
	-- can't check this, because we don't know what $topdir is
584
585
586
 | otherwise = do
   there <- doesDirectoryExist d
   when (not there)
587
       (dieOrForce force (d ++ " doesn't exist or isn't a directory"))
588
589
590
591
592
593

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
594
					++ " doesn't exist")
595
  where
596
597
	-- for backwards compat, we treat 0.0 as a special version,
	-- and don't check that it actually exists.
598
 	real_version = realVersion pkgid
599
600
601
602
	
	all_pkgs = concat (map snd db_stack)
	pkgids = map package all_pkgs
	pkg_names = map pkgName pkgids
603

604
605
606
realVersion :: PackageIdentifier -> Bool
realVersion pkgid = versionBranch (pkgVersion pkgid) /= []

607
608
checkHSLib :: [String] -> Bool -> Bool -> String -> IO ()
checkHSLib dirs auto_ghci_libs force lib = do
609
  let batch_lib_file = "lib" ++ lib ++ ".a"
610
  bs <- mapM (doesLibExistIn batch_lib_file) dirs
611
  case [ dir | (exists,dir) <- zip bs dirs, exists ] of
612
613
	[] -> dieOrForce force ("cannot find " ++ batch_lib_file ++
				 " on library path") 
614
615
	(dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs

616
doesLibExistIn :: String -> String -> IO Bool
617
doesLibExistIn lib d
618
 | "$topdir" `isPrefixOf` d = return True
619
620
 | otherwise                = doesFileExist (d ++ '/':lib)

621
checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
622
623
624
625
626
checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build
  | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
  | otherwise  = do
      bs <- mapM (doesLibExistIn ghci_lib_file) dirs
      case [dir | (exists,dir) <- zip bs dirs, exists] of
627
        []    -> hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
628
   	(_:_) -> return ()
629
630
  where
    ghci_lib_file = lib ++ ".o"
631
632
633
634

-- automatically build the GHCi version of a batch lib, 
-- using ld --whole-archive.

635
autoBuildGHCiLib :: String -> String -> String -> IO ()
636
637
638
autoBuildGHCiLib dir batch_file ghci_file = do
  let ghci_lib_file  = dir ++ '/':ghci_file
      batch_lib_file = dir ++ '/':batch_file
639
  hPutStr stderr ("building GHCi library " ++ ghci_lib_file ++ "...")
640
#if defined(darwin_HOST_OS)
641
  r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"-all_load",batch_lib_file]
642
#elif defined(mingw32_HOST_OS)
643
  execDir <- getExecDir "/bin/ghc-pkg.exe"
644
  r <- rawSystem (maybe "" (++"/gcc-lib/") execDir++"ld") ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
645
#else
646
  r <- rawSystem "ld" ["-r","-x","-o",ghci_lib_file,"--whole-archive",batch_lib_file]
647
#endif
648
  when (r /= ExitSuccess) $ exitWith r
649
650
  hPutStrLn stderr (" done.")

651
652
653
654
-- -----------------------------------------------------------------------------
-- Updating the DB with the new package.

updatePackageDB
655
656
	:: PackageDBStack
	-> [InstalledPackageInfo]
657
658
	-> InstalledPackageInfo
	-> IO [InstalledPackageInfo]
659
updatePackageDB db_stack pkgs new_pkg = do
660
  let
661
662
663
664
665
	-- 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.
666
667
	updateDeps p = p{depends = map resolveDep (depends p)}

668
669
670
	resolveDep dep_pkgid
	   | realVersion dep_pkgid  = dep_pkgid
	   | otherwise		    = lookupDep dep_pkgid
671

672
673
674
675
676
	lookupDep dep_pkgid
	   = let 
		name = pkgName dep_pkgid
	     in
	     case [ pid | p <- concat (map snd db_stack), 
677
			  let pid = package p,
678
679
680
681
682
			  pkgName pid == name ] of
		(pid:_) -> pid		-- Found installed package,
					-- replete with its version
		[]	-> dep_pkgid	-- No installed package; use 
					-- the version-less one
683

684
685
686
687
688
689
690
691
692
693
694
695
696
697
	is_exposed = exposed new_pkg
	pkgid      = package new_pkg
	name       = pkgName pkgid

	pkgs' = [ maybe_hide p | p <- pkgs, package p /= pkgid ]
	
	-- When update is on, and we're exposing the new package,
	-- we hide any packages with the same name (different versions)
	-- in the current DB.  Earlier checks will have failed if
	-- update isn't on.
	maybe_hide p
	  | is_exposed && pkgName (package p) == name = p{ exposed = False }
	  | otherwise = p
  --
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
  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
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799

-- -----------------------------------------------------------------------------
-- The old command-line syntax, supported for backwards compatibility

data OldFlag 
  = OF_Config FilePath
  | OF_Input FilePath
  | OF_List
  | OF_ListLocal
  | OF_Add Bool {- True => replace existing info -}
  | OF_Remove String | OF_Show String 
  | OF_Field String | OF_AutoGHCiLibs | OF_Force
  | OF_DefinedName String String
  | OF_GlobalConfig FilePath
  deriving (Eq)

isAction :: OldFlag -> Bool
isAction OF_Config{}        = False
isAction OF_Field{}         = False
isAction OF_Input{}         = False
isAction OF_AutoGHCiLibs{}  = False
isAction OF_Force{}	    = False
isAction OF_DefinedName{}   = False
isAction OF_GlobalConfig{}  = False
isAction _                  = True

oldFlags :: [OptDescr OldFlag]
oldFlags = [
  Option ['f'] ["config-file"] (ReqArg OF_Config "FILE")
	"use the specified package config file",
  Option ['l'] ["list-packages"] (NoArg OF_List)
 	"list packages in all config files",
  Option ['L'] ["list-local-packages"] (NoArg OF_ListLocal)
 	"list packages in the specified config file",
  Option ['a'] ["add-package"] (NoArg (OF_Add False))
 	"add a new package",
  Option ['u'] ["update-package"] (NoArg (OF_Add True))
 	"update package with new configuration",
  Option ['i'] ["input-file"] (ReqArg OF_Input "FILE")
	"read new package info from specified file",
  Option ['s'] ["show-package"] (ReqArg OF_Show "NAME")
 	"show the configuration for package NAME",
  Option [] ["field"] (ReqArg OF_Field "FIELD")
 	"(with --show-package) Show field FIELD only",
  Option [] ["force"] (NoArg OF_Force)
 	"ignore missing directories/libraries",
  Option ['r'] ["remove-package"] (ReqArg OF_Remove "NAME")
 	"remove an installed package",
  Option ['g'] ["auto-ghci-libs"] (NoArg OF_AutoGHCiLibs)
	"automatically build libs for GHCi (with -a)",
  Option ['D'] ["define-name"] (ReqArg toDefined "NAME=VALUE")
  	"define NAME as VALUE",
  Option [] ["global-conf"] (ReqArg OF_GlobalConfig "FILE")
	"location of the global package config"
  ]
 where
  toDefined str = 
    case break (=='=') str of
      (nm,[]) -> OF_DefinedName nm []
      (nm,_:val) -> OF_DefinedName nm val

oldRunit :: [OldFlag] -> IO ()
oldRunit clis = do
800
  let new_flags = [ f | Just f <- map conv clis ]
801
802
803
804
805

      conv (OF_GlobalConfig f) = Just (FlagGlobalConfig f)
      conv (OF_Config f)       = Just (FlagConfig f)
      conv _                   = Nothing

806
  
807
808
809
810
811

  let fields = [ f | OF_Field f <- clis ]

  let auto_ghci_libs = any isAuto clis 
	 where isAuto OF_AutoGHCiLibs = True; isAuto _ = False
812
      input_file = my_head "inp" ([ f | (OF_Input f) <- clis] ++ ["-"])
813
814
815
816
817
818

      force = OF_Force `elem` clis
      
      defines = [ (nm,val) | OF_DefinedName nm val <- clis ]

  case [ c | c <- clis, isAction c ] of
819
820
821
822
    [ OF_List ]      -> listPackages new_flags
    [ OF_ListLocal ] -> listPackages new_flags
    [ OF_Add upd ]   -> 
	registerPackage input_file defines new_flags auto_ghci_libs upd force
823
824
    [ OF_Remove pkgid_str ]  -> do
	pkgid <- readPkgId pkgid_str
825
	unregisterPackage pkgid new_flags
826
827
828
    [ OF_Show pkgid_str ]
	| null fields -> do
		pkgid <- readPkgId pkgid_str
829
		describePackage new_flags pkgid
830
831
	| otherwise   -> do
		pkgid <- readPkgId pkgid_str
832
		mapM_ (describeField new_flags pkgid) fields
833
834
835
    _ -> do 
	prog <- getProgramName
	die (usageInfo (usageHeader prog) flags)
836

837
838
839
my_head s [] = error s
my_head s (x:xs) = x

840
841
-- ---------------------------------------------------------------------------

842
843
#ifdef OLD_STUFF
-- ToDo: reinstate
844
845
expandEnvVars :: PackageConfig -> [(String, String)]
	-> Bool -> IO PackageConfig
sof's avatar
sof committed
846
expandEnvVars pkg defines force = do
sof's avatar
sof committed
847
848
   -- permit _all_ strings to contain ${..} environment variable references,
   -- arguably too flexible.
849
  nm       <- expandString  (name pkg)
sof's avatar
sof committed
850
851
852
853
854
855
856
857
858
859
860
  imp_dirs <- expandStrings (import_dirs pkg) 
  src_dirs <- expandStrings (source_dirs pkg) 
  lib_dirs <- expandStrings (library_dirs pkg) 
  hs_libs  <- expandStrings (hs_libraries pkg)
  ex_libs  <- expandStrings (extra_libraries pkg)
  inc_dirs <- expandStrings (include_dirs pkg)
  c_incs   <- expandStrings (c_includes pkg)
  p_deps   <- expandStrings (package_deps pkg)
  e_g_opts <- expandStrings (extra_ghc_opts pkg)
  e_c_opts <- expandStrings (extra_cc_opts pkg)
  e_l_opts <- expandStrings (extra_ld_opts pkg)
861
862
  f_dirs   <- expandStrings (framework_dirs pkg)
  e_frames <- expandStrings (extra_frameworks pkg)
sof's avatar
sof committed
863
864
865
866
867
868
869
870
871
872
873
874
  return (pkg { name            = nm
  	      , import_dirs     = imp_dirs
	      , source_dirs     = src_dirs
	      , library_dirs    = lib_dirs
	      , hs_libraries    = hs_libs
	      , extra_libraries = ex_libs
	      , include_dirs    = inc_dirs
	      , c_includes      = c_incs
	      , package_deps    = p_deps
	      , extra_ghc_opts  = e_g_opts
	      , extra_cc_opts   = e_c_opts
	      , extra_ld_opts   = e_l_opts
875
876
	      , framework_dirs  = f_dirs
	      , extra_frameworks= e_frames
sof's avatar
sof committed
877
878
	      })
  where
879
880
881
882
883
884
885
886
887
888
889
890
891
   expandStrings :: [String] -> IO [String]
   expandStrings = liftM concat . mapM expandSpecial

   -- Permit substitutions for list-valued variables (but only when
   -- they occur alone), e.g., package_deps["${deps}"] where env var
   -- (say) 'deps' is "base,haskell98,network"
   expandSpecial :: String -> IO [String]
   expandSpecial str =
      let expand f = liftM f $ expandString str
      in case splitString str of
         [Var _] -> expand (wordsBy (== ','))
         _ -> expand (\x -> [x])

sof's avatar
sof committed
892
   expandString :: String -> IO String
893
894
895
896
897
   expandString = liftM concat . mapM expandElem . splitString

   expandElem :: Elem -> IO String
   expandElem (String s) = return s
   expandElem (Var v)    = lookupEnvVar v
sof's avatar
sof committed
898

899
   lookupEnvVar :: String -> IO String
sof's avatar
sof committed
900
   lookupEnvVar nm = 
sof's avatar
sof committed
901
902
903
     case lookup nm defines of
       Just x | not (null x) -> return x
       _      -> 
sof's avatar
sof committed
904
	catch (System.getEnv nm)
905
906
907
	   (\ _ -> do dieOrForce force ("Unable to expand variable " ++ 
					show nm)
		      return "")
sof's avatar
sof committed
908

909
910
911
912
913
914
915
916
917
918
919
920
921
922
data Elem = String String | Var String

splitString :: String -> [Elem]
splitString "" = []
splitString str =
   case break (== '$') str of
      (pre, _:'{':xs) ->
         case span (/= '}') xs of
            (var, _:suf) ->
               (if null pre then id else (String pre :)) (Var var : splitString suf)
            _ -> [String str]   -- no closing brace
      _ -> [String str]   -- no dollar/opening brace combo

-- wordsBy isSpace == words
sof's avatar
sof committed
923
924
925
926
wordsBy :: (Char -> Bool) -> String -> [String]
wordsBy p s = case dropWhile p s of
  "" -> []
  s' -> w : wordsBy p s'' where (w,s'') = break p s'
927
#endif
sof's avatar
sof committed
928

929
930
-----------------------------------------------------------------------------

931
932
933
934
935
936
937
938
939
getProgramName :: IO String
getProgramName = liftM (`withoutSuffix` ".bin") getProgName
   where str `withoutSuffix` suff
            | suff `isSuffixOf` str = take (length str - length suff) str
            | otherwise             = str

bye :: String -> IO a
bye s = putStr s >> exitWith ExitSuccess

940
die :: String -> IO a
941
942
943
die s = do 
  hFlush stdout
  prog <- getProgramName
944
  hPutStrLn stderr (prog ++ ": " ++ s)
945
  exitWith (ExitFailure 1)
946

947
948
949
dieOrForce :: Bool -> String -> IO ()
dieOrForce force s 
  | force     = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
950
  | otherwise = die s
951

952

953
954
955
-----------------------------------------
--	Cut and pasted from ghc/compiler/SysTools

956
#if defined(mingw32_HOST_OS)
957
958
959
subst a b ls = map (\ x -> if x == a then b else x) ls
unDosifyPath xs = subst '\\' '/' xs

960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
getExecDir :: String -> IO (Maybe String)
-- (getExecDir cmd) returns the directory in which the current
--	  	    executable, which should be called 'cmd', is running
-- So if the full path is /a/b/c/d/e, and you pass "d/e" as cmd,
-- you'll get "/a/b/c" back as the result
getExecDir cmd
  = allocaArray len $ \buf -> do
	ret <- getModuleFileName nullPtr buf len
	if ret == 0 then return Nothing
	            else do s <- peekCString buf
			    return (Just (reverse (drop (length cmd) 
							(reverse (unDosifyPath s)))))
  where
    len = 2048::Int -- Plenty, PATH_MAX is 512 under Win32.

sof's avatar
sof committed
975
foreign import stdcall unsafe  "GetModuleFileNameA"
976
977
978
  getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
#else
getExecDir :: String -> IO (Maybe String) 
979
getExecDir _ = return Nothing
980
#endif
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017

-- -----------------------------------------------------------------------------
-- 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 = 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
1018
#ifdef mingw32_HOST_OS
1019
1020
1021
1022
pathSeparator = '\\'
#else
pathSeparator = '/'
#endif