diff options
Diffstat (limited to 'ghc')
| -rw-r--r-- | ghc/GhciMonad.hs | 5 | ||||
| -rw-r--r-- | ghc/InteractiveUI.hs | 101 | ||||
| -rw-r--r-- | ghc/Main.hs | 10 | ||||
| -rw-r--r-- | ghc/ghc-bin.cabal.in | 23 |
4 files changed, 94 insertions, 45 deletions
diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index a4abe322d2..22109c428d 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-} {-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly @@ -32,6 +33,7 @@ import Outputable hiding (printForUser, printForUserPartWay) import qualified Outputable import Util import DynFlags +import FastString import HscTypes import SrcLoc import Module @@ -104,7 +106,8 @@ data GHCiState = GHCiState -- help text to display to a user short_help :: String, - long_help :: String + long_help :: String, + lastErrorLocations :: IORef [(FastString, Int)] } type TickArray = Array Int [(BreakIndex,SrcSpan)] diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index b41c2db45a..ef48c348bd 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, TupleSections #-} {-# OPTIONS -fno-cse #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly @@ -27,6 +28,7 @@ import Debugger -- The GHC interface import DynFlags +import ErrUtils import GhcMonad ( modifySession ) import qualified GHC import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..), @@ -71,7 +73,7 @@ import Data.Array import qualified Data.ByteString.Char8 as BS import Data.Char import Data.Function -import Data.IORef ( IORef, readIORef, writeIORef ) +import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub, partition, sort, sortBy ) import Data.Maybe @@ -103,7 +105,6 @@ import GHC.IO.Exception ( IOErrorType(InvalidArgument) ) import GHC.IO.Handle ( hFlushAll ) import GHC.TopHandler ( topHandler ) - ----------------------------------------------------------------------------- data GhciSettings = GhciSettings { @@ -379,6 +380,12 @@ interactiveUI config srcs maybe_exprs = do $ dflags GHC.setInteractiveDynFlags dflags' + lastErrLocationsRef <- liftIO $ newIORef [] + progDynFlags <- GHC.getProgramDynFlags + _ <- GHC.setProgramDynFlags $ + progDynFlags { log_action = ghciLogAction lastErrLocationsRef } + + liftIO $ when (isNothing maybe_exprs) $ do -- Only for GHCi (not runghc and ghc -e): @@ -399,31 +406,46 @@ interactiveUI config srcs maybe_exprs = do #endif default_editor <- liftIO $ findEditor - startGHCi (runGHCi srcs maybe_exprs) - GHCiState{ progname = default_progname, - GhciMonad.args = default_args, - prompt = defPrompt config, - prompt2 = defPrompt2 config, - stop = default_stop, - editor = default_editor, - options = [], - line_number = 1, - break_ctr = 0, - breaks = [], - tickarrays = emptyModuleEnv, - ghci_commands = availableCommands config, - last_command = Nothing, - cmdqueue = [], - remembered_ctx = [], - transient_ctx = [], - ghc_e = isJust maybe_exprs, - short_help = shortHelpText config, - long_help = fullHelpText config + GHCiState{ progname = default_progname, + GhciMonad.args = default_args, + prompt = defPrompt config, + prompt2 = defPrompt2 config, + stop = default_stop, + editor = default_editor, + options = [], + line_number = 1, + break_ctr = 0, + breaks = [], + tickarrays = emptyModuleEnv, + ghci_commands = availableCommands config, + last_command = Nothing, + cmdqueue = [], + remembered_ctx = [], + transient_ctx = [], + ghc_e = isJust maybe_exprs, + short_help = shortHelpText config, + long_help = fullHelpText config, + lastErrorLocations = lastErrLocationsRef } - + return () +resetLastErrorLocations :: GHCi () +resetLastErrorLocations = do + st <- getGHCiState + liftIO $ writeIORef (lastErrorLocations st) [] + +ghciLogAction :: IORef [(FastString, Int)] -> LogAction +ghciLogAction lastErrLocations dflags severity srcSpan style msg = do + defaultLogAction dflags severity srcSpan style msg + case severity of + SevError -> case srcSpan of + RealSrcSpan rsp -> modifyIORef lastErrLocations + (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))]) + _ -> return () + _ -> return () + withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a withGhcAppData right left = do either_dir <- tryIO (getAppUserDataDirectory "ghc") @@ -1119,9 +1141,10 @@ runMain s = case toArgs s of Left err -> liftIO (hPutStrLn stderr err) Right args -> do dflags <- getDynFlags - case mainFunIs dflags of - Nothing -> doWithArgs args "main" - Just f -> doWithArgs args f + let main = fromMaybe "main" (mainFunIs dflags) + -- Wrap the main function in 'void' to discard its value instead + -- of printing it (#9086). See Haskell 2010 report Chapter 5. + doWithArgs args $ "Control.Monad.void (" ++ main ++ ")" ----------------------------------------------------------------------------- -- :run @@ -1169,10 +1192,18 @@ editFile :: String -> InputT GHCi () editFile str = do file <- if null str then lift chooseEditFile else expandPath str st <- lift getGHCiState + errs <- liftIO $ readIORef $ lastErrorLocations st let cmd = editor st when (null cmd) $ throwGhcException (CmdLineError "editor not set, use :set editor") - code <- liftIO $ system (cmd ++ ' ':file) + lineOpt <- liftIO $ do + curFileErrs <- filterM (\(f, _) -> unpackFS f `sameFile` file) errs + return $ case curFileErrs of + (_, line):_ -> " +" ++ show line + _ -> "" + let cmdArgs = ' ':(file ++ lineOpt) + code <- liftIO $ system (cmd ++ cmdArgs) + when (code == ExitSuccess) $ reloadModule "" @@ -1363,6 +1394,7 @@ doLoad retain_context howmuch = do -- the ModBreaks will have gone away. lift discardActiveBreakPoints + lift resetLastErrorLocations -- Enable buffering stdout and stderr as we're compiling. Keeping these -- handles unbuffered will just slow the compilation down, especially when -- compiling in parallel. @@ -1387,7 +1419,6 @@ afterLoad ok retain_context = do modulesLoadedMsg ok loaded_mods lift $ setContextAfterLoad retain_context loaded_mod_summaries - setContextAfterLoad :: Bool -> [GHC.ModSummary] -> GHCi () setContextAfterLoad keep_ctxt [] = do setContextKeepingPackageModules keep_ctxt [] @@ -1493,7 +1524,7 @@ kindOfType norm str $ do (ty, kind) <- GHC.typeKind norm str printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind - , ppWhen norm $ equals <+> ppr ty ] + , ppWhen norm $ equals <+> pprTypeForUser ty ] ----------------------------------------------------------------------------- @@ -2505,14 +2536,14 @@ unionComplete f1 f2 line = do wrapCompleter :: String -> (String -> GHCi [String]) -> CompletionFunc GHCi wrapCompleter breakChars fun = completeWord Nothing breakChars - $ fmap (map simpleCompletion) . fmap sort . fun + $ fmap (map simpleCompletion . nubSort) . fun wrapIdentCompleter :: (String -> GHCi [String]) -> CompletionFunc GHCi wrapIdentCompleter = wrapCompleter word_break_chars wrapIdentCompleterWithModifier :: String -> (Maybe Char -> String -> GHCi [String]) -> CompletionFunc GHCi wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars - $ \rest -> fmap (map simpleCompletion) . fmap sort . fun (getModifier rest) + $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest) where getModifier = find (`elem` modifChars) @@ -3117,7 +3148,13 @@ expandPathIO p = tilde <- getHomeDirectory -- will fail if HOME not defined return (tilde ++ '/':d) other -> - return other + return other + +sameFile :: FilePath -> FilePath -> IO Bool +sameFile path1 path2 = do + absPath1 <- canonicalizePath path1 + absPath2 <- canonicalizePath path2 + return $ absPath1 == absPath2 wantInterpretedModule :: GHC.GhcMonad m => String -> m Module wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str) diff --git a/ghc/Main.hs b/ghc/Main.hs index d056bf97c4..2bb156c5b9 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -1,5 +1,5 @@ +{-# LANGUAGE CPP, NondecreasingIndentation #-} {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} -{-# LANGUAGE ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- @@ -33,7 +33,7 @@ import InteractiveUI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings ) import Config import Constants import HscTypes -import Packages ( dumpPackages ) +import Packages ( dumpPackages, simpleDumpPackages ) import DriverPhases import BasicTypes ( failed ) import StaticFlags @@ -209,8 +209,10 @@ main' postLoadMode dflags0 args flagWarnings = do hsc_env <- GHC.getSession ---------------- Display configuration ----------- - when (verbosity dflags6 >= 4) $ - liftIO $ dumpPackages dflags6 + case verbosity dflags6 of + v | v == 4 -> liftIO $ simpleDumpPackages dflags6 + | v >= 5 -> liftIO $ dumpPackages dflags6 + | otherwise -> return () when (verbosity dflags6 >= 3) $ do liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) diff --git a/ghc/ghc-bin.cabal.in b/ghc/ghc-bin.cabal.in index 68338f37f7..dcbc695675 100644 --- a/ghc/ghc-bin.cabal.in +++ b/ghc/ghc-bin.cabal.in @@ -16,7 +16,7 @@ Category: XXX Data-Dir: .. Data-Files: settings Build-Type: Simple -Cabal-Version: >= 1.2 +Cabal-Version: >=1.10 Flag ghci Description: Build GHCi support. @@ -24,6 +24,8 @@ Flag ghci Manual: True Executable ghc + Default-Language: Haskell2010 + Main-Is: Main.hs Build-Depends: base >= 3 && < 5, array >= 0.1 && < 0.6, @@ -43,12 +45,17 @@ Executable ghc if flag(ghci) CPP-Options: -DGHCI GHC-Options: -fno-warn-name-shadowing - Other-Modules: InteractiveUI, GhciMonad, GhciTags + Other-Modules: + InteractiveUI + GhciMonad + GhciTags Build-Depends: transformers, haskeline - Extensions: ForeignFunctionInterface, - UnboxedTuples, - FlexibleInstances, - TupleSections, - MagicHash + Other-Extensions: + FlexibleInstances + MagicHash + TupleSections + UnboxedTuples - Extensions: CPP, PatternGuards, NondecreasingIndentation + Other-Extensions: + CPP + NondecreasingIndentation |