compiler/ghci/TickTree.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- Trees of source spans used by the breakpoint machinery
   4 --
   5 -- (c) The University of Glasgow 2007
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module TickTree
  10    ( TickTree, lookupTickTreeCoord, lookupTickTreeLine, tickTreeFromList )
  11    where
  12
  13 import SrcLoc
  14
  15 import Data.List (partition, foldl')
  16
  17 type TickNumber = Int
  18
  19 newtype TickTree = Root [SpanTree]
  20
  21 data SpanTree
  22    = Node
  23      { spanTreeTick     :: TickNumber
  24      , spanTreeLoc      :: SrcSpan
  25      , spanTreeChildren :: [SpanTree]
  26      }
  27
  28 mkNode :: TickNumber -> SrcSpan -> [SpanTree] -> SpanTree
  29 mkNode tick loc kids
  30    = Node { spanTreeTick = tick, spanTreeLoc = loc, spanTreeChildren = kids }
  31
  32 emptyTickTree :: TickTree
  33 emptyTickTree = Root []
  34
  35 tickTreeFromList :: [(TickNumber, SrcSpan)] -> TickTree
  36 tickTreeFromList
  37    = foldl' (\tree (tick,loc) -> insertTickTree tick loc tree) emptyTickTree
  38
  39 insertTickTree :: TickNumber -> SrcSpan -> TickTree -> TickTree
  40 insertTickTree tick loc (Root children)
  41    = Root $ insertSpanTree tick loc children
  42
  43 insertSpanTree :: TickNumber -> SrcSpan -> [SpanTree] -> [SpanTree]
  44 insertSpanTree tick loc [] = [mkNode tick loc []]
  45 insertSpanTree tick loc children@(kid:siblings)
  46    | null containedKids = insertDeeper tick loc children
  47    | otherwise = mkNode tick loc children : rest
  48    where
  49    (containedKids, rest) = getContainedKids loc children
  50    insertDeeper :: TickNumber -> SrcSpan -> [SpanTree] -> [SpanTree]
  51    insertDeeper tick loc [] = [mkNode tick loc []]
  52    insertDeeper tick loc nodes@(kid:siblings)
  53       | srcSpanStart loc < srcSpanStart kidLoc = newBranch : nodes
  54       | kidLoc `contains` loc = newKid : siblings
  55       | otherwise = kid : insertDeeper tick loc siblings
  56       where
  57       newBranch = mkNode tick loc []
  58       kidLoc = spanTreeLoc kid
  59       newKid = mkNode (spanTreeTick kid) (spanTreeLoc kid)
  60                       (insertSpanTree tick loc $ spanTreeChildren kid)
  61
  62 getContainedKids :: SrcSpan -> [SpanTree] -> ([SpanTree], [SpanTree])
  63 getContainedKids loc = Data.List.partition (\tree -> loc `contains` (spanTreeLoc tree))
  64
  65 -- True if the left loc contains the right loc
  66 contains :: SrcSpan -> SrcSpan -> Bool
  67 contains span1 span2
  68    = srcSpanStart span1 <= srcSpanStart span2 &&
  69      srcSpanEnd   span1 <= srcSpanEnd   span2
  70
  71 type TickLoc = (TickNumber, SrcSpan)
  72 type LineNumber = Int
  73 type ColumnNumber = Int
  74 type Coord = (LineNumber, ColumnNumber)
  75
  76 srcSpanStartLine = srcLocLine . srcSpanStart
  77
  78 lookupTickTreeLine :: LineNumber -> TickTree -> Maybe TickLoc
  79 lookupTickTreeLine line (Root children) = lookupSpanTreeLine line children
  80
  81 lookupSpanTreeLine :: LineNumber -> [SpanTree] -> Maybe TickLoc
  82 lookupSpanTreeLine line [] = Nothing
  83 lookupSpanTreeLine line (node:nodes)
  84    | startLine == line && endLine == line
  85         = Just (spanTreeTick node, spanTreeLoc node)
  86    | startLine > line
  87         = lookupSpanTreeLine line nodes
  88    | otherwise =
  89         case lookupSpanTreeLine line (spanTreeChildren node) of
  90                 Nothing    -> lookupSpanTreeLine line nodes
  91                 x@(Just _) -> x
  92    where
  93    startLine = srcSpanStartLine (spanTreeLoc node)
  94    endLine = srcSpanEndLine (spanTreeLoc node)
  95
  96 lookupTickTreeCoord :: Coord -> TickTree -> Maybe TickLoc
  97 lookupTickTreeCoord coord (Root children) = lookupSpanTreeCoord coord children Nothing
  98
  99 lookupSpanTreeCoord :: Coord -> [SpanTree] -> Maybe TickLoc -> Maybe TickLoc
 100 lookupSpanTreeCoord coord [] acc = acc
 101 lookupSpanTreeCoord coord (kid:siblings) acc
 102    | spanTreeLoc kid `spans` coord
 103         = lookupSpanTreeCoord coord (spanTreeChildren kid)
 104                               (Just (spanTreeTick kid, spanTreeLoc kid))
 105    | otherwise
 106         = lookupSpanTreeCoord coord siblings acc
 107    where
 108    spans :: SrcSpan -> Coord -> Bool
 109    spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
 110         where loc = mkSrcLoc (srcSpanFile span) l c