Commit e7e771d1 authored by dterei's avatar dterei
Browse files

Fix warnings

parent 6a42e96e
{-# OPTIONS -fno-cse #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-----------------------------------------------------------------------------
--
-- GHC Interactive User Interface
......@@ -14,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 )
-----------------------------------------------------------------------------
......@@ -155,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
......@@ -245,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" ++
......@@ -259,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" ++
......@@ -279,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
......@@ -309,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
......@@ -348,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 ()
......@@ -458,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."
......@@ -480,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
......@@ -496,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
-- running code planted by a malicious third party.
-- Furthermore, We only read ./.ghci if . is owned by the current user
......@@ -518,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
......@@ -544,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
......@@ -562,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
......@@ -603,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
......@@ -635,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
......@@ -668,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
......@@ -689,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
......@@ -718,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
......@@ -769,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]
......@@ -791,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 ()
......@@ -888,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
......@@ -951,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)
......@@ -965,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)
......@@ -1011,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 =
......@@ -1028,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 ()
......@@ -1056,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?
......@@ -1076,14 +1079,14 @@ 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)
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
if (not overwrite && macro_name `elem` defined)
then ghcError (CmdLineError
then ghcError (CmdLineError
("macro '" ++ macro_name ++ "' is already defined"))
else do
......@@ -1114,11 +1117,11 @@ 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
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))
......@@ -1150,11 +1153,11 @@ checkModule m = do
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
(loc, glob) = ASSERT( all isExternalName scope )
partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
in
(text "global names: " <+> ppr global) $$
(text "local names: " <+> ppr local)
(text "global names: " <+> ppr glob) $$
(text "local names: " <+> ppr loc)
_ -> empty
return True
afterLoad (successIf ok) False
......@@ -1195,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
......@@ -1208,7 +1211,7 @@ addModule files = do
reloadModule :: String -> InputT GHCi ()
reloadModule m = do