From c5ff473955ffc2c1e4de76ae3d6eb2a37f785001 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Tue, 14 Aug 2007 16:19:53 +0000 Subject: [PATCH] Generalize some code dealing with SrcSpan sorting and the subspan relation, and move it to the SrcLoc module --- compiler/basicTypes/SrcLoc.lhs | 31 ++++++++++++++++++++++++- compiler/ghci/InteractiveUI.hs | 49 +++++++++++++--------------------------- compiler/utils/Util.lhs | 6 ++++- 3 files changed, 51 insertions(+), 35 deletions(-) diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs index ea32651..9e84c64 100644 --- a/compiler/basicTypes/SrcLoc.lhs +++ b/compiler/basicTypes/SrcLoc.lhs @@ -36,7 +36,8 @@ module SrcLoc ( srcSpanStartLine, srcSpanEndLine, srcSpanStartCol, srcSpanEndCol, - Located(..), getLoc, unLoc, noLoc, eqLocated, cmpLocated, combineLocs, addCLoc + Located(..), getLoc, unLoc, noLoc, eqLocated, cmpLocated, combineLocs, addCLoc, + leftmost_smallest, leftmost_largest, rightmost, spans, isSubspanOf ) where #include "HsVersions.h" @@ -400,3 +401,31 @@ instance Outputable e => Outputable (Located e) where ppr (L span e) = ppr e -- do we want to dump the span in debugSty mode? \end{code} + + +%************************************************************************ +%* * +\subsection{Manipulating SrcSpans} +%* * +%************************************************************************ + +\begin{code} +leftmost_smallest, leftmost_largest, rightmost :: SrcSpan -> SrcSpan -> Ordering +rightmost = flip compare +leftmost_smallest = compare +leftmost_largest a b = (srcSpanStart a `compare` srcSpanStart b) + `thenCmp` + (srcSpanEnd b `compare` srcSpanEnd a) + + +spans :: SrcSpan -> (Int,Int) -> Bool +spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span + where loc = mkSrcLoc (srcSpanFile span) l c + +isSubspanOf :: SrcSpan -> SrcSpan -> Bool +isSubspanOf src parent + | optSrcSpanFileName parent /= optSrcSpanFileName src = False + | otherwise = srcSpanStart parent <= srcSpanStart src && + srcSpanEnd parent >= srcSpanEnd src + +\end{code} \ No newline at end of file diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index f0a8fb4..22b8211 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -1554,13 +1554,13 @@ stepOverCmd [] = do Nothing -> stepCmd [] Just loc -> do Just mod <- getCurrentBreakModule - parent <- enclosingSubSpan mod loc - allTicksRightmost <- sortBy rightmost `fmap` + parent <- enclosingTickSpan mod loc + allTicksRightmost <- (sortBy rightmost . map snd) `fmap` ticksIn mod parent let lastTick = null allTicksRightmost || - snd(head allTicksRightmost) == loc + head allTicksRightmost == loc if not lastTick - then doContinue (`lexicalSubSpanOf` parent) GHC.SingleStep + then doContinue (`isSubspanOf` parent) GHC.SingleStep else doContinue (const True) GHC.SingleStep where @@ -1570,7 +1570,7 @@ stepOverCmd [] = do 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 + 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 -} @@ -1585,20 +1585,14 @@ ticksIn mod src = do , srcSpanEnd src >= srcSpanEnd span ] -enclosingSubSpan :: Module -> SrcSpan -> GHCi SrcSpan -enclosingSubSpan mod src = do +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 @@ -1765,9 +1759,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 +1776,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 +1793,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 diff --git a/compiler/utils/Util.lhs b/compiler/utils/Util.lhs index 495df82..e5f7023 100644 --- a/compiler/utils/Util.lhs +++ b/compiler/utils/Util.lhs @@ -26,7 +26,7 @@ module Util ( nTimes, -- sorting - sortLe, sortWith, + sortLe, sortWith, on, -- transitive closures transitiveClosure, @@ -457,6 +457,10 @@ sortWith :: Ord b => (a->b) -> [a] -> [a] sortWith get_key xs = sortLe le xs where x `le` y = get_key x < get_key y + +on :: (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering +on cmp sel = \x y -> sel x `cmp` sel y + \end{code} %************************************************************************ -- 1.7.10.4