SrcLoc.hs 22.7 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
-- (c) The University of Glasgow, 1992-2006
2

Alan Zimmerman's avatar
Alan Zimmerman committed
3
{-# LANGUAGE CPP #-}
4
{-# LANGUAGE DeriveDataTypeable #-}
Alan Zimmerman's avatar
Alan Zimmerman committed
5 6 7 8
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveFoldable     #-}
{-# LANGUAGE DeriveTraversable  #-}
{-# LANGUAGE FlexibleInstances  #-}
9 10 11 12 13
{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
   -- Workaround for Trac #5252 crashes the bootstrap compiler without -O
   -- When the earliest compiler we want to boostrap with is
   -- GHC 7.2, we can make RealSrcLoc properly abstract

batterseapower's avatar
batterseapower committed
14 15
-- | This module contains types that relate to the positions of things
-- in source files, and allow tagging of those things with locations
16
module SrcLoc (
17 18 19
        -- * SrcLoc
        RealSrcLoc,             -- Abstract
        SrcLoc(..),
20

batterseapower's avatar
batterseapower committed
21
        -- ** Constructing SrcLoc
22
        mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc,
23

24 25 26
        noSrcLoc,               -- "I'm sorry, I haven't a clue"
        generatedSrcLoc,        -- Code generated within the compiler
        interactiveSrcLoc,      -- Code from an interactive session
27

batterseapower's avatar
batterseapower committed
28 29
        advanceSrcLoc,

30 31 32 33 34 35
        -- ** Unsafely deconstructing SrcLoc
        -- These are dubious exports, because they crash on some inputs
        srcLocFile,             -- return the file name part
        srcLocLine,             -- return the line part
        srcLocCol,              -- return the column part

batterseapower's avatar
batterseapower committed
36
        -- * SrcSpan
37 38
        RealSrcSpan,            -- Abstract
        SrcSpan(..),
batterseapower's avatar
batterseapower committed
39 40

        -- ** Constructing SrcSpan
41 42 43 44 45 46 47 48 49 50
        mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,
        noSrcSpan,
        wiredInSrcSpan,         -- Something wired into the compiler
        srcLocSpan, realSrcLocSpan,
        combineSrcSpans,

        -- ** Deconstructing SrcSpan
        srcSpanStart, srcSpanEnd,
        realSrcSpanStart, realSrcSpanEnd,
        srcSpanFileName_maybe,
Peter Wortmann's avatar
Peter Wortmann committed
51
        showUserSpan, pprUserRealSpan,
52 53 54 55 56

        -- ** Unsafely deconstructing SrcSpan
        -- These are dubious exports, because they crash on some inputs
        srcSpanFile,
        srcSpanStartLine, srcSpanEndLine,
57
        srcSpanStartCol, srcSpanEndCol,
58

batterseapower's avatar
batterseapower committed
59 60
        -- ** Predicates on SrcSpan
        isGoodSrcSpan, isOneLineSpan,
Peter Wortmann's avatar
Peter Wortmann committed
61
        containsSpan,
batterseapower's avatar
batterseapower committed
62 63

        -- * Located
64 65 66 67 68 69
        Located,
        RealLocated,
        GenLocated(..),

        -- ** Constructing Located
        noLoc,
Simon Marlow's avatar
Simon Marlow committed
70
        mkGeneralLocated,
71 72 73 74 75 76 77

        -- ** Deconstructing Located
        getLoc, unLoc,

        -- ** Combining and comparing Located values
        eqLocated, cmpLocated, combineLocs, addCLoc,
        leftmost_smallest, leftmost_largest, rightmost,
78
        spans, isSubspanOf, sortLocated
79
    ) where
80

Simon Marlow's avatar
Simon Marlow committed
81
import Util
82
import Outputable
83
import FastString
84

Alan Zimmerman's avatar
Alan Zimmerman committed
85 86 87 88
#if __GLASGOW_HASKELL__ < 709
import Data.Foldable ( Foldable )
import Data.Traversable ( Traversable )
#endif
89
import Data.Bits
90
import Data.Data
Ian Lynagh's avatar
Ian Lynagh committed
91 92
import Data.List
import Data.Ord
93

Austin Seipp's avatar
Austin Seipp committed
94 95 96
{-
************************************************************************
*                                                                      *
97
\subsection[SrcLoc-SrcLocations]{Source-location information}
Austin Seipp's avatar
Austin Seipp committed
98 99
*                                                                      *
************************************************************************
100 101 102

We keep information about the {\em definition} point for each entity;
this is the obvious stuff:
Austin Seipp's avatar
Austin Seipp committed
103 104
-}

batterseapower's avatar
batterseapower committed
105
-- | Represents a single point within a file
Ian Lynagh's avatar
Ian Lynagh committed
106
data RealSrcLoc
107 108 109
  = SrcLoc      FastString              -- A precise location (file name)
                {-# UNPACK #-} !Int     -- line number, begins at 1
                {-# UNPACK #-} !Int     -- column number, begins at 1
batterseapower's avatar
batterseapower committed
110

Ian Lynagh's avatar
Ian Lynagh committed
111 112
data SrcLoc
  = RealSrcLoc {-# UNPACK #-}!RealSrcLoc
113
  | UnhelpfulLoc FastString     -- Just a general indication
114
  deriving Show
115

Austin Seipp's avatar
Austin Seipp committed
116 117 118
{-
************************************************************************
*                                                                      *
batterseapower's avatar
batterseapower committed
119
\subsection[SrcLoc-access-fns]{Access functions}
Austin Seipp's avatar
Austin Seipp committed
120 121 122
*                                                                      *
************************************************************************
-}
123

Simon Marlow's avatar
Simon Marlow committed
124
mkSrcLoc :: FastString -> Int -> Int -> SrcLoc
Ian Lynagh's avatar
Ian Lynagh committed
125 126 127 128
mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col)

mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc x line col = SrcLoc x line col
Simon Marlow's avatar
Simon Marlow committed
129

batterseapower's avatar
batterseapower committed
130
-- | Built-in "bad" 'SrcLoc' values for particular locations
Simon Marlow's avatar
Simon Marlow committed
131
noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc
132
noSrcLoc          = UnhelpfulLoc (fsLit "<no location info>")
Ian Lynagh's avatar
Ian Lynagh committed
133 134
generatedSrcLoc   = UnhelpfulLoc (fsLit "<compiler-generated code>")
interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive session>")
135

batterseapower's avatar
batterseapower committed
136
-- | Creates a "bad" 'SrcLoc' that has no detailed information about its location
137
mkGeneralSrcLoc :: FastString -> SrcLoc
138
mkGeneralSrcLoc = UnhelpfulLoc
139

Ian Lynagh's avatar
Ian Lynagh committed
140 141
-- | Gives the filename of the 'RealSrcLoc'
srcLocFile :: RealSrcLoc -> FastString
142 143
srcLocFile (SrcLoc fname _ _) = fname

batterseapower's avatar
batterseapower committed
144
-- | Raises an error when used on a "bad" 'SrcLoc'
Ian Lynagh's avatar
Ian Lynagh committed
145
srcLocLine :: RealSrcLoc -> Int
Simon Marlow's avatar
Simon Marlow committed
146
srcLocLine (SrcLoc _ l _) = l
sof's avatar
sof committed
147

batterseapower's avatar
batterseapower committed
148
-- | Raises an error when used on a "bad" 'SrcLoc'
Ian Lynagh's avatar
Ian Lynagh committed
149
srcLocCol :: RealSrcLoc -> Int
Simon Marlow's avatar
Simon Marlow committed
150
srcLocCol (SrcLoc _ _ c) = c
151

152 153 154
-- | Move the 'SrcLoc' down by one line if the character is a newline,
-- to the next 8-char tabstop if it is a tab, and across by one
-- character in any other case
Ian Lynagh's avatar
Ian Lynagh committed
155
advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc
156
advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f  (l + 1) 1
157
advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f  l (((((c - 1) `shiftR` 3) + 1)
158
                                                  `shiftL` 3) + 1)
159
advanceSrcLoc (SrcLoc f l c) _    = SrcLoc f  l (c + 1)
160

Austin Seipp's avatar
Austin Seipp committed
161 162 163
{-
************************************************************************
*                                                                      *
164
\subsection[SrcLoc-instances]{Instance declarations for various names}
Austin Seipp's avatar
Austin Seipp committed
165 166 167
*                                                                      *
************************************************************************
-}
168

169 170 171
-- SrcLoc is an instance of Ord so that we can sort error messages easily
instance Eq SrcLoc where
  loc1 == loc2 = case loc1 `cmpSrcLoc` loc2 of
Ian Lynagh's avatar
Ian Lynagh committed
172 173 174 175 176 177 178
                 EQ     -> True
                 _other -> False

instance Eq RealSrcLoc where
  loc1 == loc2 = case loc1 `cmpRealSrcLoc` loc2 of
                 EQ     -> True
                 _other -> False
179 180 181

instance Ord SrcLoc where
  compare = cmpSrcLoc
Ian Lynagh's avatar
Ian Lynagh committed
182 183 184 185

instance Ord RealSrcLoc where
  compare = cmpRealSrcLoc

186
sortLocated :: [Located a] -> [Located a]
Ian Lynagh's avatar
Ian Lynagh committed
187
sortLocated things = sortBy (comparing getLoc) things
188

Simon Marlow's avatar
Simon Marlow committed
189
cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering
190
cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2
Ian Lynagh's avatar
Ian Lynagh committed
191 192 193
cmpSrcLoc (UnhelpfulLoc _)  (RealSrcLoc _)    = GT
cmpSrcLoc (RealSrcLoc _)    (UnhelpfulLoc _)  = LT
cmpSrcLoc (RealSrcLoc l1)   (RealSrcLoc l2)   = (l1 `compare` l2)
194

Ian Lynagh's avatar
Ian Lynagh committed
195 196
cmpRealSrcLoc :: RealSrcLoc -> RealSrcLoc -> Ordering
cmpRealSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2)
197
  = (s1 `compare` s2) `thenCmp` (l1 `compare` l2) `thenCmp` (c1 `compare` c2)
198

Ian Lynagh's avatar
Ian Lynagh committed
199
instance Outputable RealSrcLoc where
200
    ppr (SrcLoc src_path src_line src_col)
201 202 203 204 205 206 207 208 209 210 211 212 213
      = hcat [ pprFastFilePath src_path <> colon
             , int src_line <> colon
             , int src_col ]

-- I don't know why there is this style-based difference
--        if userStyle sty || debugStyle sty then
--            hcat [ pprFastFilePath src_path, char ':',
--                   int src_line,
--                   char ':', int src_col
--                 ]
--        else
--            hcat [text "{-# LINE ", int src_line, space,
--                  char '\"', pprFastFilePath src_path, text " #-}"]
214

Ian Lynagh's avatar
Ian Lynagh committed
215 216
instance Outputable SrcLoc where
    ppr (RealSrcLoc l) = ppr l
217
    ppr (UnhelpfulLoc s)  = ftext s
218

Ian Lynagh's avatar
Ian Lynagh committed
219 220 221 222 223 224
instance Data RealSrcSpan where
  -- don't traverse?
  toConstr _   = abstractConstr "RealSrcSpan"
  gunfold _ _  = error "gunfold"
  dataTypeOf _ = mkNoRepType "RealSrcSpan"

225 226 227 228 229
instance Data SrcSpan where
  -- don't traverse?
  toConstr _   = abstractConstr "SrcSpan"
  gunfold _ _  = error "gunfold"
  dataTypeOf _ = mkNoRepType "SrcSpan"
230

Austin Seipp's avatar
Austin Seipp committed
231 232 233
{-
************************************************************************
*                                                                      *
234
\subsection[SrcSpan]{Source Spans}
Austin Seipp's avatar
Austin Seipp committed
235 236 237
*                                                                      *
************************************************************************
-}
238 239 240 241 242 243 244

{- |
A SrcSpan delimits a portion of a text file.  It could be represented
by a pair of (line,column) coordinates, but in fact we optimise
slightly by using more compact representations for single-line and
zero-length spans, both of which are quite common.

batterseapower's avatar
batterseapower committed
245
The end position is defined to be the column /after/ the end of the
246 247 248
span.  That is, a span of (1,1)-(1,2) is one character long, and a
span of (1,1)-(1,1) is zero characters long.
-}
Ian Lynagh's avatar
Ian Lynagh committed
249
data RealSrcSpan
250 251 252 253 254 255
  = SrcSpanOneLine              -- a common case: a single line
        { srcSpanFile     :: !FastString,
          srcSpanLine     :: {-# UNPACK #-} !Int,
          srcSpanSCol     :: {-# UNPACK #-} !Int,
          srcSpanECol     :: {-# UNPACK #-} !Int
        }
256 257

  | SrcSpanMultiLine
258 259 260 261 262 263
        { srcSpanFile     :: !FastString,
          srcSpanSLine    :: {-# UNPACK #-} !Int,
          srcSpanSCol     :: {-# UNPACK #-} !Int,
          srcSpanELine    :: {-# UNPACK #-} !Int,
          srcSpanECol     :: {-# UNPACK #-} !Int
        }
264 265

  | SrcSpanPoint
266 267 268 269
        { srcSpanFile     :: !FastString,
          srcSpanLine     :: {-# UNPACK #-} !Int,
          srcSpanCol      :: {-# UNPACK #-} !Int
        }
270
  deriving (Eq, Typeable)
271

Ian Lynagh's avatar
Ian Lynagh committed
272 273
data SrcSpan =
    RealSrcSpan !RealSrcSpan
274 275
  | UnhelpfulSpan !FastString   -- Just a general indication
                                -- also used to indicate an empty span
276

Peter Wortmann's avatar
Peter Wortmann committed
277 278
  deriving (Eq, Ord, Typeable, Show) -- Show is used by Lexer.x, because we
                                     -- derive Show for Token
279

batterseapower's avatar
batterseapower committed
280
-- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty
Simon Marlow's avatar
Simon Marlow committed
281
noSrcSpan, wiredInSrcSpan :: SrcSpan
Ian Lynagh's avatar
Ian Lynagh committed
282 283
noSrcSpan      = UnhelpfulSpan (fsLit "<no location info>")
wiredInSrcSpan = UnhelpfulSpan (fsLit "<wired into compiler>")
284

batterseapower's avatar
batterseapower committed
285
-- | Create a "bad" 'SrcSpan' that has not location information
286 287 288
mkGeneralSrcSpan :: FastString -> SrcSpan
mkGeneralSrcSpan = UnhelpfulSpan

batterseapower's avatar
batterseapower committed
289 290 291
-- | Create a 'SrcSpan' corresponding to a single point
srcLocSpan :: SrcLoc -> SrcSpan
srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str
Ian Lynagh's avatar
Ian Lynagh committed
292 293 294 295
srcLocSpan (RealSrcLoc l) = RealSrcSpan (realSrcLocSpan l)

realSrcLocSpan :: RealSrcLoc -> RealSrcSpan
realSrcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col
batterseapower's avatar
batterseapower committed
296 297

-- | Create a 'SrcSpan' between two points in a file
Ian Lynagh's avatar
Ian Lynagh committed
298 299
mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan loc1 loc2
batterseapower's avatar
batterseapower committed
300
  | line1 == line2 = if col1 == col2
301 302
                        then SrcSpanPoint file line1 col1
                        else SrcSpanOneLine file line1 col1 col2
batterseapower's avatar
batterseapower committed
303 304
  | otherwise      = SrcSpanMultiLine file line1 col1 line2 col2
  where
305 306 307 308 309
        line1 = srcLocLine loc1
        line2 = srcLocLine loc2
        col1 = srcLocCol loc1
        col2 = srcLocCol loc2
        file = srcLocFile loc1
batterseapower's avatar
batterseapower committed
310

Ian Lynagh's avatar
Ian Lynagh committed
311 312 313 314 315 316 317
-- | Create a 'SrcSpan' between two points in a file
mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str
mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str
mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2)
    = RealSrcSpan (mkRealSrcSpan loc1 loc2)

batterseapower's avatar
batterseapower committed
318 319
-- | Combines two 'SrcSpan' into one that spans at least all the characters
-- within both spans. Assumes the "file" part is the same in both inputs
320 321 322 323
combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful
combineSrcSpans l (UnhelpfulSpan _) = l
combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2)
Ian Lynagh's avatar
Ian Lynagh committed
324 325 326 327 328 329
    = RealSrcSpan (combineRealSrcSpans span1 span2)

-- | Combines two 'SrcSpan' into one that spans at least all the characters
-- within both spans. Assumes the "file" part is the same in both inputs
combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan
combineRealSrcSpans span1 span2
330
 = if line_start == line_end
331 332 333 334
   then if col_start == col_end
        then SrcSpanPoint     file line_start col_start
        else SrcSpanOneLine   file line_start col_start col_end
   else      SrcSpanMultiLine file line_start col_start line_end col_end
batterseapower's avatar
batterseapower committed
335
  where
336
    (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1)
337
                                  (srcSpanStartLine span2, srcSpanStartCol span2)
338
    (line_end, col_end)     = max (srcSpanEndLine span1, srcSpanEndCol span1)
339
                                  (srcSpanEndLine span2, srcSpanEndCol span2)
340
    file = srcSpanFile span1
batterseapower's avatar
batterseapower committed
341

Austin Seipp's avatar
Austin Seipp committed
342 343 344
{-
************************************************************************
*                                                                      *
batterseapower's avatar
batterseapower committed
345
\subsection[SrcSpan-predicates]{Predicates}
Austin Seipp's avatar
Austin Seipp committed
346 347 348
*                                                                      *
************************************************************************
-}
batterseapower's avatar
batterseapower committed
349 350

-- | Test if a 'SrcSpan' is "good", i.e. has precise location information
Simon Marlow's avatar
Simon Marlow committed
351
isGoodSrcSpan :: SrcSpan -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
352 353
isGoodSrcSpan (RealSrcSpan _) = True
isGoodSrcSpan (UnhelpfulSpan _) = False
354

355
isOneLineSpan :: SrcSpan -> Bool
356
-- ^ True if the span is known to straddle only one line.
batterseapower's avatar
batterseapower committed
357
-- For "bad" 'SrcSpan', it returns False
Ian Lynagh's avatar
Ian Lynagh committed
358 359
isOneLineSpan (RealSrcSpan s) = srcSpanStartLine s == srcSpanEndLine s
isOneLineSpan (UnhelpfulSpan _) = False
360

Peter Wortmann's avatar
Peter Wortmann committed
361 362 363 364 365 366 367 368 369 370
-- | Tests whether the first span "contains" the other span, meaning
-- that it covers at least as much source code. True where spans are equal.
containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool
containsSpan s1 s2
  = srcSpanFile s1 == srcSpanFile s2
    && (srcSpanStartLine s1, srcSpanStartCol s1)
       <= (srcSpanStartLine s2, srcSpanStartCol s2)
    && (srcSpanEndLine s1, srcSpanEndCol s1)
       >= (srcSpanEndLine s2, srcSpanEndCol s2)

Austin Seipp's avatar
Austin Seipp committed
371
{-
Peter Wortmann's avatar
Peter Wortmann committed
372 373
%************************************************************************
%*                                                                      *
batterseapower's avatar
batterseapower committed
374
\subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions}
Austin Seipp's avatar
Austin Seipp committed
375 376 377
*                                                                      *
************************************************************************
-}
378

Ian Lynagh's avatar
Ian Lynagh committed
379 380 381 382
srcSpanStartLine :: RealSrcSpan -> Int
srcSpanEndLine :: RealSrcSpan -> Int
srcSpanStartCol :: RealSrcSpan -> Int
srcSpanEndCol :: RealSrcSpan -> Int
Simon Marlow's avatar
Simon Marlow committed
383

384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399
srcSpanStartLine SrcSpanOneLine{ srcSpanLine=l } = l
srcSpanStartLine SrcSpanMultiLine{ srcSpanSLine=l } = l
srcSpanStartLine SrcSpanPoint{ srcSpanLine=l } = l

srcSpanEndLine SrcSpanOneLine{ srcSpanLine=l } = l
srcSpanEndLine SrcSpanMultiLine{ srcSpanELine=l } = l
srcSpanEndLine SrcSpanPoint{ srcSpanLine=l } = l

srcSpanStartCol SrcSpanOneLine{ srcSpanSCol=l } = l
srcSpanStartCol SrcSpanMultiLine{ srcSpanSCol=l } = l
srcSpanStartCol SrcSpanPoint{ srcSpanCol=l } = l

srcSpanEndCol SrcSpanOneLine{ srcSpanECol=c } = c
srcSpanEndCol SrcSpanMultiLine{ srcSpanECol=c } = c
srcSpanEndCol SrcSpanPoint{ srcSpanCol=c } = c

Austin Seipp's avatar
Austin Seipp committed
400 401 402
{-
************************************************************************
*                                                                      *
batterseapower's avatar
batterseapower committed
403
\subsection[SrcSpan-access-fns]{Access functions}
Austin Seipp's avatar
Austin Seipp committed
404 405 406
*                                                                      *
************************************************************************
-}
batterseapower's avatar
batterseapower committed
407 408 409

-- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
srcSpanStart :: SrcSpan -> SrcLoc
Ian Lynagh's avatar
Ian Lynagh committed
410 411 412
srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str
srcSpanStart (RealSrcSpan s) = RealSrcLoc (realSrcSpanStart s)

batterseapower's avatar
batterseapower committed
413 414
-- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
srcSpanEnd :: SrcSpan -> SrcLoc
Ian Lynagh's avatar
Ian Lynagh committed
415 416
srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str
srcSpanEnd (RealSrcSpan s) = RealSrcLoc (realSrcSpanEnd s)
Simon Marlow's avatar
Simon Marlow committed
417

Ian Lynagh's avatar
Ian Lynagh committed
418 419 420 421
realSrcSpanStart :: RealSrcSpan -> RealSrcLoc
realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s)
                                  (srcSpanStartLine s)
                                  (srcSpanStartCol s)
422

Ian Lynagh's avatar
Ian Lynagh committed
423 424 425 426
realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc
realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s)
                                (srcSpanEndLine s)
                                (srcSpanEndCol s)
427

batterseapower's avatar
batterseapower committed
428 429
-- | Obtains the filename for a 'SrcSpan' if it is "good"
srcSpanFileName_maybe :: SrcSpan -> Maybe FastString
Ian Lynagh's avatar
Ian Lynagh committed
430 431
srcSpanFileName_maybe (RealSrcSpan s)   = Just (srcSpanFile s)
srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing
432

Austin Seipp's avatar
Austin Seipp committed
433 434 435
{-
************************************************************************
*                                                                      *
batterseapower's avatar
batterseapower committed
436
\subsection[SrcSpan-instances]{Instances}
Austin Seipp's avatar
Austin Seipp committed
437 438 439
*                                                                      *
************************************************************************
-}
batterseapower's avatar
batterseapower committed
440

Peter Wortmann's avatar
Peter Wortmann committed
441 442 443
-- We want to order RealSrcSpans first by the start point, then by the
-- end point.
instance Ord RealSrcSpan where
444
  a `compare` b =
Peter Wortmann's avatar
Peter Wortmann committed
445 446
     (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp`
     (realSrcSpanEnd   a `compare` realSrcSpanEnd   b)
447

448 449 450 451 452 453 454 455 456 457 458 459 460 461 462
instance Show RealSrcLoc where
  show (SrcLoc filename row col)
      = "SrcLoc " ++ show filename ++ " " ++ show row ++ " " ++ show col

-- Show is used by Lexer.x, because we derive Show for Token
instance Show RealSrcSpan where
  show (SrcSpanOneLine file l sc ec)
    = "SrcSpanOneLine " ++ show file ++ " "
                        ++ intercalate " " (map show [l,sc,ec])
  show (SrcSpanMultiLine file sl sc el ec)
    = "SrcSpanMultiLine " ++ show file ++ " "
                          ++ intercalate " " (map show [sl,sc,el,ec])
  show (SrcSpanPoint file l c)
    = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [l,c])

463

Ian Lynagh's avatar
Ian Lynagh committed
464
instance Outputable RealSrcSpan where
465 466 467 468 469 470 471 472 473
    ppr span = pprUserRealSpan True span

-- I don't know why there is this style-based difference
--      = getPprStyle $ \ sty ->
--        if userStyle sty || debugStyle sty then
--           text (showUserRealSpan True span)
--        else
--           hcat [text "{-# LINE ", int (srcSpanStartLine span), space,
--                 char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"]
474

Ian Lynagh's avatar
Ian Lynagh committed
475
instance Outputable SrcSpan where
476
    ppr span = pprUserSpan True span
Ian Lynagh's avatar
Ian Lynagh committed
477

478 479 480 481 482 483 484 485
-- I don't know why there is this style-based difference
--      = getPprStyle $ \ sty ->
--        if userStyle sty || debugStyle sty then
--           pprUserSpan True span
--        else
--           case span of
--           UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan"
--           RealSrcSpan s -> ppr s
486 487

showUserSpan :: Bool -> SrcSpan -> String
488 489 490 491 492 493 494 495 496 497 498 499
showUserSpan show_path span = showSDocSimple (pprUserSpan show_path span)

pprUserSpan :: Bool -> SrcSpan -> SDoc
pprUserSpan _         (UnhelpfulSpan s) = ftext s
pprUserSpan show_path (RealSrcSpan s)   = pprUserRealSpan show_path s

pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc
pprUserRealSpan show_path (SrcSpanOneLine src_path line start_col end_col)
  = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
         , int line <> colon
         , int start_col
         , ppUnless (end_col - start_col <= 1) (char '-' <> int (end_col - 1)) ]
500 501
            -- For single-character or point spans, we just
            -- output the starting column number
502

503 504 505 506 507 508 509 510 511 512 513 514
pprUserRealSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol)
  = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
         , parens (int sline <> comma <> int scol)
         , char '-'
         , parens (int eline <> comma <> int ecol') ]
 where
   ecol' = if ecol == 0 then ecol else ecol - 1

pprUserRealSpan show_path (SrcSpanPoint src_path line col)
  = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
         , int line <> colon
         , int col ]
515

Austin Seipp's avatar
Austin Seipp committed
516 517 518
{-
************************************************************************
*                                                                      *
519
\subsection[Located]{Attaching SrcSpans to things}
Austin Seipp's avatar
Austin Seipp committed
520 521 522
*                                                                      *
************************************************************************
-}
523 524

-- | We attach SrcSpans to lots of things, so let's have a datatype for it.
Ian Lynagh's avatar
Ian Lynagh committed
525
data GenLocated l e = L l e
526
  deriving (Eq, Ord, Typeable, Data)
Alan Zimmerman's avatar
Alan Zimmerman committed
527 528
deriving instance Foldable    (GenLocated l)
deriving instance Traversable (GenLocated l)
529

Ian Lynagh's avatar
Ian Lynagh committed
530 531 532 533
type Located e = GenLocated SrcSpan e
type RealLocated e = GenLocated RealSrcSpan e

unLoc :: GenLocated l e -> e
534 535
unLoc (L _ e) = e

Ian Lynagh's avatar
Ian Lynagh committed
536
getLoc :: GenLocated l e -> l
537 538 539 540 541
getLoc (L l _) = l

noLoc :: e -> Located e
noLoc e = L noSrcSpan e

542 543 544
mkGeneralLocated :: String -> e -> Located e
mkGeneralLocated s e = L (mkGeneralSrcSpan (fsLit s)) e

545 546 547
combineLocs :: Located a -> Located b -> SrcSpan
combineLocs a b = combineSrcSpans (getLoc a) (getLoc b)

batterseapower's avatar
batterseapower committed
548
-- | Combine locations from two 'Located' things and add them to a third thing
549 550 551 552
addCLoc :: Located a -> Located b -> c -> Located c
addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c

-- not clear whether to add a general Eq instance, but this is useful sometimes:
batterseapower's avatar
batterseapower committed
553 554

-- | Tests whether the two located things are equal
555 556 557
eqLocated :: Eq a => Located a -> Located a -> Bool
eqLocated a b = unLoc a == unLoc b

batterseapower's avatar
batterseapower committed
558 559 560
-- not clear whether to add a general Ord instance, but this is useful sometimes:

-- | Tests the ordering of the two located things
561 562 563
cmpLocated :: Ord a => Located a -> Located a -> Ordering
cmpLocated a b = unLoc a `compare` unLoc b

Ian Lynagh's avatar
Ian Lynagh committed
564
instance Functor (GenLocated l) where
565 566
  fmap f (L l e) = L l (f e)

Ian Lynagh's avatar
Ian Lynagh committed
567 568 569 570 571 572 573
instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
  ppr (L l e) = -- TODO: We can't do this since Located was refactored into
                -- GenLocated:
                -- Print spans without the file name etc
                -- ifPprDebug (braces (pprUserSpan False l))
                ifPprDebug (braces (ppr l))
             $$ ppr e
574

Austin Seipp's avatar
Austin Seipp committed
575 576 577
{-
************************************************************************
*                                                                      *
batterseapower's avatar
batterseapower committed
578
\subsection{Ordering SrcSpans for InteractiveUI}
Austin Seipp's avatar
Austin Seipp committed
579 580 581
*                                                                      *
************************************************************************
-}
582

batterseapower's avatar
batterseapower committed
583
-- | Alternative strategies for ordering 'SrcSpan's
584 585
leftmost_smallest, leftmost_largest, rightmost :: SrcSpan -> SrcSpan -> Ordering
rightmost            = flip compare
586
leftmost_smallest    = compare
587 588 589 590
leftmost_largest a b = (srcSpanStart a `compare` srcSpanStart b)
                                `thenCmp`
                       (srcSpanEnd b `compare` srcSpanEnd a)

batterseapower's avatar
batterseapower committed
591 592
-- | Determines whether a span encloses a given line and column index
spans :: SrcSpan -> (Int, Int) -> Bool
Ian Lynagh's avatar
Ian Lynagh committed
593 594 595
spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan"
spans (RealSrcSpan span) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span
   where loc = mkRealSrcLoc (srcSpanFile span) l c
596

batterseapower's avatar
batterseapower committed
597 598 599 600
-- | Determines whether a span is enclosed by another one
isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other
            -> SrcSpan -- ^ The span it may be enclosed by
            -> Bool
601
isSubspanOf src parent
batterseapower's avatar
batterseapower committed
602
    | srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False
603 604
    | otherwise = srcSpanStart parent <= srcSpanStart src &&
                  srcSpanEnd parent   >= srcSpanEnd src