X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=dddbb347038f7e5c62bbe84d7df644217e2d1b1a;hb=ad94d40948668032189ad22a0ad741ac1f645f50;hp=aacf8b3e621f01e1dddd1fff556b1264af2a7dab;hpb=68a8c3bbab3a77a982fcac980e69f47b4ec13dfd;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index aacf8b3..dddbb34 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -6,6 +6,13 @@ -- (c) The GHC Team 2005-2006 -- ----------------------------------------------------------------------------- +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings +-- for details + module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where #include "HsVersions.h" @@ -130,7 +137,8 @@ builtin_commands = [ ("show", keepGoing showCmd, False, completeNone), ("sprint", keepGoing sprintCmd, False, completeIdentifier), ("step", keepGoing stepCmd, False, completeIdentifier), - ("stepover", keepGoing stepOverCmd, 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), @@ -186,6 +194,8 @@ helpText = " :sprint [ ...] simplifed version of :print\n" ++ " :step single-step after stopping at a breakpoint\n"++ " :step single-step into \n"++ + " :steplocal single-step restricted to the current top level decl.\n"++ + " :stepmodule single-step restricted to the current module\n"++ " :trace trace after stopping at a breakpoint\n"++ " :trace trace into (remembers breakpoints for :history)\n"++ @@ -565,7 +575,7 @@ runStmt stmt step --afterRunStmt :: GHC.RunResult -> GHCi Bool -- False <=> the statement failed to compile afterRunStmt _ (GHC.RunException e) = throw e -afterRunStmt pred run_result = do +afterRunStmt step_here run_result = do session <- getSession resumes <- io $ GHC.getResumeContext session case run_result of @@ -574,17 +584,18 @@ afterRunStmt pred run_result = do when show_types $ printTypeOfNames session names GHC.RunBreak _ names mb_info | isNothing mb_info || - pred (GHC.resumeSpan $ head resumes) -> do + step_here (GHC.resumeSpan $ head resumes) -> do printForUser $ ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan $ head resumes) - printTypeOfNames session names +-- printTypeOfNames session names + printTypeAndContentOfNames session names maybe (return ()) runBreakCmd mb_info -- run the command set with ":set stop " st <- getGHCiState enqueueCommands [stop st] return () | otherwise -> io(GHC.resume session GHC.SingleStep) >>= - afterRunStmt pred >> return () + afterRunStmt step_here >> return () _ -> return () flushInterpBuffers @@ -594,6 +605,18 @@ afterRunStmt pred run_result = do return (case run_result of GHC.RunOk _ -> True; _ -> False) + where printTypeAndContentOfNames session names = do + let namesSorted = sortBy compareNames names + tythings <- catMaybes `liftM` + io (mapM (GHC.lookupName session) namesSorted) + docs_ty <- mapM showTyThing tythings + terms <- mapM (io . GHC.obtainTermB session 10 False) + [ id | (AnId id, Just _) <- zip tythings docs_ty] + docs_terms <- mapM (io . showTerm session) terms + printForUser $ vcat $ zipWith (\ty cts -> ty <> text " = " <> cts) + (catMaybes docs_ty) + docs_terms + runBreakCmd :: GHC.BreakInfo -> GHCi () runBreakCmd info = do let mod = GHC.breakInfo_module info @@ -666,7 +689,7 @@ getCurrentBreakModule = do (r:rs) -> do let ix = GHC.resumeHistoryIx r if ix == 0 - then return (GHC.breakInfo_module `fmap` GHC.resumeBreakInfo r) + then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r) else do let hist = GHC.resumeHistory r !! (ix-1) return $ Just $ GHC.getHistoryModule hist @@ -892,8 +915,6 @@ checkModule m = do reloadModule :: String -> GHCi () reloadModule m = do - io (revertCAFs) -- always revert CAFs on reload. - discardActiveBreakPoints session <- getSession doLoad session $ if null m then LoadAllTargets else LoadUpTo (GHC.mkModuleName m) @@ -1277,11 +1298,18 @@ showBindings = do compareTyThings :: TyThing -> TyThing -> Ordering t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2 -printTyThing :: TyThing -> GHCi () -printTyThing (AnId id) = do +showTyThing :: TyThing -> GHCi (Maybe SDoc) +showTyThing (AnId id) = do ty' <- cleanType (GHC.idType id) - printForUser $ ppr id <> text " :: " <> ppr ty' -printTyThing _ = return () + return $ Just $ ppr id <> text " :: " <> ppr ty' +showTyThing _ = return Nothing + +printTyThing :: TyThing -> GHCi () +printTyThing tyth = do + mb_x <- showTyThing tyth + case mb_x of + Just x -> printForUser x + Nothing -> return () -- if -fglasgow-exts is on we show the foralls, otherwise we don't. cleanType :: Type -> GHCi Type @@ -1548,43 +1576,31 @@ stepCmd :: String -> GHCi () stepCmd [] = doContinue (const True) GHC.SingleStep stepCmd expression = do runStmt expression GHC.SingleStep; return () -stepOverCmd [] = do +stepLocalCmd :: String -> GHCi () +stepLocalCmd [] = do mb_span <- getCurrentBreakSpan case mb_span of Nothing -> stepCmd [] Just loc -> do Just mod <- getCurrentBreakModule - parent <- enclosingTickSpan mod loc - allTicksRightmost <- (sortBy rightmost . map snd) `fmap` - ticksIn mod parent - let lastTick = null allTicksRightmost || - head allTicksRightmost == loc - if not lastTick - then doContinue (`isSubspanOf` parent) GHC.SingleStep - else doContinue (const True) GHC.SingleStep - - where - -{- - So, the only tricky part in stepOver is detecting that we have - arrived to the last tick in an expression, in which case we must - step normally to the next tick. - What we do is: - 1. Retrieve the enclosing expression block (with a tick) - 2. Retrieve all the ticks there and sort them out by 'rightness' - 3. See if the current tick turned out the first one in the list --} - ---ticksIn :: Module -> SrcSpan -> GHCi [Tick] -ticksIn mod src = do - ticks <- getTickArray mod - let lines = [srcSpanStartLine src .. srcSpanEndLine src] - return [ t | line <- lines - , t@(_,span) <- ticks ! line - , srcSpanStart src <= srcSpanStart span - , srcSpanEnd src >= srcSpanEnd span - ] + current_toplevel_decl <- enclosingTickSpan mod loc + doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep +stepLocalCmd expression = stepCmd expression + +stepModuleCmd :: String -> GHCi () +stepModuleCmd [] = do + mb_span <- getCurrentBreakSpan + case mb_span of + Nothing -> stepCmd [] + Just loc -> do + Just span <- getCurrentBreakSpan + let f some_span = optSrcSpanFileName span == optSrcSpanFileName some_span + doContinue f GHC.SingleStep + +stepModuleCmd expression = stepCmd expression + +-- | Returns the span of the largest tick containing the srcspan given enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan enclosingTickSpan mod src = do ticks <- getTickArray mod @@ -1652,10 +1668,13 @@ historyCmd arg printForUser (vcat(zipWith3 (\x y z -> x <+> y <+> z) (map text nums) - (map (ftext . occNameFS . nameOccName) names) + (map (bold . ppr) names) (map (parens . ppr) spans))) io $ putStrLn $ if null rest then "" else "..." +bold c | do_bold = text start_bold <> c <> text end_bold + | otherwise = c + backCmd :: String -> GHCi () backCmd = noArgs $ do s <- getSession @@ -1809,8 +1828,8 @@ do_bold = True do_bold = False #endif -start_bold = BS.pack "\ESC[1m" -end_bold = BS.pack "\ESC[0m" +start_bold = "\ESC[1m" +end_bold = "\ESC[0m" listCmd :: String -> GHCi () listCmd "" = do @@ -1901,13 +1920,13 @@ listAround span do_highlight = do = let (a,r) = BS.splitAt col1 line (b,c) = BS.splitAt (col2-col1) r in - BS.concat [a,start_bold,b,end_bold,c] + BS.concat [a,BS.pack start_bold,b,BS.pack end_bold,c] | no == line1 = let (a,b) = BS.splitAt col1 line in - BS.concat [a, start_bold, b] + BS.concat [a, BS.pack start_bold, b] | no == line2 = let (a,b) = BS.splitAt col2 line in - BS.concat [a, end_bold, b] + BS.concat [a, BS.pack end_bold, b] | otherwise = line highlight_carets no line