1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
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
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
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
|
{-# OPTIONS -fglasgow-exts #-}
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2004.
--
-- Package management tool
--
-----------------------------------------------------------------------------
-- TODO:
-- - validate modules
-- - expose/hide
-- - 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
import Distribution.Package
import Distribution.License
import Distribution.Version
import Compat.Directory ( getAppUserDataDirectory )
import Control.Exception ( evaluate )
import qualified Control.Exception as Exception
import Prelude
import Package -- the old package config type
#if __GLASGOW_HASKELL__ < 603
#include "config.h"
#endif
#if __GLASGOW_HASKELL__ >= 504
import System.Console.GetOpt
import Text.PrettyPrint
import qualified Control.Exception as Exception
#else
import GetOpt
import Pretty
import qualified Exception
#endif
import Data.Char ( isSpace )
import Monad
import Directory
import System ( getEnv, getArgs, getProgName,
system, exitWith,
ExitCode(..)
)
import IO
import List ( isPrefixOf, isSuffixOf )
import ParsePkgConfLite
#include "../../includes/ghcconfig.h"
#ifdef mingw32_HOST_OS
import Foreign
#if __GLASGOW_HASKELL__ >= 504
import Foreign.C.String
#else
import CString
#endif
#endif
-- -----------------------------------------------------------------------------
-- Entry point
main :: IO ()
main = do
args <- getArgs
case getOpt Permute flags args of
(cli,_,[]) | FlagHelp `elem` cli -> do
prog <- getProgramName
bye (usageInfo (usageHeader prog) flags)
(cli,_,[]) | FlagVersion `elem` cli ->
bye ourCopyright
(cli@(_:_),nonopts,[]) ->
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
prog <- getProgramName
die (concat errors ++ usageInfo (usageHeader prog) flags)
-- -----------------------------------------------------------------------------
-- Command-line syntax
data Flag
= FlagUser
| FlagGlobal
| FlagHelp
| FlagVersion
| FlagConfig FilePath
| FlagGlobalConfig FilePath
| FlagForce
deriving Eq
flags :: [OptDescr Flag]
flags = [
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",
Option ['?'] ["help"] (NoArg FlagHelp)
"display this help and exit",
Option ['V'] ["version"] (NoArg FlagVersion)
"output version information and exit"
]
ourCopyright :: String
ourCopyright = "GHC package manager version " ++ version ++ "\n"
usageHeader :: String -> String
usageHeader prog = substProg prog $
"Usage:\n" ++
" $p {--help | -?}\n" ++
" Produce this usage message.\n" ++
"\n" ++
" $p register {filename | -} [--user | --global]\n" ++
" Register the package using the specified installed package\n" ++
" description. The syntax for the latter is given in the $p\n" ++
" documentation.\n" ++
"\n" ++
" $p 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" ++
" $p list [--global | --user]\n" ++
" List all registered packages, both global and user (unless either\n" ++
" --global or --user is specified), and both hidden and exposed.\n" ++
"\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" ++
" specified package.\n"
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
dbs <- getPkgDatabases cli
db_stack <- mapM readParseDatabase dbs
let
force = FlagForce `elem` cli
--
-- first, parse the command
case nonopts of
["register", filename] ->
registerPackage filename [] db_stack False False force
["update", filename] ->
registerPackage filename [] db_stack False True force
["unregister", pkgid_str] -> do
pkgid <- readPkgId pkgid_str
unregisterPackage db_stack pkgid
["expose", pkgid_str] -> do
pkgid <- readPkgId pkgid_str
exposePackage pkgid db_stack
["hide", pkgid_str] -> do
pkgid <- readPkgId pkgid_str
hidePackage pkgid db_stack
["list"] -> do
listPackages db_stack
["describe", pkgid_str] -> do
pkgid <- readPkgId pkgid_str
describePackage db_stack pkgid
["field", pkgid_str, field] -> do
pkgid <- readPkgId pkgid_str
describeField db_stack pkgid field
[] -> 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 =
case readP_to_S parser str of
[(x,ys)] | all isSpace ys -> return x
_ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
readPkgId :: String -> IO PackageIdentifier
readPkgId str = parseCheck parsePackageId str "package identifier"
-- -----------------------------------------------------------------------------
-- 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.
-- The output of this function is the list of databases to act upon, with
-- the "topmost" overlapped database last. The commands which operate on a
-- single database will use the last one. Commands which operate on multiple
-- databases will interpret the databases as overlapping.
getPkgDatabases :: [Flag] -> IO [PackageDBName]
getPkgDatabases flags = do
-- 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
[] -> do mb_dir <- getExecDir "/bin/ghc-pkg.exe"
case mb_dir of
Nothing -> die err_msg
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
user_conf = appdir `joinFileName` subdir `joinFileName` "package.conf"
b <- doesFileExist user_conf
when (not b) $ do
putStrLn ("Creating user package database in " ++ user_conf)
createParents user_conf
writeFile user_conf emptyPackageConfig
let
databases = foldl addDB [global_conf] flags
-- implement the following rules:
-- global database is the default
-- --user means overlap with the user database
-- --global means reset to just the global database
-- -f <file> means overlap with <file>
addDB dbs FlagUser = user_conf : dbs
addDB dbs FlagGlobal = [global_conf]
addDB dbs (FlagConfig f) = f : dbs
addDB dbs _ = dbs
return databases
readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
readParseDatabase filename = do
str <- readFile filename
let packages = read str
evaluate packages
`Exception.catch` \_ ->
die (filename ++ ": parse error in package config file\n")
return (filename,packages)
emptyPackageConfig :: String
emptyPackageConfig = "[]"
-- -----------------------------------------------------------------------------
-- Registering
registerPackage :: FilePath
-> [(String,String)] -- defines, ToDo: maybe remove?
-> PackageDBStack
-> Bool -- auto_ghci_libs
-> Bool -- update
-> Bool -- force
-> IO ()
registerPackage input defines db_stack auto_ghci_libs update force = do
let
db_to_operate_on = head db_stack
db_filename = fst db_to_operate_on
--
checkConfigAccess db_filename
s <-
case input of
"-" -> do
putStr "Reading package info from stdin... "
getContents
f -> do
putStr ("Reading package info from " ++ show f)
readFile f
pkg <- parsePackageInfo s defines force
putStrLn "done."
validatePackageConfig pkg db_stack auto_ghci_libs update force
new_details <- updatePackageDB (snd db_to_operate_on) pkg
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
Right ok -> return ok
Left err -> do
old_pkg <- evaluate (parseOnePackageConfig str)
`Exception.catch` \_ -> parse_failed
putStr "Expanding embedded variables... "
new_old_pkg <- expandEnvVars old_pkg defines force
return (convertOldPackage old_pkg)
where
parse_failed = die "parse error in package info\n"
convertOldPackage :: PackageConfig -> InstalledPackageInfo
convertOldPackage
Package {
name = name,
auto = auto,
import_dirs = import_dirs,
source_dirs = source_dirs,
library_dirs = library_dirs,
hs_libraries = hs_libraries,
extra_libraries = extra_libraries,
include_dirs = include_dirs,
c_includes = c_includes,
package_deps = package_deps,
extra_ghc_opts = extra_ghc_opts,
extra_cc_opts = extra_cc_opts,
extra_ld_opts = extra_ld_opts,
framework_dirs = framework_dirs,
extra_frameworks= extra_frameworks
}
= InstalledPackageInfo {
package = pkgNameToId name,
license = AllRightsReserved,
copyright = "",
maintainer = "",
author = "",
stability = "",
homepage = "",
pkgUrl = "",
description = "",
category = "",
exposed = auto,
exposedModules = [],
hiddenModules = [],
importDirs = import_dirs,
libraryDirs = library_dirs,
hsLibraries = hs_libraries,
extraLibraries = extra_libraries,
includeDirs = include_dirs,
includes = c_includes,
depends = map pkgNameToId package_deps,
extraHugsOpts = [],
extraCcOpts = extra_cc_opts,
extraLdOpts = extra_ld_opts,
frameworkDirs = framework_dirs,
extraFrameworks = extra_frameworks,
haddockInterfaces = [],
haddockHTMLs = []
}
-- Used for converting old versionless package names to new PackageIdentifiers.
-- "Version [] []" is special: it means "no version" or "any version"
pkgNameToId :: String -> PackageIdentifier
pkgNameToId name = PackageIdentifier name (Version [] [])
-- -----------------------------------------------------------------------------
-- Unregistering
unregisterPackage :: PackageDBStack -> PackageIdentifier -> IO ()
unregisterPackage [] _ = error "unregisterPackage"
unregisterPackage ((db_name, pkgs) : _) pkgid = do
checkConfigAccess db_name
when (pkgid `notElem` map package pkgs)
(die (db_name ++ ": package '" ++ showPackageId pkgid
++ "' not found\n"))
savePackageConfig db_name
maybeRestoreOldConfig db_name $
writeNewConfig db_name (filter ((/= pkgid) . package) pkgs)
-- -----------------------------------------------------------------------------
-- Exposing
exposePackage :: PackageIdentifier -> PackageDBStack -> IO ()
exposePackage = error "TODO"
-- -----------------------------------------------------------------------------
-- Hiding
hidePackage :: PackageIdentifier -> PackageDBStack -> IO ()
hidePackage = error "TODO"
-- -----------------------------------------------------------------------------
-- Listing packages
listPackages :: PackageDBStack -> IO ()
listPackages db_confs = do
mapM_ show_pkgconf (reverse db_confs)
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))
pp_pkg = text . showPackageId . package
-- -----------------------------------------------------------------------------
-- Describe
describePackage :: PackageDBStack -> PackageIdentifier -> IO ()
describePackage db_stack pkgid = do
p <- findPackage db_stack pkgid
putStrLn (showInstalledPackageInfo p)
findPackage :: PackageDBStack -> PackageIdentifier -> IO InstalledPackageInfo
findPackage db_stack pkgid
= case [ p | p <- all_pkgs, pkgid == package p ] of
[] -> die ("cannot find package " ++ showPackageId pkgid)
(p:ps) -> return p
where
all_pkgs = concat (map snd db_stack)
-- -----------------------------------------------------------------------------
-- Field
describeField :: PackageDBStack -> PackageIdentifier -> String -> IO ()
describeField db_stack pkgid field = do
case toField field of
Nothing -> die ("unknown field: " ++ field)
Just fn -> do
p <- findPackage db_stack pkgid
putStrLn (fn p)
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
checkConfigAccess :: FilePath -> IO ()
checkConfigAccess filename = do
access <- getPermissions filename
when (not (writable access))
(die (filename ++ ": you don't have permission to modify this file\n"))
maybeRestoreOldConfig :: FilePath -> IO () -> IO ()
maybeRestoreOldConfig filename io
= io `catch` \e -> do
hPutStrLn stderr (show e)
hPutStr stdout ("\nWARNING: an error was encountered while the new \n"++
"configuration was being written. Attempting to \n"++
"restore the old configuration... ")
renameFile (filename ++ ".old") filename
hPutStrLn stdout "done."
ioError e
writeNewConfig :: FilePath -> [InstalledPackageInfo] -> IO ()
writeNewConfig filename packages = do
hPutStr stdout "Writing new package config file... "
h <- openFile filename WriteMode
hPutStrLn h (show packages)
hClose h
hPutStrLn stdout "done."
savePackageConfig :: FilePath -> IO ()
savePackageConfig filename = do
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...
let oldFile = filename ++ ".old"
doesExist <- doesFileExist oldFile `catch` (\ _ -> return False)
when doesExist (removeFile oldFile `catch` (const $ return ()))
catch (renameFile filename oldFile)
(\ err -> do
hPutStrLn stderr (unwords [ "Unable to rename "
, show filename
, " to "
, show oldFile
])
ioError err)
hPutStrLn stdout "done."
-----------------------------------------------------------------------------
-- Sanity-check a new package config, and automatically build GHCi libs
-- if requested.
validatePackageConfig :: InstalledPackageInfo
-> PackageDBStack
-> Bool -- auto-ghc-libs
-> Bool -- update
-> Bool -- force
-> IO ()
validatePackageConfig pkg db_stack auto_ghci_libs update force = do
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)
-- ToDo: check these somehow?
-- extra_libraries :: [String],
-- c_includes :: [String],
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)) $
die ("package " ++ showPackageId pkgid ++ " is already installed\n")
--
-- 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 "
++ showPackageId (package (head exposed_pkgs_with_same_name))
++ " is also exposed.")
checkDir :: Bool -> String -> IO ()
checkDir force d
| "$libdir" `isPrefixOf` d = return ()
-- can't check this, because we don't know what $libdir is
| otherwise = do
there <- doesDirectoryExist d
when (not there)
(dieOrForce force (d ++ " doesn't exist or isn't a directory\n"))
checkDep :: PackageDBStack -> Bool -> PackageIdentifier -> IO ()
checkDep db_stack force pkgid
| real_version && pkgid `elem` pkgids = return ()
| not real_version && pkgName pkgid `elem` pkg_names = return ()
| otherwise = dieOrForce force ("dependency " ++ showPackageId pkgid
++ " doesn't exist\n")
where
-- for backwards compat, we treat 0.0 as a special version,
-- and don't check that it actually exists.
real_version = versionBranch (pkgVersion pkgid) /= []
all_pkgs = concat (map snd db_stack)
pkgids = map package all_pkgs
pkg_names = map pkgName pkgids
checkHSLib :: [String] -> Bool -> Bool -> String -> IO ()
checkHSLib dirs auto_ghci_libs force lib = do
let batch_lib_file = "lib" ++ lib ++ ".a"
bs <- mapM (doesLibExistIn batch_lib_file) dirs
case [ dir | (exists,dir) <- zip bs dirs, exists ] of
[] -> dieOrForce force ("cannot find `" ++ batch_lib_file ++
"' on library path")
(dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
doesLibExistIn :: String -> String -> IO Bool
doesLibExistIn lib d
| "$libdir" `isPrefixOf` d = return True
| otherwise = doesFileExist (d ++ '/':lib)
checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO ()
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
[] -> hPutStrLn stderr ("warning: can't find GHCi lib `" ++ ghci_lib_file ++ "'")
(_:_) -> return ()
where
ghci_lib_file = lib ++ ".o"
-- automatically build the GHCi version of a batch lib,
-- using ld --whole-archive.
autoBuildGHCiLib :: String -> String -> String -> IO ()
autoBuildGHCiLib dir batch_file ghci_file = do
let ghci_lib_file = dir ++ '/':ghci_file
batch_lib_file = dir ++ '/':batch_file
hPutStr stderr ("building GHCi library `" ++ ghci_lib_file ++ "'...")
#if defined(darwin_TARGET_OS)
r <- system("ld -r -x -o " ++ ghci_lib_file ++
" -all_load " ++ batch_lib_file)
#elif defined(mingw32_HOST_OS)
execDir <- getExecDir "/bin/ghc-pkg.exe"
r <- system (maybe "" (++"/gcc-lib/") execDir++"ld -r -x -o " ++
ghci_lib_file ++ " --whole-archive " ++ batch_lib_file)
#else
r <- system("ld -r -x -o " ++ ghci_lib_file ++
" --whole-archive " ++ batch_lib_file)
#endif
when (r /= ExitSuccess) $ exitWith r
hPutStrLn stderr (" done.")
-- -----------------------------------------------------------------------------
-- Updating the DB with the new package.
updatePackageDB
:: [InstalledPackageInfo]
-> InstalledPackageInfo
-> IO [InstalledPackageInfo]
updatePackageDB pkgs new_pkg = do
let
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
--
return (pkgs'++[new_pkg])
-- -----------------------------------------------------------------------------
-- 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
let config_flags = [ f | Just f <- map conv clis ]
conv (OF_GlobalConfig f) = Just (FlagGlobalConfig f)
conv (OF_Config f) = Just (FlagConfig f)
conv _ = Nothing
db_names <- getPkgDatabases config_flags
db_stack <- mapM readParseDatabase db_names
let fields = [ f | OF_Field f <- clis ]
let auto_ghci_libs = any isAuto clis
where isAuto OF_AutoGHCiLibs = True; isAuto _ = False
input_file = head ([ f | (OF_Input f) <- clis] ++ ["-"])
force = OF_Force `elem` clis
defines = [ (nm,val) | OF_DefinedName nm val <- clis ]
case [ c | c <- clis, isAction c ] of
[ OF_List ] -> listPackages db_stack
[ OF_ListLocal ] -> listPackages db_stack
[ OF_Add upd ] -> registerPackage input_file defines db_stack
auto_ghci_libs upd force
[ OF_Remove p ] -> unregisterPackage db_stack (pkgNameToId p)
[ OF_Show p ]
| null fields -> describePackage db_stack (pkgNameToId p)
| otherwise -> mapM_ (describeField db_stack (pkgNameToId p)) fields
_ -> do prog <- getProgramName
die (usageInfo (usageHeader prog) flags)
-- ---------------------------------------------------------------------------
expandEnvVars :: PackageConfig -> [(String, String)]
-> Bool -> IO PackageConfig
expandEnvVars pkg defines force = do
-- permit _all_ strings to contain ${..} environment variable references,
-- arguably too flexible.
nm <- expandString (name pkg)
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)
f_dirs <- expandStrings (framework_dirs pkg)
e_frames <- expandStrings (extra_frameworks pkg)
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
, framework_dirs = f_dirs
, extra_frameworks= e_frames
})
where
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])
expandString :: String -> IO String
expandString = liftM concat . mapM expandElem . splitString
expandElem :: Elem -> IO String
expandElem (String s) = return s
expandElem (Var v) = lookupEnvVar v
lookupEnvVar :: String -> IO String
lookupEnvVar nm =
case lookup nm defines of
Just x | not (null x) -> return x
_ ->
catch (System.getEnv nm)
(\ _ -> do dieOrForce force ("Unable to expand variable " ++
show nm)
return "")
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
wordsBy :: (Char -> Bool) -> String -> [String]
wordsBy p s = case dropWhile p s of
"" -> []
s' -> w : wordsBy p s'' where (w,s'') = break p s'
-----------------------------------------------------------------------------
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
die :: String -> IO a
die s = do
hFlush stdout
prog <- getProgramName
hPutStr stderr (prog ++ ": " ++ s)
exitWith (ExitFailure 1)
dieOrForce :: Bool -> String -> IO ()
dieOrForce force s
| force = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
| otherwise = die (s ++ "\n")
-----------------------------------------------------------------------------
-- Create a hierarchy of directories
createParents :: FilePath -> IO ()
createParents dir = do
let parent = directoryOf dir
b <- doesDirectoryExist parent
when (not b) $ do
createParents parent
createDirectory parent
-----------------------------------------
-- Cut and pasted from ghc/compiler/SysTools
#if defined(mingw32_HOST_OS)
subst a b ls = map (\ x -> if x == a then b else x) ls
unDosifyPath xs = subst '\\' '/' xs
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.
foreign import stdcall unsafe "GetModuleFileNameA"
getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
#else
getExecDir :: String -> IO (Maybe String)
getExecDir _ = return Nothing
#endif
-- -----------------------------------------------------------------------------
-- Utils from Krasimir's FilePath library, copied here for now
directoryOf :: FilePath -> FilePath
directoryOf = fst.splitFileName
splitFileName :: FilePath -> (String, String)
splitFileName p = (reverse (path2++drive), reverse fname)
where
#ifdef mingw32_TARGET_OS
(path,drive) = break (== ':') (reverse p)
#else
(path,drive) = (reverse p,"")
#endif
(fname,path1) = break isPathSeparator path
path2 = case path1 of
[] -> "."
[_] -> path1 -- don't remove the trailing slash if
-- there is only one character
(c:path) | isPathSeparator c -> path
_ -> path1
joinFileName :: String -> String -> FilePath
joinFileName "" fname = fname
joinFileName "." fname = fname
joinFileName dir fname
| isPathSeparator (last dir) = dir++fname
| otherwise = dir++pathSeparator:fname
isPathSeparator :: Char -> Bool
isPathSeparator ch =
#ifdef mingw32_TARGET_OS
ch == '/' || ch == '\\'
#else
ch == '/'
#endif
pathSeparator :: Char
#ifdef mingw32_TARGET_OS
pathSeparator = '\\'
#else
pathSeparator = '/'
#endif
|