diff options
Diffstat (limited to 'ghc')
| -rw-r--r-- | ghc/GhciMonad.hs | 2 | ||||
| -rw-r--r-- | ghc/InteractiveUI.hs | 145 | ||||
| -rw-r--r-- | ghc/Main.hs | 34 |
3 files changed, 133 insertions, 48 deletions
diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index e61e1409de..a3fe632493 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -64,7 +64,7 @@ data GHCiState = GHCiState progname :: String, args :: [String], prompt :: String, - def_prompt :: String, + prompt2 :: String, editor :: String, stop :: String, options :: [GHCiOption], diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 263babeafc..fd034eaf7d 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -90,6 +90,7 @@ import System.IO.Error import System.IO.Unsafe ( unsafePerformIO ) import System.Process import Text.Printf +import Text.Read ( readMaybe ) #ifndef mingw32_HOST_OS import System.Posix hiding ( getEnv ) @@ -109,7 +110,8 @@ data GhciSettings = GhciSettings { availableCommands :: [Command], shortHelpText :: String, fullHelpText :: String, - defPrompt :: String + defPrompt :: String, + defPrompt2 :: String } defaultGhciSettings :: GhciSettings @@ -118,7 +120,8 @@ defaultGhciSettings = availableCommands = ghciCommands, shortHelpText = defShortHelpText, fullHelpText = defFullHelpText, - defPrompt = default_prompt + defPrompt = default_prompt, + defPrompt2 = default_prompt2 } ghciWelcomeMsg :: String @@ -143,6 +146,7 @@ ghciCommands = [ ("cd", keepGoing' changeDirectory, completeFilename), ("check", keepGoing' checkModule, completeHomeModule), ("continue", keepGoing continueCmd, noCompletion), + ("complete", keepGoing completeCmd, noCompletion), ("cmd", keepGoing cmdCmd, completeExpression), ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename), ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename), @@ -230,6 +234,7 @@ defFullHelpText = " (!: more details; *: all top-level names)\n" ++ " :cd <dir> change directory to <dir>\n" ++ " :cmd <expr> run the commands returned by <expr>::IO String\n" ++ + " :complete <dom> [<rng>] <s> list completions for partial input string\n" ++ " :ctags[!] [<file>] create tags file for Vi (default: \"tags\")\n" ++ " (!: use regex instead of line number)\n" ++ " :def <cmd> <expr> define command :<cmd> (later defined command has\n" ++ @@ -285,6 +290,7 @@ defFullHelpText = " :set args <arg> ... set the arguments returned by System.getArgs\n" ++ " :set prog <progname> set the value returned by System.getProgName\n" ++ " :set prompt <prompt> set the prompt used in GHCi\n" ++ + " :set prompt2 <prompt> set the continuation prompt used in GHCi\n" ++ " :set editor <cmd> set the command used for :edit\n" ++ " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++ " :unset <option> ... unset options\n" ++ @@ -306,6 +312,7 @@ defFullHelpText = " :show breaks show the active breakpoints\n" ++ " :show context show the breakpoint context\n" ++ " :show imports show the current imports\n" ++ + " :show linker show current linker state\n" ++ " :show modules show the currently loaded modules\n" ++ " :show packages show the currently active package flags\n" ++ " :show language show the currently active language flags\n" ++ @@ -327,9 +334,10 @@ findEditor = do foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt -default_progname, default_prompt, default_stop :: String +default_progname, default_prompt, default_prompt2, default_stop :: String default_progname = "<interactive>" default_prompt = "%s> " +default_prompt2 = "%s| " default_stop = "" default_args :: [String] @@ -393,7 +401,7 @@ interactiveUI config srcs maybe_exprs = do GHCiState{ progname = default_progname, GhciMonad.args = default_args, prompt = defPrompt config, - def_prompt = defPrompt config, + prompt2 = defPrompt2 config, stop = default_stop, editor = default_editor, options = [], @@ -583,6 +591,11 @@ fileLoop hdl = do l <- liftIO $ tryIO $ hGetLine hdl case l of Left e | isEOFError e -> return Nothing + | -- as we share stdin with the program, the program + -- might have already closed it, so we might get a + -- handle-closed exception. We therefore catch that + -- too. + isIllegalOperation e -> return Nothing | InvalidArgument <- etype -> return Nothing | otherwise -> liftIO $ ioError e where etype = ioeGetErrorType e @@ -596,6 +609,7 @@ fileLoop hdl = do mkPrompt :: GHCi String mkPrompt = do + st <- getGHCiState imports <- GHC.getContext resumes <- GHC.getResumeContext @@ -626,12 +640,12 @@ mkPrompt = do deflt_prompt = dots <> context_bit <> modules_bit + f ('%':'l':xs) = ppr (1 + line_number st) <> f xs f ('%':'s':xs) = deflt_prompt <> f xs f ('%':'%':xs) = char '%' <> f xs f (x:xs) = char x <> f xs f [] = empty - st <- getGHCiState dflags <- getDynFlags return (showSDoc dflags (f (prompt st))) @@ -704,7 +718,7 @@ runOneCommand eh gCmd = do multiLineCmd q = do st <- lift getGHCiState let p = prompt st - lift $ setGHCiState st{ prompt = "%s| " } + lift $ setGHCiState st{ prompt = prompt2 st } mb_cmd <- collectCommand q "" lift $ getGHCiState >>= \st' -> setGHCiState st'{ prompt = p } return mb_cmd @@ -767,7 +781,7 @@ checkInputForLayout stmt getStmt = do _other -> do st1 <- lift getGHCiState let p = prompt st1 - lift $ setGHCiState st1{ prompt = "%s| " } + lift $ setGHCiState st1{ prompt = prompt2 st1 } mb_stmt <- ghciHandle (\ex -> case fromException ex of Just UserInterrupt -> return Nothing _ -> case fromException ex of @@ -1038,7 +1052,7 @@ filterOutChildren get_thing xs Nothing -> False pprInfo :: PrintExplicitForalls - -> (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst GHC.Branched]) -> SDoc + -> (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc pprInfo pefas (thing, fixity, cls_insts, fam_insts) = pprTyThingInContextLoc pefas thing $$ show_fixity @@ -1872,17 +1886,18 @@ setCmd "" = showOptions False setCmd "-a" = showOptions True setCmd str = case getCmd str of - Right ("args", rest) -> + Right ("args", rest) -> case toArgs rest of Left err -> liftIO (hPutStrLn stderr err) Right args -> setArgs args - Right ("prog", rest) -> + Right ("prog", rest) -> case toArgs rest of Right [prog] -> setProg prog _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>") - Right ("prompt", rest) -> setPrompt $ Just $ dropWhile isSpace rest - Right ("editor", rest) -> setEditor $ dropWhile isSpace rest - Right ("stop", rest) -> setStop $ dropWhile isSpace rest + Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest + Right ("prompt2", rest) -> setPrompt2 $ dropWhile isSpace rest + Right ("editor", rest) -> setEditor $ dropWhile isSpace rest + Right ("stop", rest) -> setStop $ dropWhile isSpace rest _ -> case toArgs str of Left err -> liftIO (hPutStrLn stderr err) Right wds -> setOptions wds @@ -1975,22 +1990,30 @@ setStop cmd = do st <- getGHCiState setGHCiState st{ stop = cmd } -setPrompt :: Maybe String -> GHCi () -setPrompt Nothing = do - st <- getGHCiState - setGHCiState ( st { prompt = def_prompt st } ) +setPrompt :: String -> GHCi () +setPrompt = setPrompt_ f err + where + f v st = st { prompt = v } + err st = "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\"" + +setPrompt2 :: String -> GHCi () +setPrompt2 = setPrompt_ f err + where + f v st = st { prompt2 = v } + err st = "syntax: :set prompt2 <prompt>, currently \"" ++ prompt2 st ++ "\"" -setPrompt (Just value) = do +setPrompt_ :: (String -> GHCiState -> GHCiState) -> (GHCiState -> String) -> String -> GHCi () +setPrompt_ f err value = do st <- getGHCiState if null value - then liftIO $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\"" + then liftIO $ hPutStrLn stderr $ err st else case value of '\"' : _ -> case reads value of [(value', xs)] | all isSpace xs -> - setGHCiState (st { prompt = value' }) + setGHCiState $ f value' st _ -> liftIO $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax." - _ -> setGHCiState (st { prompt = value }) + _ -> setGHCiState $ f value st setOptions wds = do -- first, deal with the GHCi opts (+s, +t, etc.) @@ -2054,11 +2077,12 @@ unsetOptions str (other_opts, rest3) = partition (`elem` map fst defaulters) rest2 defaulters = - [ ("args" , setArgs default_args) - , ("prog" , setProg default_progname) - , ("prompt", setPrompt Nothing) - , ("editor", liftIO findEditor >>= setEditor) - , ("stop" , setStop default_stop) + [ ("args" , setArgs default_args) + , ("prog" , setProg default_progname) + , ("prompt" , setPrompt default_prompt) + , ("prompt2", setPrompt2 default_prompt2) + , ("editor" , liftIO findEditor >>= setEditor) + , ("stop" , setStop default_stop) ] no_flag ('-':'f':rest) = return ("-fno-" ++ rest) @@ -2120,6 +2144,7 @@ showCmd str = do ["args"] -> liftIO $ putStrLn (show (GhciMonad.args st)) ["prog"] -> liftIO $ putStrLn (show (progname st)) ["prompt"] -> liftIO $ putStrLn (show (prompt st)) + ["prompt2"] -> liftIO $ putStrLn (show (prompt2 st)) ["editor"] -> liftIO $ putStrLn (show (editor st)) ["stop"] -> liftIO $ putStrLn (show (stop st)) ["imports"] -> showImports @@ -2134,8 +2159,8 @@ showCmd str = do ["languages"] -> showLanguages -- backwards compat ["language"] -> showLanguages ["lang"] -> showLanguages -- useful abbreviation - _ -> throwGhcException (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++ - " | breaks | context | packages | language ]")) + _ -> throwGhcException (CmdLineError ("syntax: :show [ args | prog | prompt | prompt2 | editor | stop | modules\n" ++ + " | bindings | breaks | context | packages | language ]")) showiCmd :: String -> GHCi () showiCmd str = do @@ -2195,7 +2220,7 @@ showBindings = do return $ maybe (text "") (pprTT pefas) mb_stuff pprTT :: PrintExplicitForalls - -> (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst GHC.Branched]) -> SDoc + -> (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst]) -> SDoc pprTT pefas (thing, fixity, _cls_insts, _fam_insts) = pprTyThing pefas thing $$ show_fixity @@ -2273,7 +2298,48 @@ showLanguages' show_all dflags = -- ----------------------------------------------------------------------------- -- Completion -completeCmd, completeMacro, completeIdentifier, completeModule, +completeCmd :: String -> GHCi () +completeCmd argLine0 = case parseLine argLine0 of + Just ("repl", resultRange, left) -> do + (unusedLine,compls) <- ghciCompleteWord (reverse left,"") + let compls' = takeRange resultRange compls + liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ] + forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do + liftIO $ print r + _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>") + where + parseLine argLine + | null argLine = Nothing + | null rest1 = Nothing + | otherwise = (,,) dom <$> resRange <*> s + where + (dom, rest1) = breakSpace argLine + (rng, rest2) = breakSpace rest1 + resRange | head rest1 == '"' = parseRange "" + | otherwise = parseRange rng + s | head rest1 == '"' = readMaybe rest1 :: Maybe String + | otherwise = readMaybe rest2 + breakSpace = fmap (dropWhile isSpace) . break isSpace + + takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub + + -- syntax: [n-][m] with semantics "drop (n-1) . take m" + parseRange :: String -> Maybe (Maybe Int,Maybe Int) + parseRange s = case span isDigit s of + (_, "") -> + -- upper limit only + Just (Nothing, bndRead s) + (s1, '-' : s2) + | all isDigit s2 -> + Just (bndRead s1, bndRead s2) + _ -> + Nothing + where + bndRead x = if null x then Nothing else Just (read x) + + + +completeGhciCommand, completeMacro, completeIdentifier, completeModule, completeSetModule, completeSeti, completeShowiOptions, completeHomeModule, completeSetOptions, completeShowOptions, completeHomeModuleOrFile, completeExpression @@ -2281,7 +2347,7 @@ completeCmd, completeMacro, completeIdentifier, completeModule, ghciCompleteWord :: CompletionFunc GHCi ghciCompleteWord line@(left,_) = case firstWord of - ':':cmd | null rest -> completeCmd line + ':':cmd | null rest -> completeGhciCommand line | otherwise -> do completion <- lookupCompletion cmd completion line @@ -2296,7 +2362,7 @@ ghciCompleteWord line@(left,_) = case firstWord of Just (_,_,f) -> return f Nothing -> return completeFilename -completeCmd = wrapCompleter " " $ \w -> do +completeGhciCommand = wrapCompleter " " $ \w -> do macros <- liftIO $ readIORef macros_ref cmds <- ghci_commands `fmap` getGHCiState let macro_names = map (':':) . map cmdName $ macros @@ -2346,7 +2412,7 @@ listHomeModules w = do completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do return (filter (w `isPrefixOf`) opts) - where opts = "args":"prog":"prompt":"editor":"stop":flagList + where opts = "args":"prog":"prompt":"prompt2":"editor":"stop":flagList flagList = map head $ group $ sort allFlags completeSeti = wrapCompleter flagWordBreakChars $ \w -> do @@ -2355,9 +2421,9 @@ completeSeti = wrapCompleter flagWordBreakChars $ \w -> do completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do return (filter (w `isPrefixOf`) opts) - where opts = ["args", "prog", "prompt", "editor", "stop", + where opts = ["args", "prog", "prompt", "prompt2", "editor", "stop", "modules", "bindings", "linker", "breaks", - "context", "packages", "language"] + "context", "packages", "language", "imports"] completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do return (filter (w `isPrefixOf`) ["language"]) @@ -2446,7 +2512,7 @@ enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" enclosingTickSpan md (RealSrcSpan src) = do ticks <- getTickArray md let line = srcSpanStartLine src - ASSERT (inRange (bounds ticks) line) do + ASSERT(inRange (bounds ticks) line) do let toRealSrcSpan (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan" toRealSrcSpan (RealSrcSpan s) = s enclosing_spans = [ pan | (_,pan) <- ticks ! line @@ -2947,9 +3013,10 @@ showException se = -- in an exception loop (eg. let a = error a in a) the ^C exception -- may never be delivered. Thanks to Marcin for pointing out the bug. -ghciHandle :: ExceptionMonad m => (SomeException -> m a) -> m a -> m a -ghciHandle h m = gmask $ \restore -> - gcatch (restore m) $ \e -> restore (h e) +ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a +ghciHandle h m = gmask $ \restore -> do + dflags <- getDynFlags + gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e) ghciTry :: GHCi a -> GHCi (Either SomeException a) ghciTry (GHCi m) = GHCi $ \s -> gtry (m s) diff --git a/ghc/Main.hs b/ghc/Main.hs index 35dbf5bf2a..66db90a9f7 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -33,8 +33,7 @@ import Config import Constants import HscTypes import Packages ( dumpPackages ) -import DriverPhases ( Phase(..), isSourceFilename, anyHsc, - startPhase, isHaskellSrcFilename ) +import DriverPhases import BasicTypes ( failed ) import StaticFlags import DynFlags @@ -109,6 +108,7 @@ main = do ShowSupportedExtensions -> showSupportedExtensions ShowVersion -> showVersion ShowNumVersion -> putStrLn cProjectVersion + ShowOptions -> showOptions Right postStartupMode -> -- start our GHC session GHC.runGhc mbMinusB $ do @@ -159,8 +159,6 @@ main' postLoadMode dflags0 args flagWarnings = do dflags2 = dflags1{ ghcMode = mode, hscTarget = lang, ghcLink = link, - -- leave out hscOutName for now - hscOutName = panic "Main.main:hscOutName not set", verbosity = case postLoadMode of DoEval _ -> 0 _other -> 1 @@ -200,7 +198,8 @@ main' postLoadMode dflags0 args flagWarnings = do normal_fileish_paths = map (normalise . unLoc) fileish_args (srcs, objs) = partition_args normal_fileish_paths [] [] - dflags5 = dflags4 { ldInputs = objs ++ ldInputs dflags4 } + dflags5 = dflags4 { ldInputs = map (FileOption "") objs + ++ ldInputs dflags4 } -- we've finished manipulating the DynFlags, update the session _ <- GHC.setSessionDynFlags dflags5 @@ -372,11 +371,13 @@ data PreStartupMode = ShowVersion -- ghc -V/--version | ShowNumVersion -- ghc --numeric-version | ShowSupportedExtensions -- ghc --supported-extensions + | ShowOptions -- ghc --show-options -showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode +showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode showVersionMode = mkPreStartupMode ShowVersion showNumVersionMode = mkPreStartupMode ShowNumVersion showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions +showOptionsMode = mkPreStartupMode ShowOptions mkPreStartupMode :: PreStartupMode -> Mode mkPreStartupMode = Left @@ -520,6 +521,7 @@ mode_flags = , Flag "-version" (PassFlag (setMode showVersionMode)) , Flag "-numeric-version" (PassFlag (setMode showNumVersionMode)) , Flag "-info" (PassFlag (setMode showInfoMode)) + , Flag "-show-options" (PassFlag (setMode showOptionsMode)) , Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode)) , Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode)) ] ++ @@ -623,7 +625,7 @@ doMake srcs = do let (hs_srcs, non_hs_srcs) = partition haskellish srcs haskellish (f,Nothing) = - looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f + looksLikeModuleName f || isHaskellUserSrcFilename f || '.' `notElem` f haskellish (_,Just phase) = phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn] @@ -640,7 +642,8 @@ doMake srcs = do o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x) non_hs_srcs dflags <- GHC.getSessionDynFlags - let dflags' = dflags { ldInputs = o_files ++ ldInputs dflags } + let dflags' = dflags { ldInputs = map (FileOption "") o_files + ++ ldInputs dflags } _ <- GHC.setSessionDynFlags dflags' targets <- mapM (uncurry GHC.guessTarget) hs_srcs @@ -693,6 +696,21 @@ showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions showVersion :: IO () showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion) +showOptions :: IO () +showOptions = putStr (unlines availableOptions) + where + availableOptions = map ((:) '-') $ + getFlagNames mode_flags ++ + getFlagNames flagsDynamic ++ + (filterUnwantedStatic . getFlagNames $ flagsStatic) ++ + flagsStaticNames + getFlagNames opts = map getFlagName opts + getFlagName (Flag name _) = name + -- this is a hack to get rid of two unwanted entries that get listed + -- as static flags. Hopefully this hack will disappear one day together + -- with static flags + filterUnwantedStatic = filter (\x -> not (x `elem` ["f", "fno-"])) + showGhcUsage :: DynFlags -> IO () showGhcUsage = showUsage False |