X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FMain.hs;h=d41e5906c97a11891283cc5a6e686b41ee53d5bd;hb=c395b75ce4f20583a5b28c5df79c4de019beecb9;hp=d5e8de75c3cbc450afa16bf83f6cd1039d79c3e9;hpb=fb57f87ad779852b3bbcd96617fb211a8821d857;p=ghc-hetmet.git diff --git a/compiler/main/Main.hs b/compiler/main/Main.hs index d5e8de7..d41e590 100644 --- a/compiler/main/Main.hs +++ b/compiler/main/Main.hs @@ -1,4 +1,11 @@ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + ----------------------------------------------------------------------------- -- -- GHC Driver program @@ -24,16 +31,16 @@ import HscMain ( newHscEnv ) import DriverPipeline ( oneShot, compileFile ) import DriverMkDepend ( doMkDependHS ) #ifdef GHCI -import InteractiveUI ( ghciWelcomeMsg, interactiveUI ) +import InteractiveUI ( interactiveUI, ghciWelcomeMsg ) #endif -- Various other random stuff that we need -import Config ( cProjectVersion, cBooterVersion, cProjectName ) +import Config import Packages ( dumpPackages ) import DriverPhases ( Phase(..), isSourceFilename, anyHsc, startPhase, isHaskellSrcFilename ) import StaticFlags -import DynFlags ( defaultDynFlags ) +import DynFlags import BasicTypes ( failed ) import ErrUtils ( putMsg ) import FastString ( getFastStringTable, isZEncoded, hasZEncoding ) @@ -47,6 +54,7 @@ import System.IO import System.Directory ( doesDirectoryExist ) import System.Environment import System.Exit +import System.FilePath import Control.Monad import Data.List import Data.Maybe @@ -70,7 +78,7 @@ main = argv0 <- getArgs let - (minusB_args, argv1) = partition (prefixMatch "-B") argv0 + (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0 mbMinusB | null minusB_args = Nothing | otherwise = Just (drop 2 (last minusB_args)) @@ -85,11 +93,15 @@ main = -- to find out what version of GHC it's using before package.conf -- exists, so starting the session fails. case cli_mode of - ShowVersion -> do showVersion - exitWith ExitSuccess - ShowNumVersion -> do putStrLn cProjectVersion - exitWith ExitSuccess - _ -> return () + ShowInfo -> do showInfo + exitWith ExitSuccess + ShowSupportedLanguages -> do showSupportedLanguages + exitWith ExitSuccess + ShowVersion -> do showVersion + exitWith ExitSuccess + ShowNumVersion -> do putStrLn cProjectVersion + exitWith ExitSuccess + _ -> return () -- start our GHC session session <- GHC.newSession mbMinusB @@ -126,7 +138,6 @@ main = -- make sure we clean up after ourselves GHC.defaultCleanupHandler dflags $ do - -- Display banner showBanner cli_mode dflags -- we've finished manipulating the DynFlags, update the session @@ -137,7 +148,7 @@ main = -- To simplify the handling of filepaths, we normalise all filepaths right -- away - e.g., for win32 platforms, backslashes are converted -- into forward slashes. - normal_fileish_paths = map normalisePath fileish_args + normal_fileish_paths = map normalise fileish_args (srcs, objs) = partition_args normal_fileish_paths [] [] -- Note: have v_Ld_inputs maintain the order in which 'objs' occurred on @@ -154,18 +165,21 @@ main = ---------------- Final sanity checking ----------- checkOptions cli_mode dflags srcs objs - ---------------- Do the business ----------- + ---------------- Do the business ----------- + let alreadyHandled = panic (show cli_mode ++ + " should already have been handled") case cli_mode of - ShowUsage -> showGhcUsage dflags cli_mode - PrintLibdir -> putStrLn (topDir dflags) - ShowVersion -> panic "ShowVersion should already have been handled" - ShowNumVersion -> panic "ShowNumVersion should already have been handled" - ShowInterface f -> doShowIface dflags f - DoMake -> doMake session srcs - DoMkDependHS -> doMkDependHS session (map fst srcs) - StopBefore p -> oneShot dflags p srcs - DoInteractive -> interactiveUI session srcs Nothing - DoEval expr -> interactiveUI session srcs (Just expr) + ShowUsage -> showGhcUsage dflags cli_mode + PrintLibdir -> putStrLn (topDir dflags) + ShowSupportedLanguages -> alreadyHandled + ShowVersion -> alreadyHandled + ShowNumVersion -> alreadyHandled + ShowInterface f -> doShowIface dflags f + DoMake -> doMake session srcs + DoMkDependHS -> doMkDependHS session (map fst srcs) + StopBefore p -> oneShot dflags p srcs + DoInteractive -> interactiveUI session srcs Nothing + DoEval expr -> interactiveUI session srcs (Just expr) dumpFinalStats dflags exitWith ExitSuccess @@ -290,17 +304,19 @@ verifyOutputFiles dflags = do -- GHC modes of operation data CmdLineMode - = ShowUsage -- ghc -? - | PrintLibdir -- ghc --print-libdir - | ShowVersion -- ghc -V/--version - | ShowNumVersion -- ghc --numeric-version - | ShowInterface String -- ghc --show-iface - | DoMkDependHS -- ghc -M - | StopBefore Phase -- ghc -E | -C | -S - -- StopBefore StopLn is the default - | DoMake -- ghc --make - | DoInteractive -- ghc --interactive - | DoEval String -- ghc -e + = ShowUsage -- ghc -? + | PrintLibdir -- ghc --print-libdir + | ShowInfo -- ghc --info + | ShowSupportedLanguages -- ghc --supported-languages + | ShowVersion -- ghc -V/--version + | ShowNumVersion -- ghc --numeric-version + | ShowInterface String -- ghc --show-iface + | DoMkDependHS -- ghc -M + | StopBefore Phase -- ghc -E | -C | -S + -- StopBefore StopLn is the default + | DoMake -- ghc --make + | DoInteractive -- ghc --interactive + | DoEval String -- ghc -e deriving (Show) isInteractiveMode, isInterpretiveMode :: CmdLineMode -> Bool @@ -349,40 +365,42 @@ type ModeM a = CmdLineP (CmdLineMode, String, [String]) a mode_flags :: [(String, OptKind (CmdLineP (CmdLineMode, String, [String])))] mode_flags = [ ------- help / version ---------------------------------------------- - ( "?" , PassFlag (setMode ShowUsage)) - , ( "-help" , PassFlag (setMode ShowUsage)) - , ( "-print-libdir" , PassFlag (setMode PrintLibdir)) - , ( "V" , PassFlag (setMode ShowVersion)) - , ( "-version" , PassFlag (setMode ShowVersion)) - , ( "-numeric-version", PassFlag (setMode ShowNumVersion)) + ( "?" , PassFlag (setMode ShowUsage)) + , ( "-help" , PassFlag (setMode ShowUsage)) + , ( "-print-libdir" , PassFlag (setMode PrintLibdir)) + , ( "V" , PassFlag (setMode ShowVersion)) + , ( "-version" , PassFlag (setMode ShowVersion)) + , ( "-numeric-version" , PassFlag (setMode ShowNumVersion)) + , ( "-info" , PassFlag (setMode ShowInfo)) + , ( "-supported-languages", PassFlag (setMode ShowSupportedLanguages)) ------- interfaces ---------------------------------------------------- , ( "-show-iface" , HasArg (\f -> setMode (ShowInterface f) - "--show-iface")) + "--show-iface")) ------- primary modes ------------------------------------------------ - , ( "M" , PassFlag (setMode DoMkDependHS)) - , ( "E" , PassFlag (setMode (StopBefore anyHsc))) - , ( "C" , PassFlag (\f -> do setMode (StopBefore HCc) f - addFlag "-fvia-C")) - , ( "S" , PassFlag (setMode (StopBefore As))) - , ( "-make" , PassFlag (setMode DoMake)) - , ( "-interactive" , PassFlag (setMode DoInteractive)) + , ( "M" , PassFlag (setMode DoMkDependHS)) + , ( "E" , PassFlag (setMode (StopBefore anyHsc))) + , ( "C" , PassFlag (\f -> do setMode (StopBefore HCc) f + addFlag "-fvia-C")) + , ( "S" , PassFlag (setMode (StopBefore As))) + , ( "-make" , PassFlag (setMode DoMake)) + , ( "-interactive" , PassFlag (setMode DoInteractive)) , ( "e" , HasArg (\s -> setMode (DoEval s) "-e")) - -- -fno-code says to stop after Hsc but don't generate any code. - , ( "fno-code" , PassFlag (\f -> do setMode (StopBefore HCc) f - addFlag "-fno-code" - addFlag "-no-recomp")) + -- -fno-code says to stop after Hsc but don't generate any code. + , ( "fno-code" , PassFlag (\f -> do setMode (StopBefore HCc) f + addFlag "-fno-code" + addFlag "-no-recomp")) ] setMode :: CmdLineMode -> String -> ModeM () setMode m flag = do (old_mode, old_flag, flags) <- getCmdLineState - when (notNull old_flag && flag /= old_flag) $ - throwDyn (UsageError - ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'")) - putCmdLineState (m, flag, flags) + if notNull old_flag && flag /= old_flag + then throwDyn (UsageError + ("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'")) + else putCmdLineState (m, flag, flags) addFlag :: String -> ModeM () addFlag s = do @@ -428,24 +446,33 @@ doShowIface dflags file = do showBanner :: CmdLineMode -> DynFlags -> IO () showBanner cli_mode dflags = do let verb = verbosity dflags - -- Show the GHCi banner -# ifdef GHCI - when (isInteractiveMode cli_mode && verb >= 1) $ - hPutStrLn stdout ghciWelcomeMsg -# endif - - -- Display details of the configuration in verbose mode - when (not (isInteractiveMode cli_mode) && verb >= 2) $ - do hPutStr stderr "Glasgow Haskell Compiler, Version " - hPutStr stderr cProjectVersion - hPutStr stderr ", for Haskell 98, compiled by GHC version " + #ifdef GHCI - -- GHCI is only set when we are bootstrapping... - hPutStrLn stderr cProjectVersion -#else - hPutStrLn stderr cBooterVersion + -- Show the GHCi banner + when (isInteractiveMode cli_mode && verb >= 1) $ putStrLn ghciWelcomeMsg #endif + -- Display details of the configuration in verbose mode + when (verb >= 2) $ + do hPutStr stderr "Glasgow Haskell Compiler, Version " + hPutStr stderr cProjectVersion + hPutStr stderr ", for Haskell 98, stage " + hPutStr stderr cStage + hPutStr stderr " booted by GHC version " + hPutStrLn stderr cBooterVersion + +-- We print out a Read-friendly string, but a prettier one than the +-- Show instance gives us +showInfo :: IO () +showInfo = do + let sq x = " [" ++ x ++ "\n ]" + putStrLn $ sq $ concat $ intersperse "\n ," $ map show compilerInfo + exitWith ExitSuccess + +showSupportedLanguages :: IO () +showSupportedLanguages = do mapM_ putStrLn supportedLanguages + exitWith ExitSuccess + showVersion :: IO () showVersion = do putStrLn (cProjectName ++ ", version " ++ cProjectVersion) @@ -453,8 +480,8 @@ showVersion = do showGhcUsage dflags cli_mode = do let usage_path - | DoInteractive <- cli_mode = ghcUsagePath dflags - | otherwise = ghciUsagePath dflags + | DoInteractive <- cli_mode = ghciUsagePath dflags + | otherwise = ghcUsagePath dflags usage <- readFile usage_path dump usage exitWith ExitSuccess