Refactor splice_exp in Parser.y
[ghc.git] / compiler / basicTypes / SrcLoc.hs
1 -- (c) The University of Glasgow, 1992-2006
2
3 {-# LANGUAGE DeriveDataTypeable #-}
4 {-# LANGUAGE StandaloneDeriving #-}
5 {-# LANGUAGE DeriveFunctor #-}
6 {-# LANGUAGE DeriveFoldable #-}
7 {-# LANGUAGE DeriveTraversable #-}
8 {-# LANGUAGE FlexibleInstances #-}
9 {-# LANGUAGE RecordWildCards #-}
10 {-# LANGUAGE TypeFamilies #-}
11 {-# LANGUAGE ViewPatterns #-}
12 {-# LANGUAGE FlexibleContexts #-}
13 {-# LANGUAGE PatternSynonyms #-}
14
15
16 -- | This module contains types that relate to the positions of things
17 -- in source files, and allow tagging of those things with locations
18 module SrcLoc (
19 -- * SrcLoc
20 RealSrcLoc, -- Abstract
21 SrcLoc(..),
22
23 -- ** Constructing SrcLoc
24 mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc,
25
26 noSrcLoc, -- "I'm sorry, I haven't a clue"
27 generatedSrcLoc, -- Code generated within the compiler
28 interactiveSrcLoc, -- Code from an interactive session
29
30 advanceSrcLoc,
31
32 -- ** Unsafely deconstructing SrcLoc
33 -- These are dubious exports, because they crash on some inputs
34 srcLocFile, -- return the file name part
35 srcLocLine, -- return the line part
36 srcLocCol, -- return the column part
37
38 -- * SrcSpan
39 RealSrcSpan, -- Abstract
40 SrcSpan(..),
41
42 -- ** Constructing SrcSpan
43 mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,
44 noSrcSpan,
45 wiredInSrcSpan, -- Something wired into the compiler
46 interactiveSrcSpan,
47 srcLocSpan, realSrcLocSpan,
48 combineSrcSpans,
49 srcSpanFirstCharacter,
50
51 -- ** Deconstructing SrcSpan
52 srcSpanStart, srcSpanEnd,
53 realSrcSpanStart, realSrcSpanEnd,
54 srcSpanFileName_maybe,
55 pprUserRealSpan,
56
57 -- ** Unsafely deconstructing SrcSpan
58 -- These are dubious exports, because they crash on some inputs
59 srcSpanFile,
60 srcSpanStartLine, srcSpanEndLine,
61 srcSpanStartCol, srcSpanEndCol,
62
63 -- ** Predicates on SrcSpan
64 isGoodSrcSpan, isOneLineSpan,
65 containsSpan,
66
67 -- * Located
68 Located,
69 RealLocated,
70 GenLocated(..),
71
72 -- ** Constructing Located
73 noLoc,
74 mkGeneralLocated,
75
76 -- ** Deconstructing Located
77 getLoc, unLoc,
78 unRealSrcSpan, getRealSrcSpan,
79
80 -- ** Modifying Located
81 mapLoc,
82
83 -- ** Combining and comparing Located values
84 eqLocated, cmpLocated, combineLocs, addCLoc,
85 leftmost_smallest, leftmost_largest, rightmost,
86 spans, isSubspanOf, sortLocated,
87
88 -- ** HasSrcSpan
89 HasSrcSpan(..), SrcSpanLess, dL, cL,
90 pattern LL, onHasSrcSpan, liftL
91 ) where
92
93 import GhcPrelude
94
95 import Util
96 import Json
97 import Outputable
98 import FastString
99
100 import Control.DeepSeq
101 import Data.Bits
102 import Data.Data
103 import Data.List
104 import Data.Ord
105
106 {-
107 ************************************************************************
108 * *
109 \subsection[SrcLoc-SrcLocations]{Source-location information}
110 * *
111 ************************************************************************
112
113 We keep information about the {\em definition} point for each entity;
114 this is the obvious stuff:
115 -}
116
117 -- | Real Source Location
118 --
119 -- Represents a single point within a file
120 data RealSrcLoc
121 = SrcLoc FastString -- A precise location (file name)
122 {-# UNPACK #-} !Int -- line number, begins at 1
123 {-# UNPACK #-} !Int -- column number, begins at 1
124 deriving (Eq, Ord)
125
126 -- | Source Location
127 data SrcLoc
128 = RealSrcLoc {-# UNPACK #-}!RealSrcLoc
129 | UnhelpfulLoc FastString -- Just a general indication
130 deriving (Eq, Ord, Show)
131
132 {-
133 ************************************************************************
134 * *
135 \subsection[SrcLoc-access-fns]{Access functions}
136 * *
137 ************************************************************************
138 -}
139
140 mkSrcLoc :: FastString -> Int -> Int -> SrcLoc
141 mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col)
142
143 mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc
144 mkRealSrcLoc x line col = SrcLoc x line col
145
146 -- | Built-in "bad" 'SrcLoc' values for particular locations
147 noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc
148 noSrcLoc = UnhelpfulLoc (fsLit "<no location info>")
149 generatedSrcLoc = UnhelpfulLoc (fsLit "<compiler-generated code>")
150 interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive>")
151
152 -- | Creates a "bad" 'SrcLoc' that has no detailed information about its location
153 mkGeneralSrcLoc :: FastString -> SrcLoc
154 mkGeneralSrcLoc = UnhelpfulLoc
155
156 -- | Gives the filename of the 'RealSrcLoc'
157 srcLocFile :: RealSrcLoc -> FastString
158 srcLocFile (SrcLoc fname _ _) = fname
159
160 -- | Raises an error when used on a "bad" 'SrcLoc'
161 srcLocLine :: RealSrcLoc -> Int
162 srcLocLine (SrcLoc _ l _) = l
163
164 -- | Raises an error when used on a "bad" 'SrcLoc'
165 srcLocCol :: RealSrcLoc -> Int
166 srcLocCol (SrcLoc _ _ c) = c
167
168 -- | Move the 'SrcLoc' down by one line if the character is a newline,
169 -- to the next 8-char tabstop if it is a tab, and across by one
170 -- character in any other case
171 advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc
172 advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1
173 advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (((((c - 1) `shiftR` 3) + 1)
174 `shiftL` 3) + 1)
175 advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1)
176
177 {-
178 ************************************************************************
179 * *
180 \subsection[SrcLoc-instances]{Instance declarations for various names}
181 * *
182 ************************************************************************
183 -}
184
185 sortLocated :: HasSrcSpan a => [a] -> [a]
186 sortLocated things = sortBy (comparing getLoc) things
187
188 instance Outputable RealSrcLoc where
189 ppr (SrcLoc src_path src_line src_col)
190 = hcat [ pprFastFilePath src_path <> colon
191 , int src_line <> colon
192 , int src_col ]
193
194 -- I don't know why there is this style-based difference
195 -- if userStyle sty || debugStyle sty then
196 -- hcat [ pprFastFilePath src_path, char ':',
197 -- int src_line,
198 -- char ':', int src_col
199 -- ]
200 -- else
201 -- hcat [text "{-# LINE ", int src_line, space,
202 -- char '\"', pprFastFilePath src_path, text " #-}"]
203
204 instance Outputable SrcLoc where
205 ppr (RealSrcLoc l) = ppr l
206 ppr (UnhelpfulLoc s) = ftext s
207
208 instance Data RealSrcSpan where
209 -- don't traverse?
210 toConstr _ = abstractConstr "RealSrcSpan"
211 gunfold _ _ = error "gunfold"
212 dataTypeOf _ = mkNoRepType "RealSrcSpan"
213
214 instance Data SrcSpan where
215 -- don't traverse?
216 toConstr _ = abstractConstr "SrcSpan"
217 gunfold _ _ = error "gunfold"
218 dataTypeOf _ = mkNoRepType "SrcSpan"
219
220 {-
221 ************************************************************************
222 * *
223 \subsection[SrcSpan]{Source Spans}
224 * *
225 ************************************************************************
226 -}
227
228 {- |
229 A 'RealSrcSpan' delimits a portion of a text file. It could be represented
230 by a pair of (line,column) coordinates, but in fact we optimise
231 slightly by using more compact representations for single-line and
232 zero-length spans, both of which are quite common.
233
234 The end position is defined to be the column /after/ the end of the
235 span. That is, a span of (1,1)-(1,2) is one character long, and a
236 span of (1,1)-(1,1) is zero characters long.
237 -}
238
239 -- | Real Source Span
240 data RealSrcSpan
241 = RealSrcSpan'
242 { srcSpanFile :: !FastString,
243 srcSpanSLine :: {-# UNPACK #-} !Int,
244 srcSpanSCol :: {-# UNPACK #-} !Int,
245 srcSpanELine :: {-# UNPACK #-} !Int,
246 srcSpanECol :: {-# UNPACK #-} !Int
247 }
248 deriving Eq
249
250 -- | Source Span
251 --
252 -- A 'SrcSpan' identifies either a specific portion of a text file
253 -- or a human-readable description of a location.
254 data SrcSpan =
255 RealSrcSpan !RealSrcSpan
256 | UnhelpfulSpan !FastString -- Just a general indication
257 -- also used to indicate an empty span
258
259 deriving (Eq, Ord, Show) -- Show is used by Lexer.x, because we
260 -- derive Show for Token
261
262 instance ToJson SrcSpan where
263 json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")]
264 json (RealSrcSpan rss) = json rss
265
266 instance ToJson RealSrcSpan where
267 json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile))
268 , ("startLine", JSInt srcSpanSLine)
269 , ("startCol", JSInt srcSpanSCol)
270 , ("endLine", JSInt srcSpanELine)
271 , ("endCol", JSInt srcSpanECol)
272 ]
273
274 instance NFData SrcSpan where
275 rnf x = x `seq` ()
276
277 -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty
278 noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan
279 noSrcSpan = UnhelpfulSpan (fsLit "<no location info>")
280 wiredInSrcSpan = UnhelpfulSpan (fsLit "<wired into compiler>")
281 interactiveSrcSpan = UnhelpfulSpan (fsLit "<interactive>")
282
283 -- | Create a "bad" 'SrcSpan' that has not location information
284 mkGeneralSrcSpan :: FastString -> SrcSpan
285 mkGeneralSrcSpan = UnhelpfulSpan
286
287 -- | Create a 'SrcSpan' corresponding to a single point
288 srcLocSpan :: SrcLoc -> SrcSpan
289 srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str
290 srcLocSpan (RealSrcLoc l) = RealSrcSpan (realSrcLocSpan l)
291
292 realSrcLocSpan :: RealSrcLoc -> RealSrcSpan
293 realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col
294
295 -- | Create a 'SrcSpan' between two points in a file
296 mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan
297 mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2
298 where
299 line1 = srcLocLine loc1
300 line2 = srcLocLine loc2
301 col1 = srcLocCol loc1
302 col2 = srcLocCol loc2
303 file = srcLocFile loc1
304
305 -- | 'True' if the span is known to straddle only one line.
306 isOneLineRealSpan :: RealSrcSpan -> Bool
307 isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _)
308 = line1 == line2
309
310 -- | 'True' if the span is a single point
311 isPointRealSpan :: RealSrcSpan -> Bool
312 isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2)
313 = line1 == line2 && col1 == col2
314
315 -- | Create a 'SrcSpan' between two points in a file
316 mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
317 mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str
318 mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str
319 mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2)
320 = RealSrcSpan (mkRealSrcSpan loc1 loc2)
321
322 -- | Combines two 'SrcSpan' into one that spans at least all the characters
323 -- within both spans. Returns UnhelpfulSpan if the files differ.
324 combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan
325 combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful
326 combineSrcSpans l (UnhelpfulSpan _) = l
327 combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2)
328 | srcSpanFile span1 == srcSpanFile span2
329 = RealSrcSpan (combineRealSrcSpans span1 span2)
330 | otherwise = UnhelpfulSpan (fsLit "<combineSrcSpans: files differ>")
331
332 -- | Combines two 'SrcSpan' into one that spans at least all the characters
333 -- within both spans. Assumes the "file" part is the same in both inputs
334 combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan
335 combineRealSrcSpans span1 span2
336 = RealSrcSpan' file line_start col_start line_end col_end
337 where
338 (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1)
339 (srcSpanStartLine span2, srcSpanStartCol span2)
340 (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1)
341 (srcSpanEndLine span2, srcSpanEndCol span2)
342 file = srcSpanFile span1
343
344 -- | Convert a SrcSpan into one that represents only its first character
345 srcSpanFirstCharacter :: SrcSpan -> SrcSpan
346 srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l
347 srcSpanFirstCharacter (RealSrcSpan span) = RealSrcSpan $ mkRealSrcSpan loc1 loc2
348 where
349 loc1@(SrcLoc f l c) = realSrcSpanStart span
350 loc2 = SrcLoc f l (c+1)
351
352 {-
353 ************************************************************************
354 * *
355 \subsection[SrcSpan-predicates]{Predicates}
356 * *
357 ************************************************************************
358 -}
359
360 -- | Test if a 'SrcSpan' is "good", i.e. has precise location information
361 isGoodSrcSpan :: SrcSpan -> Bool
362 isGoodSrcSpan (RealSrcSpan _) = True
363 isGoodSrcSpan (UnhelpfulSpan _) = False
364
365 isOneLineSpan :: SrcSpan -> Bool
366 -- ^ True if the span is known to straddle only one line.
367 -- For "bad" 'SrcSpan', it returns False
368 isOneLineSpan (RealSrcSpan s) = srcSpanStartLine s == srcSpanEndLine s
369 isOneLineSpan (UnhelpfulSpan _) = False
370
371 -- | Tests whether the first span "contains" the other span, meaning
372 -- that it covers at least as much source code. True where spans are equal.
373 containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool
374 containsSpan s1 s2
375 = (srcSpanStartLine s1, srcSpanStartCol s1)
376 <= (srcSpanStartLine s2, srcSpanStartCol s2)
377 && (srcSpanEndLine s1, srcSpanEndCol s1)
378 >= (srcSpanEndLine s2, srcSpanEndCol s2)
379 && (srcSpanFile s1 == srcSpanFile s2)
380 -- We check file equality last because it is (presumably?) least
381 -- likely to fail.
382 {-
383 %************************************************************************
384 %* *
385 \subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions}
386 * *
387 ************************************************************************
388 -}
389
390 srcSpanStartLine :: RealSrcSpan -> Int
391 srcSpanEndLine :: RealSrcSpan -> Int
392 srcSpanStartCol :: RealSrcSpan -> Int
393 srcSpanEndCol :: RealSrcSpan -> Int
394
395 srcSpanStartLine RealSrcSpan'{ srcSpanSLine=l } = l
396 srcSpanEndLine RealSrcSpan'{ srcSpanELine=l } = l
397 srcSpanStartCol RealSrcSpan'{ srcSpanSCol=l } = l
398 srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c
399
400 {-
401 ************************************************************************
402 * *
403 \subsection[SrcSpan-access-fns]{Access functions}
404 * *
405 ************************************************************************
406 -}
407
408 -- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
409 srcSpanStart :: SrcSpan -> SrcLoc
410 srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str
411 srcSpanStart (RealSrcSpan s) = RealSrcLoc (realSrcSpanStart s)
412
413 -- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
414 srcSpanEnd :: SrcSpan -> SrcLoc
415 srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str
416 srcSpanEnd (RealSrcSpan s) = RealSrcLoc (realSrcSpanEnd s)
417
418 realSrcSpanStart :: RealSrcSpan -> RealSrcLoc
419 realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s)
420 (srcSpanStartLine s)
421 (srcSpanStartCol s)
422
423 realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc
424 realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s)
425 (srcSpanEndLine s)
426 (srcSpanEndCol s)
427
428 -- | Obtains the filename for a 'SrcSpan' if it is "good"
429 srcSpanFileName_maybe :: SrcSpan -> Maybe FastString
430 srcSpanFileName_maybe (RealSrcSpan s) = Just (srcSpanFile s)
431 srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing
432
433 {-
434 ************************************************************************
435 * *
436 \subsection[SrcSpan-instances]{Instances}
437 * *
438 ************************************************************************
439 -}
440
441 -- We want to order RealSrcSpans first by the start point, then by the
442 -- end point.
443 instance Ord RealSrcSpan where
444 a `compare` b =
445 (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp`
446 (realSrcSpanEnd a `compare` realSrcSpanEnd b)
447
448 instance Show RealSrcLoc where
449 show (SrcLoc filename row col)
450 = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col
451
452 -- Show is used by Lexer.x, because we derive Show for Token
453 instance Show RealSrcSpan where
454 show span@(RealSrcSpan' file sl sc el ec)
455 | isPointRealSpan span
456 = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc])
457
458 | isOneLineRealSpan span
459 = "SrcSpanOneLine " ++ show file ++ " "
460 ++ intercalate " " (map show [sl,sc,ec])
461
462 | otherwise
463 = "SrcSpanMultiLine " ++ show file ++ " "
464 ++ intercalate " " (map show [sl,sc,el,ec])
465
466
467 instance Outputable RealSrcSpan where
468 ppr span = pprUserRealSpan True span
469
470 -- I don't know why there is this style-based difference
471 -- = getPprStyle $ \ sty ->
472 -- if userStyle sty || debugStyle sty then
473 -- text (showUserRealSpan True span)
474 -- else
475 -- hcat [text "{-# LINE ", int (srcSpanStartLine span), space,
476 -- char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"]
477
478 instance Outputable SrcSpan where
479 ppr span = pprUserSpan True span
480
481 -- I don't know why there is this style-based difference
482 -- = getPprStyle $ \ sty ->
483 -- if userStyle sty || debugStyle sty then
484 -- pprUserSpan True span
485 -- else
486 -- case span of
487 -- UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan"
488 -- RealSrcSpan s -> ppr s
489
490 pprUserSpan :: Bool -> SrcSpan -> SDoc
491 pprUserSpan _ (UnhelpfulSpan s) = ftext s
492 pprUserSpan show_path (RealSrcSpan s) = pprUserRealSpan show_path s
493
494 pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc
495 pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _)
496 | isPointRealSpan span
497 = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
498 , int line <> colon
499 , int col ]
500
501 pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol)
502 | isOneLineRealSpan span
503 = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
504 , int line <> colon
505 , int scol
506 , ppUnless (ecol - scol <= 1) (char '-' <> int (ecol - 1)) ]
507 -- For single-character or point spans, we just
508 -- output the starting column number
509
510 pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol)
511 = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
512 , parens (int sline <> comma <> int scol)
513 , char '-'
514 , parens (int eline <> comma <> int ecol') ]
515 where
516 ecol' = if ecol == 0 then ecol else ecol - 1
517
518 {-
519 ************************************************************************
520 * *
521 \subsection[Located]{Attaching SrcSpans to things}
522 * *
523 ************************************************************************
524 -}
525
526 -- | We attach SrcSpans to lots of things, so let's have a datatype for it.
527 data GenLocated l e = L l e
528 deriving (Eq, Ord, Data, Functor, Foldable, Traversable)
529
530 type Located = GenLocated SrcSpan
531 type RealLocated = GenLocated RealSrcSpan
532
533 mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b
534 mapLoc = fmap
535
536 unLoc :: HasSrcSpan a => a -> SrcSpanLess a
537 unLoc (dL->L _ e) = e
538
539 getLoc :: HasSrcSpan a => a -> SrcSpan
540 getLoc (dL->L l _) = l
541
542 noLoc :: HasSrcSpan a => SrcSpanLess a -> a
543 noLoc e = cL noSrcSpan e
544
545 mkGeneralLocated :: HasSrcSpan e => String -> SrcSpanLess e -> e
546 mkGeneralLocated s e = cL (mkGeneralSrcSpan (fsLit s)) e
547
548 combineLocs :: (HasSrcSpan a , HasSrcSpan b) => a -> b -> SrcSpan
549 combineLocs a b = combineSrcSpans (getLoc a) (getLoc b)
550
551 -- | Combine locations from two 'Located' things and add them to a third thing
552 addCLoc :: (HasSrcSpan a , HasSrcSpan b , HasSrcSpan c) =>
553 a -> b -> SrcSpanLess c -> c
554 addCLoc a b c = cL (combineSrcSpans (getLoc a) (getLoc b)) c
555
556 -- not clear whether to add a general Eq instance, but this is useful sometimes:
557
558 -- | Tests whether the two located things are equal
559 eqLocated :: (HasSrcSpan a , Eq (SrcSpanLess a)) => a -> a -> Bool
560 eqLocated a b = unLoc a == unLoc b
561
562 -- not clear whether to add a general Ord instance, but this is useful sometimes:
563
564 -- | Tests the ordering of the two located things
565 cmpLocated :: (HasSrcSpan a , Ord (SrcSpanLess a)) => a -> a -> Ordering
566 cmpLocated a b = unLoc a `compare` unLoc b
567
568 instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
569 ppr (L l e) = -- TODO: We can't do this since Located was refactored into
570 -- GenLocated:
571 -- Print spans without the file name etc
572 -- ifPprDebug (braces (pprUserSpan False l))
573 whenPprDebug (braces (ppr l))
574 $$ ppr e
575
576 {-
577 ************************************************************************
578 * *
579 \subsection{Ordering SrcSpans for InteractiveUI}
580 * *
581 ************************************************************************
582 -}
583
584 -- | Alternative strategies for ordering 'SrcSpan's
585 leftmost_smallest, leftmost_largest, rightmost :: SrcSpan -> SrcSpan -> Ordering
586 rightmost = flip compare
587 leftmost_smallest = compare
588 leftmost_largest a b = (srcSpanStart a `compare` srcSpanStart b)
589 `thenCmp`
590 (srcSpanEnd b `compare` srcSpanEnd a)
591
592 -- | Determines whether a span encloses a given line and column index
593 spans :: SrcSpan -> (Int, Int) -> Bool
594 spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan"
595 spans (RealSrcSpan span) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span
596 where loc = mkRealSrcLoc (srcSpanFile span) l c
597
598 -- | Determines whether a span is enclosed by another one
599 isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other
600 -> SrcSpan -- ^ The span it may be enclosed by
601 -> Bool
602 isSubspanOf src parent
603 | srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False
604 | otherwise = srcSpanStart parent <= srcSpanStart src &&
605 srcSpanEnd parent >= srcSpanEnd src
606
607
608 {-
609 ************************************************************************
610 * *
611 \subsection{HasSrcSpan Typeclass to Set/Get Source Location Spans}
612 * *
613 ************************************************************************
614 -}
615
616 {-
617 Note [HasSrcSpan Typeclass]
618 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
619
620 To be able to uniformly set/get source location spans (of `SrcSpan`) in
621 syntactic entities (`HsSyn`), we use the typeclass `HasSrcSpan`.
622 More details can be found at the following wiki page
623 ImplementingTreesThatGrow/HandlingSourceLocations
624
625 For most syntactic entities, the source location spans are stored in
626 a syntactic entity by a wapper constuctor (introduced by TTG's
627 new constructor extension), e.g., by `NewPat (WrapperPat sp pat)`
628 for a source location span `sp` and a pattern `pat`.
629 -}
630
631 -- | Determines the type of undecorated syntactic entities
632 -- For most syntactic entities `E`, where source location spans are
633 -- introduced by a wrapper construtor of the same syntactic entity,
634 -- we have `SrcSpanLess E = E`.
635 -- However, some syntactic entities have a different type compared to
636 -- a syntactic entity `e :: E` may have the type `Located E` when
637 -- decorated by wrapping it with `L sp e` for a source span `sp`.
638 type family SrcSpanLess a
639
640 -- | A typeclass to set/get SrcSpans
641 class HasSrcSpan a where
642 -- | Composes a `SrcSpan` decoration with an undecorated syntactic
643 -- entity to form its decorated variant
644 composeSrcSpan :: Located (SrcSpanLess a) -> a
645
646 -- | Decomposes a decorated syntactic entity into its `SrcSpan`
647 -- decoration and its undecorated variant
648 decomposeSrcSpan :: a -> Located (SrcSpanLess a)
649 {- laws:
650 composeSrcSpan . decomposeSrcSpan = id
651 decomposeSrcSpan . composeSrcSpan = id
652
653 in other words, `HasSrcSpan` defines an iso relation between
654 a `SrcSpan`-decorated syntactic entity and its undecorated variant
655 (together with the `SrcSpan`).
656 -}
657
658 type instance SrcSpanLess (GenLocated l e) = e
659 instance HasSrcSpan (Located a) where
660 composeSrcSpan = id
661 decomposeSrcSpan = id
662
663
664 -- | An abbreviated form of decomposeSrcSpan,
665 -- mainly to be used in ViewPatterns
666 dL :: HasSrcSpan a => a -> Located (SrcSpanLess a)
667 dL = decomposeSrcSpan
668
669 -- | An abbreviated form of composeSrcSpan,
670 -- mainly to replace the hardcoded `L`
671 cL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
672 cL sp e = composeSrcSpan (L sp e)
673
674 -- | A Pattern Synonym to Set/Get SrcSpans
675 pattern LL :: HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
676 pattern LL sp e <- (dL->L sp e)
677 where
678 LL sp e = cL sp e
679
680 -- | Lifts a function of undecorated entities to one of decorated ones
681 onHasSrcSpan :: (HasSrcSpan a , HasSrcSpan b) =>
682 (SrcSpanLess a -> SrcSpanLess b) -> a -> b
683 onHasSrcSpan f (dL->L l e) = cL l (f e)
684
685 liftL :: (HasSrcSpan a, HasSrcSpan b, Monad m) =>
686 (SrcSpanLess a -> m (SrcSpanLess b)) -> a -> m b
687 liftL f (dL->L loc a) = do
688 a' <- f a
689 return $ cL loc a'
690
691
692 getRealSrcSpan :: RealLocated a -> RealSrcSpan
693 getRealSrcSpan (L l _) = l
694
695 unRealSrcSpan :: RealLocated a -> a
696 unRealSrcSpan (L _ e) = e