- if null srcs then throwDyn (UsageError "no input files") else do
-
- let compileFile src = do
- writeIORef v_DynFlags init_dyn_flags
-
- exists <- doesFileExist src
- when (not exists) $
- throwDyn (CmdLineError ("file `" ++ src ++ "' does not exist"))
-
- -- We compile in two stages, because the file may have an
- -- OPTIONS pragma that affects the compilation pipeline (eg. -fvia-C)
- let (basename, suffix) = splitFilename src
-
- -- just preprocess (Haskell source only)
- pp <- if not (haskellish_src_file src) || mode == StopBefore Hsc
- then return src else do
- phases <- genPipeline (StopBefore Hsc) stop_flag
- False{-not persistent-} defaultHscLang src
- pipeLoop phases src False{-no linking-} False{-no -o flag-}
- basename suffix
-
- -- rest of compilation
- dyn_flags <- readIORef v_DynFlags
- phases <- genPipeline mode stop_flag True (hscLang dyn_flags) pp
- r <- pipeLoop phases pp (mode==DoLink || mode==DoMkDLL) True{-use -o flag-}
- basename suffix
- return r
-
- o_files <- mapM compileFile srcs
-
- when (mode == DoMkDependHS) endMkDependHS
- when (mode == DoLink) (doLink o_files)
- when (mode == DoMkDLL) (doMkDLL o_files)
- }
- -- grab the last -B option on the command line, and
- -- set topDir to its value.
-setTopDir :: [String] -> IO [String]
-setTopDir args = do
- let (minusbs, others) = partition (prefixMatch "-B") args
- (case minusbs of
- [] -> throwDyn (InstallationError ("missing -B<dir> option"))
- some -> writeIORef v_TopDir (drop 2 (last some)))
- return others
-
-beginMake :: [String] -> IO ()
-beginMake fileish_args
- = do let (objs, mods) = partition objish_file fileish_args
- mapM (add v_Ld_inputs) objs
-
- case mods of
- [] -> throwDyn (UsageError "no input files")
- [mod] -> do state <- cmInit Batch
- cmLoadModule state mod
- return ()
- _ -> throwDyn (UsageError "only one module allowed with --make")
-
-
-beginInteractive :: [String] -> IO ()
-#ifndef GHCI
-beginInteractive = throwDyn (CmdLineError "not built for interactive use")
-#else
-beginInteractive fileish_args
- = do minus_ls <- readIORef v_Cmdline_libraries
-
- let (objs, mods) = partition objish_file fileish_args
- libs = map Left objs ++ map Right minus_ls
-
- state <- cmInit Interactive
- case mods of
- [] -> interactiveUI state Nothing libs
- [mod] -> interactiveUI state (Just mod) libs
- _ -> throwDyn (UsageError
- "only one module allowed with --interactive")
-#endif
+ -- Check that there are some input files
+ -- (except in the interactive case)
+ if null srcs && null objs && needsInputsMode cli_mode
+ then throwDyn (UsageError "no input files")
+ else do
+
+ -- Verify that output files point somewhere sensible.
+ verifyOutputFiles dflags
+
+
+-- Compiler output options
+
+-- called to verify that the output files & directories
+-- point somewhere valid.
+--
+-- The assumption is that the directory portion of these output
+-- options will have to exist by the time 'verifyOutputFiles'
+-- is invoked.
+--
+verifyOutputFiles :: DynFlags -> IO ()
+verifyOutputFiles dflags = do
+ let odir = outputDir dflags
+ when (isJust odir) $ do
+ let dir = fromJust odir
+ flg <- doesDirectoryExist dir
+ when (not flg) (nonExistentDir "-odir" dir)
+ let ofile = outputFile dflags
+ when (isJust ofile) $ do
+ let fn = fromJust ofile
+ flg <- doesDirNameExist fn
+ when (not flg) (nonExistentDir "-o" fn)
+ let ohi = outputHi dflags
+ when (isJust ohi) $ do
+ let hi = fromJust ohi
+ flg <- doesDirNameExist hi
+ when (not flg) (nonExistentDir "-ohi" hi)
+ where
+ nonExistentDir flg dir =
+ throwDyn (CmdLineError ("error: directory portion of " ++
+ show dir ++ " does not exist (used with " ++
+ show flg ++ " option.)"))
+
+-----------------------------------------------------------------------------
+-- 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
+ deriving (Show)
+
+isInteractiveMode, isInterpretiveMode :: CmdLineMode -> Bool
+isLinkMode, isCompManagerMode :: CmdLineMode -> Bool
+
+isInteractiveMode DoInteractive = True
+isInteractiveMode _ = False
+
+-- isInterpretiveMode: byte-code compiler involved
+isInterpretiveMode DoInteractive = True
+isInterpretiveMode (DoEval _) = True
+isInterpretiveMode _ = False
+
+needsInputsMode DoMkDependHS = True
+needsInputsMode (StopBefore _) = True
+needsInputsMode DoMake = True
+needsInputsMode _ = False
+
+-- True if we are going to attempt to link in this mode.
+-- (we might not actually link, depending on the GhcLink flag)
+isLinkMode (StopBefore StopLn) = True
+isLinkMode DoMake = True
+isLinkMode _ = False
+
+isCompManagerMode DoMake = True
+isCompManagerMode DoInteractive = True
+isCompManagerMode (DoEval _) = True
+isCompManagerMode _ = False
+
+
+-- -----------------------------------------------------------------------------
+-- Parsing the mode flag
+
+parseModeFlags :: [String] -> IO (CmdLineMode, [String])
+parseModeFlags args = do
+ let ((leftover, errs), (mode, _, flags)) =
+ runCmdLine (processArgs mode_flags args) (StopBefore StopLn, "", [])
+ when (not (null errs)) $ do
+ throwDyn (UsageError (unlines errs))
+ return (mode, flags ++ leftover)
+
+type ModeM a = CmdLineP (CmdLineMode, String, [String]) a
+ -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
+ -- so we collect the new ones and return them.
+
+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))
+
+ ------- interfaces ----------------------------------------------------
+ , ( "-show-iface" , HasArg (\f -> setMode (ShowInterface f)
+ "--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))
+ , ( "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"))
+ ]
+
+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)
+
+addFlag :: String -> ModeM ()
+addFlag s = do
+ (m, f, flags) <- getCmdLineState
+ putCmdLineState (m, f, s:flags)
+
+
+-- ----------------------------------------------------------------------------
+-- Run --make mode
+
+doMake :: Session -> [(String,Maybe Phase)] -> IO ()
+doMake sess [] = throwDyn (UsageError "no input files")
+doMake sess srcs = do
+ let (hs_srcs, non_hs_srcs) = partition haskellish srcs
+
+ haskellish (f,Nothing) =
+ looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
+ haskellish (f,Just phase) =
+ phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]
+
+ dflags <- GHC.getSessionDynFlags sess
+ o_files <- mapM (compileFile dflags StopLn) non_hs_srcs
+ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
+
+ targets <- mapM (uncurry GHC.guessTarget) hs_srcs
+ GHC.setTargets sess targets
+ ok_flag <- GHC.load sess LoadAllTargets
+ when (failed ok_flag) (exitWith (ExitFailure 1))
+ return ()
+
+-- ---------------------------------------------------------------------------
+-- Various banners and verbosity output.
+
+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 "
+ hPutStrLn stderr cBooterVersion
+
+showVersion :: IO ()
+showVersion = do
+ putStrLn (cProjectName ++ ", version " ++ cProjectVersion)
+ exitWith ExitSuccess
+
+showGhcUsage cli_mode = do
+ (ghc_usage_path,ghci_usage_path) <- getUsageMsgPaths
+ let usage_path
+ | DoInteractive <- cli_mode = ghci_usage_path
+ | otherwise = ghc_usage_path
+ usage <- readFile usage_path
+ dump usage
+ exitWith ExitSuccess
+ where
+ dump "" = return ()
+ dump ('$':'$':s) = hPutStr stderr progName >> dump s
+ dump (c:s) = hPutChar stderr c >> dump s
+
+-- -----------------------------------------------------------------------------
+-- Util
+
+unknownFlagsErr :: [String] -> a
+unknownFlagsErr fs = throwDyn (UsageError ("unrecognised flags: " ++ unwords fs))