1 -----------------------------------------------------------------------------
3 -- Trees of source spans used by the breakpoint machinery
5 -- (c) The University of Glasgow 2007
7 -----------------------------------------------------------------------------
10 ( TickTree, lookupTickTreeCoord, lookupTickTreeLine, tickTreeFromList )
15 import Data.List (partition, foldl')
19 newtype TickTree = Root [SpanTree]
23 { spanTreeTick :: TickNumber
24 , spanTreeLoc :: SrcSpan
25 , spanTreeChildren :: [SpanTree]
28 mkNode :: TickNumber -> SrcSpan -> [SpanTree] -> SpanTree
30 = Node { spanTreeTick = tick, spanTreeLoc = loc, spanTreeChildren = kids }
32 emptyTickTree :: TickTree
33 emptyTickTree = Root []
35 tickTreeFromList :: [(TickNumber, SrcSpan)] -> TickTree
37 = foldl' (\tree (tick,loc) -> insertTickTree tick loc tree) emptyTickTree
39 insertTickTree :: TickNumber -> SrcSpan -> TickTree -> TickTree
40 insertTickTree tick loc (Root children)
41 = Root $ insertSpanTree tick loc children
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
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
57 newBranch = mkNode tick loc []
58 kidLoc = spanTreeLoc kid
59 newKid = mkNode (spanTreeTick kid) (spanTreeLoc kid)
60 (insertSpanTree tick loc $ spanTreeChildren kid)
62 getContainedKids :: SrcSpan -> [SpanTree] -> ([SpanTree], [SpanTree])
63 getContainedKids loc = Data.List.partition (\tree -> loc `contains` (spanTreeLoc tree))
65 -- True if the left loc contains the right loc
66 contains :: SrcSpan -> SrcSpan -> Bool
68 = srcSpanStart span1 <= srcSpanStart span2 &&
69 srcSpanEnd span1 <= srcSpanEnd span2
71 type TickLoc = (TickNumber, SrcSpan)
73 type ColumnNumber = Int
74 type Coord = (LineNumber, ColumnNumber)
76 srcSpanStartLine = srcLocLine . srcSpanStart
78 lookupTickTreeLine :: LineNumber -> TickTree -> Maybe TickLoc
79 lookupTickTreeLine line (Root children) = lookupSpanTreeLine line children
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)
87 = lookupSpanTreeLine line nodes
89 case lookupSpanTreeLine line (spanTreeChildren node) of
90 Nothing -> lookupSpanTreeLine line nodes
93 startLine = srcSpanStartLine (spanTreeLoc node)
94 endLine = srcSpanEndLine (spanTreeLoc node)
96 lookupTickTreeCoord :: Coord -> TickTree -> Maybe TickLoc
97 lookupTickTreeCoord coord (Root children) = lookupSpanTreeCoord coord children Nothing
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))
106 = lookupSpanTreeCoord coord siblings acc
108 spans :: SrcSpan -> Coord -> Bool
109 spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
110 where loc = mkSrcLoc (srcSpanFile span) l c