never executed always true always false
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE DeriveTraversable #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE TypeFamilies #-}
7
8 -- (c) The University of Glasgow, 1992-2006
9
10 -- | This module contains types that relate to the positions of things
11 -- in source files, and allow tagging of those things with locations
12 module GHC.Types.SrcLoc (
13 -- * SrcLoc
14 RealSrcLoc, -- Abstract
15 SrcLoc(..),
16
17 -- ** Constructing SrcLoc
18 mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc,
19
20 noSrcLoc, -- "I'm sorry, I haven't a clue"
21 generatedSrcLoc, -- Code generated within the compiler
22 interactiveSrcLoc, -- Code from an interactive session
23
24 advanceSrcLoc,
25 advanceBufPos,
26
27 -- ** Unsafely deconstructing SrcLoc
28 -- These are dubious exports, because they crash on some inputs
29 srcLocFile, -- return the file name part
30 srcLocLine, -- return the line part
31 srcLocCol, -- return the column part
32
33 -- * SrcSpan
34 RealSrcSpan, -- Abstract
35 SrcSpan(..),
36 UnhelpfulSpanReason(..),
37
38 -- ** Constructing SrcSpan
39 mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,
40 noSrcSpan, generatedSrcSpan, isGeneratedSrcSpan,
41 wiredInSrcSpan, -- Something wired into the compiler
42 interactiveSrcSpan,
43 srcLocSpan, realSrcLocSpan,
44 combineSrcSpans,
45 srcSpanFirstCharacter,
46
47 -- ** Deconstructing SrcSpan
48 srcSpanStart, srcSpanEnd,
49 realSrcSpanStart, realSrcSpanEnd,
50 srcSpanFileName_maybe,
51 pprUserRealSpan, pprUnhelpfulSpanReason,
52 pprUserSpan,
53 unhelpfulSpanFS,
54 srcSpanToRealSrcSpan,
55
56 -- ** Unsafely deconstructing SrcSpan
57 -- These are dubious exports, because they crash on some inputs
58 srcSpanFile,
59 srcSpanStartLine, srcSpanEndLine,
60 srcSpanStartCol, srcSpanEndCol,
61
62 -- ** Predicates on SrcSpan
63 isGoodSrcSpan, isOneLineSpan, isZeroWidthSpan,
64 containsSpan,
65
66 -- * StringBuffer locations
67 BufPos(..),
68 getBufPos,
69 BufSpan(..),
70 getBufSpan,
71
72 -- * Located
73 Located,
74 RealLocated,
75 GenLocated(..),
76
77 -- ** Constructing Located
78 noLoc,
79 mkGeneralLocated,
80
81 -- ** Deconstructing Located
82 getLoc, unLoc,
83 unRealSrcSpan, getRealSrcSpan,
84 pprLocated,
85
86 -- ** Modifying Located
87 mapLoc,
88
89 -- ** Combining and comparing Located values
90 eqLocated, cmpLocated, cmpBufSpan,
91 combineLocs, addCLoc,
92 leftmost_smallest, leftmost_largest, rightmost_smallest,
93 spans, isSubspanOf, isRealSubspanOf,
94 sortLocated, sortRealLocated,
95 lookupSrcLoc, lookupSrcSpan,
96
97 liftL,
98
99 -- * Parser locations
100 PsLoc(..),
101 PsSpan(..),
102 PsLocated,
103 advancePsLoc,
104 mkPsSpan,
105 psSpanStart,
106 psSpanEnd,
107 mkSrcSpanPs,
108 combineRealSrcSpans,
109
110 -- * Layout information
111 LayoutInfo(..),
112 leftmostColumn
113
114 ) where
115
116 import GHC.Prelude
117
118 import GHC.Utils.Misc
119 import GHC.Utils.Json
120 import GHC.Utils.Outputable
121 import GHC.Utils.Panic
122 import GHC.Data.FastString
123 import qualified GHC.Data.Strict as Strict
124
125 import Control.DeepSeq
126 import Control.Applicative (liftA2)
127 import Data.Data
128 import Data.List (sortBy, intercalate)
129 import Data.Function (on)
130 import qualified Data.Map as Map
131 import qualified Data.Semigroup
132
133 {-
134 ************************************************************************
135 * *
136 \subsection[SrcLoc-SrcLocations]{Source-location information}
137 * *
138 ************************************************************************
139
140 We keep information about the {\em definition} point for each entity;
141 this is the obvious stuff:
142 -}
143
144 -- | Real Source Location
145 --
146 -- Represents a single point within a file
147 data RealSrcLoc
148 = SrcLoc LexicalFastString -- A precise location (file name)
149 {-# UNPACK #-} !Int -- line number, begins at 1
150 {-# UNPACK #-} !Int -- column number, begins at 1
151 deriving (Eq, Ord)
152
153 -- | 0-based offset identifying the raw location in the 'StringBuffer'.
154 --
155 -- The lexer increments the 'BufPos' every time a character (UTF-8 code point)
156 -- is read from the input buffer. As UTF-8 is a variable-length encoding and
157 -- 'StringBuffer' needs a byte offset for indexing, a 'BufPos' cannot be used
158 -- for indexing.
159 --
160 -- The parser guarantees that 'BufPos' are monotonic. See #17632. This means
161 -- that syntactic constructs that appear later in the 'StringBuffer' are guaranteed to
162 -- have a higher 'BufPos'. Constrast that with 'RealSrcLoc', which does *not* make the
163 -- analogous guarantee about higher line/column numbers.
164 --
165 -- This is due to #line and {-# LINE ... #-} pragmas that can arbitrarily
166 -- modify 'RealSrcLoc'. Notice how 'setSrcLoc' and 'resetAlrLastLoc' in
167 -- "GHC.Parser.Lexer" update 'PsLoc', modifying 'RealSrcLoc' but preserving
168 -- 'BufPos'.
169 --
170 -- Monotonicity makes 'BufPos' useful to determine the order in which syntactic
171 -- elements appear in the source. Consider this example (haddockA041 in the test suite):
172 --
173 -- haddockA041.hs
174 -- {-# LANGUAGE CPP #-}
175 -- -- | Module header documentation
176 -- module Comments_and_CPP_include where
177 -- #include "IncludeMe.hs"
178 --
179 -- IncludeMe.hs:
180 -- -- | Comment on T
181 -- data T = MkT -- ^ Comment on MkT
182 --
183 -- After the C preprocessor runs, the 'StringBuffer' will contain a program that
184 -- looks like this (unimportant lines at the beginning removed):
185 --
186 -- # 1 "haddockA041.hs"
187 -- {-# LANGUAGE CPP #-}
188 -- -- | Module header documentation
189 -- module Comments_and_CPP_include where
190 -- # 1 "IncludeMe.hs" 1
191 -- -- | Comment on T
192 -- data T = MkT -- ^ Comment on MkT
193 -- # 7 "haddockA041.hs" 2
194 --
195 -- The line pragmas inserted by CPP make the error messages more informative.
196 -- The downside is that we can't use RealSrcLoc to determine the ordering of
197 -- syntactic elements.
198 --
199 -- With RealSrcLoc, we have the following location information recorded in the AST:
200 -- * The module name is located at haddockA041.hs:3:8-31
201 -- * The Haddock comment "Comment on T" is located at IncludeMe:1:1-17
202 -- * The data declaration is located at IncludeMe.hs:2:1-32
203 --
204 -- Is the Haddock comment located between the module name and the data
205 -- declaration? This is impossible to tell because the locations are not
206 -- comparable; they even refer to different files.
207 --
208 -- On the other hand, with 'BufPos', we have the following location information:
209 -- * The module name is located at 846-870
210 -- * The Haddock comment "Comment on T" is located at 898-915
211 -- * The data declaration is located at 916-928
212 --
213 -- Aside: if you're wondering why the numbers are so high, try running
214 -- @ghc -E haddockA041.hs@
215 -- and see the extra fluff that CPP inserts at the start of the file.
216 --
217 -- For error messages, 'BufPos' is not useful at all. On the other hand, this is
218 -- exactly what we need to determine the order of syntactic elements:
219 -- 870 < 898, therefore the Haddock comment appears *after* the module name.
220 -- 915 < 916, therefore the Haddock comment appears *before* the data declaration.
221 --
222 -- We use 'BufPos' in in GHC.Parser.PostProcess.Haddock to associate Haddock
223 -- comments with parts of the AST using location information (#17544).
224 newtype BufPos = BufPos { bufPos :: Int }
225 deriving (Eq, Ord, Show)
226
227 -- | Source Location
228 data SrcLoc
229 = RealSrcLoc !RealSrcLoc !(Strict.Maybe BufPos) -- See Note [Why Maybe BufPos]
230 | UnhelpfulLoc !FastString -- Just a general indication
231 deriving (Eq, Show)
232
233 {-
234 ************************************************************************
235 * *
236 \subsection[SrcLoc-access-fns]{Access functions}
237 * *
238 ************************************************************************
239 -}
240
241 mkSrcLoc :: FastString -> Int -> Int -> SrcLoc
242 mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Strict.Nothing
243
244 mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc
245 mkRealSrcLoc x line col = SrcLoc (LexicalFastString x) line col
246
247 getBufPos :: SrcLoc -> Strict.Maybe BufPos
248 getBufPos (RealSrcLoc _ mbpos) = mbpos
249 getBufPos (UnhelpfulLoc _) = Strict.Nothing
250
251 -- | Built-in "bad" 'SrcLoc' values for particular locations
252 noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc
253 noSrcLoc = UnhelpfulLoc (fsLit "<no location info>")
254 generatedSrcLoc = UnhelpfulLoc (fsLit "<compiler-generated code>")
255 interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive>")
256
257 -- | Creates a "bad" 'SrcLoc' that has no detailed information about its location
258 mkGeneralSrcLoc :: FastString -> SrcLoc
259 mkGeneralSrcLoc = UnhelpfulLoc
260
261 -- | Gives the filename of the 'RealSrcLoc'
262 srcLocFile :: RealSrcLoc -> FastString
263 srcLocFile (SrcLoc (LexicalFastString fname) _ _) = fname
264
265 -- | Raises an error when used on a "bad" 'SrcLoc'
266 srcLocLine :: RealSrcLoc -> Int
267 srcLocLine (SrcLoc _ l _) = l
268
269 -- | Raises an error when used on a "bad" 'SrcLoc'
270 srcLocCol :: RealSrcLoc -> Int
271 srcLocCol (SrcLoc _ _ c) = c
272
273 -- | Move the 'SrcLoc' down by one line if the character is a newline,
274 -- to the next 8-char tabstop if it is a tab, and across by one
275 -- character in any other case
276 advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc
277 advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1
278 advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (advance_tabstop c)
279 advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1)
280
281 advance_tabstop :: Int -> Int
282 advance_tabstop c = ((((c - 1) `shiftR` 3) + 1) `shiftL` 3) + 1
283
284 advanceBufPos :: BufPos -> BufPos
285 advanceBufPos (BufPos i) = BufPos (i+1)
286
287 {-
288 ************************************************************************
289 * *
290 \subsection[SrcLoc-instances]{Instance declarations for various names}
291 * *
292 ************************************************************************
293 -}
294
295 sortLocated :: [Located a] -> [Located a]
296 sortLocated = sortBy (leftmost_smallest `on` getLoc)
297
298 sortRealLocated :: [RealLocated a] -> [RealLocated a]
299 sortRealLocated = sortBy (compare `on` getLoc)
300
301 lookupSrcLoc :: SrcLoc -> Map.Map RealSrcLoc a -> Maybe a
302 lookupSrcLoc (RealSrcLoc l _) = Map.lookup l
303 lookupSrcLoc (UnhelpfulLoc _) = const Nothing
304
305 lookupSrcSpan :: SrcSpan -> Map.Map RealSrcSpan a -> Maybe a
306 lookupSrcSpan (RealSrcSpan l _) = Map.lookup l
307 lookupSrcSpan (UnhelpfulSpan _) = const Nothing
308
309 instance Outputable RealSrcLoc where
310 ppr (SrcLoc (LexicalFastString src_path) src_line src_col)
311 = hcat [ pprFastFilePath src_path <> colon
312 , int src_line <> colon
313 , int src_col ]
314
315 -- I don't know why there is this style-based difference
316 -- if userStyle sty || debugStyle sty then
317 -- hcat [ pprFastFilePath src_path, char ':',
318 -- int src_line,
319 -- char ':', int src_col
320 -- ]
321 -- else
322 -- hcat [text "{-# LINE ", int src_line, space,
323 -- char '\"', pprFastFilePath src_path, text " #-}"]
324
325 instance Outputable SrcLoc where
326 ppr (RealSrcLoc l _) = ppr l
327 ppr (UnhelpfulLoc s) = ftext s
328
329 instance Data RealSrcSpan where
330 -- don't traverse?
331 toConstr _ = abstractConstr "RealSrcSpan"
332 gunfold _ _ = error "gunfold"
333 dataTypeOf _ = mkNoRepType "RealSrcSpan"
334
335 instance Data SrcSpan where
336 -- don't traverse?
337 toConstr _ = abstractConstr "SrcSpan"
338 gunfold _ _ = error "gunfold"
339 dataTypeOf _ = mkNoRepType "SrcSpan"
340
341 {-
342 ************************************************************************
343 * *
344 \subsection[SrcSpan]{Source Spans}
345 * *
346 ************************************************************************
347 -}
348
349 {- |
350 A 'RealSrcSpan' delimits a portion of a text file. It could be represented
351 by a pair of (line,column) coordinates, but in fact we optimise
352 slightly by using more compact representations for single-line and
353 zero-length spans, both of which are quite common.
354
355 The end position is defined to be the column /after/ the end of the
356 span. That is, a span of (1,1)-(1,2) is one character long, and a
357 span of (1,1)-(1,1) is zero characters long.
358 -}
359
360 -- | Real Source Span
361 data RealSrcSpan
362 = RealSrcSpan'
363 { srcSpanFile :: !FastString,
364 srcSpanSLine :: {-# UNPACK #-} !Int,
365 srcSpanSCol :: {-# UNPACK #-} !Int,
366 srcSpanELine :: {-# UNPACK #-} !Int,
367 srcSpanECol :: {-# UNPACK #-} !Int
368 }
369 deriving Eq
370
371 -- | StringBuffer Source Span
372 data BufSpan =
373 BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos }
374 deriving (Eq, Ord, Show)
375
376 instance Semigroup BufSpan where
377 BufSpan start1 end1 <> BufSpan start2 end2 =
378 BufSpan (min start1 start2) (max end1 end2)
379
380 -- | Source Span
381 --
382 -- A 'SrcSpan' identifies either a specific portion of a text file
383 -- or a human-readable description of a location.
384 data SrcSpan =
385 RealSrcSpan !RealSrcSpan !(Strict.Maybe BufSpan) -- See Note [Why Maybe BufPos]
386 | UnhelpfulSpan !UnhelpfulSpanReason
387
388 deriving (Eq, Show) -- Show is used by GHC.Parser.Lexer, because we
389 -- derive Show for Token
390
391 data UnhelpfulSpanReason
392 = UnhelpfulNoLocationInfo
393 | UnhelpfulWiredIn
394 | UnhelpfulInteractive
395 | UnhelpfulGenerated
396 | UnhelpfulOther !FastString
397 deriving (Eq, Show)
398
399 {- Note [Why Maybe BufPos]
400 ~~~~~~~~~~~~~~~~~~~~~~~~~~
401 In SrcLoc we store (Maybe BufPos); in SrcSpan we store (Maybe BufSpan).
402 Why the Maybe?
403
404 Surely, the lexer can always fill in the buffer position, and it guarantees to do so.
405 However, sometimes the SrcLoc/SrcSpan is constructed in a different context
406 where the buffer location is not available, and then we use Nothing instead of
407 a fake value like BufPos (-1).
408
409 Perhaps the compiler could be re-engineered to pass around BufPos more
410 carefully and never discard it, and this 'Maybe' could be removed. If you're
411 interested in doing so, you may find this ripgrep query useful:
412
413 rg "RealSrc(Loc|Span).*?Nothing"
414
415 For example, it is not uncommon to whip up source locations for e.g. error
416 messages, constructing a SrcSpan without a BufSpan.
417 -}
418
419 instance ToJson SrcSpan where
420 json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")]
421 json (RealSrcSpan rss _) = json rss
422
423 instance ToJson RealSrcSpan where
424 json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile))
425 , ("startLine", JSInt srcSpanSLine)
426 , ("startCol", JSInt srcSpanSCol)
427 , ("endLine", JSInt srcSpanELine)
428 , ("endCol", JSInt srcSpanECol)
429 ]
430
431 instance NFData SrcSpan where
432 rnf x = x `seq` ()
433
434 getBufSpan :: SrcSpan -> Strict.Maybe BufSpan
435 getBufSpan (RealSrcSpan _ mbspan) = mbspan
436 getBufSpan (UnhelpfulSpan _) = Strict.Nothing
437
438 -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty
439 noSrcSpan, generatedSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan
440 noSrcSpan = UnhelpfulSpan UnhelpfulNoLocationInfo
441 wiredInSrcSpan = UnhelpfulSpan UnhelpfulWiredIn
442 interactiveSrcSpan = UnhelpfulSpan UnhelpfulInteractive
443 generatedSrcSpan = UnhelpfulSpan UnhelpfulGenerated
444
445 isGeneratedSrcSpan :: SrcSpan -> Bool
446 isGeneratedSrcSpan (UnhelpfulSpan UnhelpfulGenerated) = True
447 isGeneratedSrcSpan _ = False
448
449 -- | Create a "bad" 'SrcSpan' that has not location information
450 mkGeneralSrcSpan :: FastString -> SrcSpan
451 mkGeneralSrcSpan = UnhelpfulSpan . UnhelpfulOther
452
453 -- | Create a 'SrcSpan' corresponding to a single point
454 srcLocSpan :: SrcLoc -> SrcSpan
455 srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan (UnhelpfulOther str)
456 srcLocSpan (RealSrcLoc l mb) = RealSrcSpan (realSrcLocSpan l) (fmap (\b -> BufSpan b b) mb)
457
458 realSrcLocSpan :: RealSrcLoc -> RealSrcSpan
459 realSrcLocSpan (SrcLoc (LexicalFastString file) line col) = RealSrcSpan' file line col line col
460
461 -- | Create a 'SrcSpan' between two points in a file
462 mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan
463 mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2
464 where
465 line1 = srcLocLine loc1
466 line2 = srcLocLine loc2
467 col1 = srcLocCol loc1
468 col2 = srcLocCol loc2
469 file = srcLocFile loc1
470
471 -- | 'True' if the span is known to straddle only one line.
472 isOneLineRealSpan :: RealSrcSpan -> Bool
473 isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _)
474 = line1 == line2
475
476 -- | 'True' if the span is a single point
477 isPointRealSpan :: RealSrcSpan -> Bool
478 isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2)
479 = line1 == line2 && col1 == col2
480
481 -- | Create a 'SrcSpan' between two points in a file
482 mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
483 mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan (UnhelpfulOther str)
484 mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan (UnhelpfulOther str)
485 mkSrcSpan (RealSrcLoc loc1 mbpos1) (RealSrcLoc loc2 mbpos2)
486 = RealSrcSpan (mkRealSrcSpan loc1 loc2) (liftA2 BufSpan mbpos1 mbpos2)
487
488 -- | Combines two 'SrcSpan' into one that spans at least all the characters
489 -- within both spans. Returns UnhelpfulSpan if the files differ.
490 combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan
491 combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful
492 combineSrcSpans l (UnhelpfulSpan _) = l
493 combineSrcSpans (RealSrcSpan span1 mbspan1) (RealSrcSpan span2 mbspan2)
494 | srcSpanFile span1 == srcSpanFile span2
495 = RealSrcSpan (combineRealSrcSpans span1 span2) (liftA2 combineBufSpans mbspan1 mbspan2)
496 | otherwise = UnhelpfulSpan $
497 UnhelpfulOther (fsLit "<combineSrcSpans: files differ>")
498
499 -- | Combines two 'SrcSpan' into one that spans at least all the characters
500 -- within both spans. Assumes the "file" part is the same in both inputs
501 combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan
502 combineRealSrcSpans span1 span2
503 = RealSrcSpan' file line_start col_start line_end col_end
504 where
505 (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1)
506 (srcSpanStartLine span2, srcSpanStartCol span2)
507 (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1)
508 (srcSpanEndLine span2, srcSpanEndCol span2)
509 file = srcSpanFile span1
510
511 combineBufSpans :: BufSpan -> BufSpan -> BufSpan
512 combineBufSpans span1 span2 = BufSpan start end
513 where
514 start = min (bufSpanStart span1) (bufSpanStart span2)
515 end = max (bufSpanEnd span1) (bufSpanEnd span2)
516
517
518 -- | Convert a SrcSpan into one that represents only its first character
519 srcSpanFirstCharacter :: SrcSpan -> SrcSpan
520 srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l
521 srcSpanFirstCharacter (RealSrcSpan span mbspan) =
522 RealSrcSpan (mkRealSrcSpan loc1 loc2) (fmap mkBufSpan mbspan)
523 where
524 loc1@(SrcLoc f l c) = realSrcSpanStart span
525 loc2 = SrcLoc f l (c+1)
526 mkBufSpan bspan =
527 let bpos1@(BufPos i) = bufSpanStart bspan
528 bpos2 = BufPos (i+1)
529 in BufSpan bpos1 bpos2
530
531 {-
532 ************************************************************************
533 * *
534 \subsection[SrcSpan-predicates]{Predicates}
535 * *
536 ************************************************************************
537 -}
538
539 -- | Test if a 'SrcSpan' is "good", i.e. has precise location information
540 isGoodSrcSpan :: SrcSpan -> Bool
541 isGoodSrcSpan (RealSrcSpan _ _) = True
542 isGoodSrcSpan (UnhelpfulSpan _) = False
543
544 isOneLineSpan :: SrcSpan -> Bool
545 -- ^ True if the span is known to straddle only one line.
546 -- For "bad" 'SrcSpan', it returns False
547 isOneLineSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s
548 isOneLineSpan (UnhelpfulSpan _) = False
549
550 isZeroWidthSpan :: SrcSpan -> Bool
551 -- ^ True if the span has a width of zero, as returned for "virtual"
552 -- semicolons in the lexer.
553 -- For "bad" 'SrcSpan', it returns False
554 isZeroWidthSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s
555 && srcSpanStartCol s == srcSpanEndCol s
556 isZeroWidthSpan (UnhelpfulSpan _) = False
557
558 -- | Tests whether the first span "contains" the other span, meaning
559 -- that it covers at least as much source code. True where spans are equal.
560 containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool
561 containsSpan s1 s2
562 = (srcSpanStartLine s1, srcSpanStartCol s1)
563 <= (srcSpanStartLine s2, srcSpanStartCol s2)
564 && (srcSpanEndLine s1, srcSpanEndCol s1)
565 >= (srcSpanEndLine s2, srcSpanEndCol s2)
566 && (srcSpanFile s1 == srcSpanFile s2)
567 -- We check file equality last because it is (presumably?) least
568 -- likely to fail.
569 {-
570 %************************************************************************
571 %* *
572 \subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions}
573 * *
574 ************************************************************************
575 -}
576
577 srcSpanStartLine :: RealSrcSpan -> Int
578 srcSpanEndLine :: RealSrcSpan -> Int
579 srcSpanStartCol :: RealSrcSpan -> Int
580 srcSpanEndCol :: RealSrcSpan -> Int
581
582 srcSpanStartLine RealSrcSpan'{ srcSpanSLine=l } = l
583 srcSpanEndLine RealSrcSpan'{ srcSpanELine=l } = l
584 srcSpanStartCol RealSrcSpan'{ srcSpanSCol=l } = l
585 srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c
586
587 {-
588 ************************************************************************
589 * *
590 \subsection[SrcSpan-access-fns]{Access functions}
591 * *
592 ************************************************************************
593 -}
594
595 -- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
596 srcSpanStart :: SrcSpan -> SrcLoc
597 srcSpanStart (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r)
598 srcSpanStart (RealSrcSpan s b) = RealSrcLoc (realSrcSpanStart s) (fmap bufSpanStart b)
599
600 -- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
601 srcSpanEnd :: SrcSpan -> SrcLoc
602 srcSpanEnd (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r)
603 srcSpanEnd (RealSrcSpan s b) = RealSrcLoc (realSrcSpanEnd s) (fmap bufSpanEnd b)
604
605 realSrcSpanStart :: RealSrcSpan -> RealSrcLoc
606 realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s)
607 (srcSpanStartLine s)
608 (srcSpanStartCol s)
609
610 realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc
611 realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s)
612 (srcSpanEndLine s)
613 (srcSpanEndCol s)
614
615 -- | Obtains the filename for a 'SrcSpan' if it is "good"
616 srcSpanFileName_maybe :: SrcSpan -> Maybe FastString
617 srcSpanFileName_maybe (RealSrcSpan s _) = Just (srcSpanFile s)
618 srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing
619
620 srcSpanToRealSrcSpan :: SrcSpan -> Maybe RealSrcSpan
621 srcSpanToRealSrcSpan (RealSrcSpan ss _) = Just ss
622 srcSpanToRealSrcSpan _ = Nothing
623
624 {-
625 ************************************************************************
626 * *
627 \subsection[SrcSpan-instances]{Instances}
628 * *
629 ************************************************************************
630 -}
631
632 -- We want to order RealSrcSpans first by the start point, then by the
633 -- end point.
634 instance Ord RealSrcSpan where
635 a `compare` b =
636 (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp`
637 (realSrcSpanEnd a `compare` realSrcSpanEnd b)
638
639 instance Show RealSrcLoc where
640 show (SrcLoc filename row col)
641 = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col
642
643 -- Show is used by GHC.Parser.Lexer, because we derive Show for Token
644 instance Show RealSrcSpan where
645 show span@(RealSrcSpan' file sl sc el ec)
646 | isPointRealSpan span
647 = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc])
648
649 | isOneLineRealSpan span
650 = "SrcSpanOneLine " ++ show file ++ " "
651 ++ intercalate " " (map show [sl,sc,ec])
652
653 | otherwise
654 = "SrcSpanMultiLine " ++ show file ++ " "
655 ++ intercalate " " (map show [sl,sc,el,ec])
656
657
658 instance Outputable RealSrcSpan where
659 ppr span = pprUserRealSpan True span
660
661 -- I don't know why there is this style-based difference
662 -- = getPprStyle $ \ sty ->
663 -- if userStyle sty || debugStyle sty then
664 -- text (showUserRealSpan True span)
665 -- else
666 -- hcat [text "{-# LINE ", int (srcSpanStartLine span), space,
667 -- char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"]
668
669 instance Outputable SrcSpan where
670 ppr span = pprUserSpan True span
671
672 instance Outputable UnhelpfulSpanReason where
673 ppr = pprUnhelpfulSpanReason
674
675 -- I don't know why there is this style-based difference
676 -- = getPprStyle $ \ sty ->
677 -- if userStyle sty || debugStyle sty then
678 -- pprUserSpan True span
679 -- else
680 -- case span of
681 -- UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan"
682 -- RealSrcSpan s -> ppr s
683
684 unhelpfulSpanFS :: UnhelpfulSpanReason -> FastString
685 unhelpfulSpanFS r = case r of
686 UnhelpfulOther s -> s
687 UnhelpfulNoLocationInfo -> fsLit "<no location info>"
688 UnhelpfulWiredIn -> fsLit "<wired into compiler>"
689 UnhelpfulInteractive -> fsLit "<interactive>"
690 UnhelpfulGenerated -> fsLit "<generated>"
691
692 pprUnhelpfulSpanReason :: UnhelpfulSpanReason -> SDoc
693 pprUnhelpfulSpanReason r = ftext (unhelpfulSpanFS r)
694
695 pprUserSpan :: Bool -> SrcSpan -> SDoc
696 pprUserSpan _ (UnhelpfulSpan r) = pprUnhelpfulSpanReason r
697 pprUserSpan show_path (RealSrcSpan s _) = pprUserRealSpan show_path s
698
699 pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc
700 pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _)
701 | isPointRealSpan span
702 = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
703 , int line <> colon
704 , int col ]
705
706 pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol)
707 | isOneLineRealSpan span
708 = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
709 , int line <> colon
710 , int scol
711 , ppUnless (ecol - scol <= 1) (char '-' <> int (ecol - 1)) ]
712 -- For single-character or point spans, we just
713 -- output the starting column number
714
715 pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol)
716 = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
717 , parens (int sline <> comma <> int scol)
718 , char '-'
719 , parens (int eline <> comma <> int ecol') ]
720 where
721 ecol' = if ecol == 0 then ecol else ecol - 1
722
723 {-
724 ************************************************************************
725 * *
726 \subsection[Located]{Attaching SrcSpans to things}
727 * *
728 ************************************************************************
729 -}
730
731 -- | We attach SrcSpans to lots of things, so let's have a datatype for it.
732 data GenLocated l e = L l e
733 deriving (Eq, Ord, Data, Functor, Foldable, Traversable)
734
735 type Located = GenLocated SrcSpan
736 type RealLocated = GenLocated RealSrcSpan
737
738 mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b
739 mapLoc = fmap
740
741 unLoc :: GenLocated l e -> e
742 unLoc (L _ e) = e
743
744 getLoc :: GenLocated l e -> l
745 getLoc (L l _) = l
746
747 noLoc :: e -> Located e
748 noLoc e = L noSrcSpan e
749
750 mkGeneralLocated :: String -> e -> Located e
751 mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e
752
753 combineLocs :: Located a -> Located b -> SrcSpan
754 combineLocs a b = combineSrcSpans (getLoc a) (getLoc b)
755
756 -- | Combine locations from two 'Located' things and add them to a third thing
757 addCLoc :: Located a -> Located b -> c -> Located c
758 addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c
759
760 -- not clear whether to add a general Eq instance, but this is useful sometimes:
761
762 -- | Tests whether the two located things are equal
763 eqLocated :: Eq a => GenLocated l a -> GenLocated l a -> Bool
764 eqLocated a b = unLoc a == unLoc b
765
766 -- not clear whether to add a general Ord instance, but this is useful sometimes:
767
768 -- | Tests the ordering of the two located things
769 cmpLocated :: Ord a => GenLocated l a -> GenLocated l a -> Ordering
770 cmpLocated a b = unLoc a `compare` unLoc b
771
772 -- | Compare the 'BufSpan' of two located things.
773 --
774 -- Precondition: both operands have an associated 'BufSpan'.
775 cmpBufSpan :: HasDebugCallStack => Located a -> Located a -> Ordering
776 cmpBufSpan (L l1 _) (L l2 _)
777 | Strict.Just a <- getBufSpan l1
778 , Strict.Just b <- getBufSpan l2
779 = compare a b
780
781 | otherwise = panic "cmpBufSpan: no BufSpan"
782
783 instance (Outputable e) => Outputable (Located e) where
784 ppr (L l e) = -- GenLocated:
785 -- Print spans without the file name etc
786 whenPprDebug (braces (pprUserSpan False l))
787 $$ ppr e
788 instance (Outputable e) => Outputable (GenLocated RealSrcSpan e) where
789 ppr (L l e) = -- GenLocated:
790 -- Print spans without the file name etc
791 whenPprDebug (braces (pprUserSpan False (RealSrcSpan l Strict.Nothing)))
792 $$ ppr e
793
794
795 pprLocated :: (Outputable l, Outputable e) => GenLocated l e -> SDoc
796 pprLocated (L l e) =
797 -- Print spans without the file name etc
798 whenPprDebug (braces (ppr l))
799 $$ ppr e
800
801 {-
802 ************************************************************************
803 * *
804 \subsection{Ordering SrcSpans for InteractiveUI}
805 * *
806 ************************************************************************
807 -}
808
809 -- | Strategies for ordering 'SrcSpan's
810 leftmost_smallest, leftmost_largest, rightmost_smallest :: SrcSpan -> SrcSpan -> Ordering
811 rightmost_smallest = compareSrcSpanBy (flip compare)
812 leftmost_smallest = compareSrcSpanBy compare
813 leftmost_largest = compareSrcSpanBy $ \a b ->
814 (realSrcSpanStart a `compare` realSrcSpanStart b)
815 `thenCmp`
816 (realSrcSpanEnd b `compare` realSrcSpanEnd a)
817
818 compareSrcSpanBy :: (RealSrcSpan -> RealSrcSpan -> Ordering) -> SrcSpan -> SrcSpan -> Ordering
819 compareSrcSpanBy cmp (RealSrcSpan a _) (RealSrcSpan b _) = cmp a b
820 compareSrcSpanBy _ (RealSrcSpan _ _) (UnhelpfulSpan _) = LT
821 compareSrcSpanBy _ (UnhelpfulSpan _) (RealSrcSpan _ _) = GT
822 compareSrcSpanBy _ (UnhelpfulSpan _) (UnhelpfulSpan _) = EQ
823
824 -- | Determines whether a span encloses a given line and column index
825 spans :: SrcSpan -> (Int, Int) -> Bool
826 spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan"
827 spans (RealSrcSpan span _) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span
828 where loc = mkRealSrcLoc (srcSpanFile span) l c
829
830 -- | Determines whether a span is enclosed by another one
831 isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other
832 -> SrcSpan -- ^ The span it may be enclosed by
833 -> Bool
834 isSubspanOf (RealSrcSpan src _) (RealSrcSpan parent _) = isRealSubspanOf src parent
835 isSubspanOf _ _ = False
836
837 -- | Determines whether a span is enclosed by another one
838 isRealSubspanOf :: RealSrcSpan -- ^ The span that may be enclosed by the other
839 -> RealSrcSpan -- ^ The span it may be enclosed by
840 -> Bool
841 isRealSubspanOf src parent
842 | srcSpanFile parent /= srcSpanFile src = False
843 | otherwise = realSrcSpanStart parent <= realSrcSpanStart src &&
844 realSrcSpanEnd parent >= realSrcSpanEnd src
845
846 liftL :: Monad m => (a -> m b) -> GenLocated l a -> m (GenLocated l b)
847 liftL f (L loc a) = do
848 a' <- f a
849 return $ L loc a'
850
851 getRealSrcSpan :: RealLocated a -> RealSrcSpan
852 getRealSrcSpan (L l _) = l
853
854 unRealSrcSpan :: RealLocated a -> a
855 unRealSrcSpan (L _ e) = e
856
857
858 -- | A location as produced by the parser. Consists of two components:
859 --
860 -- * The location in the file, adjusted for #line and {-# LINE ... #-} pragmas (RealSrcLoc)
861 -- * The location in the string buffer (BufPos) with monotonicity guarantees (see #17632)
862 data PsLoc
863 = PsLoc { psRealLoc :: !RealSrcLoc, psBufPos :: !BufPos }
864 deriving (Eq, Ord, Show)
865
866 data PsSpan
867 = PsSpan { psRealSpan :: !RealSrcSpan, psBufSpan :: !BufSpan }
868 deriving (Eq, Ord, Show)
869
870 type PsLocated = GenLocated PsSpan
871
872 advancePsLoc :: PsLoc -> Char -> PsLoc
873 advancePsLoc (PsLoc real_loc buf_loc) c =
874 PsLoc (advanceSrcLoc real_loc c) (advanceBufPos buf_loc)
875
876 mkPsSpan :: PsLoc -> PsLoc -> PsSpan
877 mkPsSpan (PsLoc r1 b1) (PsLoc r2 b2) = PsSpan (mkRealSrcSpan r1 r2) (BufSpan b1 b2)
878
879 psSpanStart :: PsSpan -> PsLoc
880 psSpanStart (PsSpan r b) = PsLoc (realSrcSpanStart r) (bufSpanStart b)
881
882 psSpanEnd :: PsSpan -> PsLoc
883 psSpanEnd (PsSpan r b) = PsLoc (realSrcSpanEnd r) (bufSpanEnd b)
884
885 mkSrcSpanPs :: PsSpan -> SrcSpan
886 mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Strict.Just b)
887
888 -- | Layout information for declarations.
889 data LayoutInfo =
890
891 -- | Explicit braces written by the user.
892 --
893 -- @
894 -- class C a where { foo :: a; bar :: a }
895 -- @
896 ExplicitBraces
897 |
898 -- | Virtual braces inserted by the layout algorithm.
899 --
900 -- @
901 -- class C a where
902 -- foo :: a
903 -- bar :: a
904 -- @
905 VirtualBraces
906 !Int -- ^ Layout column (indentation level, begins at 1)
907 |
908 -- | Empty or compiler-generated blocks do not have layout information
909 -- associated with them.
910 NoLayoutInfo
911
912 deriving (Eq, Ord, Show, Data)
913
914 -- | Indentation level is 1-indexed, so the leftmost column is 1.
915 leftmostColumn :: Int
916 leftmostColumn = 1