Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Refactor SrcLoc and SrcSpan

The "Unhelpful" cases are now in a separate type. This allows us to
improve various things, e.g.:
* Most of the panic's in SrcLoc are now gone
* The Lexer now works with RealSrcSpans rather than SrcSpans, i.e. it
  knows that it has real locations and thus can assume that the line
  number etc really exists
* Some of the more suspicious cases are no longer necessary, e.g.
  we no longer need this case in advanceSrcLoc:
      advanceSrcLoc loc _ = loc -- Better than nothing

More improvements can probably be made, e.g. tick locations can
probably use RealSrcSpans too.
  • Loading branch information...
commit 5f8f1f244f49543cda309303f065c5bdcf961ea4 1 parent 1d74684
igfoo authored June 02, 2011
14  compiler/basicTypes/Name.lhs
@@ -480,12 +480,14 @@ ppr_z_occ_name occ = ftext (zEncodeFS (occNameFS occ))
480 480
 -- Prints (if mod information is available) "Defined at <loc>" or 
481 481
 --  "Defined in <mod>" information for a Name.
482 482
 pprNameLoc :: Name -> SDoc
483  
-pprNameLoc name
484  
-  | isGoodSrcSpan loc = pprDefnLoc loc
485  
-  | isInternalName name || isSystemName name 
486  
-                      = ptext (sLit "<no location info>")
487  
-  | otherwise         = ptext (sLit "Defined in ") <> ppr (nameModule name)
488  
-  where loc = nameSrcSpan name
  483
+pprNameLoc name = case nameSrcSpan name of
  484
+                  RealSrcSpan s ->
  485
+                      pprDefnLoc s
  486
+                  UnhelpfulSpan _
  487
+                   | isInternalName name || isSystemName name ->
  488
+                      ptext (sLit "<no location info>")
  489
+                   | otherwise ->
  490
+                      ptext (sLit "Defined in ") <> ppr (nameModule name)
489 491
 \end{code}
490 492
 
491 493
 %************************************************************************
10  compiler/basicTypes/RdrName.lhs
@@ -677,14 +677,16 @@ pprNameProvenance (GRE {gre_name = name, gre_prov = Imported whys})
677 677
 -- If we know the exact definition point (which we may do with GHCi)
678 678
 -- then show that too.  But not if it's just "imported from X".
679 679
 ppr_defn :: SrcLoc -> SDoc
680  
-ppr_defn loc | isGoodSrcLoc loc = parens (ptext (sLit "defined at") <+> ppr loc)
681  
-	     | otherwise	= empty
  680
+ppr_defn (RealSrcLoc loc) = parens (ptext (sLit "defined at") <+> ppr loc)
  681
+ppr_defn (UnhelpfulLoc _) = empty
682 682
 
683 683
 instance Outputable ImportSpec where
684 684
    ppr imp_spec
685 685
      = ptext (sLit "imported from") <+> ppr (importSpecModule imp_spec) 
686  
-	<+> if isGoodSrcSpan loc then ptext (sLit "at") <+> ppr loc
687  
-				 else empty
  686
+	<+> pprLoc
688 687
      where
689 688
        loc = importSpecLoc imp_spec
  689
+       pprLoc = case loc of
  690
+                RealSrcSpan s -> ptext (sLit "at") <+> ppr s
  691
+                UnhelpfulSpan _ -> empty
690 692
 \end{code}
231  compiler/basicTypes/SrcLoc.lhs
@@ -7,10 +7,11 @@
7 7
 -- in source files, and allow tagging of those things with locations
8 8
 module SrcLoc (
9 9
 	-- * SrcLoc
10  
-	SrcLoc,			-- Abstract
  10
+	RealSrcLoc,			-- Abstract
  11
+	SrcLoc(..),
11 12
 
12 13
         -- ** Constructing SrcLoc
13  
-	mkSrcLoc, mkGeneralSrcLoc,
  14
+	mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc,
14 15
 
15 16
 	noSrcLoc, 		-- "I'm sorry, I haven't a clue"
16 17
 	generatedSrcLoc,	-- Code generated within the compiler
@@ -26,22 +27,21 @@ module SrcLoc (
26 27
 	
27 28
 	-- ** Misc. operations on SrcLoc
28 29
 	pprDefnLoc,
29  
-	
30  
-        -- ** Predicates on SrcLoc
31  
-        isGoodSrcLoc,
32 30
 
33 31
         -- * SrcSpan
34  
-	SrcSpan,		-- Abstract
  32
+	RealSrcSpan,		-- Abstract
  33
+	SrcSpan(..),
35 34
 
36 35
         -- ** Constructing SrcSpan
37  
-	mkGeneralSrcSpan, mkSrcSpan, 
  36
+	mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,
38 37
 	noSrcSpan, 
39 38
 	wiredInSrcSpan,		-- Something wired into the compiler
40  
-	srcLocSpan,
  39
+	srcLocSpan, realSrcLocSpan,
41 40
 	combineSrcSpans,
42 41
 	
43 42
 	-- ** Deconstructing SrcSpan
44 43
 	srcSpanStart, srcSpanEnd,
  44
+	realSrcSpanStart, realSrcSpanEnd,
45 45
 	srcSpanFileName_maybe,
46 46
 
47 47
 	-- ** Unsafely deconstructing SrcSpan
@@ -54,7 +54,9 @@ module SrcLoc (
54 54
         isGoodSrcSpan, isOneLineSpan,
55 55
 
56 56
         -- * Located
57  
-	Located(..), 
  57
+	Located, 
  58
+	RealLocated, 
  59
+	GenLocated(..), 
58 60
 	
59 61
 	-- ** Constructing Located
60 62
 	noLoc,
@@ -89,10 +91,13 @@ We keep information about the {\em definition} point for each entity;
89 91
 this is the obvious stuff:
90 92
 \begin{code}
91 93
 -- | Represents a single point within a file
92  
-data SrcLoc
  94
+data RealSrcLoc
93 95
   = SrcLoc	FastString	-- A precise location (file name)
94 96
 		{-# UNPACK #-} !Int		-- line number, begins at 1
95 97
 		{-# UNPACK #-} !Int		-- column number, begins at 1
  98
+
  99
+data SrcLoc
  100
+  = RealSrcLoc {-# UNPACK #-}!RealSrcLoc
96 101
   | UnhelpfulLoc FastString	-- Just a general indication
97 102
 \end{code}
98 103
 
@@ -104,7 +109,10 @@ data SrcLoc
104 109
 
105 110
 \begin{code}
106 111
 mkSrcLoc :: FastString -> Int -> Int -> SrcLoc
107  
-mkSrcLoc x line col = SrcLoc x line col
  112
+mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col)
  113
+
  114
+mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc
  115
+mkRealSrcLoc x line col = SrcLoc x line col
108 116
 
109 117
 -- | Built-in "bad" 'SrcLoc' values for particular locations
110 118
 noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc
@@ -116,35 +124,26 @@ interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive session>")
116 124
 mkGeneralSrcLoc :: FastString -> SrcLoc
117 125
 mkGeneralSrcLoc = UnhelpfulLoc 
118 126
 
119  
--- | "Good" 'SrcLoc's have precise information about their location
120  
-isGoodSrcLoc :: SrcLoc -> Bool
121  
-isGoodSrcLoc (SrcLoc _ _ _) = True
122  
-isGoodSrcLoc _other         = False
123  
-
124  
--- | Gives the filename of the 'SrcLoc' if it is available, otherwise returns a dummy value
125  
-srcLocFile :: SrcLoc -> FastString
  127
+-- | Gives the filename of the 'RealSrcLoc'
  128
+srcLocFile :: RealSrcLoc -> FastString
126 129
 srcLocFile (SrcLoc fname _ _) = fname
127  
-srcLocFile _other	      = (fsLit "<unknown file")
128 130
 
129 131
 -- | Raises an error when used on a "bad" 'SrcLoc'
130  
-srcLocLine :: SrcLoc -> Int
  132
+srcLocLine :: RealSrcLoc -> Int
131 133
 srcLocLine (SrcLoc _ l _) = l
132  
-srcLocLine (UnhelpfulLoc s) = pprPanic "srcLocLine" (ftext s)
133 134
 
134 135
 -- | Raises an error when used on a "bad" 'SrcLoc'
135  
-srcLocCol :: SrcLoc -> Int
  136
+srcLocCol :: RealSrcLoc -> Int
136 137
 srcLocCol (SrcLoc _ _ c) = c
137  
-srcLocCol (UnhelpfulLoc s) = pprPanic "srcLocCol" (ftext s)
138 138
 
139 139
 -- | Move the 'SrcLoc' down by one line if the character is a newline,
140 140
 -- to the next 8-char tabstop if it is a tab, and across by one
141 141
 -- character in any other case
142  
-advanceSrcLoc :: SrcLoc -> Char -> SrcLoc
  142
+advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc
143 143
 advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f  (l + 1) 1
144 144
 advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f  l (((((c - 1) `shiftR` 3) + 1)
145 145
                                                   `shiftL` 3) + 1)
146 146
 advanceSrcLoc (SrcLoc f l c) _    = SrcLoc f  l (c + 1)
147  
-advanceSrcLoc loc            _    = loc -- Better than nothing
148 147
 \end{code}
149 148
 
150 149
 %************************************************************************
@@ -157,21 +156,31 @@ advanceSrcLoc loc            _    = loc -- Better than nothing
157 156
 -- SrcLoc is an instance of Ord so that we can sort error messages easily
158 157
 instance Eq SrcLoc where
159 158
   loc1 == loc2 = case loc1 `cmpSrcLoc` loc2 of
160  
-		   EQ     -> True
161  
-		   _other -> False
  159
+                 EQ     -> True
  160
+                 _other -> False
  161
+
  162
+instance Eq RealSrcLoc where
  163
+  loc1 == loc2 = case loc1 `cmpRealSrcLoc` loc2 of
  164
+                 EQ     -> True
  165
+                 _other -> False
162 166
 
163 167
 instance Ord SrcLoc where
164 168
   compare = cmpSrcLoc
165  
-   
  169
+
  170
+instance Ord RealSrcLoc where
  171
+  compare = cmpRealSrcLoc
  172
+
166 173
 cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering
167 174
 cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2
168  
-cmpSrcLoc (UnhelpfulLoc _)  (SrcLoc _ _ _)    = GT
169  
-cmpSrcLoc (SrcLoc _ _ _)    (UnhelpfulLoc _)  = LT
  175
+cmpSrcLoc (UnhelpfulLoc _)  (RealSrcLoc _)    = GT
  176
+cmpSrcLoc (RealSrcLoc _)    (UnhelpfulLoc _)  = LT
  177
+cmpSrcLoc (RealSrcLoc l1)   (RealSrcLoc l2)   = (l1 `compare` l2)
170 178
 
171  
-cmpSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2)      
  179
+cmpRealSrcLoc :: RealSrcLoc -> RealSrcLoc -> Ordering
  180
+cmpRealSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2)
172 181
   = (s1 `compare` s2) `thenCmp` (l1 `compare` l2) `thenCmp` (c1 `compare` c2)
173 182
 
174  
-instance Outputable SrcLoc where
  183
+instance Outputable RealSrcLoc where
175 184
     ppr (SrcLoc src_path src_line src_col)
176 185
       = getPprStyle $ \ sty ->
177 186
         if userStyle sty || debugStyle sty then
@@ -183,8 +192,16 @@ instance Outputable SrcLoc where
183 192
             hcat [text "{-# LINE ", int src_line, space,
184 193
                   char '\"', pprFastFilePath src_path, text " #-}"]
185 194
 
  195
+instance Outputable SrcLoc where
  196
+    ppr (RealSrcLoc l) = ppr l
186 197
     ppr (UnhelpfulLoc s)  = ftext s
187 198
 
  199
+instance Data RealSrcSpan where
  200
+  -- don't traverse?
  201
+  toConstr _   = abstractConstr "RealSrcSpan"
  202
+  gunfold _ _  = error "gunfold"
  203
+  dataTypeOf _ = mkNoRepType "RealSrcSpan"
  204
+
188 205
 instance Data SrcSpan where
189 206
   -- don't traverse?
190 207
   toConstr _   = abstractConstr "SrcSpan"
@@ -209,7 +226,7 @@ The end position is defined to be the column /after/ the end of the
209 226
 span.  That is, a span of (1,1)-(1,2) is one character long, and a
210 227
 span of (1,1)-(1,1) is zero characters long.
211 228
 -}
212  
-data SrcSpan
  229
+data RealSrcSpan
213 230
   = SrcSpanOneLine 		-- a common case: a single line
214 231
 	{ srcSpanFile     :: !FastString,
215 232
 	  srcSpanLine     :: {-# UNPACK #-} !Int,
@@ -230,7 +247,15 @@ data SrcSpan
230 247
 	  srcSpanLine	  :: {-# UNPACK #-} !Int,
231 248
 	  srcSpanCol      :: {-# UNPACK #-} !Int
232 249
 	}
  250
+#ifdef DEBUG
  251
+  deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, becuase we
  252
+                                -- derive Show for Token
  253
+#else
  254
+  deriving (Eq, Typeable)
  255
+#endif
233 256
 
  257
+data SrcSpan =
  258
+    RealSrcSpan {-# UNPACK #-}!RealSrcSpan
234 259
   | UnhelpfulSpan !FastString	-- Just a general indication
235 260
 				-- also used to indicate an empty span
236 261
 
@@ -253,13 +278,14 @@ mkGeneralSrcSpan = UnhelpfulSpan
253 278
 -- | Create a 'SrcSpan' corresponding to a single point
254 279
 srcLocSpan :: SrcLoc -> SrcSpan
255 280
 srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str
256  
-srcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col
  281
+srcLocSpan (RealSrcLoc l) = RealSrcSpan (realSrcLocSpan l)
  282
+
  283
+realSrcLocSpan :: RealSrcLoc -> RealSrcSpan
  284
+realSrcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col
257 285
 
258 286
 -- | Create a 'SrcSpan' between two points in a file
259  
-mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
260  
-mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str
261  
-mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str
262  
-mkSrcSpan loc1 loc2
  287
+mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan
  288
+mkRealSrcSpan loc1 loc2
263 289
   | line1 == line2 = if col1 == col2
264 290
 			then SrcSpanPoint file line1 col1
265 291
 			else SrcSpanOneLine file line1 col1 col2
@@ -271,12 +297,25 @@ mkSrcSpan loc1 loc2
271 297
 	col2 = srcLocCol loc2
272 298
 	file = srcLocFile loc1
273 299
 
  300
+-- | Create a 'SrcSpan' between two points in a file
  301
+mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
  302
+mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str
  303
+mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str
  304
+mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2)
  305
+    = RealSrcSpan (mkRealSrcSpan loc1 loc2)
  306
+
274 307
 -- | Combines two 'SrcSpan' into one that spans at least all the characters
275 308
 -- within both spans. Assumes the "file" part is the same in both inputs
276 309
 combineSrcSpans	:: SrcSpan -> SrcSpan -> SrcSpan
277 310
 combineSrcSpans	(UnhelpfulSpan _) r = r -- this seems more useful
278 311
 combineSrcSpans	l (UnhelpfulSpan _) = l
279  
-combineSrcSpans	span1 span2
  312
+combineSrcSpans	(RealSrcSpan span1) (RealSrcSpan span2)
  313
+    = RealSrcSpan (combineRealSrcSpans span1 span2)
  314
+
  315
+-- | Combines two 'SrcSpan' into one that spans at least all the characters
  316
+-- within both spans. Assumes the "file" part is the same in both inputs
  317
+combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan
  318
+combineRealSrcSpans span1 span2
280 319
  = if line_start == line_end 
281 320
    then if col_start == col_end
282 321
         then SrcSpanPoint     file line_start col_start
@@ -299,17 +338,14 @@ combineSrcSpans	span1 span2
299 338
 \begin{code}
300 339
 -- | Test if a 'SrcSpan' is "good", i.e. has precise location information
301 340
 isGoodSrcSpan :: SrcSpan -> Bool
302  
-isGoodSrcSpan SrcSpanOneLine{} = True
303  
-isGoodSrcSpan SrcSpanMultiLine{} = True
304  
-isGoodSrcSpan SrcSpanPoint{} = True
305  
-isGoodSrcSpan _ = False
  341
+isGoodSrcSpan (RealSrcSpan _) = True
  342
+isGoodSrcSpan (UnhelpfulSpan _) = False
306 343
 
307 344
 isOneLineSpan :: SrcSpan -> Bool
308 345
 -- ^ True if the span is known to straddle only one line.
309 346
 -- For "bad" 'SrcSpan', it returns False
310  
-isOneLineSpan s
311  
-  | isGoodSrcSpan s = srcSpanStartLine s == srcSpanEndLine s
312  
-  | otherwise	    = False		
  347
+isOneLineSpan (RealSrcSpan s) = srcSpanStartLine s == srcSpanEndLine s
  348
+isOneLineSpan (UnhelpfulSpan _) = False
313 349
 
314 350
 \end{code}
315 351
 
@@ -321,34 +357,26 @@ isOneLineSpan s
321 357
 
322 358
 \begin{code}
323 359
 
324  
--- | Raises an error when used on a "bad" 'SrcSpan'
325  
-srcSpanStartLine :: SrcSpan -> Int
326  
--- | Raises an error when used on a "bad" 'SrcSpan'
327  
-srcSpanEndLine :: SrcSpan -> Int
328  
--- | Raises an error when used on a "bad" 'SrcSpan'
329  
-srcSpanStartCol :: SrcSpan -> Int
330  
--- | Raises an error when used on a "bad" 'SrcSpan'
331  
-srcSpanEndCol :: SrcSpan -> Int
  360
+srcSpanStartLine :: RealSrcSpan -> Int
  361
+srcSpanEndLine :: RealSrcSpan -> Int
  362
+srcSpanStartCol :: RealSrcSpan -> Int
  363
+srcSpanEndCol :: RealSrcSpan -> Int
332 364
 
333 365
 srcSpanStartLine SrcSpanOneLine{ srcSpanLine=l } = l
334 366
 srcSpanStartLine SrcSpanMultiLine{ srcSpanSLine=l } = l
335 367
 srcSpanStartLine SrcSpanPoint{ srcSpanLine=l } = l
336  
-srcSpanStartLine _ = panic "SrcLoc.srcSpanStartLine"
337 368
 
338 369
 srcSpanEndLine SrcSpanOneLine{ srcSpanLine=l } = l
339 370
 srcSpanEndLine SrcSpanMultiLine{ srcSpanELine=l } = l
340 371
 srcSpanEndLine SrcSpanPoint{ srcSpanLine=l } = l
341  
-srcSpanEndLine _ = panic "SrcLoc.srcSpanEndLine"
342 372
 
343 373
 srcSpanStartCol SrcSpanOneLine{ srcSpanSCol=l } = l
344 374
 srcSpanStartCol SrcSpanMultiLine{ srcSpanSCol=l } = l
345 375
 srcSpanStartCol SrcSpanPoint{ srcSpanCol=l } = l
346  
-srcSpanStartCol _ = panic "SrcLoc.srcSpanStartCol"
347 376
 
348 377
 srcSpanEndCol SrcSpanOneLine{ srcSpanECol=c } = c
349 378
 srcSpanEndCol SrcSpanMultiLine{ srcSpanECol=c } = c
350 379
 srcSpanEndCol SrcSpanPoint{ srcSpanCol=c } = c
351  
-srcSpanEndCol _ = panic "SrcLoc.srcSpanEndCol"
352 380
 
353 381
 \end{code}
354 382
 
@@ -362,26 +390,28 @@ srcSpanEndCol _ = panic "SrcLoc.srcSpanEndCol"
362 390
 
363 391
 -- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
364 392
 srcSpanStart :: SrcSpan -> SrcLoc
  393
+srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str
  394
+srcSpanStart (RealSrcSpan s) = RealSrcLoc (realSrcSpanStart s)
  395
+
365 396
 -- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
366 397
 srcSpanEnd :: SrcSpan -> SrcLoc
  398
+srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str
  399
+srcSpanEnd (RealSrcSpan s) = RealSrcLoc (realSrcSpanEnd s)
367 400
 
368  
-srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str
369  
-srcSpanStart s = mkSrcLoc (srcSpanFile s) 
370  
-			  (srcSpanStartLine s)
371  
-		 	  (srcSpanStartCol s)
  401
+realSrcSpanStart :: RealSrcSpan -> RealSrcLoc
  402
+realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s)
  403
+                                  (srcSpanStartLine s)
  404
+                                  (srcSpanStartCol s)
372 405
 
373  
-srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str
374  
-srcSpanEnd s = 
375  
-  mkSrcLoc (srcSpanFile s) 
376  
-	   (srcSpanEndLine s)
377  
- 	   (srcSpanEndCol s)
  406
+realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc
  407
+realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s)
  408
+                                (srcSpanEndLine s)
  409
+                                (srcSpanEndCol s)
378 410
 
379 411
 -- | Obtains the filename for a 'SrcSpan' if it is "good"
380 412
 srcSpanFileName_maybe :: SrcSpan -> Maybe FastString
381  
-srcSpanFileName_maybe (SrcSpanOneLine { srcSpanFile = nm })   = Just nm
382  
-srcSpanFileName_maybe (SrcSpanMultiLine { srcSpanFile = nm }) = Just nm
383  
-srcSpanFileName_maybe (SrcSpanPoint { srcSpanFile = nm})      = Just nm
384  
-srcSpanFileName_maybe _                                       = Nothing
  413
+srcSpanFileName_maybe (RealSrcSpan s)   = Just (srcSpanFile s)
  414
+srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing
385 415
 
386 416
 \end{code}
387 417
 
@@ -400,17 +430,31 @@ instance Ord SrcSpan where
400 430
      (srcSpanEnd   a `compare` srcSpanEnd   b)
401 431
 
402 432
 
403  
-instance Outputable SrcSpan where
  433
+instance Outputable RealSrcSpan where
404 434
     ppr span
405 435
       = getPprStyle $ \ sty ->
406 436
         if userStyle sty || debugStyle sty then
407  
-           pprUserSpan True span
  437
+           pprUserRealSpan True span
408 438
         else
409 439
            hcat [text "{-# LINE ", int (srcSpanStartLine span), space,
410 440
                  char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"]
411 441
 
  442
+instance Outputable SrcSpan where
  443
+    ppr span
  444
+      = getPprStyle $ \ sty ->
  445
+        if userStyle sty || debugStyle sty then
  446
+           pprUserSpan True span
  447
+        else
  448
+           case span of
  449
+           UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan"
  450
+           RealSrcSpan s -> ppr s
  451
+
412 452
 pprUserSpan :: Bool -> SrcSpan -> SDoc
413  
-pprUserSpan show_path (SrcSpanOneLine src_path line start_col end_col)
  453
+pprUserSpan _         (UnhelpfulSpan s) = ftext s
  454
+pprUserSpan show_path (RealSrcSpan s)   = pprUserRealSpan show_path s
  455
+
  456
+pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc
  457
+pprUserRealSpan show_path (SrcSpanOneLine src_path line start_col end_col)
414 458
   = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
415 459
          , int line, char ':', int start_col
416 460
          , ppUnless (end_col - start_col <= 1)
@@ -420,7 +464,7 @@ pprUserSpan show_path (SrcSpanOneLine src_path line start_col end_col)
420 464
          ]
421 465
 	  
422 466
 
423  
-pprUserSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol)
  467
+pprUserRealSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol)
424 468
   = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
425 469
 	 , parens (int sline <> char ',' <>  int scol)
426 470
 	 , char '-'
@@ -428,17 +472,13 @@ pprUserSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol)
428 472
 	   	   if ecol == 0 then int ecol else int (ecol-1))
429 473
 	 ]
430 474
 
431  
-pprUserSpan show_path (SrcSpanPoint src_path line col)
  475
+pprUserRealSpan show_path (SrcSpanPoint src_path line col)
432 476
   = hcat [ ppWhen show_path $ (pprFastFilePath src_path <> colon)
433 477
          , int line, char ':', int col ]
434 478
 
435  
-pprUserSpan _ (UnhelpfulSpan s)  = ftext s
436  
-
437  
-pprDefnLoc :: SrcSpan -> SDoc
  479
+pprDefnLoc :: RealSrcSpan -> SDoc
438 480
 -- ^ Pretty prints information about the 'SrcSpan' in the style "defined at ..."
439  
-pprDefnLoc loc
440  
-  | isGoodSrcSpan loc = ptext (sLit "Defined at") <+> ppr loc
441  
-  | otherwise	      = ppr loc
  481
+pprDefnLoc loc = ptext (sLit "Defined at") <+> ppr loc
442 482
 \end{code}
443 483
 
444 484
 %************************************************************************
@@ -449,13 +489,16 @@ pprDefnLoc loc
449 489
 
450 490
 \begin{code}
451 491
 -- | We attach SrcSpans to lots of things, so let's have a datatype for it.
452  
-data Located e = L SrcSpan e
  492
+data GenLocated l e = L l e
453 493
   deriving (Eq, Ord, Typeable, Data)
454 494
 
455  
-unLoc :: Located e -> e
  495
+type Located e = GenLocated SrcSpan e
  496
+type RealLocated e = GenLocated RealSrcSpan e
  497
+
  498
+unLoc :: GenLocated l e -> e
456 499
 unLoc (L _ e) = e
457 500
 
458  
-getLoc :: Located e -> SrcSpan
  501
+getLoc :: GenLocated l e -> l
459 502
 getLoc (L l _) = l
460 503
 
461 504
 noLoc :: e -> Located e
@@ -483,12 +526,16 @@ eqLocated a b = unLoc a == unLoc b
483 526
 cmpLocated :: Ord a => Located a -> Located a -> Ordering
484 527
 cmpLocated a b = unLoc a `compare` unLoc b
485 528
 
486  
-instance Functor Located where
  529
+instance Functor (GenLocated l) where
487 530
   fmap f (L l e) = L l (f e)
488 531
 
489  
-instance Outputable e => Outputable (Located e) where
490  
-  ppr (L l e) = ifPprDebug (braces (pprUserSpan False l)) $$ ppr e
491  
-		-- Print spans without the file name etc
  532
+instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
  533
+  ppr (L l e) = -- TODO: We can't do this since Located was refactored into
  534
+                -- GenLocated:
  535
+                -- Print spans without the file name etc
  536
+                -- ifPprDebug (braces (pprUserSpan False l))
  537
+                ifPprDebug (braces (ppr l))
  538
+             $$ ppr e
492 539
 \end{code}
493 540
 
494 541
 %************************************************************************
@@ -506,11 +553,11 @@ leftmost_largest a b = (srcSpanStart a `compare` srcSpanStart b)
506 553
                                 `thenCmp`
507 554
                        (srcSpanEnd b `compare` srcSpanEnd a)
508 555
 
509  
-
510 556
 -- | Determines whether a span encloses a given line and column index
511 557
 spans :: SrcSpan -> (Int, Int) -> Bool
512  
-spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span
513  
-   where loc = mkSrcLoc (srcSpanFile span) l c
  558
+spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan"
  559
+spans (RealSrcSpan span) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span
  560
+   where loc = mkRealSrcLoc (srcSpanFile span) l c
514 561
 
515 562
 -- | Determines whether a span is enclosed by another one
516 563
 isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other
20  compiler/cmm/CmmLex.x
@@ -173,7 +173,7 @@ data CmmToken
173 173
 -- -----------------------------------------------------------------------------
174 174
 -- Lexer actions
175 175
 
176  
-type Action = SrcSpan -> StringBuffer -> Int -> P (Located CmmToken)
  176
+type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated CmmToken)
177 177
 
178 178
 begin :: Int -> Action
179 179
 begin code _span _str _len = do pushLexState code; lexToken
@@ -268,7 +268,7 @@ tok_string str = CmmT_String (read str)
268 268
 setLine :: Int -> Action
269 269
 setLine code span buf len = do
270 270
   let line = parseUnsignedInteger buf len 10 octDecDigit
271  
-  setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
  271
+  setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
272 272
 	-- subtract one: the line number refers to the *following* line
273 273
   -- trace ("setLine "  ++ show line) $ do
274 274
   popLexState
@@ -278,7 +278,7 @@ setLine code span buf len = do
278 278
 setFile :: Int -> Action
279 279
 setFile code span buf len = do
280 280
   let file = lexemeToFastString (stepOn buf) (len-2)
281  
-  setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
  281
+  setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
282 282
   popLexState
283 283
   pushLexState code
284 284
   lexToken
@@ -289,16 +289,16 @@ setFile code span buf len = do
289 289
 
290 290
 cmmlex :: (Located CmmToken -> P a) -> P a
291 291
 cmmlex cont = do
292  
-  tok@(L _ tok__) <- lexToken
293  
-  --trace ("token: " ++ show tok__) $ do
294  
-  cont tok
  292
+  (L span tok) <- lexToken
  293
+  --trace ("token: " ++ show tok) $ do
  294
+  cont (L (RealSrcSpan span) tok)
295 295
 
296  
-lexToken :: P (Located CmmToken)
  296
+lexToken :: P (RealLocated CmmToken)
297 297
 lexToken = do
298 298
   inp@(loc1,buf) <- getInput
299 299
   sc <- getLexState
300 300
   case alexScan inp sc of
301  
-    AlexEOF -> do let span = mkSrcSpan loc1 loc1
  301
+    AlexEOF -> do let span = mkRealSrcSpan loc1 loc1
302 302
 		  setLastToken span 0
303 303
 		  return (L span CmmT_EOF)
304 304
     AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error"
@@ -307,7 +307,7 @@ lexToken = do
307 307
 	lexToken
308 308
     AlexToken inp2@(end,buf2) len t -> do
309 309
 	setInput inp2
310  
-	let span = mkSrcSpan loc1 end
  310
+	let span = mkRealSrcSpan loc1 end
311 311
 	span `seq` setLastToken span len
312 312
 	t span buf len
313 313
 
@@ -315,7 +315,7 @@ lexToken = do
315 315
 -- Monad stuff
316 316
 
317 317
 -- Stuff that Alex needs to know about our input type:
318  
-type AlexInput = (SrcLoc,StringBuffer)
  318
+type AlexInput = (RealSrcLoc,StringBuffer)
319 319
 
320 320
 alexInputPrevChar :: AlexInput -> Char
321 321
 alexInputPrevChar (_,s) = prevChar s '\n'
2  compiler/cmm/CmmParse.y
@@ -1062,7 +1062,7 @@ parseCmmFile dflags filename = do
1062 1062
   showPass dflags "ParseCmm"
1063 1063
   buf <- hGetStringBuffer filename
1064 1064
   let
1065  
-	init_loc = mkSrcLoc (mkFastString filename) 1 1
  1065
+	init_loc = mkRealSrcLoc (mkFastString filename) 1 1
1066 1066
 	init_state = (mkPState dflags buf init_loc) { lex_state = [0] }
1067 1067
 		-- reset the lex_state: the Lexer monad leaves some stuff
1068 1068
 		-- in there we don't want.
26  compiler/deSugar/Coverage.lhs
@@ -846,26 +846,16 @@ allocBinTickBox boxLabel pos m
846 846
 allocBinTickBox _boxLabel pos m = do e <- m; return (L pos e)
847 847
 
848 848
 isGoodSrcSpan' :: SrcSpan -> Bool
849  
-isGoodSrcSpan' pos
850  
-   | not (isGoodSrcSpan pos) = False
851  
-   | start == end            = False
852  
-   | otherwise		     = True
853  
-  where
854  
-   start = srcSpanStart pos
855  
-   end   = srcSpanEnd pos
  849
+isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos
  850
+isGoodSrcSpan' (UnhelpfulSpan _) = False
856 851
 
857 852
 mkHpcPos :: SrcSpan -> HpcPos
858  
-mkHpcPos pos 
859  
-   | not (isGoodSrcSpan' pos) = panic "bad source span; expected such spans to be filtered out"
860  
-   | otherwise		      = hpcPos
861  
-  where
862  
-   start = srcSpanStart pos
863  
-   end   = srcSpanEnd pos
864  
-   hpcPos = toHpcPos ( srcLocLine start
865  
-		     , srcLocCol start
866  
-		     , srcLocLine end
867  
-		     , srcLocCol end - 1
868  
-		     )
  853
+mkHpcPos pos@(RealSrcSpan s)
  854
+   | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,
  855
+                                    srcSpanStartCol s,
  856
+                                    srcSpanEndLine s,
  857
+                                    srcSpanEndCol s)
  858
+mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"
869 859
 
870 860
 hpcSrcSpan :: SrcSpan
871 861
 hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")
2  compiler/hsSyn/HsImpExp.lhs
@@ -15,7 +15,7 @@ import HsDoc		( HsDocString )
15 15
 
16 16
 import Outputable
17 17
 import FastString
18  
-import SrcLoc           ( Located(..), noLoc )
  18
+import SrcLoc
19 19
 
20 20
 import Data.Data
21 21
 \end{code}
2  compiler/hsSyn/HsSyn.lhs
@@ -41,7 +41,7 @@ import HsDoc
41 41
 -- others:
42 42
 import IfaceSyn		( IfaceBinding )
43 43
 import Outputable
44  
-import SrcLoc		( Located(..) )
  44
+import SrcLoc
45 45
 import Module		( Module, ModuleName )
46 46
 import FastString
47 47
 
66  compiler/main/GHC.hs
@@ -187,7 +187,7 @@ module GHC (
187 187
 
188 188
 	-- ** Source locations
189 189
 	SrcLoc, pprDefnLoc,
190  
-        mkSrcLoc, isGoodSrcLoc, noSrcLoc,
  190
+        mkSrcLoc, noSrcLoc,
191 191
 	srcLocFile, srcLocLine, srcLocCol,
192 192
         SrcSpan,
193 193
         mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,
@@ -197,7 +197,7 @@ module GHC (
197 197
         srcSpanStartCol, srcSpanEndCol,
198 198
 
199 199
         -- ** Located
200  
-	Located(..),
  200
+	GenLocated(..), Located,
201 201
 
202 202
 	-- *** Constructing Located
203 203
 	noLoc, mkGeneralLocated,
@@ -1105,7 +1105,7 @@ getModuleSourceAndFlags mod = do
1105 1105
 getTokenStream :: GhcMonad m => Module -> m [Located Token]
1106 1106
 getTokenStream mod = do
1107 1107
   (sourceFile, source, flags) <- getModuleSourceAndFlags mod
1108  
-  let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
  1108
+  let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
1109 1109
   case lexTokenStream source startLoc flags of
1110 1110
     POk _ ts  -> return ts
1111 1111
     PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
@@ -1116,7 +1116,7 @@ getTokenStream mod = do
1116 1116
 getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
1117 1117
 getRichTokenStream mod = do
1118 1118
   (sourceFile, source, flags) <- getModuleSourceAndFlags mod
1119  
-  let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1
  1119
+  let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
1120 1120
   case lexTokenStream source startLoc flags of
1121 1121
     POk _ ts -> return $ addSourceToTokens startLoc source ts
1122 1122
     PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
@@ -1124,21 +1124,22 @@ getRichTokenStream mod = do
1124 1124
 -- | Given a source location and a StringBuffer corresponding to this
1125 1125
 -- location, return a rich token stream with the source associated to the
1126 1126
 -- tokens.
1127  
-addSourceToTokens :: SrcLoc -> StringBuffer -> [Located Token]
  1127
+addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]
1128 1128
                   -> [(Located Token, String)]
1129 1129
 addSourceToTokens _ _ [] = []
1130 1130
 addSourceToTokens loc buf (t@(L span _) : ts)
1131  
-    | not (isGoodSrcSpan span) = (t,"") : addSourceToTokens loc buf ts
1132  
-    | otherwise = (t,str) : addSourceToTokens newLoc newBuf ts
1133  
-    where
1134  
-      (newLoc, newBuf, str) = go "" loc buf
1135  
-      start = srcSpanStart span
1136  
-      end = srcSpanEnd span
1137  
-      go acc loc buf | loc < start = go acc nLoc nBuf
1138  
-                     | start <= loc && loc < end = go (ch:acc) nLoc nBuf
1139  
-                     | otherwise = (loc, buf, reverse acc)
1140  
-          where (ch, nBuf) = nextChar buf
1141  
-                nLoc = advanceSrcLoc loc ch
  1131
+    = case span of
  1132
+      UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts
  1133
+      RealSrcSpan s   -> (t,str) : addSourceToTokens newLoc newBuf ts
  1134
+        where
  1135
+          (newLoc, newBuf, str) = go "" loc buf
  1136
+          start = realSrcSpanStart s
  1137
+          end = realSrcSpanEnd s
  1138
+          go acc loc buf | loc < start = go acc nLoc nBuf
  1139
+                         | start <= loc && loc < end = go (ch:acc) nLoc nBuf
  1140
+                         | otherwise = (loc, buf, reverse acc)
  1141
+              where (ch, nBuf) = nextChar buf
  1142
+                    nLoc = advanceSrcLoc loc ch
1142 1143
 
1143 1144
 
1144 1145
 -- | Take a rich token stream such as produced from 'getRichTokenStream' and
@@ -1146,21 +1147,26 @@ addSourceToTokens loc buf (t@(L span _) : ts)
1146 1147
 -- insignificant whitespace.)
1147 1148
 showRichTokenStream :: [(Located Token, String)] -> String
1148 1149
 showRichTokenStream ts = go startLoc ts ""
1149  
-    where sourceFile = srcSpanFile (getLoc . fst . head $ ts)
1150  
-          startLoc = mkSrcLoc sourceFile 1 1
  1150
+    where sourceFile = getFile $ map (getLoc . fst) ts
  1151
+          getFile [] = panic "showRichTokenStream: No source file found"
  1152
+          getFile (UnhelpfulSpan _ : xs) = getFile xs
  1153
+          getFile (RealSrcSpan s : _) = srcSpanFile s
  1154
+          startLoc = mkRealSrcLoc sourceFile 1 1
1151 1155
           go _ [] = id
1152 1156
           go loc ((L span _, str):ts)
1153  
-              | not (isGoodSrcSpan span) = go loc ts
1154  
-              | locLine == tokLine = ((replicate (tokCol - locCol) ' ') ++)
1155  
-                                     . (str ++)
1156  
-                                     . go tokEnd ts
1157  
-              | otherwise = ((replicate (tokLine - locLine) '\n') ++)
1158  
-                            . ((replicate tokCol ' ') ++)
1159  
-                            . (str ++)
1160  
-                            . go tokEnd ts
1161  
-              where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
1162  
-                    (tokLine, tokCol) = (srcSpanStartLine span, srcSpanStartCol span)
1163  
-                    tokEnd = srcSpanEnd span
  1157
+              = case span of
  1158
+                UnhelpfulSpan _ -> go loc ts
  1159
+                RealSrcSpan s
  1160
+                 | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++)
  1161
+                                       . (str ++)
  1162
+                                       . go tokEnd ts
  1163
+                 | otherwise -> ((replicate (tokLine - locLine) '\n') ++)
  1164
+                              . ((replicate tokCol ' ') ++)
  1165
+                              . (str ++)
  1166
+                              . go tokEnd ts
  1167
+                  where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)
  1168
+                        (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s)
  1169
+                        tokEnd = realSrcSpanEnd s
1164 1170
 
1165 1171
 -- -----------------------------------------------------------------------------
1166 1172
 -- Interactive evaluation
@@ -1258,7 +1264,7 @@ parser :: String         -- ^ Haskell module source text (full Unicode is suppor
1258 1264
 
1259 1265
 parser str dflags filename = 
1260 1266
    let
1261  
-       loc  = mkSrcLoc (mkFastString filename) 1 1
  1267
+       loc  = mkRealSrcLoc (mkFastString filename) 1 1
1262 1268
        buf  = stringToStringBuffer str
1263 1269
    in
1264 1270
    case unP Parser.parseModule (mkPState dflags buf loc) of
10  compiler/main/HeaderInfo.hs
@@ -55,7 +55,7 @@ getImports :: DynFlags
55 55
            -> IO ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName)
56 56
               -- ^ The source imports, normal imports, and the module name.
57 57
 getImports dflags buf filename source_filename = do
58  
-  let loc  = mkSrcLoc (mkFastString filename) 1 1
  58
+  let loc  = mkRealSrcLoc (mkFastString filename) 1 1
59 59
   case unP parseHeader (mkPState dflags buf loc) of
60 60
     PFailed span err -> parseError span err
61 61
     POk pst rdr_module -> do
@@ -143,7 +143,7 @@ lazyGetToks dflags filename handle = do
143 143
   buf <- hGetStringBufferBlock handle blockSize
144 144
   unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False
145 145
  where
146  
-  loc  = mkSrcLoc (mkFastString filename) 1 1
  146
+  loc  = mkRealSrcLoc (mkFastString filename) 1 1
147 147
 
148 148
   lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token]
149 149
   lazyLexBuf handle state eof = do
@@ -160,7 +160,7 @@ lazyGetToks dflags filename handle = do
160 160
                   _other    -> do rest <- lazyLexBuf handle state' eof
161 161
                                   return (t : rest)
162 162
       _ | not eof   -> getMore handle state
163  
-        | otherwise -> return [L (last_loc state) ITeof]
  163
+        | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof]
164 164
                          -- parser assumes an ITeof sentinel at the end
165 165
 
166 166
   getMore :: Handle -> PState -> IO [Located Token]
@@ -175,12 +175,12 @@ lazyGetToks dflags filename handle = do
175 175
 getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]
176 176
 getToks dflags filename buf = lexAll (pragState dflags buf loc)
177 177
  where
178  
-  loc  = mkSrcLoc (mkFastString filename) 1 1
  178
+  loc  = mkRealSrcLoc (mkFastString filename) 1 1
179 179
 
180 180
   lexAll state = case unP (lexer return) state of
181 181
                    POk _      t@(L _ ITeof) -> [t]
182 182
                    POk state' t -> t : lexAll state'
183  
-                   _ -> [L (last_loc state) ITeof]
  183
+                   _ -> [L (RealSrcSpan (last_loc state)) ITeof]
184 184
 
185 185
 
186 186
 -- | Parse OPTIONS and LANGUAGE pragmas of the source file.
4  compiler/main/HscMain.lhs
@@ -340,7 +340,7 @@ hscParse' mod_summary
340 340
             Just b  -> return b
341 341
             Nothing -> liftIO $ hGetStringBuffer src_filename
342 342
 
343  
-   let loc  = mkSrcLoc (mkFastString src_filename) 1 1
  343
+   let loc  = mkRealSrcLoc (mkFastString src_filename) 1 1
344 344
 
345 345
    case unP parseModule (mkPState dflags buf loc) of
346 346
      PFailed span err ->
@@ -1186,7 +1186,7 @@ hscParseThingWithLocation source linenumber parser str
1186 1186
       liftIO $ showPass dflags "Parser"
1187 1187
 
1188 1188
       let buf = stringToStringBuffer str
1189  
-          loc  = mkSrcLoc (fsLit source) linenumber 1
  1189
+          loc  = mkRealSrcLoc (fsLit source) linenumber 1
1190 1190
 
1191 1191
       case unP parser (mkPState dflags buf loc) of
1192 1192
 
2  compiler/main/HscTypes.lhs
@@ -136,7 +136,7 @@ import CoreSyn		( CoreRule, CoreVect )
136 136
 import Maybes		( orElse, expectJust, catMaybes )
137 137
 import Outputable
138 138
 import BreakArray
139  
-import SrcLoc		( SrcSpan, Located(..) )
  139
+import SrcLoc
140 140
 import UniqFM		( lookupUFM, eltsUFM, emptyUFM )
141 141
 import UniqSupply	( UniqSupply )
142 142
 import FastString
143  compiler/parser/Lexer.x
@@ -7,7 +7,8 @@
7 7
 -- definition, with some hand-coded bits.
8 8
 --
9 9
 -- Completely accurate information about token-spans within the source
10  
--- file is maintained.  Every token has a start and end SrcLoc attached to it.
  10
+-- file is maintained.  Every token has a start and end RealSrcLoc
  11
+-- attached to it.
11 12
 --
12 13
 -----------------------------------------------------------------------------
13 14
 
@@ -555,7 +556,7 @@ data Token
555 556
   | ITparenEscape		--  $( 
556 557
   | ITvarQuote			--  '
557 558
   | ITtyQuote			--  ''
558  
-  | ITquasiQuote (FastString,FastString,SrcSpan) --  [:...|...|]
  559
+  | ITquasiQuote (FastString,FastString,RealSrcSpan) --  [:...|...|]
559 560
 
560 561
   -- Arrow notation extension
561 562
   | ITproc
@@ -721,7 +722,7 @@ reservedSymsFM = listToUFM $
721 722
 -- -----------------------------------------------------------------------------
722 723
 -- Lexer actions
723 724
 
724  
-type Action = SrcSpan -> StringBuffer -> Int -> P (Located Token)
  725
+type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token)
725 726
 
726 727
 special :: Token -> Action
727 728
 special tok span _buf _len = return (L span tok)
@@ -764,7 +765,7 @@ hopefully_open_brace span buf len
764 765
                  Layout prev_off : _ -> prev_off < offset
765 766
                  _                   -> True
766 767
       if isOK then pop_and open_brace span buf len
767  
-              else failSpanMsgP span (text "Missing block")
  768
+              else failSpanMsgP (RealSrcSpan span) (text "Missing block")
768 769
 
769 770
 pop_and :: Action -> Action
770 771
 pop_and act span buf len = do _ <- popLexState
@@ -846,7 +847,7 @@ lineCommentToken span buf len = do
846 847
   nested comments require traversing by hand, they can't be parsed
847 848
   using regular expressions.
848 849
 -}
849  
-nested_comment :: P (Located Token) -> Action
  850
+nested_comment :: P (RealLocated Token) -> Action
850 851
 nested_comment cont span _str _len = do
851 852
   input <- getInput
852 853
   go "" (1::Int) input
@@ -887,8 +888,8 @@ nested_doc_comment span buf _len = withLexedDocType (go "")
887 888
         Just (_,_) -> go ('\123':commentAcc) input docType False
888 889
       Just (c,input) -> go (c:commentAcc) input docType False
889 890
 
890  
-withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (Located Token))
891  
-                 -> P (Located Token)
  891
+withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token))
  892
+                 -> P (RealLocated Token)
892 893
 withLexedDocType lexDocComment = do
893 894
   input@(AI _ buf) <- getInput
894 895
   case prevChar buf ' ' of
@@ -925,19 +926,19 @@ endPrag span _buf _len = do
925 926
 -- called afterwards, so it can just update the state. 
926 927
 
927 928
 docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer ->
928  
-                 SrcSpan -> P (Located Token) 
  929
+                 RealSrcSpan -> P (RealLocated Token) 
929 930
 docCommentEnd input commentAcc docType buf span = do
930 931
   setInput input
931 932
   let (AI loc nextBuf) = input
932 933
       comment = reverse commentAcc
933  
-      span' = mkSrcSpan (srcSpanStart span) loc
  934
+      span' = mkRealSrcSpan (realSrcSpanStart span) loc
934 935
       last_len = byteDiff buf nextBuf
935 936
       
936 937
   span `seq` setLastToken span' last_len
937 938
   return (L span' (docType comment))
938 939
  
939  
-errBrace :: AlexInput -> SrcSpan -> P a
940  
-errBrace (AI end _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'"
  940
+errBrace :: AlexInput -> RealSrcSpan -> P a
  941
+errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'"
941 942
 
942 943
 open_brace, close_brace :: Action
943 944
 open_brace span _str _len = do 
@@ -1012,8 +1013,8 @@ varsym, consym :: Action
1012 1013
 varsym = sym ITvarsym
1013 1014
 consym = sym ITconsym
1014 1015
 
1015  
-sym :: (FastString -> Token) -> SrcSpan -> StringBuffer -> Int
1016  
-    -> P (Located Token)
  1016
+sym :: (FastString -> Token) -> RealSrcSpan -> StringBuffer -> Int
  1017
+    -> P (RealLocated Token)
1017 1018
 sym con span buf len = 
1018 1019
   case lookupUFM reservedSymsFM fs of
1019 1020
 	Just (keyword,exts) -> do
@@ -1145,7 +1146,7 @@ do_layout_left span _buf _len = do
1145 1146
 setLine :: Int -> Action
1146 1147
 setLine code span buf len = do
1147 1148
   let line = parseUnsignedInteger buf len 10 octDecDigit
1148  
-  setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
  1149
+  setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
1149 1150
 	-- subtract one: the line number refers to the *following* line
1150 1151
   _ <- popLexState
1151 1152
   pushLexState code
@@ -1154,12 +1155,17 @@ setLine code span buf len = do
1154 1155
 setFile :: Int -> Action
1155 1156
 setFile code span buf len = do
1156 1157
   let file = lexemeToFastString (stepOn buf) (len-2)
1157  
-  setAlrLastLoc noSrcSpan
1158  
-  setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
  1158
+  setAlrLastLoc $ alrInitialLoc file
  1159
+  setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
1159 1160
   _ <- popLexState
1160 1161
   pushLexState code
1161 1162
   lexToken
1162 1163
 
  1164
+alrInitialLoc :: FastString -> RealSrcSpan
  1165
+alrInitialLoc file = mkRealSrcSpan loc loc
  1166
+    where -- This is a hack to ensure that the first line in a file
  1167
+          -- looks like it is after the initial location:
  1168
+          loc = mkRealSrcLoc file (-1) (-1)
1163 1169
 
1164 1170
 -- -----------------------------------------------------------------------------
1165 1171
 -- Options, includes and language pragmas.
@@ -1170,7 +1176,7 @@ lex_string_prag mkTok span _buf _len
1170 1176
          start <- getSrcLoc
1171 1177
          tok <- go [] input
1172 1178
          end <- getSrcLoc
1173  
-         return (L (mkSrcSpan start end) tok)
  1179
+         return (L (mkRealSrcSpan start end) tok)
1174 1180
     where go acc input
1175 1181
               = if isString input "#-}"
1176 1182
                    then do setInput input
@@ -1183,7 +1189,7 @@ lex_string_prag mkTok span _buf _len
1183 1189
               = case alexGetChar i of
1184 1190
                   Just (c,i') | c == x    -> isString i' xs
1185 1191
                   _other -> False
1186  
-          err (AI end _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma"
  1192
+          err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma"
1187 1193
 
1188 1194
 
1189 1195
 -- -----------------------------------------------------------------------------
@@ -1195,7 +1201,7 @@ lex_string_tok :: Action
1195 1201
 lex_string_tok span _buf _len = do
1196 1202
   tok <- lex_string ""
1197 1203
   end <- getSrcLoc 
1198  
-  return (L (mkSrcSpan (srcSpanStart span) end) tok)
  1204
+  return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok)
1199 1205
 
1200 1206
 lex_string :: String -> P Token
1201 1207
 lex_string s = do
@@ -1256,7 +1262,7 @@ lex_char_tok :: Action
1256 1262
 -- see if there's a trailing quote
1257 1263
 lex_char_tok span _buf _len = do	-- We've seen '
1258 1264
    i1 <- getInput	-- Look ahead to first character
1259  
-   let loc = srcSpanStart span
  1265
+   let loc = realSrcSpanStart span
1260 1266
    case alexGetChar' i1 of
1261 1267
 	Nothing -> lit_error  i1
1262 1268
 
@@ -1264,7 +1270,7 @@ lex_char_tok span _buf _len = do	-- We've seen '
1264 1270
 		  th_exts <- extension thEnabled
1265 1271
 		  if th_exts then do
1266 1272
 			setInput i2
1267  
-			return (L (mkSrcSpan loc end2)  ITtyQuote)
  1273
+			return (L (mkRealSrcSpan loc end2)  ITtyQuote)
1268 1274
 		   else lit_error i1
1269 1275
 
1270 1276
 	Just ('\\', i2@(AI _end2 _)) -> do 	-- We've seen 'backslash
@@ -1290,10 +1296,10 @@ lex_char_tok span _buf _len = do	-- We've seen '
1290 1296
 					-- If TH is on, just parse the quote only
1291 1297
 			th_exts <- extension thEnabled	
1292 1298
 			let (AI end _) = i1
1293  
-			if th_exts then return (L (mkSrcSpan loc end) ITvarQuote)
  1299
+			if th_exts then return (L (mkRealSrcSpan loc end) ITvarQuote)
1294 1300
 				   else lit_error i2
1295 1301
 
1296  
-finish_char_tok :: SrcLoc -> Char -> P (Located Token)
  1302
+finish_char_tok :: RealSrcLoc -> Char -> P (RealLocated Token)
1297 1303
 finish_char_tok loc ch	-- We've already seen the closing quote
1298 1304
 			-- Just need to check for trailing #
1299 1305
   = do	magicHash <- extension magicHashEnabled
@@ -1302,11 +1308,11 @@ finish_char_tok loc ch	-- We've already seen the closing quote
1302 1308
 		case alexGetChar' i of
1303 1309
 			Just ('#',i@(AI end _)) -> do
1304 1310
 				setInput i
1305  
-				return (L (mkSrcSpan loc end) (ITprimchar ch))
  1311
+				return (L (mkRealSrcSpan loc end) (ITprimchar ch))
1306 1312
 			_other ->
1307  
-				return (L (mkSrcSpan loc end) (ITchar ch))
  1313
+				return (L (mkRealSrcSpan loc end) (ITchar ch))
1308 1314
 	    else do
1309  
-		   return (L (mkSrcSpan loc end) (ITchar ch))
  1315
+		   return (L (mkRealSrcSpan loc end) (ITchar ch))
1310 1316
 
1311 1317
 isAny :: Char -> Bool
1312 1318
 isAny c | c > '\x7f' = isPrint c
@@ -1441,10 +1447,10 @@ lex_quasiquote_tok span buf len = do
1441 1447
   quoteStart <- getSrcLoc              
1442 1448
   quote <- lex_quasiquote ""
1443 1449
   end <- getSrcLoc 
1444  
-  return (L (mkSrcSpan (srcSpanStart span) end)
  1450
+  return (L (mkRealSrcSpan (realSrcSpanStart span) end)
1445 1451
            (ITquasiQuote (mkFastString quoter,
1446 1452
                           mkFastString (reverse quote),
1447  
-                          mkSrcSpan quoteStart end)))
  1453
+                          mkRealSrcSpan quoteStart end)))
1448 1454
 
1449 1455
 lex_quasiquote :: String -> P String
1450 1456
 lex_quasiquote s = do
@@ -1472,12 +1478,12 @@ lex_quasiquote s = do
1472 1478
 
1473 1479
 warn :: DynFlag -> SDoc -> Action
1474 1480
 warn option warning srcspan _buf _len = do
1475  
-    addWarning option srcspan warning
  1481
+    addWarning option (RealSrcSpan srcspan) warning
1476 1482
     lexToken
1477 1483
 
1478 1484
 warnThen :: DynFlag -> SDoc -> Action -> Action
1479 1485
 warnThen option warning action srcspan buf len = do
1480  
-    addWarning option srcspan warning
  1486
+    addWarning option (RealSrcSpan srcspan) warning
1481 1487
     action srcspan buf len
1482 1488
 
1483 1489
 -- -----------------------------------------------------------------------------
@@ -1500,22 +1506,22 @@ data PState = PState {
1500 1506
 	buffer	   :: StringBuffer,
1501 1507
         dflags     :: DynFlags,
1502 1508
         messages   :: Messages,
1503  
-        last_loc   :: SrcSpan,	-- pos of previous token
  1509
+        last_loc   :: RealSrcSpan,	-- pos of previous token
1504 1510
 	last_len   :: !Int,	-- len of previous token
1505  
-        loc        :: SrcLoc,   -- current loc (end of prev token + 1)
  1511
+        loc        :: RealSrcLoc,   -- current loc (end of prev token + 1)
1506 1512
 	extsBitmap :: !Int,	-- bitmap that determines permitted extensions
1507 1513
 	context	   :: [LayoutContext],
1508 1514
 	lex_state  :: [Int],
1509 1515
         -- Used in the alternative layout rule:
1510 1516
         -- These tokens are the next ones to be sent out. They are
1511 1517
         -- just blindly emitted, without the rule looking at them again:
1512  
-        alr_pending_implicit_tokens :: [Located Token],
  1518
+        alr_pending_implicit_tokens :: [RealLocated Token],
1513 1519
         -- This is the next token to be considered or, if it is Nothing,
1514 1520
         -- we need to get the next token from the input stream:
1515  
-        alr_next_token :: Maybe (Located Token),
  1521
+        alr_next_token :: Maybe (RealLocated Token),
1516 1522
         -- This is what we consider to be the locatino of the last token
1517 1523
         -- emitted:
1518  
-        alr_last_loc :: SrcSpan,
  1524
+        alr_last_loc :: RealSrcSpan,
1519 1525
         -- The stack of layout contexts:
1520 1526
         alr_context :: [ALRContext],
1521 1527
         -- Are we expecting a '{'? If it's Just, then the ALRLayout tells
@@ -1556,13 +1562,13 @@ thenP :: P a -> (a -> P b) -> P b
1556 1562
 		PFailed span err -> PFailed span err
1557 1563
 
1558 1564
 failP :: String -> P a
1559  
-failP msg = P $ \s -> PFailed (last_loc s) (text msg)
  1565
+failP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)
1560 1566
 
1561 1567
 failMsgP :: String -> P a
1562  
-failMsgP msg = P $ \s -> PFailed (last_loc s) (text msg)
  1568
+failMsgP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg)
1563 1569
 
1564  
-failLocMsgP :: SrcLoc -> SrcLoc -> String -> P a
1565  
-failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (mkSrcSpan loc1 loc2) (text str)
  1570
+failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a
  1571
+failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str)
1566 1572
 
1567 1573
 failSpanMsgP :: SrcSpan -> SDoc -> P a
1568 1574
 failSpanMsgP span msg = P $ \_ -> PFailed span msg
@@ -1587,19 +1593,19 @@ getExts = P $ \s -> POk s (extsBitmap s)
1587 1593
 setExts :: (Int -> Int) -> P ()
1588 1594
 setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } ()
1589 1595
 
1590  
-setSrcLoc :: SrcLoc -> P ()
  1596
+setSrcLoc :: RealSrcLoc -> P ()
1591 1597
 setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} ()
1592 1598
 
1593  
-getSrcLoc :: P SrcLoc
  1599
+getSrcLoc :: P RealSrcLoc