diff options
Diffstat (limited to 'ghc')
| -rw-r--r-- | ghc/GhciMonad.hs | 90 | ||||
| -rw-r--r-- | ghc/InteractiveUI.hs | 863 | ||||
| -rw-r--r-- | ghc/Main.hs | 123 |
3 files changed, 542 insertions, 534 deletions
diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index 55d8946c4f..be9a9f6b2f 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -1,13 +1,6 @@ {-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSp --- for details - ----------------------------------------------------------------------------- -- -- Monadery code used in InteractiveUI @@ -56,13 +49,13 @@ import Control.Monad.Trans as Trans type Command = (String, String -> InputT GHCi Bool, CompletionFunc GHCi) data GHCiState = GHCiState - { - progname :: String, - args :: [String], + { + progname :: String, + args :: [String], prompt :: String, - editor :: String, + editor :: String, stop :: String, - options :: [GHCiOption], + options :: [GHCiOption], line_number :: !Int, -- input line break_ctr :: !Int, breaks :: ![(Int, BreakLocation)], @@ -97,12 +90,12 @@ data GHCiState = GHCiState type TickArray = Array Int [(BreakIndex,SrcSpan)] -data GHCiOption - = ShowTiming -- show time/allocs after evaluation - | ShowType -- show the type of expressions - | RevertCAFs -- revert CAFs after every evaluation +data GHCiOption + = ShowTiming -- show time/allocs after evaluation + | ShowType -- show the type of expressions + | RevertCAFs -- revert CAFs after every evaluation | Multiline -- use multiline commands - deriving Eq + deriving Eq data BreakLocation = BreakLocation @@ -110,14 +103,14 @@ data BreakLocation , breakLoc :: !SrcSpan , breakTick :: {-# UNPACK #-} !Int , onBreakCmd :: String - } + } instance Eq BreakLocation where loc1 == loc2 = breakModule loc1 == breakModule loc2 && breakTick loc1 == breakTick loc2 prettyLocations :: [(Int, BreakLocation)] -> SDoc -prettyLocations [] = text "No active breakpoints." +prettyLocations [] = text "No active breakpoints." prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs instance Outputable BreakLocation where @@ -129,7 +122,7 @@ instance Outputable BreakLocation where recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int) recordBreak brkLoc = do st <- getGHCiState - let oldActiveBreaks = breaks st + let oldActiveBreaks = breaks st -- don't store the same break point twice case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of (nm:_) -> return (True, nm) @@ -183,10 +176,16 @@ instance MonadUtils.MonadIO GHCi where instance Trans.MonadIO Ghc where liftIO = MonadUtils.liftIO +instance HasDynFlags GHCi where + getDynFlags = getSessionDynFlags + instance GhcMonad GHCi where setSession s' = liftGhc $ setSession s' getSession = liftGhc $ getSession +instance HasDynFlags (InputT GHCi) where + getDynFlags = lift getDynFlags + instance GhcMonad (InputT GHCi) where setSession = lift . setSession getSession = lift getSession @@ -212,7 +211,7 @@ instance Haskeline.MonadException GHCi where catch = gcatch block = gblock unblock = gunblock - -- XXX when Haskeline's MonadException changes, we can drop our + -- XXX when Haskeline's MonadException changes, we can drop our -- deprecated block/unblock methods instance ExceptionMonad (InputT GHCi) where @@ -221,12 +220,8 @@ instance ExceptionMonad (InputT GHCi) where gblock = Haskeline.block gunblock = Haskeline.unblock -getDynFlags :: GhcMonad m => m DynFlags -getDynFlags = do - GHC.getSessionDynFlags - setDynFlags :: DynFlags -> GHCi [PackageId] -setDynFlags dflags = do +setDynFlags dflags = do GHC.setSessionDynFlags dflags isOptionSet :: GHCiOption -> GHCi Bool @@ -261,7 +256,7 @@ runStmt expr step = do withProgName (progname st) $ withArgs (args st) $ reflectGHCi x $ do - GHC.handleSourceError (\e -> do GHC.printException e; + GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do r <- GHC.runStmtWithLocation (progname st) (line_number st) expr step return (Just r) @@ -291,41 +286,41 @@ resume canLogSpan step = do timeIt :: InputT GHCi a -> InputT GHCi a timeIt action = do b <- lift $ isOptionSet ShowTiming - if not b - then action - else do allocs1 <- liftIO $ getAllocations - time1 <- liftIO $ getCPUTime - a <- action - allocs2 <- liftIO $ getAllocations - time2 <- liftIO $ getCPUTime - liftIO $ printTimes (fromIntegral (allocs2 - allocs1)) - (time2 - time1) - return a + if not b + then action + else do allocs1 <- liftIO $ getAllocations + time1 <- liftIO $ getCPUTime + a <- action + allocs2 <- liftIO $ getAllocations + time2 <- liftIO $ getCPUTime + liftIO $ printTimes (fromIntegral (allocs2 - allocs1)) + (time2 - time1) + return a foreign import ccall unsafe "getAllocations" getAllocations :: IO Int64 - -- defined in ghc/rts/Stats.c + -- defined in ghc/rts/Stats.c printTimes :: Integer -> Integer -> IO () printTimes allocs psecs = do let secs = (fromIntegral psecs / (10^(12::Integer))) :: Float - secs_str = showFFloat (Just 2) secs - putStrLn (showSDoc ( - parens (text (secs_str "") <+> text "secs" <> comma <+> - text (show allocs) <+> text "bytes"))) + secs_str = showFFloat (Just 2) secs + putStrLn (showSDoc ( + parens (text (secs_str "") <+> text "secs" <> comma <+> + text (show allocs) <+> text "bytes"))) ----------------------------------------------------------------------------- -- reverting CAFs - + revertCAFs :: GHCi () revertCAFs = do liftIO rts_revertCAFs s <- getGHCiState when (not (ghc_e s)) $ liftIO turnOffBuffering - -- Have to turn off buffering again, because we just - -- reverted stdout, stderr & stdin to their defaults. + -- Have to turn off buffering again, because we just + -- reverted stdout, stderr & stdin to their defaults. -foreign import ccall "revertCAFs" rts_revertCAFs :: IO () - -- Make it "safe", just in case +foreign import ccall "revertCAFs" rts_revertCAFs :: IO () + -- Make it "safe", just in case ----------------------------------------------------------------------------- -- To flush buffers for the *interpreted* computation we need @@ -381,3 +376,4 @@ getHandle :: IORef (Ptr ()) -> IO Handle getHandle ref = do (Ptr addr) <- readIORef ref case addrToAny# addr of (# hval #) -> return (unsafeCoerce# hval) + diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 0525f4098c..cc4be40f44 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -1,14 +1,6 @@ {-# OPTIONS -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSp --- for details - -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} ----------------------------------------------------------------------------- -- -- GHC Interactive User Interface @@ -21,84 +13,88 @@ module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where #include "HsVersions.h" -import qualified GhciMonad -import GhciMonad hiding ( runStmt ) +-- GHCi +import qualified GhciMonad ( args, runStmt ) +import GhciMonad hiding ( args, runStmt ) import GhciTags import Debugger -- The GHC interface +import DynFlags import qualified GHC import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..), TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc, handleSourceError ) -import PprTyThing -import DynFlags -import qualified Lexer -import StringBuffer - -import Packages -import UniqFM - -import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, dep_pkgs ) import HsImpExp -import RdrName ( getGRE_NameQualifier_maybes ) -import Outputable hiding ( printForUser, printForUserPartWay, bold ) +import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, dep_pkgs ) import Module import Name +import Packages ( trusted, getPackageDetails, exposed, exposedModules, pkgIdMap ) +import PprTyThing +import RdrName ( getGRE_NameQualifier_maybes ) import SrcLoc +import qualified Lexer + +import StringBuffer +import UniqFM ( eltsUFM ) +import Outputable hiding ( printForUser, printForUserPartWay, bold ) -- Other random utilities -import Digraph import BasicTypes hiding ( isTopLevel ) -import Panic hiding ( showException ) import Config -import StaticFlags +import Digraph +import Encoding +import FastString import Linker -import Util( on, global, toArgs, toCmdArgs, removeSpaces, getCmd, - filterOut, seqList, looksLikeModuleName, partitionWith ) -import NameSet import Maybes ( orElse, expectJust ) -import FastString -import Encoding -import Foreign.C - -#ifndef mingw32_HOST_OS -import System.Posix hiding ( getEnv ) -#else -import qualified System.Win32 -#endif +import NameSet +import Panic hiding ( showException ) +import StaticFlags +import Util ( on, global, toArgs, toCmdArgs, removeSpaces, getCmd, + filterOut, seqList, looksLikeModuleName, partitionWith ) +-- Haskell Libraries import System.Console.Haskeline as Haskeline import qualified System.Console.Haskeline.Encoding as Encoding -import Control.Monad.Trans -import Exception hiding (catch, block, unblock) +import Control.Applicative hiding (empty) +import Control.Monad as Monad +import Control.Monad.Trans -import System.FilePath +import Data.Array import qualified Data.ByteString.Char8 as BS -import Data.List +import Data.Char +import Data.IORef ( IORef, readIORef, writeIORef ) +import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub, + partition, sort, sortBy ) import Data.Maybe + +import Exception hiding (catch, block, unblock) + +import Foreign.C +import Foreign.Safe + import System.Cmd +import System.Directory import System.Environment import System.Exit ( exitWith, ExitCode(..) ) -import System.Directory +import System.FilePath import System.IO -import System.IO.Unsafe ( unsafePerformIO ) import System.IO.Error -import Data.Char -import Data.Array -import Control.Monad as Monad +import System.IO.Unsafe ( unsafePerformIO ) import Text.Printf -import Foreign.Safe -import GHC.Exts ( unsafeCoerce# ) -import Control.Applicative hiding (empty) +#ifndef mingw32_HOST_OS +import System.Posix hiding ( getEnv ) +#else +import qualified System.Win32 +#endif + +import GHC.Exts ( unsafeCoerce# ) import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) import GHC.IO.Handle ( hFlushAll ) +import GHC.TopHandler ( topHandler ) -import GHC.TopHandler - -import Data.IORef ( IORef, readIORef, writeIORef ) ----------------------------------------------------------------------------- @@ -162,12 +158,12 @@ builtin_commands = [ ] --- We initialize readline (in the interactiveUI function) to use +-- We initialize readline (in the interactiveUI function) to use -- word_break_chars as the default set of completion word break characters. -- This can be overridden for a particular command (for example, filename -- expansion shouldn't consider '/' to be a word break) by setting the third -- entry in the Command tuple above. --- +-- -- NOTE: in order for us to override the default correctly, any custom entry -- must be a SUBSET of word_break_chars. word_break_chars :: String @@ -252,7 +248,7 @@ helpText = " :stepmodule single-step restricted to the current module\n"++ " :trace trace after stopping at a breakpoint\n"++ " :trace <expr> evaluate <expr> with tracing on (see :history)\n"++ - + "\n" ++ " -- Commands for changing settings:\n" ++ "\n" ++ @@ -266,7 +262,7 @@ helpText = "\n" ++ " Options for ':set' and ':unset':\n" ++ "\n" ++ - " +m allow multiline commands\n" ++ + " +m allow multiline commands\n" ++ " +r revert top-level expressions after each evaluation\n" ++ " +s print timing/memory stats after each evaluation\n" ++ " +t print type after evaluation\n" ++ @@ -286,11 +282,11 @@ helpText = " :show languages show the currently active language flags\n" ++ " :show <setting> show value of <setting>, which is one of\n" ++ " [args, prog, prompt, editor, stop]\n" ++ - "\n" + "\n" findEditor :: IO String findEditor = do - getEnv "EDITOR" + getEnv "EDITOR" `catchIO` \_ -> do #if mingw32_HOST_OS win <- System.Win32.getWindowsDirectory @@ -316,7 +312,7 @@ interactiveUI srcs maybe_exprs = do -- compiler and interpreter don't work with profiling. So we check for -- this up front and emit a helpful error message (#2197) i <- liftIO $ isProfiled - when (i /= 0) $ + when (i /= 0) $ ghcError (InstallationError "GHCi cannot be used when compiled with -prof") -- HACK! If we happen to get into an infinite loop (eg the user @@ -355,21 +351,21 @@ interactiveUI srcs maybe_exprs = do default_editor <- liftIO $ findEditor startGHCi (runGHCi srcs maybe_exprs) - GHCiState{ progname = default_progname, - args = default_args, - prompt = default_prompt, - stop = default_stop, - editor = default_editor, - options = [], - line_number = 1, - break_ctr = 0, - breaks = [], - tickarrays = emptyModuleEnv, - last_command = Nothing, - cmdqueue = [], + GHCiState{ progname = default_progname, + GhciMonad.args = default_args, + prompt = default_prompt, + stop = default_stop, + editor = default_editor, + options = [], + line_number = 1, + break_ctr = 0, + breaks = [], + tickarrays = emptyModuleEnv, + last_command = Nothing, + cmdqueue = [], remembered_ctx = [], - transient_ctx = [], - ghc_e = isJust maybe_exprs + transient_ctx = [], + ghc_e = isJust maybe_exprs } return () @@ -465,17 +461,17 @@ runGHCi paths maybe_exprs = do Just exprs -> do -- just evaluate the expression we were given enqueueCommands exprs - let handle e = do st <- getGHCiState - -- flush the interpreter's stdout/stderr on exit (#3890) - flushInterpBuffers - -- Jump through some hoops to get the - -- current progname in the exception text: - -- <progname>: <exception> - liftIO $ withProgName (progname st) + let hdle e = do st <- getGHCiState + -- flush the interpreter's stdout/stderr on exit (#3890) + flushInterpBuffers + -- Jump through some hoops to get the + -- current progname in the exception text: + -- <progname>: <exception> + liftIO $ withProgName (progname st) + $ topHandler e -- this used to be topHandlerFastExit, see #2228 - $ topHandler e runInputTWithPrefs defaultPrefs defaultSettings $ do - runCommands' handle (return Nothing) + runCommands' hdle (return Nothing) -- and finally, exit liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi." @@ -487,15 +483,15 @@ runGHCiInput f = do then liftIO $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history"))) (return Nothing) else return Nothing - let settings = setComplete ghciCompleteWord - $ defaultSettings {historyFile = histFile} - runInputT settings f + runInputT + (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile}) + f nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String) nextInputLine show_prompt is_tty | is_tty = do - prompt <- if show_prompt then lift mkPrompt else return "" - r <- getInputLine prompt + prmpt <- if show_prompt then lift mkPrompt else return "" + r <- getInputLine prmpt incrementLineNo return r | otherwise = do @@ -503,7 +499,7 @@ nextInputLine show_prompt is_tty fileLoop stdin -- NOTE: We only read .ghci files if they are owned by the current user, --- and aren't world writable. Otherwise, we could be accidentally +-- and aren't world writable. Otherwise, we could be accidentally -- running code planted by a malicious third party. -- Furthermore, We only read ./.ghci if . is owned by the current user @@ -525,9 +521,9 @@ checkPerms name = else do let mode = System.Posix.fileMode st if (groupWriteMode == (mode `intersectFileModes` groupWriteMode)) - || (otherWriteMode == (mode `intersectFileModes` otherWriteMode)) + || (otherWriteMode == (mode `intersectFileModes` otherWriteMode)) then do - putStrLn $ "*** WARNING: " ++ name ++ + putStrLn $ "*** WARNING: " ++ name ++ " is writable by someone else, IGNORING!" return False else return True @@ -551,9 +547,9 @@ fileLoop hdl = do -- this can happen if the user closed stdin, or -- perhaps did getContents which closes stdin at -- EOF. - Right l -> do + Right l' -> do incrementLineNo - return (Just l) + return (Just l') mkPrompt :: GHCi String mkPrompt = do @@ -569,9 +565,9 @@ mkPrompt = do then return (brackets (ppr (GHC.resumeSpan r)) <> space) else do let hist = GHC.resumeHistory r !! (ix-1) - span <- GHC.getHistorySpan hist - return (brackets (ppr (negate ix) <> char ':' - <+> ppr span) <> space) + pan <- GHC.getHistorySpan hist + return (brackets (ppr (negate ix) <> char ':' + <+> ppr pan) <> space) let dots | _:rs <- resumes, not (null rs) = text "... " | otherwise = empty @@ -610,26 +606,26 @@ runCommands = runCommands' handler runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler -> InputT GHCi (Maybe String) -> InputT GHCi () -runCommands' eh getCmd = do +runCommands' eh gCmd = do b <- ghandle (\e -> case fromException e of Just UserInterrupt -> return $ Just False _ -> case fromException e of - Just ghc_e -> - do liftIO (print (ghc_e :: GhcException)) + Just ghce -> + do liftIO (print (ghce :: GhcException)) return Nothing _other -> liftIO (Exception.throwIO e)) - (runOneCommand eh getCmd) + (runOneCommand eh gCmd) case b of Nothing -> return () - Just _ -> runCommands' eh getCmd + Just _ -> runCommands' eh gCmd runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String) -> InputT GHCi (Maybe Bool) -runOneCommand eh getCmd = do - mb_cmd <- noSpace (lift queryQueue) - mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd - case mb_cmd of +runOneCommand eh gCmd = do + mb_cmd0 <- noSpace (lift queryQueue) + mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0 + case mb_cmd1 of Nothing -> return Nothing Just c -> ghciHandle (\e -> lift $ eh e >>= return . Just) $ handleSourceError printErrorAndKeepGoing @@ -642,32 +638,32 @@ runOneCommand eh getCmd = do return $ Just True noSpace q = q >>= maybe (return Nothing) - (\c->case removeSpaces c of - "" -> noSpace q - ":{" -> multiLineCmd q - c -> return (Just c) ) + (\c -> case removeSpaces c of + "" -> noSpace q + ":{" -> multiLineCmd q + _ -> return (Just c) ) multiLineCmd q = do st <- lift getGHCiState let p = prompt st lift $ setGHCiState st{ prompt = "%s| " } mb_cmd <- collectCommand q "" - lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p } + lift $ getGHCiState >>= \st' -> setGHCiState st'{ prompt = p } return mb_cmd - -- we can't use removeSpaces for the sublines here, so + -- we can't use removeSpaces for the sublines here, so -- multiline commands are somewhat more brittle against - -- fileformat errors (such as \r in dos input on unix), - -- we get rid of any extra spaces for the ":}" test; + -- fileformat errors (such as \r in dos input on unix), + -- we get rid of any extra spaces for the ":}" test; -- we also avoid silent failure if ":}" is not found; - -- and since there is no (?) valid occurrence of \r (as + -- and since there is no (?) valid occurrence of \r (as -- opposed to its String representation, "\r") inside a -- ghci command, we replace any such with ' ' (argh:-( - collectCommand q c = q >>= + collectCommand q c = q >>= maybe (liftIO (ioError collectError)) - (\l->if removeSpaces l == ":}" - then return (Just $ removeSpaces c) + (\l->if removeSpaces l == ":}" + then return (Just $ removeSpaces c) else collectCommand q (c ++ "\n" ++ map normSpace l)) where normSpace '\r' = ' ' - normSpace c = c + normSpace x = x -- SDM (2007-11-07): is userError the one to use here? collectError = userError "unterminated multiline command :{ .. :}" doCommand (':' : cmd) = do @@ -675,11 +671,11 @@ runOneCommand eh getCmd = do case result of True -> return Nothing _ -> return $ Just True - doCommand stmt = do + doCommand stmt = do ml <- lift $ isOptionSet Multiline if ml - then do - mb_stmt <- checkInputForLayout stmt getCmd + then do + mb_stmt <- checkInputForLayout stmt gCmd case mb_stmt of Nothing -> return $ Just True Just ml_stmt -> do @@ -696,25 +692,25 @@ checkInputForLayout :: String -> InputT GHCi (Maybe String) checkInputForLayout stmt getStmt = do dflags' <- lift $ getDynFlags let dflags = xopt_set dflags' Opt_AlternativeLayoutRule - st <- lift $ getGHCiState - let buf = stringToStringBuffer stmt - loc = mkRealSrcLoc (fsLit (progname st)) (line_number st) 1 - pstate = Lexer.mkPState dflags buf loc + st0 <- lift $ getGHCiState + let buf' = stringToStringBuffer stmt + loc = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1 + pstate = Lexer.mkPState dflags buf' loc case Lexer.unP goToEnd pstate of (Lexer.POk _ False) -> return $ Just stmt _other -> do - st <- lift getGHCiState - let p = prompt st - lift $ setGHCiState st{ prompt = "%s| " } + st1 <- lift getGHCiState + let p = prompt st1 + lift $ setGHCiState st1{ prompt = "%s| " } mb_stmt <- ghciHandle (\ex -> case fromException ex of Just UserInterrupt -> return Nothing _ -> case fromException ex of - Just ghc_e -> - do liftIO (print (ghc_e :: GhcException)) + Just ghce -> + do liftIO (print (ghce :: GhcException)) return Nothing - _other -> liftIO (Exception.throwIO ex)) + _other -> liftIO (Exception.throwIO ex)) getStmt - lift $ getGHCiState >>= \st->setGHCiState st{ prompt = p } + lift $ getGHCiState >>= \st' -> setGHCiState st'{ prompt = p } -- the recursive call does not recycle parser state -- as we use a new string buffer case mb_stmt of @@ -725,7 +721,7 @@ checkInputForLayout stmt getStmt = do checkInputForLayout (stmt++"\n"++str) getStmt where goToEnd = do eof <- Lexer.nextIsEOF - if eof + if eof then Lexer.activeContext else Lexer.lexer return >> goToEnd @@ -776,10 +772,10 @@ afterRunStmt step_here run_result = do | isNothing mb_info || step_here (GHC.resumeSpan $ head resumes) -> do mb_id_loc <- toBreakIdAndLocation mb_info - let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc - if (null breakCmd) + let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc + if (null bCmd) then printStoppedAtBreakInfo (head resumes) names - else enqueueCommands [breakCmd] + else enqueueCommands [bCmd] -- run the command set with ":set stop <cmd>" st <- getGHCiState enqueueCommands [stop st] @@ -798,22 +794,22 @@ afterRunStmt step_here run_result = do toBreakIdAndLocation :: Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation)) toBreakIdAndLocation Nothing = return Nothing -toBreakIdAndLocation (Just info) = do - let mod = GHC.breakInfo_module info - nm = GHC.breakInfo_number info +toBreakIdAndLocation (Just inf) = do + let md = GHC.breakInfo_module inf + nm = GHC.breakInfo_number inf st <- getGHCiState return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st, - breakModule loc == mod, + breakModule loc == md, breakTick loc == nm ] printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi () -printStoppedAtBreakInfo resume names = do +printStoppedAtBreakInfo res names = do printForUser $ ptext (sLit "Stopped at") <+> - ppr (GHC.resumeSpan resume) + ppr (GHC.resumeSpan res) -- printTypeOfNames session names let namesSorted = sortBy compareNames names tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted - docs <- mapM pprTypeAndContents [id | AnId id <- tythings] + docs <- mapM pprTypeAndContents [i | AnId i <- tythings] printForUserPartWay $ vcat docs printTypeOfNames :: [Name] -> GHCi () @@ -895,8 +891,8 @@ getCurrentBreakSpan = do then return (Just (GHC.resumeSpan r)) else do let hist = GHC.resumeHistory r !! (ix-1) - span <- GHC.getHistorySpan hist - return (Just span) + pan <- GHC.getHistorySpan hist + return (Just pan) getCurrentBreakModule :: GHCi (Maybe Module) getCurrentBreakModule = do @@ -958,7 +954,7 @@ infoThing str = do -- example is '[]', which is both a type and data -- constructor in the same type filterOutChildren :: (a -> TyThing) -> [a] -> [a] -filterOutChildren get_thing xs +filterOutChildren get_thing xs = filterOut has_parent xs where all_names = mkNameSet (map (getName . get_thing) xs) @@ -972,7 +968,7 @@ pprInfo pefas (thing, fixity, insts) $$ show_fixity fixity $$ vcat (map GHC.pprInstance insts) where - show_fixity fix + show_fixity fix | fix == GHC.defaultFixity = empty | otherwise = ppr fix <+> ppr (GHC.getName thing) @@ -1018,8 +1014,8 @@ changeDirectory dir = do _ <- GHC.load LoadAllTargets lift $ setContextAfterLoad False [] GHC.workingDirectoryChanged - dir <- expandPath dir - liftIO $ setCurrentDirectory dir + dir' <- expandPath dir + liftIO $ setCurrentDirectory dir' trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag trySuccess act = @@ -1035,7 +1031,7 @@ editFile str = do file <- if null str then chooseEditFile else return str st <- getGHCiState let cmd = editor st - when (null cmd) + when (null cmd) $ ghcError (CmdLineError "editor not set, use :set editor") _ <- liftIO $ system (cmd ++ ' ':file) return () @@ -1063,12 +1059,12 @@ chooseEditFile = case pick (order failed_graph) of Just file -> return file - Nothing -> + Nothing -> do targets <- GHC.getTargets case msum (map fromTarget targets) of Just file -> return file Nothing -> ghcError (CmdLineError "No files to edit.") - + where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f fromTarget _ = Nothing -- when would we get a module target? @@ -1083,16 +1079,16 @@ defineMacro overwrite s = do let (macro_name, definition) = break isSpace s macros <- liftIO (readIORef macros_ref) let defined = map cmdName macros - if (null macro_name) - then if null defined + if (null macro_name) + then if null defined then liftIO $ putStrLn "no macros defined" else liftIO $ putStr ("the following macros are defined:\n" ++ unlines defined) - else do + else do if (not overwrite && macro_name `elem` defined) - then ghcError (CmdLineError - ("macro '" ++ macro_name ++ "' is already defined")) - else do + then ghcError (CmdLineError + ("macro '" ++ macro_name ++ "' is already defined")) + else do let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ] @@ -1121,13 +1117,13 @@ runMacro fun s = do -- :undef undefineMacro :: String -> GHCi () -undefineMacro str = mapM_ undef (words str) +undefineMacro str = mapM_ undef (words str) where undef macro_name = do cmds <- liftIO (readIORef macros_ref) - if (macro_name `notElem` map cmdName cmds) - then ghcError (CmdLineError - ("macro '" ++ macro_name ++ "' is not defined")) - else do + if (macro_name `notElem` map cmdName cmds) + then ghcError (CmdLineError + ("macro '" ++ macro_name ++ "' is not defined")) + else do liftIO (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds)) @@ -1154,15 +1150,15 @@ checkModule m = do ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl liftIO $ putStrLn $ showSDoc $ - case GHC.moduleInfo r of - cm | Just scope <- GHC.modInfoTopLevelScope cm -> - let - (local,global) = ASSERT( all isExternalName scope ) - partition ((== modl) . GHC.moduleName . GHC.nameModule) scope - in - (text "global names: " <+> ppr global) $$ - (text "local names: " <+> ppr local) - _ -> empty + case GHC.moduleInfo r of + cm | Just scope <- GHC.modInfoTopLevelScope cm -> + let + (loc, glob) = ASSERT( all isExternalName scope ) + partition ((== modl) . GHC.moduleName . GHC.nameModule) scope + in + (text "global names: " <+> ppr glob) $$ + (text "local names: " <+> ppr loc) + _ -> empty return True afterLoad (successIf ok) False @@ -1202,8 +1198,8 @@ loadModule' files = do addModule :: [FilePath] -> InputT GHCi () addModule files = do lift revertCAFs -- always revert CAFs on load/add. - files <- mapM expandPath files - targets <- mapM (\m -> GHC.guessTarget m Nothing) files + files' <- mapM expandPath files + targets <- mapM (\m -> GHC.guessTarget m Nothing) files' -- remove old targets with the same id; e.g. for :add *M mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ] mapM_ GHC.addTarget targets @@ -1215,7 +1211,7 @@ addModule files = do reloadModule :: String -> InputT GHCi () reloadModule m = do _ <- doLoad True $ - if null m then LoadAllTargets + if null m then LoadAllTargets else LoadUpTo (GHC.mkModuleName m) return () @@ -1250,23 +1246,23 @@ setContextAfterLoad keep_ctxt ms = do -- load a target if one is available, otherwise load the topmost module. targets <- GHC.getTargets case [ m | Just m <- map (findTarget ms) targets ] of - [] -> - let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in - load_this (last graph') - (m:_) -> - load_this m + [] -> + let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in + load_this (last graph') + (m:_) -> + load_this m where - findTarget ms t - = case filter (`matches` t) ms of - [] -> Nothing - (m:_) -> Just m + findTarget mds t + = case filter (`matches` t) mds of + [] -> Nothing + (m:_) -> Just m summary `matches` Target (TargetModule m) _ _ - = GHC.ms_mod_name summary == m - summary `matches` Target (TargetFile f _) _ _ - | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f' + = GHC.ms_mod_name summary == m + summary `matches` Target (TargetFile f _) _ _ + | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f' _ `matches` _ - = False + = False load_this summary | m <- GHC.ms_mod summary = do is_interp <- GHC.moduleIsInterpreted m @@ -1282,14 +1278,14 @@ setContextKeepingPackageModules -> [InteractiveImport] -- new context -> GHCi () -setContextKeepingPackageModules keep_ctx transient_ctx = do +setContextKeepingPackageModules keep_ctx trans_ctx = do st <- getGHCiState let rem_ctx = remembered_ctx st new_rem_ctx <- if keep_ctx then return rem_ctx else keepPackageImports rem_ctx setGHCiState st{ remembered_ctx = new_rem_ctx, - transient_ctx = transient_ctx } + transient_ctx = trans_ctx } setGHCContextFromGHCiState @@ -1311,10 +1307,10 @@ modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> InputT GHCi () modulesLoadedMsg ok mods = do dflags <- getDynFlags when (verbosity dflags > 0) $ do - let mod_commas - | null mods = text "none." - | otherwise = hsep ( - punctuate comma (map ppr mods)) <> text "." + let mod_commas + | null mods = text "none." + | otherwise = hsep ( + punctuate comma (map ppr mods)) <> text "." case ok of Failed -> liftIO $ putStrLn $ showSDoc (text "Failed, modules loaded: " <> mod_commas) @@ -1326,7 +1322,7 @@ modulesLoadedMsg ok mods = do -- :type typeOfExpr :: String -> InputT GHCi () -typeOfExpr str +typeOfExpr str = handleSourceError GHC.printException $ do ty <- GHC.exprType str @@ -1338,12 +1334,12 @@ typeOfExpr str -- :kind kindOfType :: Bool -> String -> InputT GHCi () -kindOfType normalise str +kindOfType norm str = handleSourceError GHC.printException $ do - (ty, kind) <- GHC.typeKind normalise str + (ty, kind) <- GHC.typeKind norm str printForUser $ vcat [ text str <+> dcolon <+> ppr kind - , ppWhen normalise $ equals <+> ppr ty ] + , ppWhen norm $ equals <+> ppr ty ] ----------------------------------------------------------------------------- @@ -1359,8 +1355,8 @@ quit _ = return True -- running a script file #1363 scriptCmd :: String -> InputT GHCi () -scriptCmd s = do - case words s of +scriptCmd ws = do + case words ws of [s] -> runScript s _ -> ghcError (CmdLineError "syntax: :script <filename>") @@ -1383,8 +1379,8 @@ runScript filename = do where scriptLoop script = do res <- runOneCommand handler $ fileLoop script case res of - Nothing -> return () - Just succ -> if succ + Nothing -> return () + Just s -> if s then scriptLoop script else return () @@ -1394,13 +1390,13 @@ runScript filename = do -- Displaying Safe Haskell properties of a module isSafeCmd :: String -> InputT GHCi () -isSafeCmd m = +isSafeCmd m = case words m of [s] | looksLikeModuleName s -> do - m <- lift $ lookupModule s - isSafeModule m - [] -> do m <- guessCurrentModule "issafe" - isSafeModule m + md <- lift $ lookupModule s + isSafeModule md + [] -> do md <- guessCurrentModule "issafe" + isSafeModule md _ -> ghcError (CmdLineError "syntax: :issafe <module>") isSafeModule :: Module -> InputT GHCi () @@ -1416,29 +1412,45 @@ isSafeModule m = do (GHC.moduleNameString $ GHC.moduleName m)) let iface' = fromJust iface - trust = showPpr $ getSafeMode $ GHC.mi_trust iface' - pkg = if packageTrusted dflags m then "trusted" else "untrusted" - (good, bad) = tallyPkgs dflags $ - map fst $ filter snd $ dep_pkgs $ GHC.mi_deps iface' + + trust = showPpr $ getSafeMode $ GHC.mi_trust iface' + pkgT = packageTrusted dflags m + pkg = if pkgT then "trusted" else "untrusted" + (good', bad') = tallyPkgs dflags $ + map fst $ filter snd $ dep_pkgs $ GHC.mi_deps iface' + (good, bad) = case GHC.mi_trust_pkg iface' of + True | pkgT -> (modulePackageId m:good', bad') + True -> (good', modulePackageId m:bad') + False -> (good', bad') liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")" - when (not $ null good) + liftIO $ putStrLn $ "Package Trust: " + ++ (if packageTrustOn dflags then "On" else "Off") + + when (packageTrustOn dflags && not (null good)) (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " ++ (intercalate ", " $ map packageIdString good)) - if (null bad) - then liftIO $ putStrLn $ mname ++ " is trusted!" - else do + + case goodTrust (getSafeMode $ GHC.mi_trust iface') of + True | (null bad || not (packageTrustOn dflags)) -> + liftIO $ putStrLn $ mname ++ " is trusted!" + + True -> do liftIO $ putStrLn $ "Trusted package dependencies (untrusted): " ++ (intercalate ", " $ map packageIdString bad) liftIO $ putStrLn $ mname ++ " is NOT trusted!" + False -> liftIO $ putStrLn $ mname ++ " is NOT trusted!" + where + goodTrust t = t `elem` [Sf_Safe, Sf_SafeInfered, Sf_Trustworthy] + mname = GHC.moduleNameString $ GHC.moduleName m - packageTrusted dflags m - | thisPackage dflags == modulePackageId m = True + packageTrusted dflags md + | thisPackage dflags == modulePackageId md = True | otherwise = trusted $ getPackageDetails (pkgState dflags) - (modulePackageId m) + (modulePackageId md) tallyPkgs dflags deps = partition part deps where state = pkgState dflags @@ -1450,16 +1462,16 @@ isSafeModule m = do -- Browsing a module's contents browseCmd :: Bool -> String -> InputT GHCi () -browseCmd bang m = +browseCmd bang m = case words m of - ['*':s] | looksLikeModuleName s -> do - m <- lift $ wantInterpretedModule s - browseModule bang m False + ['*':s] | looksLikeModuleName s -> do + md <- lift $ wantInterpretedModule s + browseModule bang md False [s] | looksLikeModuleName s -> do - m <- lift $ lookupModule s - browseModule bang m True - [] -> do m <- guessCurrentModule ("browse" ++ if bang then "!" else "") - browseModule bang m True + md <- lift $ lookupModule s + browseModule bang md True + [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "") + browseModule bang md True _ -> ghcError (CmdLineError "syntax: :browse <module>") guessCurrentModule :: String -> InputT GHCi Module @@ -1494,21 +1506,20 @@ browseModule bang modl exports_only = do | otherwise = GHC.modInfoTopLevelScope mod_info `orElse` [] - -- sort alphabetically name, but putting - -- locally-defined identifiers first. - -- We would like to improve this; see #1799. + -- sort alphabetically name, but putting locally-defined + -- identifiers first. We would like to improve this; see #1799. sorted_names = loc_sort local ++ occ_sort external - where + where (local,external) = ASSERT( all isExternalName names ) - partition ((==modl) . nameModule) names - occ_sort = sortBy (compare `on` nameOccName) - -- try to sort by src location. If the first name in - -- our list has a good source location, then they all should. - loc_sort names - | n:_ <- names, isGoodSrcSpan (nameSrcSpan n) - = sortBy (compare `on` nameSrcSpan) names + partition ((==modl) . nameModule) names + occ_sort = sortBy (compare `on` nameOccName) + -- try to sort by src location. If the first name in our list + -- has a good source location, then they all should. + loc_sort ns + | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n) + = sortBy (compare `on` nameSrcSpan) ns | otherwise - = occ_sort names + = occ_sort ns mb_things <- mapM GHC.lookupName sorted_names let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things) @@ -1524,25 +1535,25 @@ browseModule bang modl exports_only = do labels [] = text "-- not currently imported" labels l = text $ intercalate "\n" $ map qualifier l - qualifier :: Maybe [ModuleName] -> String - qualifier = maybe "-- defined locally" - (("-- imported via "++) . intercalate ", " + qualifier :: Maybe [ModuleName] -> String + qualifier = maybe "-- defined locally" + (("-- imported via "++) . intercalate ", " . map GHC.moduleNameString) importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env - modNames :: [[Maybe [ModuleName]]] + modNames :: [[Maybe [ModuleName]]] modNames = map (importInfo . GHC.getName) things - + -- annotate groups of imports with their import modules - -- the default ordering is somewhat arbitrary, so we group + -- the default ordering is somewhat arbitrary, so we group -- by header and sort groups; the names themselves should -- really come in order of source appearance.. (trac #1799) annotate mts = concatMap (\(m,ts)->labels m:ts) - $ sortBy cmpQualifiers $ group mts - where cmpQualifiers = + $ sortBy cmpQualifiers $ grp mts + where cmpQualifiers = compare `on` (map (fmap (map moduleNameFS)) . fst) - group [] = [] - group mts@((m,_):_) = (m,map snd g) : group ng + grp [] = [] + grp mts@((m,_):_) = (m,map snd g) : grp ng where (g,ng) = partition ((==m).fst) mts let prettyThings, prettyThings' :: [SDoc] @@ -1567,14 +1578,14 @@ moduleCmd str | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") where (cmd, strs) = - case str of + case str of '+':stuff -> rest addModulesToContext stuff '-':stuff -> rest remModulesFromContext stuff stuff -> rest setContext stuff - rest cmd stuff = (cmd as bs, strs) - where strs = words stuff - (as,bs) = partitionWith starred strs + rest op stuff = (op as bs, stuffs) + where (as,bs) = partitionWith starred stuffs + stuffs = words stuff sensible ('*':m) = looksLikeModuleName m sensible m = looksLikeModuleName m @@ -1596,11 +1607,11 @@ addModulesToContext as bs = do remModulesFromContext :: [String] -> [String] -> GHCi () remModulesFromContext as bs = do - mapM_ rem (as ++ bs) + mapM_ rm (as ++ bs) setGHCContextFromGHCiState where - rem :: String -> GHCi () - rem str = do + rm :: String -> GHCi () + rm str = do m <- moduleName <$> lookupModule str let filt = filter ((/=) m . iiModuleName) modifyGHCiState $ \st -> @@ -1624,12 +1635,23 @@ setContext starred not_starred = do setGHCContextFromGHCiState checkAdd :: Bool -> String -> GHCi InteractiveImport -checkAdd star mstr - | star = do m <- wantInterpretedModule mstr - return (IIModule m) - | otherwise = do m <- lookupModule mstr - return (IIDecl (simpleImportDecl (moduleName m))) +checkAdd star mstr = do + dflags <- getDynFlags + case safeLanguageOn dflags of + True | star -> ghcError $ CmdLineError "can't use * imports with Safe Haskell" + True -> do m <- lookupModule mstr + s <- GHC.isModuleTrusted m + case s of + True -> return $ IIDecl (simpleImportDecl $ moduleName m) + False -> ghcError $ CmdLineError $ "can't import " ++ mstr + ++ " as it isn't trusted." + + False | star -> do m <- wantInterpretedModule mstr + return $ IIModule m + + False -> do m <- lookupModule mstr + return $ IIDecl (simpleImportDecl $ moduleName m) -- | Sets the GHC context from the GHCi state. The GHC context is -- always set this way, we never modify it incrementally. @@ -1718,11 +1740,11 @@ setCmd "" = do st <- getGHCiState let opts = options st liftIO $ putStrLn (showSDoc ( - text "options currently set: " <> - if null opts - then text "none." - else hsep (map (\o -> char '+' <> text (optToStr o)) opts) - )) + text "options currently set: " <> + if null opts + then text "none." + else hsep (map (\o -> char '+' <> text (optToStr o)) opts) + )) dflags <- getDynFlags liftIO $ putStrLn (showSDoc ( text "GHCi-specific dynamic flag settings:" $$ @@ -1747,14 +1769,14 @@ setCmd "" fstr str = text "-f" <> text str fnostr str = text "-fno-" <> text str - (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flags) + (ghciFlags,others) = partition (\(_, f, _) -> f `elem` flgs) DynFlags.fFlags - flags = [Opt_PrintExplicitForalls + flgs = [Opt_PrintExplicitForalls ,Opt_PrintBindResult ,Opt_BreakOnException ,Opt_BreakOnError ,Opt_PrintEvldWithShow - ] + ] setCmd str = case getCmd str of Right ("args", rest) -> @@ -1777,7 +1799,7 @@ setProg, setEditor, setStop, setPrompt :: String -> GHCi () setArgs args = do st <- getGHCiState - setGHCiState st{ args = args } + setGHCiState st{ GhciMonad.args = args } setProg prog = do st <- getGHCiState @@ -1825,26 +1847,26 @@ setOptions wds = newDynFlags :: [String] -> GHCi () newDynFlags minus_opts = do - dflags <- getDynFlags - let pkg_flags = packageFlags dflags - (dflags', leftovers, warns) <- liftIO $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts - liftIO $ handleFlagWarnings dflags' warns + dflags0 <- getDynFlags + let pkg_flags = packageFlags dflags0 + (dflags1, leftovers, warns) <- liftIO $ GHC.parseDynamicFlags dflags0 $ map noLoc minus_opts + liftIO $ handleFlagWarnings dflags1 warns when (not $ null leftovers) (ghcError . CmdLineError $ "Some flags have not been recognized: " ++ (concat . intersperse ", " $ map unLoc leftovers)) - new_pkgs <- setDynFlags dflags' + new_pkgs <- setDynFlags dflags1 -- if the package flags changed, we should reset the context -- and link the new packages. - dflags <- getDynFlags - when (packageFlags dflags /= pkg_flags) $ do + dflags2 <- getDynFlags + when (packageFlags dflags2 /= pkg_flags) $ do liftIO $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..." GHC.setTargets [] _ <- GHC.load LoadAllTargets - liftIO (linkPackages dflags new_pkgs) + liftIO (linkPackages dflags2 new_pkgs) -- package flags changed, we can't re-use any of the old context setContextAfterLoad False [] return () @@ -1858,7 +1880,7 @@ unsetOptions str (plus_opts, rest2) = partitionWith isPlus rest1 (other_opts, rest3) = partition (`elem` map fst defaulters) rest2 - defaulters = + defaulters = [ ("args" , setArgs default_args) , ("prog" , setProg default_progname) , ("prompt", setPrompt default_prompt) @@ -1891,13 +1913,13 @@ setOpt, unsetOpt :: String -> GHCi () setOpt str = case strToGHCiOpt str of - Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'")) - Just o -> setOption o + Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'")) + Just o -> setOption o unsetOpt str = case strToGHCiOpt str of - Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'")) - Just o -> unsetOption o + Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'")) + Just o -> unsetOption o strToGHCiOpt :: String -> (Maybe GHCiOption) strToGHCiOpt "m" = Just Multiline @@ -1920,20 +1942,20 @@ showCmd :: String -> GHCi () showCmd str = do st <- getGHCiState case words str of - ["args"] -> liftIO $ putStrLn (show (args st)) + ["args"] -> liftIO $ putStrLn (show (GhciMonad.args st)) ["prog"] -> liftIO $ putStrLn (show (progname st)) ["prompt"] -> liftIO $ putStrLn (show (prompt st)) ["editor"] -> liftIO $ putStrLn (show (editor st)) ["stop"] -> liftIO $ putStrLn (show (stop st)) ["imports"] -> showImports ["modules" ] -> showModules - ["bindings"] -> showBindings - ["linker"] -> liftIO showLinkerState + ["bindings"] -> showBindings + ["linker"] -> liftIO showLinkerState ["breaks"] -> showBkptTable ["context"] -> showContext ["packages"] -> showPackages ["languages"] -> showLanguages - _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++ + _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++ " | breaks | context | packages | languages ]")) showImports :: GHCi () @@ -1977,18 +1999,18 @@ showBindings = do fidocs = map GHC.pprFamInstHdr finsts mapM_ printForUserPartWay (docs ++ idocs ++ fidocs) where - makeDoc (AnId id) = pprTypeAndContents id + makeDoc (AnId i) = pprTypeAndContents i makeDoc tt = do dflags <- getDynFlags let pefas = dopt Opt_PrintExplicitForalls dflags mb_stuff <- GHC.getInfo (getName tt) return $ maybe (text "") (pprTT pefas) mb_stuff pprTT :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc - pprTT pefas (thing, fixity, _insts) = + pprTT pefas (thing, fixity, _insts) = pprTyThing pefas thing $$ show_fixity fixity where - show_fixity fix + show_fixity fix | fix == GHC.defaultFixity = empty | otherwise = ppr fix <+> ppr (GHC.getName thing) @@ -1996,7 +2018,7 @@ showBindings = do printTyThing :: TyThing -> GHCi () printTyThing tyth = do dflags <- getDynFlags let pefas = dopt Opt_PrintExplicitForalls dflags - printForUser (pprTyThing pefas tyth) + printForUser (pprTyThing pefas tyth) showBkptTable :: GHCi () showBkptTable = do @@ -2008,9 +2030,9 @@ showContext = do resumes <- GHC.getResumeContext printForUser $ vcat (map pp_resume (reverse resumes)) where - pp_resume resume = - ptext (sLit "--> ") <> text (GHC.resumeStmt resume) - $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume)) + pp_resume res = + ptext (sLit "--> ") <> text (GHC.resumeStmt res) + $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan res)) showPackages :: GHCi () showPackages = do @@ -2105,13 +2127,13 @@ listHomeModules w = do $ map (showSDoc.ppr) home_mods completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do - return (filter (w `isPrefixOf`) options) - where options = "args":"prog":"prompt":"editor":"stop":flagList + return (filter (w `isPrefixOf`) opts) + where opts = "args":"prog":"prompt":"editor":"stop":flagList flagList = map head $ group $ sort allFlags completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do - return (filter (w `isPrefixOf`) options) - where options = ["args", "prog", "prompt", "editor", "stop", + return (filter (w `isPrefixOf`) opts) + where opts = ["args", "prog", "prompt", "editor", "stop", "modules", "bindings", "linker", "breaks", "context", "packages", "languages"] @@ -2139,7 +2161,7 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor getModifier = find (`elem` modifChars) allExposedModules :: DynFlags -> [ModuleName] -allExposedModules dflags +allExposedModules dflags = concat (map exposedModules (filter exposed (eltsUFM pkg_db))) where pkg_db = pkgIdMap (pkgState dflags) @@ -2176,8 +2198,8 @@ stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg case mb_span of Nothing -> stepCmd [] Just loc -> do - Just mod <- getCurrentBreakModule - current_toplevel_decl <- enclosingTickSpan mod loc + Just md <- getCurrentBreakModule + current_toplevel_decl <- enclosingTickSpan md loc doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep stepModuleCmd :: String -> GHCi () @@ -2189,38 +2211,38 @@ stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg mb_span <- getCurrentBreakSpan case mb_span of Nothing -> stepCmd [] - Just span -> do - let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span + Just pan -> do + let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span doContinue f GHC.SingleStep -- | Returns the span of the largest tick containing the srcspan given enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" -enclosingTickSpan mod (RealSrcSpan src) = do - ticks <- getTickArray mod +enclosingTickSpan md (RealSrcSpan src) = do + ticks <- getTickArray md let line = srcSpanStartLine src ASSERT (inRange (bounds ticks) line) do let toRealSrcSpan (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" toRealSrcSpan (RealSrcSpan s) = s - enclosing_spans = [ span | (_,span) <- ticks ! line - , realSrcSpanEnd (toRealSrcSpan span) >= realSrcSpanEnd src] + enclosing_spans = [ pan | (_,pan) <- ticks ! line + , realSrcSpanEnd (toRealSrcSpan pan) >= realSrcSpanEnd src] return . head . sortBy leftmost_largest $ enclosing_spans traceCmd :: String -> GHCi () traceCmd arg - = withSandboxOnly ":trace" $ trace arg + = withSandboxOnly ":trace" $ tr arg where - trace [] = doContinue (const True) GHC.RunAndLogSteps - trace expression = runStmt expression GHC.RunAndLogSteps >> return () + tr [] = doContinue (const True) GHC.RunAndLogSteps + tr expression = runStmt expression GHC.RunAndLogSteps >> return () continueCmd :: String -> GHCi () continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion -- doContinue :: SingleStep -> GHCi () doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi () -doContinue pred step = do - runResult <- resume pred step - _ <- afterRunStmt pred runResult +doContinue pre step = do + runResult <- resume pre step + _ <- afterRunStmt pre runResult return () abandonCmd :: String -> GHCi () @@ -2238,7 +2260,7 @@ deleteCmd argLine = withSandboxOnly ":delete" $ do -- delete all break points deleteSwitch ("*":_rest) = discardActiveBreakPoints deleteSwitch idents = do - mapM_ deleteOneBreak idents + mapM_ deleteOneBreak idents where deleteOneBreak :: String -> GHCi () deleteOneBreak str @@ -2262,14 +2284,14 @@ historyCmd arg [] -> liftIO $ putStrLn $ "Empty history. Perhaps you forgot to use :trace?" _ -> do - spans <- mapM GHC.getHistorySpan took + pans <- mapM GHC.getHistorySpan took let nums = map (printf "-%-3d:") [(1::Int)..] names = map GHC.historyEnclosingDecls took - printForUser (vcat(zipWith3 - (\x y z -> x <+> y <+> z) - (map text nums) + printForUser (vcat(zipWith3 + (\x y z -> x <+> y <+> z) + (map text nums) (map (bold . hcat . punctuate colon . map text) names) - (map (parens . ppr) spans))) + (map (parens . ppr) pans))) liftIO $ putStrLn $ if null rest then "<end of history>" else "..." bold :: SDoc -> SDoc @@ -2278,8 +2300,8 @@ bold c | do_bold = text start_bold <> c <> text end_bold backCmd :: String -> GHCi () backCmd = noArgs $ withSandboxOnly ":back" $ do - (names, _, span) <- GHC.back - printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span + (names, _, pan) <- GHC.back + printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan printTypeOfNames names -- run the command set with ":set stop <cmd>" st <- getGHCiState @@ -2287,10 +2309,10 @@ backCmd = noArgs $ withSandboxOnly ":back" $ do forwardCmd :: String -> GHCi () forwardCmd = noArgs $ withSandboxOnly ":forward" $ do - (names, ix, span) <- GHC.forward + (names, ix, pan) <- GHC.forward printForUser $ (if (ix == 0) then ptext (sLit "Stopped at") - else ptext (sLit "Logged breakpoint at")) <+> ppr span + else ptext (sLit "Logged breakpoint at")) <+> ppr pan printTypeOfNames names -- run the command set with ":set stop <cmd>" st <- getGHCiState @@ -2305,24 +2327,24 @@ breakSwitch [] = do liftIO $ putStrLn "The break command requires at least one argument." breakSwitch (arg1:rest) | looksLikeModuleName arg1 && not (null rest) = do - mod <- wantInterpretedModule arg1 - breakByModule mod rest + md <- wantInterpretedModule arg1 + breakByModule md rest | all isDigit arg1 = do imports <- GHC.getContext case iiModules imports of - (mod : _) -> breakByModuleLine mod (read arg1) rest - [] -> do - liftIO $ putStrLn "Cannot find default module for breakpoint." + (md : _) -> breakByModuleLine md (read arg1) rest + [] -> do + liftIO $ putStrLn "Cannot find default module for breakpoint." liftIO $ putStrLn "Perhaps no modules are loaded for debugging?" | otherwise = do -- try parsing it as an identifier wantNameFromInterpretedModule noCanDo arg1 $ \name -> do let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) case loc of RealSrcLoc l -> - ASSERT( isExternalName name ) - findBreakAndSet (GHC.nameModule name) $ + ASSERT( isExternalName name ) + findBreakAndSet (GHC.nameModule name) $ findBreakByCoord (Just (GHC.srcLocFile l)) - (GHC.srcLocLine l, + (GHC.srcLocLine l, GHC.srcLocCol l) UnhelpfulLoc _ -> noCanDo name $ text "can't find its location: " <> ppr loc @@ -2330,48 +2352,48 @@ breakSwitch (arg1:rest) noCanDo n why = printForUser $ text "cannot set breakpoint on " <> ppr n <> text ": " <> why -breakByModule :: Module -> [String] -> GHCi () -breakByModule mod (arg1:rest) +breakByModule :: Module -> [String] -> GHCi () +breakByModule md (arg1:rest) | all isDigit arg1 = do -- looks like a line number - breakByModuleLine mod (read arg1) rest + breakByModuleLine md (read arg1) rest breakByModule _ _ = breakSyntax breakByModuleLine :: Module -> Int -> [String] -> GHCi () -breakByModuleLine mod line args - | [] <- args = findBreakAndSet mod $ findBreakByLine line +breakByModuleLine md line args + | [] <- args = findBreakAndSet md $ findBreakByLine line | [col] <- args, all isDigit col = - findBreakAndSet mod $ findBreakByCoord Nothing (line, read col) + findBreakAndSet md $ findBreakByCoord Nothing (line, read col) | otherwise = breakSyntax breakSyntax :: a breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]") findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi () -findBreakAndSet mod lookupTickTree = do - tickArray <- getTickArray mod - (breakArray, _) <- getModBreak mod - case lookupTickTree tickArray of +findBreakAndSet md lookupTickTree = do + tickArray <- getTickArray md + (breakArray, _) <- getModBreak md + case lookupTickTree tickArray of Nothing -> liftIO $ putStrLn $ "No breakpoints found at that location." - Just (tick, span) -> do + Just (tick, pan) -> do success <- liftIO $ setBreakFlag True breakArray tick - if success + if success then do - (alreadySet, nm) <- + (alreadySet, nm) <- recordBreak $ BreakLocation - { breakModule = mod - , breakLoc = span + { breakModule = md + , breakLoc = pan , breakTick = tick , onBreakCmd = "" } printForUser $ text "Breakpoint " <> ppr nm <> - if alreadySet - then text " was already set at " <> ppr span - else text " activated at " <> ppr span + if alreadySet + then text " was already set at " <> ppr pan + else text " activated at " <> ppr pan else do - printForUser $ text "Breakpoint could not be activated at" - <+> ppr span + printForUser $ text "Breakpoint could not be activated at" + <+> ppr pan -- When a line number is specified, the current policy for choosing -- the best breakpoint is this: @@ -2383,18 +2405,18 @@ findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan) findBreakByLine line arr | not (inRange (bounds arr) line) = Nothing | otherwise = - listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus` - listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus` + listToMaybe (sortBy (leftmost_largest `on` snd) comp) `mplus` + listToMaybe (sortBy (leftmost_smallest `on` snd) incomp) `mplus` listToMaybe (sortBy (rightmost `on` snd) ticks) - where + where ticks = arr ! line - starts_here = [ tick | tick@(_,span) <- ticks, - GHC.srcSpanStartLine (toRealSpan span) == line ] + starts_here = [ tick | tick@(_,pan) <- ticks, + GHC.srcSpanStartLine (toRealSpan pan) == line ] - (complete,incomplete) = partition ends_here starts_here - where ends_here (_,span) = GHC.srcSpanEndLine (toRealSpan span) == line - toRealSpan (RealSrcSpan span) = span + (comp, incomp) = partition ends_here starts_here + where ends_here (_,pan) = GHC.srcSpanEndLine (toRealSpan pan) == line + toRealSpan (RealSrcSpan pan) = pan toRealSpan (UnhelpfulSpan _) = panic "findBreakByLine UnhelpfulSpan" findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray @@ -2404,23 +2426,23 @@ findBreakByCoord mb_file (line, col) arr | otherwise = listToMaybe (sortBy (rightmost `on` snd) contains ++ sortBy (leftmost_smallest `on` snd) after_here) - where + where ticks = arr ! line -- the ticks that span this coordinate - contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col), - is_correct_file span ] + contains = [ tick | tick@(_,pan) <- ticks, pan `spans` (line,col), + is_correct_file pan ] - is_correct_file span - | Just f <- mb_file = GHC.srcSpanFile (toRealSpan span) == f + is_correct_file pan + | Just f <- mb_file = GHC.srcSpanFile (toRealSpan pan) == f | otherwise = True - after_here = [ tick | tick@(_,span) <- ticks, - let span' = toRealSpan span, - GHC.srcSpanStartLine span' == line, - GHC.srcSpanStartCol span' >= col ] + after_here = [ tick | tick@(_,pan) <- ticks, + let pan' = toRealSpan pan, + GHC.srcSpanStartLine pan' == line, + GHC.srcSpanStartCol pan' >= col ] - toRealSpan (RealSrcSpan span) = span + toRealSpan (RealSrcSpan pan) = pan toRealSpan (UnhelpfulSpan _) = panic "findBreakByCoord UnhelpfulSpan" -- For now, use ANSI bold on terminals that we know support it. @@ -2451,9 +2473,9 @@ listCmd' "" = do case mb_span of Nothing -> printForUser $ text "Not stopped at a breakpoint; nothing to list" - Just (RealSrcSpan span) -> - listAround span True - Just span@(UnhelpfulSpan _) -> + Just (RealSrcSpan pan) -> + listAround pan True + Just pan@(UnhelpfulSpan _) -> do resumes <- GHC.getResumeContext case resumes of [] -> panic "No resumes" @@ -2463,7 +2485,7 @@ listCmd' "" = do _ -> empty doWhat = traceIt <+> text ":back then :list" printForUser (text "Unable to list source for" <+> - ppr span + ppr pan $$ text "Try" <+> doWhat) listCmd' str = list2 (words str) @@ -2472,31 +2494,31 @@ list2 [arg] | all isDigit arg = do imports <- GHC.getContext case iiModules imports of [] -> liftIO $ putStrLn "No module to list" - (mod : _) -> listModuleLine mod (read arg) + (md : _) -> listModuleLine md (read arg) list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do - mod <- wantInterpretedModule arg1 - listModuleLine mod (read arg2) + md <- wantInterpretedModule arg1 + listModuleLine md (read arg2) list2 [arg] = do wantNameFromInterpretedModule noCanDo arg $ \name -> do let loc = GHC.srcSpanStart (GHC.nameSrcSpan name) case loc of RealSrcLoc l -> do tickArray <- ASSERT( isExternalName name ) - lift $ getTickArray (GHC.nameModule name) + lift $ getTickArray (GHC.nameModule name) let mb_span = findBreakByCoord (Just (GHC.srcLocFile l)) (GHC.srcLocLine l, GHC.srcLocCol l) tickArray case mb_span of Nothing -> listAround (realSrcLocSpan l) False Just (_, UnhelpfulSpan _) -> panic "list2 UnhelpfulSpan" - Just (_, RealSrcSpan span) -> listAround span False + Just (_, RealSrcSpan pan) -> listAround pan False UnhelpfulLoc _ -> noCanDo name $ text "can't find its location: " <> ppr loc where noCanDo n why = printForUser $ text "cannot list source code for " <> ppr n <> text ": " <> why -list2 _other = +list2 _other = liftIO $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]" listModuleLine :: Module -> Int -> InputT GHCi () @@ -2520,31 +2542,30 @@ listModuleLine modl line = do -- It would be better if we could convert directly between UTF-8 and the -- console encoding, of course. listAround :: MonadIO m => RealSrcSpan -> Bool -> InputT m () -listAround span do_highlight = do +listAround pan do_highlight = do contents <- liftIO $ BS.readFile (unpackFS file) - let - lines = BS.split '\n' contents - these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $ - drop (line1 - 1 - pad_before) $ lines + let ls = BS.split '\n' contents + ls' = take (line2 - line1 + 1 + pad_before + pad_after) $ + drop (line1 - 1 - pad_before) $ ls fst_line = max 1 (line1 - pad_before) line_nos = [ fst_line .. ] - highlighted | do_highlight = zipWith highlight line_nos these_lines - | otherwise = [\p -> BS.concat[p,l] | l <- these_lines] + highlighted | do_highlight = zipWith highlight line_nos ls' + | otherwise = [\p -> BS.concat[p,l] | l <- ls'] bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ] prefixed = zipWith ($) highlighted bs_line_nos - -- - let output = BS.intercalate (BS.pack "\n") prefixed + output = BS.intercalate (BS.pack "\n") prefixed + utf8Decoded <- liftIO $ BS.useAsCStringLen output $ \(p,n) -> utf8DecodeString (castPtr p) n liftIO $ putStrLn utf8Decoded where - file = GHC.srcSpanFile span - line1 = GHC.srcSpanStartLine span - col1 = GHC.srcSpanStartCol span - 1 - line2 = GHC.srcSpanEndLine span - col2 = GHC.srcSpanEndCol span - 1 + file = GHC.srcSpanFile pan + line1 = GHC.srcSpanStartLine pan + col1 = GHC.srcSpanStartCol pan - 1 + line2 = GHC.srcSpanEndLine pan + col2 = GHC.srcSpanEndCol pan - 1 pad_before | line1 == 1 = 0 | otherwise = 1 @@ -2572,7 +2593,7 @@ listAround span do_highlight = do = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ', BS.replicate (col2-col1) '^'] | no == line1 - = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl, + = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl, prefix, line] | no == line2 = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ', @@ -2593,7 +2614,7 @@ getTickArray modl = do case lookupModuleEnv arrmap modl of Just arr -> return arr Nothing -> do - (_breakArray, ticks) <- getModBreak modl + (_breakArray, ticks) <- getModBreak modl let arr = mkTickArray (assocs ticks) setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr} return arr @@ -2605,15 +2626,14 @@ discardTickArrays = do mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray mkTickArray ticks - = accumArray (flip (:)) [] (1, max_line) - [ (line, (nm,span)) | (nm,span) <- ticks, - let span' = toRealSpan span, - line <- srcSpanLines span' ] + = accumArray (flip (:)) [] (1, max_line) + [ (line, (nm,pan)) | (nm,pan) <- ticks, + let pan' = toRealSpan pan, + line <- srcSpanLines pan' ] where max_line = foldr max 0 (map (GHC.srcSpanEndLine . toRealSpan . snd) ticks) - srcSpanLines span = [ GHC.srcSpanStartLine span .. - GHC.srcSpanEndLine span ] - toRealSpan (RealSrcSpan span) = span + srcSpanLines pan = [ GHC.srcSpanStartLine pan .. GHC.srcSpanEndLine pan ] + toRealSpan (RealSrcSpan pan) = pan toRealSpan (UnhelpfulSpan _) = panic "mkTickArray UnhelpfulSpan" -- don't reset the counter back to zero? @@ -2628,7 +2648,7 @@ deleteBreak identity = do st <- getGHCiState let oldLocations = breaks st (this,rest) = partition (\loc -> fst loc == identity) oldLocations - if null this + if null this then printForUser (text "Breakpoint" <+> ppr identity <+> text "does not exist") else do @@ -2641,24 +2661,24 @@ turnOffBreak loc = do liftIO $ setBreakFlag False arr (breakTick loc) getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan) -getModBreak mod = do - Just mod_info <- GHC.getModuleInfo mod +getModBreak m = do + Just mod_info <- GHC.getModuleInfo m let modBreaks = GHC.modInfoModBreaks mod_info - let array = GHC.modBreaks_flags modBreaks + let arr = GHC.modBreaks_flags modBreaks let ticks = GHC.modBreaks_locs modBreaks - return (array, ticks) + return (arr, ticks) -setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool -setBreakFlag toggle array index - | toggle = GHC.setBreakOn array index - | otherwise = GHC.setBreakOff array index +setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool +setBreakFlag toggle arr i + | toggle = GHC.setBreakOn arr i + | otherwise = GHC.setBreakOff arr i -- --------------------------------------------------------------------------- -- User code exception handling -- This is the exception handler for exceptions generated by the --- user's code and exceptions coming from children sessions; +-- user's code and exceptions coming from children sessions; -- it normally just prints out the exception. The -- handler must be recursive, in case showing the exception causes -- more exceptions to be raised. @@ -2712,28 +2732,27 @@ tryBool m = do -- Utils lookupModule :: GHC.GhcMonad m => String -> m Module -lookupModule modName - = GHC.lookupModule (GHC.mkModuleName modName) Nothing +lookupModule mName = GHC.lookupModule (GHC.mkModuleName mName) Nothing isHomeModule :: Module -> Bool -isHomeModule mod = GHC.modulePackageId mod == mainPackageId +isHomeModule m = GHC.modulePackageId m == mainPackageId -- TODO: won't work if home dir is encoded. -- (changeDirectory may not work either in that case.) expandPath :: MonadIO m => String -> InputT m String -expandPath path = do - exp_path <- liftIO $ expandPathIO path - enc <- fmap BS.unpack $ Encoding.encode exp_path - return enc +expandPath p = do + exp_path <- liftIO $ expandPathIO p + e <- fmap BS.unpack $ Encoding.encode exp_path + return e expandPathIO :: String -> IO String -expandPathIO path = - case dropWhile isSpace path of +expandPathIO p = + case dropWhile isSpace p of ('~':d) -> do - tilde <- getHomeDirectory -- will fail if HOME not defined - return (tilde ++ '/':d) - other -> - return other + tilde <- getHomeDirectory -- will fail if HOME not defined + return (tilde ++ '/':d) + other -> + return other wantInterpretedModule :: GHC.GhcMonad m => String -> m Module wantInterpretedModule str = do diff --git a/ghc/Main.hs b/ghc/Main.hs index 4829a4f5a8..b9de7b1f97 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -1,12 +1,5 @@ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSp --- for details - ----------------------------------------------------------------------------- -- -- GHC Driver program @@ -19,28 +12,28 @@ module Main (main) where -- The official GHC API import qualified GHC -import GHC ( -- DynFlags(..), HscTarget(..), +import GHC ( -- DynFlags(..), HscTarget(..), -- GhcMode(..), GhcLink(..), Ghc, GhcMonad(..), - LoadHowMuch(..) ) + LoadHowMuch(..) ) import CmdLineParser -- Implementations of the various modes (--show-iface, mkdependHS. etc.) -import LoadIface ( showIface ) +import LoadIface ( showIface ) import HscMain ( newHscEnv ) -import DriverPipeline ( oneShot, compileFile ) -import DriverMkDepend ( doMkDependHS ) +import DriverPipeline ( oneShot, compileFile ) +import DriverMkDepend ( doMkDependHS ) #ifdef GHCI -import InteractiveUI ( interactiveUI, ghciWelcomeMsg ) +import InteractiveUI ( interactiveUI, ghciWelcomeMsg ) #endif -- Various other random stuff that we need import Config import HscTypes -import Packages ( dumpPackages ) -import DriverPhases ( Phase(..), isSourceFilename, anyHsc, - startPhase, isHaskellSrcFilename ) +import Packages ( dumpPackages ) +import DriverPhases ( Phase(..), isSourceFilename, anyHsc, + startPhase, isHaskellSrcFilename ) import BasicTypes ( failed ) import StaticFlags import StaticFlagParser @@ -239,12 +232,12 @@ partition_args :: [String] -> [(String, Maybe Phase)] -> [String] -> ([(String, Maybe Phase)], [String]) partition_args [] srcs objs = (reverse srcs, reverse objs) partition_args ("-x":suff:args) srcs objs - | "none" <- suff = partition_args args srcs objs - | StopLn <- phase = partition_args args srcs (slurp ++ objs) - | otherwise = partition_args rest (these_srcs ++ srcs) objs - where phase = startPhase suff - (slurp,rest) = break (== "-x") args - these_srcs = zip slurp (repeat (Just phase)) + | "none" <- suff = partition_args args srcs objs + | StopLn <- phase = partition_args args srcs (slurp ++ objs) + | otherwise = partition_args rest (these_srcs ++ srcs) objs + where phase = startPhase suff + (slurp,rest) = break (== "-x") args + these_srcs = zip slurp (repeat (Just phase)) partition_args (arg:args) srcs objs | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs | otherwise = partition_args args srcs (arg:objs) @@ -268,8 +261,8 @@ partition_args (arg:args) srcs objs -} looks_like_an_input :: String -> Bool looks_like_an_input m = isSourceFilename m - || looksLikeModuleName m - || '.' `notElem` m + || looksLikeModuleName m + || '.' `notElem` m -- ----------------------------------------------------------------------------- -- Option sanity checks @@ -288,33 +281,33 @@ checkOptions mode dflags srcs objs = do && isInterpretiveMode mode) $ hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi") - -- -prof and --interactive are not a good combination + -- -prof and --interactive are not a good combination when (notNull (filter (not . isRTSWay) (wayNames dflags)) && isInterpretiveMode mode) $ do ghcError (UsageError "--interactive can't be used with -prof or -unreg.") - -- -ohi sanity check + -- -ohi sanity check if (isJust (outputHi dflags) && (isCompManagerMode mode || srcs `lengthExceeds` 1)) - then ghcError (UsageError "-ohi can only be used when compiling a single source file") - else do + then ghcError (UsageError "-ohi can only be used when compiling a single source file") + else do - -- -o sanity checking + -- -o sanity checking if (srcs `lengthExceeds` 1 && isJust (outputFile dflags) - && not (isLinkMode mode)) - then ghcError (UsageError "can't apply -o to multiple source files") - else do + && not (isLinkMode mode)) + then ghcError (UsageError "can't apply -o to multiple source files") + else do let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags) when (not_linking && not (null objs)) $ hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs) - -- Check that there are some input files - -- (except in the interactive case) + -- Check that there are some input files + -- (except in the interactive case) if null srcs && (null objs || not_linking) && needsInputsMode mode - then ghcError (UsageError "no input files") - else do + then ghcError (UsageError "no input files") + else do -- Verify that output files point somewhere sensible. verifyOutputFiles dflags @@ -346,7 +339,7 @@ verifyOutputFiles dflags = do nonExistentDir flg dir = ghcError (CmdLineError ("error: directory portion of " ++ show dir ++ " does not exist (used with " ++ - show flg ++ " option.)")) + show flg ++ " option.)")) ----------------------------------------------------------------------------- -- GHC modes of operation @@ -446,7 +439,7 @@ isDoMakeMode _ = False #ifdef GHCI isInteractiveMode :: PostLoadMode -> Bool isInteractiveMode DoInteractive = True -isInteractiveMode _ = False +isInteractiveMode _ = False #endif -- isInterpretiveMode: byte-code compiler involved @@ -456,19 +449,19 @@ isInterpretiveMode (DoEval _) = True isInterpretiveMode _ = False needsInputsMode :: PostLoadMode -> Bool -needsInputsMode DoMkDependHS = True -needsInputsMode (StopBefore _) = True -needsInputsMode DoMake = True -needsInputsMode _ = 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 :: PostLoadMode -> Bool isLinkMode (StopBefore StopLn) = True -isLinkMode DoMake = True +isLinkMode DoMake = True isLinkMode DoInteractive = True isLinkMode (DoEval _) = True -isLinkMode _ = False +isLinkMode _ = False isCompManagerMode :: PostLoadMode -> Bool isCompManagerMode DoMake = True @@ -610,10 +603,10 @@ doMake :: [(String,Maybe Phase)] -> Ghc () doMake srcs = do let (hs_srcs, non_hs_srcs) = partition haskellish srcs - haskellish (f,Nothing) = - looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f - haskellish (_,Just phase) = - phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn] + haskellish (f,Nothing) = + looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f + haskellish (_,Just phase) = + phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn] hsc_env <- GHC.getSession @@ -705,17 +698,17 @@ dumpFastStringStats dflags = do buckets <- getFastStringTable let (entries, longest, is_z, has_z) = countFS 0 0 0 0 buckets msg = text "FastString stats:" $$ - nest 4 (vcat [text "size: " <+> int (length buckets), - text "entries: " <+> int entries, - text "longest chain: " <+> int longest, - text "z-encoded: " <+> (is_z `pcntOf` entries), - text "has z-encoding: " <+> (has_z `pcntOf` entries) - ]) - -- we usually get more "has z-encoding" than "z-encoded", because - -- when we z-encode a string it might hash to the exact same string, - -- which will is not counted as "z-encoded". Only strings whose - -- Z-encoding is different from the original string are counted in - -- the "z-encoded" total. + nest 4 (vcat [text "size: " <+> int (length buckets), + text "entries: " <+> int entries, + text "longest chain: " <+> int longest, + text "z-encoded: " <+> (is_z `pcntOf` entries), + text "has z-encoding: " <+> (has_z `pcntOf` entries) + ]) + -- we usually get more "has z-encoding" than "z-encoded", because + -- when we z-encode a string it might hash to the exact same string, + -- which will is not counted as "z-encoded". Only strings whose + -- Z-encoding is different from the original string are counted in + -- the "z-encoded" total. putMsg dflags msg where x `pcntOf` y = int ((x * 100) `quot` y) <> char '%' @@ -724,13 +717,13 @@ countFS :: Int -> Int -> Int -> Int -> [[FastString]] -> (Int, Int, Int, Int) countFS entries longest is_z has_z [] = (entries, longest, is_z, has_z) countFS entries longest is_z has_z (b:bs) = let - len = length b - longest' = max len longest - entries' = entries + len - is_zs = length (filter isZEncoded b) - has_zs = length (filter hasZEncoding b) + len = length b + longest' = max len longest + entries' = entries + len + is_zs = length (filter isZEncoded b) + has_zs = length (filter hasZEncoding b) in - countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs + countFS entries' longest' (is_z + is_zs) (has_z + has_zs) bs -- ----------------------------------------------------------------------------- -- ABI hash support |