import Dynamic
import IO
+import Monad
import Array
import List
import System
-- user ways
-- Win32 support
-- make sure OPTIONS in .hs file propogate to .hc file if -C or -keep-hc-file-too
+-- reading the package configuration file is too slow
-----------------------------------------------------------------------------
-- Differences vs. old driver:
-----------------------------------------------------------------------------
-- non-configured things
-_Haskell1Version = "5" -- i.e., Haskell 98
+cHaskell1Version = "5" -- i.e., Haskell 98
-----------------------------------------------------------------------------
-- Usage Message
exitWith ExitSuccess
long_usage = do
- let usage_dir = findFile "ghc-usage.txt" (cGHC_DRIVER_DIR++"/ghc-usage.txt")
- usage <- readFile (usage_dir++"/ghc-usage.txt")
+ let usage_filename = "ghc-usage.txt"
+ usage_dir = findFile usage_filename cGHC_DRIVER_DIR
+ usage <- readFile (usage_dir ++ "/" ++ usage_filename)
dump usage
exitWith ExitSuccess
where
| PhaseFailed String ExitCode
| Interrupted
| NoInputFiles
+ | OtherError String
deriving Eq
GLOBAL_VAR(prog_name, "ghc", String)
(map (showString . wayName . lkupWay) ws)
showBarf (NoInputFiles)
= showString "no input files"
+showBarf (OtherError str)
+ = showString str
barfKindTc = mkTyCon "BarfKind"
-- Cpp-related flags
GLOBAL_VAR(cpp_flag, False, Bool)
hs_source_cpp_opts = global
- [ "-D__HASKELL1__="++_Haskell1Version
+ [ "-D__HASKELL1__="++cHaskell1Version
, "-D__GLASGOW_HASKELL__="++cProjectVersionInt
, "-D__HASKELL98__"
, "-D__CONCURRENT_HASKELL__"
-----------------------------------------------------------------------------
-- Packages
+GLOBAL_VAR(package_config, (findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace")), String)
+
+listPackages :: IO ()
+listPackages = do
+ details <- readIORef package_details
+ hPutStr stdout (listPkgs details)
+ hPutChar stdout '\n'
+ exitWith ExitSuccess
+
+newPackage :: IO ()
+newPackage = do
+ checkConfigAccess
+ details <- readIORef package_details
+ hPutStr stdout "Reading package info from stdin... "
+ stuff <- getContents
+ let new_pkg = read stuff :: (String,Package)
+ catchAll new_pkg
+ (\e -> 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 ++
+ "' already installed"))
+ else do
+ conf_file <- readIORef package_config
+ savePackageConfig conf_file
+ maybeRestoreOldConfig conf_file $ do
+ writeNewConfig conf_file ( ++ [new_pkg])
+ exitWith ExitSuccess
+
+deletePackage :: String -> IO ()
+deletePackage pkg = do
+ checkConfigAccess
+ details <- readIORef package_details
+ if (pkg `notElem` map fst 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))
+ exitWith ExitSuccess
+
+checkConfigAccess :: IO ()
+checkConfigAccess = do
+ conf_file <- readIORef package_config
+ access <- fileAccess conf_file True True False
+ if not access
+ then throwDyn (OtherError "you don't have permission to modify the package configuration file")
+ else return ()
+
+maybeRestoreOldConfig :: String -> IO () -> IO ()
+maybeRestoreOldConfig conf_file io
+ = catchAllIO io (\e -> do
+ hPutStr stdout "\nWARNING: an error was encountered while the new \n\
+ \configuration was being written. Attempting to \n\
+ \restore the old configuration... "
+ system ("cp " ++ conf_file ++ ".old " ++ conf_file)
+ hPutStrLn stdout "done."
+ throw e
+ )
+
+writeNewConfig :: String -> ([(String,Package)] -> [(String,Package)]) -> IO ()
+writeNewConfig conf_file fn = do
+ hPutStr stdout "Writing new package config file... "
+ old_details <- readIORef package_details
+ h <- openFile conf_file WriteMode
+ hPutStr h (dumpPackages (fn old_details))
+ hClose h
+ hPutStrLn stdout "done."
+
+savePackageConfig :: String -> IO ()
+savePackageConfig conf_file = 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...
+ system ("mv " ++ conf_file ++ " " ++ conf_file ++ ".old")
+ hPutStrLn stdout "done."
+
-- package list is maintained in dependency order
packages = global ["std", "rts", "gmp"] :: IORef [String]
-- comma in value, so can't use macro, grrr
l <- hGetLine h
case () of
() | null l -> look h
+ | prefixMatch "#" l -> look h
| prefixMatch "{-# LINE" l -> look h
| Just (opts:_) <- matchRegex optionRegex l
-> return (words opts)
argv' <- setTopDir argv
-- read the package configuration
- let conf = findFile "package.conf" (cGHC_DRIVER_DIR++"/package.conf.inplace")
- contents <- readFile conf
+ conf_file <- readIORef package_config
+ contents <- readFile conf_file
writeIORef package_details (read contents)
-- find the phase to stop after (i.e. -E, -C, -c, -S flags)
more_opts <- findBuildTag
_ <- processArgs more_opts []
+ -- get the -v flag
+ verb <- readIORef verbose
+
+ when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file))
+
if stop_phase == MkDependHS -- mkdependHS is special
then do_mkdependHS flags2 srcs
else do
case phase of
Hsc -> case lang of
HscC -> HCc
- HscAsm -> As
+ HscAsm | split -> SplitMangle
+ | otherwise -> As
HCc | mangle -> Mangle
| otherwise -> As
Ln -> True
Mangle | keep_raw_s -> True -- first enhancement :)
As | keep_s -> True
- Cc | keep_hc -> True
+ HCc | keep_hc -> True
_other -> False
output_fn <-
- (if phase == last_phase && not do_linking && use_ofile
+ (if next_phase > last_phase && not do_linking && use_ofile
then do o_file <- readIORef output_file
case o_file of
Just s -> return s
do_mkdependHS :: [String] -> [String] -> IO ()
do_mkdependHS cmd_opts srcs = do
-
- -- # They're not (currently) needed, but we need to quote any -#include options
- -- foreach (@Cmd_opts) {
- -- s/-#include.*$/'$&'/g;
- -- };
+ -- HACK
+ let quote_include_opt o | prefixMatch "-#include" o = "'" ++ o ++ "'"
+ | otherwise = o
mkdependHS <- readIORef pgm_dep
mkdependHS_opts <- getOpts opt_dep
(unwords (mkdependHS :
mkdependHS_opts
++ hs_src_cpp_opts
- ++ ("--" : cmd_opts )
+ ++ ("--" : map quote_include_opt cmd_opts )
++ ("--" : srcs)
))
-- we add the current directory (i.e. the directory in which
-- the .hs files resides) to the import path, since this is
-- what gcc does, and it's probably what you want.
- let (root,dir) = break (=='/') (reverse basename)
- current_dir = if null dir then "." else reverse dir
+ let current_dir = getdir basename
paths <- readIORef include_paths
writeIORef include_paths (current_dir : paths)
add files_to_clean tmp_stub_h
add files_to_clean tmp_stub_c
+ -- figure out where to put the .hi file
+ ohi <- readIORef output_hi
+ hisuf <- readIORef hi_suf
+ let hi_flags = case ohi of
+ Nothing -> [ "-hidir="++current_dir, "-hisuf="++hisuf ]
+ Just fn -> [ "-hifile="++fn ]
+
+ -- run the compiler!
run_something "Haskell Compiler"
(unwords (hsc : input_fn : (
hsc_opts
- ++ [ hi_flag, " -ofile="++output_fn ]
- ++ [ "-F="++tmp_stub_c, "-FH="++tmp_stub_h ]
+ ++ hi_flags
+ ++ [
+ "-ofile="++output_fn,
+ "-F="++tmp_stub_c,
+ "-FH="++tmp_stub_h
+ ]
++ stat_opts
)))
- -- Copy the .hi file into the current dir if it changed
- on doing_hi
- (do ohi <- readIORef output_hi
- hisuf <- readIORef hi_suf
- let hi_target = case ohi of
- Nothing -> basename ++ '.':hisuf
- Just fn -> fn
- new_hi_file <- fileExist tmp_hi_file
- on new_hi_file
- (run_something "Copy hi file"
- (unwords ["mv", tmp_hi_file, hi_target]))
- )
-
-- Generate -Rghc-timing info
on (timing) (
run_something "Generate timing stats"
-- probably _stub.o files
extra_ld_inputs <- readIORef ld_inputs
+ -- opts from -optl-<blah>
+ extra_ld_opts <- getOpts opt_l
+
run_something "Linker"
(unwords
([ ln, verb, "-o", output_fn ]
- -- ToDo: -u <blah> options
++ o_files
++ unknown_srcs
++ extra_ld_inputs
++ pkg_lib_path_opts
++ pkg_lib_opts
++ pkg_extra_ld_opts
+ ++ extra_ld_opts
)
)
, ( "split-objs" , NoArg (if can_split
then do writeIORef split_object_files True
- writeIORef hsc_lang HscC
add opt_C "-fglobalise-toplev-names"
add opt_c "-DUSE_SPLIT_MARKERS"
else hPutStrLn stderr
, ( "package" , HasArg (addPackage) )
, ( "syslib" , HasArg (addPackage) ) -- for compatibility w/ old vsns
+ , ( "-list-packages" , NoArg (listPackages) )
+ , ( "-add-package" , NoArg (newPackage) )
+ , ( "-delete-package" , SepArg (deletePackage) )
+
------- Specific phases --------------------------------------------
, ( "pgmdep" , HasArg (writeIORef pgm_dep) )
, ( "pgmL" , HasArg (writeIORef pgm_L) )
newsuf :: String -> String -> String
newsuf suf s = remove_suffix s '.' ++ suf
+-- getdir strips the filename off the input string, returning the directory.
+getdir :: String -> String
+getdir s = if null dir then "." else init dir
+ where dir = take_longest_prefix s '/'
+
newdir :: String -> String -> String
newdir dir s = dir ++ '/':drop_longest_prefix s '/'
projects / ghc-hetmet.git / blobdiff