Change representation of Package so it contains the package's name.
(This makes GHCI a bit more convenient).
{-# OPTIONS -W -fno-warn-incomplete-patterns #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.61 2000/09/25 12:30:44 simonmar Exp $
+-- $Id: Main.hs,v 1.62 2000/10/03 16:51:57 sewardj Exp $
--
-- GHC Driver program
--
-----------------------------------------------------------------------------
-- Usage Message
-short_usage = "Usage: For basic information, try the `-help' option."
+short_usage = "Usage: For basic information, try the `--help' option."
long_usage = do
let usage_file = "ghc-usage.txt"
details <- readIORef package_details
hPutStr stdout "Reading package info from stdin... "
stuff <- getContents
- let new_pkg = read stuff :: (String,Package)
+ let new_pkg = read stuff :: Package
catchAll new_pkg
(\_ -> throwDyn (OtherError "parse error in package info"))
hPutStrLn stdout "done."
- if (fst new_pkg `elem` map fst details)
- then throwDyn (OtherError ("package `" ++ fst new_pkg ++
+ if (name new_pkg `elem` map name details)
+ then throwDyn (OtherError ("package `" ++ name new_pkg ++
"' already installed"))
else do
conf_file <- readIORef package_config
deletePackage pkg = do
checkConfigAccess
details <- readIORef package_details
- if (pkg `notElem` map fst details)
+ if (pkg `notElem` map name details)
then throwDyn (OtherError ("package `" ++ pkg ++ "' not installed"))
else do
conf_file <- readIORef package_config
savePackageConfig conf_file
maybeRestoreOldConfig conf_file $ do
- writeNewConfig conf_file (filter ((/= pkg) . fst))
+ writeNewConfig conf_file (filter ((/= pkg) . name))
exitWith ExitSuccess
checkConfigAccess :: IO ()
throw e
)
-writeNewConfig :: String -> ([(String,Package)] -> [(String,Package)]) -> IO ()
+writeNewConfig :: String -> ([Package] -> [Package]) -> IO ()
writeNewConfig conf_file fn = do
hPutStr stdout "Writing new package config file... "
old_details <- readIORef package_details
addPackage :: String -> IO ()
addPackage package
= do pkg_details <- readIORef package_details
- case lookup package pkg_details of
+ case lookupPkg package pkg_details of
Nothing -> throwDyn (OtherError ("unknown package name: " ++ package))
Just details -> do
ps <- readIORef packages
getPackageDetails :: [String] -> IO [Package]
getPackageDetails ps = do
pkg_details <- readIORef package_details
- return [ pkg | p <- ps, Just pkg <- [ lookup p pkg_details ] ]
+ return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ]
-GLOBAL_VAR(package_details, (error "package_details"), [(String,Package)])
+GLOBAL_VAR(package_details, (error "package_details"), [Package])
+
+lookupPkg :: String -> [Package] -> Maybe Package
+lookupPkg nm ps
+ = case [p | p <- ps, name p == nm] of
+ [] -> Nothing
+ (p:_) -> Just p
-----------------------------------------------------------------------------
-- Ways
++ [ "-x", "c", input_fn, ">>", output_fn ]
))
else do
- run_something "Inefective C pre-processor"
+ run_something "Ineffective C pre-processor"
("echo '{-# LINE 1 \"" ++ input_fn ++ "\" -}' > "
++ output_fn ++ " && cat " ++ input_fn
++ " >> " ++ output_fn)
import Pretty
data Package = Package {
+ name :: String,
import_dirs :: [String],
library_dirs :: [String],
hs_libraries :: [String],
}
deriving (Read, Show)
-listPkgs :: [(String,Package)] -> String
-listPkgs pkgs = render (fsep (punctuate comma (map (text . fst) pkgs)))
+listPkgs :: [Package] -> String
+listPkgs pkgs = render (fsep (punctuate comma (map (text . name) pkgs)))
-dumpPackages :: [(String,Package)] -> String
+dumpPackages :: [Package] -> String
dumpPackages pkgs =
- render (brackets (vcat (punctuate comma (map dumpPkg pkgs))))
-
-dumpPkg :: (String,Package) -> Doc
-dumpPkg (name, pkg) =
- parens (hang (text (show name) <> comma) 2 (dumpPkgGuts pkg))
+ render (brackets (vcat (punctuate comma (map dumpPkgGuts pkgs))))
dumpPkgGuts :: Package -> Doc
dumpPkgGuts pkg =
text "Package" $$ nest 3 (braces (
sep (punctuate comma [
+ text "name = " <> text (show (name pkg)),
dumpField "import_dirs" (import_dirs pkg),
dumpField "library_dirs" (library_dirs pkg),
dumpField "hs_libraries" (hs_libraries pkg),
_ -> do hPutStr stderr "usage: pkgconf (install | in-place)\n"
exitWith (ExitFailure 1)
-package_details :: Bool -> [(String,Package)]
+package_details :: Bool -> [Package]
package_details installing =
[
- ( "gmp", -- GMP is at the bottom of the heap
Package {
+ name = "gmp", -- GMP is at the bottom of the heap
import_dirs = [],
library_dirs = if cHaveLibGmp == "YES"
then []
extra_ghc_opts = [],
extra_cc_opts = [],
extra_ld_opts = []
- }
- ),
+ },
- ( "rts", -- The RTS is just another package!
Package {
+ name = "rts", -- The RTS is just another package!
import_dirs = [],
library_dirs = if installing
then [ clibdir ]
, "-u __init_Prelude"
, "-u __init_PrelMain"
]
- }
- ),
+ },
- ( "std", -- The Prelude & Standard Hs_libraries
Package {
- import_dirs = if installing
+ name = "std", -- The Prelude & Standard Hs_libraries
+ import_dirs = if installing
then [ clibdir ++ "/imports/std" ]
else [ ghc_src_dir cGHC_LIB_DIR ++ "/std" ],
library_dirs = if installing
extra_ghc_opts = [],
extra_cc_opts = [],
extra_ld_opts = [ "-lm" ]
- }
- ),
+ },
- ( "lang",
Package {
- import_dirs = if installing
+ name = "lang",
+ import_dirs = if installing
then [ clibdir ++ "/imports/lang" ]
else [ cFPTOOLS_TOP_ABS ++ "/hslibs/lang"
, cFPTOOLS_TOP_ABS ++ "/hslibs/lang/monads" ],
extra_ghc_opts = [],
extra_cc_opts = [],
extra_ld_opts = []
- }
- ),
+ },
- ( "concurrent",
Package {
+ name = "concurrent",
import_dirs = if installing
then [ clibdir ++ "/imports/concurrent" ]
else [ cFPTOOLS_TOP_ABS ++ "/hslibs/concurrent" ],
extra_ghc_opts = [],
extra_cc_opts = [],
extra_ld_opts = []
- }
- ),
+ },
- ( "data",
Package {
+ name = "data",
import_dirs = if installing
then [ clibdir ++ "/imports/data" ]
else [ cFPTOOLS_TOP_ABS ++ "/hslibs/data"
extra_ghc_opts = [],
extra_cc_opts = [],
extra_ld_opts = []
- }
- ),
+ },
- ( "net",
Package {
+ name = "net",
import_dirs = if installing
then [ clibdir ++ "/imports/net" ]
else [ cFPTOOLS_TOP_ABS ++ "/hslibs/net" ],
extra_ld_opts = if postfixMatch "solaris2" cTARGETPLATFORM
then [ "-lnsl", "-lsocket" ]
else []
- }
- ),
+ },
- ( "posix",
Package {
+ name = "posix",
import_dirs = if installing
then [ clibdir ++ "/imports/posix" ]
else [ cFPTOOLS_TOP_ABS ++ "/hslibs/posix" ],
extra_ghc_opts = [],
extra_cc_opts = [],
extra_ld_opts = []
- }
- ),
+ },
- ( "text",
Package {
+ name = "text",
import_dirs = if installing
then [ clibdir ++ "/imports/text" ]
else [ cFPTOOLS_TOP_ABS ++ "/hslibs/text"
extra_ghc_opts = [],
extra_cc_opts = [],
extra_ld_opts = []
- }
- ),
+ },
- ( "util",
Package {
+ name = "util",
import_dirs = if installing
then [ clibdir ++ "/imports/util" ]
else [ cFPTOOLS_TOP_ABS ++ "/hslibs/util"
extra_ghc_opts = [],
extra_cc_opts = [],
extra_ld_opts = []
- }
- ),
+ },
-- no cbits at the moment, we'll need to add one if this library
-- ever calls out to any C libs.
- ( "hssource",
Package {
+ name = "hssource",
import_dirs = if installing
then [ clibdir ++ "/imports/hssource" ]
else [ cFPTOOLS_TOP_ABS ++ "/hslibs/hssource" ],
extra_ghc_opts = [],
extra_cc_opts = [],
extra_ld_opts = []
- }
- ),
+ },
- ( "win32",
Package {
- import_dirs = if installing
+ name = "win32",
+ import_dirs = if installing
then [ clibdir ++ "/imports/win32" ]
else [ cFPTOOLS_TOP_ABS ++ "/hslibs/win32/src" ],
library_dirs = if installing
extra_ghc_opts = [],
extra_cc_opts = [],
extra_ld_opts = [ "-luser32", "-lgdi32" ]
- }
- ),
+ },
- ( "com",
Package {
+ name = "com",
import_dirs = if installing
then [ clibdir ++ "/imports/com" ]
else [ cFPTOOLS_TOP_ABS ++ "/hdirect/lib" ],
extra_cc_opts = [],
extra_ld_opts = [ "-luser32", "-lole32", "-loleaut32", "-ladvapi32" ]
}
- )
]
ghc_src_dir :: String -> String
projects / ghc-hetmet.git / commitdiff