X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=28854650b78e5d330f913f06c5819422fdc1cc43;hb=b1160a12ea2f0b202ee3a50274f43222935e19cb;hp=4a98b9e60a1210e700854f1ce9a1a3e0e5c0f75e;hpb=38e7ac3ffa32d75c1922e7247a910e06d9957116;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 4a98b9e..2885465 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -26,7 +26,7 @@ import Packages import PackageConfig import UniqFM import PprTyThing -import Outputable +import Outputable hiding (printForUser) import Module -- for ModuleEnv -- for createtags @@ -79,7 +79,7 @@ import Control.Monad as Monad import Foreign.StablePtr ( newStablePtr ) import GHC.Exts ( unsafeCoerce# ) -import GHC.IOBase ( IOErrorType(InvalidArgument), IO(IO) ) +import GHC.IOBase ( IOErrorType(InvalidArgument) ) import Data.IORef ( IORef, readIORef, writeIORef ) @@ -109,14 +109,14 @@ builtin_commands = [ -- Hugs users are accustomed to :e, so make sure it doesn't overlap ("?", keepGoing help, False, completeNone), ("add", keepGoingPaths addModule, False, completeFilename), - ("break", breakCmd, False, completeNone), + ("break", breakCmd, False, completeIdentifier), ("browse", keepGoing browseCmd, False, completeModule), ("cd", keepGoing changeDirectory, False, completeFilename), ("check", keepGoing checkModule, False, completeHomeModule), - ("continue", continueCmd, False, completeNone), + ("continue", continueCmd, False, completeNone), ("ctags", keepGoing createCTagsFileCmd, False, completeFilename), ("def", keepGoing defineMacro, False, completeIdentifier), - ("delete", deleteCmd, False, completeNone), + ("delete", deleteCmd, False, completeNone), ("e", keepGoing editFile, False, completeFilename), ("edit", keepGoing editFile, False, completeFilename), ("etags", keepGoing createETagsFileCmd, False, completeFilename), @@ -124,7 +124,7 @@ builtin_commands = [ ("help", keepGoing help, False, completeNone), ("info", keepGoing info, False, completeIdentifier), ("kind", keepGoing kindOfType, False, completeIdentifier), - ("load", keepGoingPaths loadModule_,False, completeHomeModuleOrFile), + ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile), ("module", keepGoing setContext, False, completeModule), ("main", keepGoing runMain, False, completeIdentifier), ("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier), @@ -133,7 +133,7 @@ builtin_commands = [ ("set", keepGoing setCmd, True, completeSetOptions), ("show", keepGoing showCmd, False, completeNone), ("sprint", keepGoing (pprintClosureCommand False False),False, completeIdentifier), - ("step", stepCmd, False, completeNone), + ("step", stepCmd, False, completeIdentifier), ("type", keepGoing typeOfExpr, False, completeIdentifier), ("undef", keepGoing undefineMacro, False, completeMacro), ("unset", keepGoing unsetOptions, True, completeSetOptions) @@ -517,9 +517,7 @@ switchOnRunResult (GHC.RunBreak threadId names info resume) = do -- display information about the breakpoint let location = ticks ! breakInfo_number info - unqual <- io $ GHC.getPrintUnqual session - io $ printForUser stdout unqual $ - ptext SLIT("Stopped at") <+> ppr location + printForUser $ ptext SLIT("Stopped at") <+> ppr location pushResume location threadId resume return (Just (True,names)) @@ -830,8 +828,7 @@ typeOfExpr str case maybe_ty of Nothing -> return () Just ty -> do ty' <- cleanType ty - tystr <- showForUser (ppr ty') - io (putStrLn (str ++ " :: " ++ tystr)) + printForUser $ text str <> text " :: " <> ppr ty' kindOfType :: String -> GHCi () kindOfType str @@ -839,8 +836,7 @@ kindOfType str maybe_ty <- io (GHC.typeKind cms str) case maybe_ty of Nothing -> return () - Just ty -> do tystr <- showForUser (ppr ty) - io (putStrLn (str ++ " :: " ++ tystr)) + Just ty -> printForUser $ text str <> text " :: " <> ppr ty quit :: String -> GHCi Bool quit _ = return True @@ -1204,7 +1200,8 @@ showCmd str = ["bindings"] -> showBindings ["linker"] -> io showLinkerState ["breaks"] -> showBkptTable - _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]") + ["context"] -> showContext + _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings|breaks]") showModules = do session <- getSession @@ -1222,8 +1219,7 @@ showBindings = do showTyThing (AnId id) = do ty' <- cleanType (GHC.idType id) - str <- showForUser (ppr id <> text " :: " <> ppr ty') - io (putStrLn str) + printForUser $ ppr id <> text " :: " <> ppr ty' showTyThing _ = return () -- if -fglasgow-exts is on we show the foralls, otherwise we don't. @@ -1237,8 +1233,14 @@ cleanType ty = do showBkptTable :: GHCi () showBkptTable = do activeBreaks <- getActiveBreakPoints - str <- showForUser $ ppr activeBreaks - io $ putStrLn str + printForUser $ ppr activeBreaks + +showContext :: GHCi () +showContext = do + st <- getGHCiState + printForUser $ vcat (map pp_resume (resume st)) + where + pp_resume (span, _, _) = ptext SLIT("Stopped at") <+> ppr span -- ----------------------------------------------------------------------------- -- Completion @@ -1493,29 +1495,43 @@ breakCmd :: String -> GHCi Bool breakCmd argLine = do session <- getSession breakSwitch session $ words argLine + return False -breakSwitch :: Session -> [String] -> GHCi Bool +breakSwitch :: Session -> [String] -> GHCi () breakSwitch _session [] = do io $ putStrLn "The break command requires at least one argument." - return False breakSwitch session args@(arg1:rest) - | looksLikeModule arg1 = do + | looksLikeModuleName arg1 = do mod <- wantInterpretedModule session arg1 - breakByModule mod rest - return False - | otherwise = do + breakByModule session mod rest + | all isDigit arg1 = do (toplevel, _) <- io $ GHC.getContext session case toplevel of - (mod : _) -> breakByModule mod args + (mod : _) -> breakByModuleLine mod (read arg1) rest [] -> do io $ putStrLn "Cannot find default module for breakpoint." io $ putStrLn "Perhaps no modules are loaded for debugging?" - return False - where - -- Todo there may be a nicer way to test this - looksLikeModule :: String -> Bool - looksLikeModule [] = False - looksLikeModule (x:_) = isUpper x + | otherwise = do -- assume it's a name + names <- io $ GHC.parseName session arg1 + case names of + [] -> return () + (n:_) -> do + let loc = nameSrcLoc n + modl = nameModule n + is_interpreted <- io (GHC.moduleIsInterpreted session modl) + if not is_interpreted + then noCanDo $ text "module " <> ppr modl <> + text " is not interpreted" + else do + if isGoodSrcLoc loc + then findBreakAndSet (nameModule n) $ + findBreakByCoord (srcLocLine loc, srcLocCol loc) + else noCanDo $ text "can't find its location: " <> + ppr loc + where + noCanDo why = printForUser $ + text "cannot set breakpoint on " <> ppr n <> text ": " <> why + wantInterpretedModule :: Session -> String -> GHCi Module wantInterpretedModule session str = do @@ -1525,26 +1541,18 @@ wantInterpretedModule session str = do throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted")) return modl -breakByModule :: Module -> [String] -> GHCi () -breakByModule mod args@(arg1:rest) +breakByModule :: Session -> Module -> [String] -> GHCi () +breakByModule session mod args@(arg1:rest) | all isDigit arg1 = do -- looks like a line number breakByModuleLine mod (read arg1) rest - | looksLikeVar arg1 = do - -- break by a function definition - io $ putStrLn "Break by function definition not implemented." - | otherwise = io $ putStrLn "Invalid arguments to break command." - where - -- Todo there may be a nicer way to test this - looksLikeVar :: String -> Bool - looksLikeVar [] = False - looksLikeVar (x:_) = isLower x || x `elem` "~!@#$%^&*-+" + | otherwise = io $ putStrLn "Invalid arguments to :break" breakByModuleLine :: Module -> Int -> [String] -> GHCi () breakByModuleLine mod line args | [] <- args = findBreakAndSet mod $ findBreakByLine line | [col] <- args, all isDigit col = findBreakAndSet mod $ findBreakByCoord (line, read col) - | otherwise = io $ putStrLn "Invalid arguments to break command." + | otherwise = io $ putStrLn "Invalid arguments to :break" findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi () findBreakAndSet mod lookupTickTree = do @@ -1555,7 +1563,6 @@ findBreakAndSet mod lookupTickTree = do Just (tick, span) -> do success <- io $ setBreakFlag True breakArray tick session <- getSession - unqual <- io $ GHC.getPrintUnqual session if success then do (alreadySet, nm) <- @@ -1564,15 +1571,14 @@ findBreakAndSet mod lookupTickTree = do , breakLoc = span , breakTick = tick } - io $ printForUser stdout unqual $ + printForUser $ text "Breakpoint " <> ppr nm <> if alreadySet then text " was already set at " <> ppr span else text " activated at " <> ppr span else do - str <- showForUser $ text "Breakpoint could not be activated at" + printForUser $ text "Breakpoint could not be activated at" <+> ppr span - io $ putStrLn str -- When a line number is specified, the current policy for choosing -- the best breakpoint is this: @@ -1581,10 +1587,12 @@ findBreakAndSet mod lookupTickTree = do -- - the rightmost subexpression enclosing the specified line -- findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan) -findBreakByLine line arr = - listToMaybe (sortBy leftmost complete) `mplus` - listToMaybe (sortBy leftmost incomplete) `mplus` - listToMaybe (sortBy rightmost ticks) +findBreakByLine line arr + | not (inRange (bounds arr) line) = Nothing + | otherwise = + listToMaybe (sortBy leftmost complete) `mplus` + listToMaybe (sortBy leftmost incomplete) `mplus` + listToMaybe (sortBy rightmost ticks) where ticks = arr ! line @@ -1595,8 +1603,10 @@ findBreakByLine line arr = where ends_here (nm,span) = srcSpanEndLine span == line findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan) -findBreakByCoord (line, col) arr = - listToMaybe (sortBy rightmost contains) +findBreakByCoord (line, col) arr + | not (inRange (bounds arr) line) = Nothing + | otherwise = + listToMaybe (sortBy rightmost contains) where ticks = arr ! line