X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=dddbb347038f7e5c62bbe84d7df644217e2d1b1a;hb=ad94d40948668032189ad22a0ad741ac1f645f50;hp=f0a8fb4a1483bd5c6b1e38d23d99e54e5656ea3f;hpb=fcd7ba21a64c12b6e0f1053892d2698ae7d29f81;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index f0a8fb4..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"++ @@ -464,7 +474,7 @@ mkPrompt = do then return (brackets (ppr (GHC.resumeSpan r)) <> space) else do let hist = GHC.resumeHistory r !! (ix-1) - span <- io $ GHC.getHistorySpan session hist + span <- io$ GHC.getHistorySpan session hist return (brackets (ppr (negate ix) <> char ':' <+> ppr span) <> space) let @@ -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,57 +1576,39 @@ 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 <- enclosingSubSpan mod loc - allTicksRightmost <- sortBy rightmost `fmap` - ticksIn mod parent - let lastTick = null allTicksRightmost || - snd(head allTicksRightmost) == loc - if not lastTick - then doContinue (`lexicalSubSpanOf` 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 - 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 - ] - -enclosingSubSpan :: Module -> SrcSpan -> GHCi SrcSpan -enclosingSubSpan mod src = do + 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 let line = srcSpanStartLine src - ASSERT (inRange (bounds arr) line) do - let enclosing_spans = [ t | t@(_,span) <- ticks ! line - , srcSpanEnd span >= srcSpanEnd src] - return . snd . head . sortBy leftmost_largest $ enclosing_spans - -lexicalSubSpanOf :: SrcSpan -> SrcSpan -> Bool -lexicalSubSpanOf src parent - | GHC.srcSpanFile parent /= GHC.srcSpanFile src = False - | otherwise = srcSpanStart parent <= srcSpanStart src && - srcSpanEnd parent >= srcSpanEnd src + ASSERT (inRange (bounds ticks) line) do + let enclosing_spans = [ span | (_,span) <- ticks ! line + , srcSpanEnd span >= srcSpanEnd src] + return . head . sortBy leftmost_largest $ enclosing_spans traceCmd :: String -> GHCi () traceCmd [] = doContinue (const True) GHC.RunAndLogSteps @@ -1653,10 +1663,18 @@ historyCmd arg let hist = GHC.resumeHistory r (took,rest) = splitAt num hist spans <- mapM (io . GHC.getHistorySpan s) took - let nums = map (printf "-%-3d:") [(1::Int)..] - printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans))) + 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 "..." +bold c | do_bold = text start_bold <> c <> text end_bold + | otherwise = c + backCmd :: String -> GHCi () backCmd = noArgs $ do s <- getSession @@ -1765,9 +1783,9 @@ findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan) findBreakByLine line arr | not (inRange (bounds arr) line) = Nothing | otherwise = - listToMaybe (sortBy leftmost_largest complete) `mplus` - listToMaybe (sortBy leftmost_smallest incomplete) `mplus` - listToMaybe (sortBy rightmost ticks) + listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus` + listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus` + listToMaybe (sortBy (rightmost `on` snd) ticks) where ticks = arr ! line @@ -1782,8 +1800,8 @@ findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray findBreakByCoord mb_file (line, col) arr | not (inRange (bounds arr) line) = Nothing | otherwise = - listToMaybe (sortBy rightmost contains) `mplus` - listToMaybe (sortBy leftmost_smallest after_here) + listToMaybe (sortBy (rightmost `on` snd) contains ++ + sortBy (leftmost_smallest `on` snd) after_here) where ticks = arr ! line @@ -1799,17 +1817,6 @@ findBreakByCoord mb_file (line, col) arr GHC.srcSpanStartLine span == line, GHC.srcSpanStartCol span >= col ] - -leftmost_smallest (_,a) (_,b) = a `compare` b -leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b) - `thenCmp` - (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a) -rightmost (_,a) (_,b) = b `compare` a - -spans :: SrcSpan -> (Int,Int) -> Bool -spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span - where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c - -- for now, use ANSI bold on Unixy systems. On Windows, we add a line -- of carets under the active expression instead. The Windows console -- doesn't support ANSI escape sequences, and most Unix terminals @@ -1821,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 @@ -1913,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