X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=a0c76ec52ef8f3279536d00221f101941eeef1fc;hb=b70f35afc1c606dc85e6feb7da74be72411f58c1;hp=8cc15132a808e9eb1ec9413f9217f3b231e791e1;hpb=d297cfc0ca26fa68ec38756c0751a589c97e0206;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 8cc1513..a0c76ec 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -106,49 +106,67 @@ GLOBAL_VAR(macros_ref, [], [Command]) builtin_commands :: [Command] builtin_commands = [ -- Hugs users are accustomed to :e, so make sure it doesn't overlap - ("?", keepGoing help, False, completeNone), - ("add", keepGoingPaths addModule, False, completeFilename), - ("abandon", keepGoing abandonCmd, False, completeNone), - ("break", keepGoing breakCmd, False, completeIdentifier), - ("back", keepGoing backCmd, False, completeNone), - ("browse", keepGoing (browseCmd False), False, completeModule), - ("browse!", keepGoing (browseCmd True), False, completeModule), - ("cd", keepGoing changeDirectory, False, completeFilename), - ("check", keepGoing checkModule, False, completeHomeModule), - ("continue", keepGoing continueCmd, False, completeNone), - ("cmd", keepGoing cmdCmd, False, completeIdentifier), - ("ctags", keepGoing createCTagsFileCmd, False, completeFilename), - ("def", keepGoing (defineMacro False), False, completeIdentifier), - ("def!", keepGoing (defineMacro True), False, completeIdentifier), - ("delete", keepGoing deleteCmd, False, completeNone), - ("e", keepGoing editFile, False, completeFilename), - ("edit", keepGoing editFile, False, completeFilename), - ("etags", keepGoing createETagsFileCmd, False, completeFilename), - ("force", keepGoing forceCmd, False, completeIdentifier), - ("forward", keepGoing forwardCmd, False, completeNone), - ("help", keepGoing help, False, completeNone), - ("history", keepGoing historyCmd, False, completeNone), - ("info", keepGoing info, False, completeIdentifier), - ("kind", keepGoing kindOfType, False, completeIdentifier), - ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile), - ("list", keepGoing listCmd, False, completeNone), - ("module", keepGoing setContext, False, completeModule), - ("main", keepGoing runMain, False, completeIdentifier), - ("print", keepGoing printCmd, False, completeIdentifier), - ("quit", quit, False, completeNone), - ("reload", keepGoing reloadModule, False, completeNone), - ("set", keepGoing setCmd, True, completeSetOptions), - ("show", keepGoing showCmd, False, completeNone), - ("sprint", keepGoing sprintCmd, False, completeIdentifier), - ("step", keepGoing stepCmd, False, completeIdentifier), - ("steplocal", keepGoing stepLocalCmd, False, completeIdentifier), - ("stepmodule",keepGoing stepModuleCmd, False, completeIdentifier), - ("type", keepGoing typeOfExpr, False, completeIdentifier), - ("trace", keepGoing traceCmd, False, completeIdentifier), - ("undef", keepGoing undefineMacro, False, completeMacro), - ("unset", keepGoing unsetOptions, True, completeSetOptions) + ("?", keepGoing help, Nothing, completeNone), + ("add", keepGoingPaths addModule, Just filenameWordBreakChars, completeFilename), + ("abandon", keepGoing abandonCmd, Nothing, completeNone), + ("break", keepGoing breakCmd, Nothing, completeIdentifier), + ("back", keepGoing backCmd, Nothing, completeNone), + ("browse", keepGoing (browseCmd False), Nothing, completeModule), + ("browse!", keepGoing (browseCmd True), Nothing, completeModule), + ("cd", keepGoing changeDirectory, Just filenameWordBreakChars, completeFilename), + ("check", keepGoing checkModule, Nothing, completeHomeModule), + ("continue", keepGoing continueCmd, Nothing, completeNone), + ("cmd", keepGoing cmdCmd, Nothing, completeIdentifier), + ("ctags", keepGoing createCTagsFileCmd, Just filenameWordBreakChars, completeFilename), + ("def", keepGoing (defineMacro False), Nothing, completeIdentifier), + ("def!", keepGoing (defineMacro True), Nothing, completeIdentifier), + ("delete", keepGoing deleteCmd, Nothing, completeNone), + ("e", keepGoing editFile, Just filenameWordBreakChars, completeFilename), + ("edit", keepGoing editFile, Just filenameWordBreakChars, completeFilename), + ("etags", keepGoing createETagsFileCmd, Just filenameWordBreakChars, completeFilename), + ("force", keepGoing forceCmd, Nothing, completeIdentifier), + ("forward", keepGoing forwardCmd, Nothing, completeNone), + ("help", keepGoing help, Nothing, completeNone), + ("history", keepGoing historyCmd, Nothing, completeNone), + ("info", keepGoing info, Nothing, completeIdentifier), + ("kind", keepGoing kindOfType, Nothing, completeIdentifier), + ("load", keepGoingPaths loadModule_, Just filenameWordBreakChars, completeHomeModuleOrFile), + ("list", keepGoing listCmd, Nothing, completeNone), + ("module", keepGoing setContext, Nothing, completeModule), + ("main", keepGoing runMain, Nothing, completeIdentifier), + ("print", keepGoing printCmd, Nothing, completeIdentifier), + ("quit", quit, Nothing, completeNone), + ("reload", keepGoing reloadModule, Nothing, completeNone), + ("set", keepGoing setCmd, Just flagWordBreakChars, completeSetOptions), + ("show", keepGoing showCmd, Nothing, completeNone), + ("sprint", keepGoing sprintCmd, Nothing, completeIdentifier), + ("step", keepGoing stepCmd, Nothing, completeIdentifier), + ("steplocal", keepGoing stepLocalCmd, Nothing, completeIdentifier), + ("stepmodule",keepGoing stepModuleCmd, Nothing, completeIdentifier), + ("type", keepGoing typeOfExpr, Nothing, completeIdentifier), + ("trace", keepGoing traceCmd, Nothing, completeIdentifier), + ("undef", keepGoing undefineMacro, Nothing, completeMacro), + ("unset", keepGoing unsetOptions, Just flagWordBreakChars, completeSetOptions) ] + +-- 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, flagWordBreakChars, filenameWordBreakChars :: String +word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~" + specials = "(),;[]`{}" + spaces = " \t\n" + in spaces ++ specials ++ symbols +flagWordBreakChars = " \t\n" +filenameWordBreakChars = " \t\n\\`@$><=;|&{(" -- bash defaults + + keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool) keepGoing a str = a str >> return False @@ -290,13 +308,9 @@ interactiveUI session srcs maybe_expr = do Readline.setAttemptedCompletionFunction (Just completeWord) --Readline.parseAndBind "set show-all-if-ambiguous 1" - let symbols = "!#$%&*+/<=>?@\\^|-~" - specials = "(),;[]`{}" - spaces = " \t\n" - word_break_chars = spaces ++ specials ++ symbols - Readline.setBasicWordBreakCharacters word_break_chars Readline.setCompleterWordBreakCharacters word_break_chars + Readline.setCompletionAppendCharacter Nothing #endif default_editor <- findEditor @@ -936,7 +950,7 @@ defineMacro overwrite s = do case maybe_hv of Nothing -> return () Just hv -> io (writeIORef macros_ref -- - (filtered ++ [(macro_name, runMacro hv, False, completeNone)])) + (filtered ++ [(macro_name, runMacro hv, Nothing, completeNone)])) runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool runMacro fun s = do @@ -1619,23 +1633,24 @@ completeWord w start end = do ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w _other | ((':':c) : _) <- line_words -> do - maybe_cmd <- lookupCommand' c - let (n,w') = selectWord (words' 0 line) - case maybe_cmd of - Nothing -> return Nothing - Just (_,_,False,complete) -> wrapCompleter complete w - Just (_,_,True,complete) -> let complete' w = do rets <- complete w - return (map (drop n) rets) - in wrapCompleter complete' w' + completionVars <- lookupCompletionVars c + case completionVars of + (Nothing,complete) -> wrapCompleter complete w + (Just breakChars,complete) + -> let (n,w') = selectWord + (words' (`elem` breakChars) 0 line) + complete' w = do rets <- complete w + return (map (drop n) rets) + in wrapCompleter complete' w' | ("import" : _) <- line_words -> wrapCompleter completeModule w | otherwise -> do --printf "complete %s, start = %d, end = %d\n" w start end wrapCompleter completeIdentifier w - where words' _ [] = [] - words' n str = let (w,r) = break isSpace str - (s,r') = span isSpace r - in (n,w):words' (n+length w+length s) r' + where words' _ _ [] = [] + words' isBreak n str = let (w,r) = break isBreak str + (s,r') = span isBreak r + in (n,w):words' isBreak (n+length w+length s) r' -- In a Haskell expression we want to parse 'a-b' as three words -- where a compiler flag (ie. -fno-monomorphism-restriction) should -- only be a single word. @@ -1643,6 +1658,16 @@ completeWord w start end = do selectWord ((offset,x):xs) | offset+length x >= start = (start-offset,take (end-offset) x) | otherwise = selectWord xs + + lookupCompletionVars ('!':_) = return (Just filenameWordBreakChars, + completeFilename) + lookupCompletionVars c = do + maybe_cmd <- lookupCommand' c + case maybe_cmd of + Just (_,_,ws,f) -> return (ws,f) + Nothing -> return (Just filenameWordBreakChars, + completeFilename) + completeCmd :: String -> IO [String] completeCmd w = do @@ -1675,7 +1700,18 @@ completeSetOptions w = do return (filter (w `isPrefixOf`) options) where options = "args":"prog":allFlags -completeFilename = Readline.filenameCompletionFunction +completeFilename w = do + ws <- Readline.filenameCompletionFunction w + case ws of + -- If we only found one result, and it's a directory, + -- add a trailing slash. + [file] -> do + isDir <- expandPathIO file >>= doesDirectoryExist + if isDir && last file /= '/' + then return [file ++ "/"] + else return [file] + _ -> return ws + completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename @@ -1689,8 +1725,10 @@ wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String] wrapCompleter fun w = do strs <- fun w case strs of - [] -> return Nothing - [x] -> return (Just (x,[])) + [] -> Readline.setAttemptedCompletionOver True >> return Nothing + [x] -> -- Add a trailing space, unless it already has an appended slash. + let appended = if last x == '/' then x else x ++ " " + in return (Just (appended,[])) xs -> case getCommonPrefix xs of "" -> return (Just ("",xs)) pref -> return (Just (pref,xs)) @@ -1771,10 +1809,13 @@ ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s) -- Utils expandPath :: String -> GHCi String -expandPath path = +expandPath path = io (expandPathIO path) + +expandPathIO :: String -> IO String +expandPathIO path = case dropWhile isSpace path of ('~':d) -> do - tilde <- io getHomeDirectory -- will fail if HOME not defined + tilde <- getHomeDirectory -- will fail if HOME not defined return (tilde ++ '/':d) other -> return other @@ -1912,15 +1953,19 @@ historyCmd arg (r:_) -> do let hist = GHC.resumeHistory r (took,rest) = splitAt num hist - spans <- mapM (io . GHC.getHistorySpan s) took - let nums = map (printf "-%-3d:") [(1::Int)..] - let names = map GHC.historyEnclosingDecl took - printForUser (vcat(zipWith3 - (\x y z -> x <+> y <+> z) - (map text nums) - (map (bold . ppr) names) - (map (parens . ppr) spans))) - io $ putStrLn $ if null rest then "" else "..." + case hist of + [] -> io $ putStrLn $ + "Empty history. Perhaps you forgot to use :trace?" + _ -> do + spans <- mapM (io . GHC.getHistorySpan s) took + let nums = map (printf "-%-3d:") [(1::Int)..] + names = map GHC.historyEnclosingDecl took + printForUser (vcat(zipWith3 + (\x y z -> x <+> y <+> z) + (map text nums) + (map (bold . ppr) names) + (map (parens . ppr) spans))) + io $ putStrLn $ if null rest then "" else "..." bold :: SDoc -> SDoc bold c | do_bold = text start_bold <> c <> text end_bold