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

3
{-# LANGUAGE DeriveDataTypeable #-}
Alan Zimmerman's avatar
Alan Zimmerman committed
4
{-# LANGUAGE StandaloneDeriving #-}
Adam Gundry's avatar
Adam Gundry committed
5
{-# LANGUAGE DeriveFunctor      #-}
Alan Zimmerman's avatar
Alan Zimmerman committed
6 7 8
{-# LANGUAGE DeriveFoldable     #-}
{-# LANGUAGE DeriveTraversable  #-}
{-# LANGUAGE FlexibleInstances  #-}
9
{-# LANGUAGE RecordWildCards    #-}
10 11 12 13 14
{-# LANGUAGE TypeFamilies       #-}
{-# LANGUAGE ViewPatterns       #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE PatternSynonyms    #-}

15

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

batterseapower's avatar
batterseapower committed
23
        -- ** Constructing SrcLoc
24
        mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc,
25

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

batterseapower's avatar
batterseapower committed
30 31
        advanceSrcLoc,

32 33 34 35 36 37
        -- ** 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
38
        -- * SrcSpan
39 40
        RealSrcSpan,            -- Abstract
        SrcSpan(..),
batterseapower's avatar
batterseapower committed
41 42

        -- ** Constructing SrcSpan
43 44 45
        mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,
        noSrcSpan,
        wiredInSrcSpan,         -- Something wired into the compiler
46
        interactiveSrcSpan,
47 48
        srcLocSpan, realSrcLocSpan,
        combineSrcSpans,
49
        srcSpanFirstCharacter,
50 51 52 53 54

        -- ** Deconstructing SrcSpan
        srcSpanStart, srcSpanEnd,
        realSrcSpanStart, realSrcSpanEnd,
        srcSpanFileName_maybe,
55
        pprUserRealSpan,
56 57 58 59 60

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

batterseapower's avatar
batterseapower committed
63 64
        -- ** Predicates on SrcSpan
        isGoodSrcSpan, isOneLineSpan,
Peter Wortmann's avatar
Peter Wortmann committed
65
        containsSpan,
batterseapower's avatar
batterseapower committed
66 67

        -- * Located
68 69 70 71 72 73
        Located,
        RealLocated,
        GenLocated(..),

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

        -- ** Deconstructing Located
        getLoc, unLoc,
78
        unRealSrcSpan, getRealSrcSpan,
79

80 81 82
        -- ** Modifying Located
        mapLoc,

83 84 85
        -- ** Combining and comparing Located values
        eqLocated, cmpLocated, combineLocs, addCLoc,
        leftmost_smallest, leftmost_largest, rightmost,
86
        spans, isSubspanOf, isRealSubspanOf, sortLocated,
87

88
        liftL
89
    ) where
90

91 92
import GhcPrelude

Simon Marlow's avatar
Simon Marlow committed
93
import Util
94
import Json
95
import Outputable
96
import FastString
97

98
import Control.DeepSeq
99
import Data.Bits
100
import Data.Data
101
import Data.List (sortBy, intercalate)
Ian Lynagh's avatar
Ian Lynagh committed
102
import Data.Ord
103

Austin Seipp's avatar
Austin Seipp committed
104 105 106
{-
************************************************************************
*                                                                      *
107
\subsection[SrcLoc-SrcLocations]{Source-location information}
Austin Seipp's avatar
Austin Seipp committed
108 109
*                                                                      *
************************************************************************
110 111 112

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

115 116 117
-- | Real Source Location
--
-- Represents a single point within a file
Ian Lynagh's avatar
Ian Lynagh committed
118
data RealSrcLoc
119 120 121
  = SrcLoc      FastString              -- A precise location (file name)
                {-# UNPACK #-} !Int     -- line number, begins at 1
                {-# UNPACK #-} !Int     -- column number, begins at 1
122
  deriving (Eq, Ord)
batterseapower's avatar
batterseapower committed
123

124
-- | Source Location
Ian Lynagh's avatar
Ian Lynagh committed
125 126
data SrcLoc
  = RealSrcLoc {-# UNPACK #-}!RealSrcLoc
127
  | UnhelpfulLoc FastString     -- Just a general indication
128
  deriving (Eq, Ord, Show)
129

Austin Seipp's avatar
Austin Seipp committed
130 131 132
{-
************************************************************************
*                                                                      *
batterseapower's avatar
batterseapower committed
133
\subsection[SrcLoc-access-fns]{Access functions}
Austin Seipp's avatar
Austin Seipp committed
134 135 136
*                                                                      *
************************************************************************
-}
137

Simon Marlow's avatar
Simon Marlow committed
138
mkSrcLoc :: FastString -> Int -> Int -> SrcLoc
Ian Lynagh's avatar
Ian Lynagh committed
139 140 141 142
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
143

batterseapower's avatar
batterseapower committed
144
-- | Built-in "bad" 'SrcLoc' values for particular locations
Simon Marlow's avatar
Simon Marlow committed
145
noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc
146
noSrcLoc          = UnhelpfulLoc (fsLit "<no location info>")
Ian Lynagh's avatar
Ian Lynagh committed
147
generatedSrcLoc   = UnhelpfulLoc (fsLit "<compiler-generated code>")
148
interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive>")
149

batterseapower's avatar
batterseapower committed
150
-- | Creates a "bad" 'SrcLoc' that has no detailed information about its location
151
mkGeneralSrcLoc :: FastString -> SrcLoc
152
mkGeneralSrcLoc = UnhelpfulLoc
153

Ian Lynagh's avatar
Ian Lynagh committed
154 155
-- | Gives the filename of the 'RealSrcLoc'
srcLocFile :: RealSrcLoc -> FastString
156 157
srcLocFile (SrcLoc fname _ _) = fname

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

batterseapower's avatar
batterseapower committed
162
-- | Raises an error when used on a "bad" 'SrcLoc'
Ian Lynagh's avatar
Ian Lynagh committed
163
srcLocCol :: RealSrcLoc -> Int
Simon Marlow's avatar
Simon Marlow committed
164
srcLocCol (SrcLoc _ _ c) = c
165

166 167 168
-- | 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
169
advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc
170
advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f  (l + 1) 1
171
advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f  l (((((c - 1) `shiftR` 3) + 1)
172
                                                  `shiftL` 3) + 1)
173
advanceSrcLoc (SrcLoc f l c) _    = SrcLoc f  l (c + 1)
174

Austin Seipp's avatar
Austin Seipp committed
175 176 177
{-
************************************************************************
*                                                                      *
178
\subsection[SrcLoc-instances]{Instance declarations for various names}
Austin Seipp's avatar
Austin Seipp committed
179 180 181
*                                                                      *
************************************************************************
-}
182

183
sortLocated :: Ord l => [GenLocated l a] -> [GenLocated l a]
Ian Lynagh's avatar
Ian Lynagh committed
184
sortLocated things = sortBy (comparing getLoc) things
185

Ian Lynagh's avatar
Ian Lynagh committed
186
instance Outputable RealSrcLoc where
187
    ppr (SrcLoc src_path src_line src_col)
188 189 190 191 192 193 194 195 196 197 198 199 200
      = 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 " #-}"]
201

Ian Lynagh's avatar
Ian Lynagh committed
202 203
instance Outputable SrcLoc where
    ppr (RealSrcLoc l) = ppr l
204
    ppr (UnhelpfulLoc s)  = ftext s
205

Ian Lynagh's avatar
Ian Lynagh committed
206 207 208 209 210 211
instance Data RealSrcSpan where
  -- don't traverse?
  toConstr _   = abstractConstr "RealSrcSpan"
  gunfold _ _  = error "gunfold"
  dataTypeOf _ = mkNoRepType "RealSrcSpan"

212 213 214 215 216
instance Data SrcSpan where
  -- don't traverse?
  toConstr _   = abstractConstr "SrcSpan"
  gunfold _ _  = error "gunfold"
  dataTypeOf _ = mkNoRepType "SrcSpan"
217

Austin Seipp's avatar
Austin Seipp committed
218 219 220
{-
************************************************************************
*                                                                      *
221
\subsection[SrcSpan]{Source Spans}
Austin Seipp's avatar
Austin Seipp committed
222 223 224
*                                                                      *
************************************************************************
-}
225 226

{- |
227
A 'RealSrcSpan' delimits a portion of a text file.  It could be represented
228 229 230 231
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
232
The end position is defined to be the column /after/ the end of the
233 234 235
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.
-}
236 237

-- | Real Source Span
Ian Lynagh's avatar
Ian Lynagh committed
238
data RealSrcSpan
239
  = RealSrcSpan'
240 241 242 243 244 245
        { srcSpanFile     :: !FastString,
          srcSpanSLine    :: {-# UNPACK #-} !Int,
          srcSpanSCol     :: {-# UNPACK #-} !Int,
          srcSpanELine    :: {-# UNPACK #-} !Int,
          srcSpanECol     :: {-# UNPACK #-} !Int
        }
246
  deriving Eq
247

248 249 250
-- | Source Span
--
-- A 'SrcSpan' identifies either a specific portion of a text file
251
-- or a human-readable description of a location.
Ian Lynagh's avatar
Ian Lynagh committed
252 253
data SrcSpan =
    RealSrcSpan !RealSrcSpan
254 255
  | UnhelpfulSpan !FastString   -- Just a general indication
                                -- also used to indicate an empty span
256

257 258
  deriving (Eq, Ord, Show) -- Show is used by Lexer.x, because we
                           -- derive Show for Token
259

260 261 262 263 264 265 266 267 268 269 270 271
instance ToJson SrcSpan where
  json (UnhelpfulSpan {} ) = JSNull --JSObject [( "type", "unhelpful")]
  json (RealSrcSpan rss)  = json rss

instance ToJson RealSrcSpan where
  json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile))
                                     , ("startLine", JSInt srcSpanSLine)
                                     , ("startCol", JSInt srcSpanSCol)
                                     , ("endLine", JSInt srcSpanELine)
                                     , ("endCol", JSInt srcSpanECol)
                                     ]

272 273 274
instance NFData SrcSpan where
  rnf x = x `seq` ()

batterseapower's avatar
batterseapower committed
275
-- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty
276 277 278 279
noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan
noSrcSpan          = UnhelpfulSpan (fsLit "<no location info>")
wiredInSrcSpan     = UnhelpfulSpan (fsLit "<wired into compiler>")
interactiveSrcSpan = UnhelpfulSpan (fsLit "<interactive>")
280

batterseapower's avatar
batterseapower committed
281
-- | Create a "bad" 'SrcSpan' that has not location information
282 283 284
mkGeneralSrcSpan :: FastString -> SrcSpan
mkGeneralSrcSpan = UnhelpfulSpan

batterseapower's avatar
batterseapower committed
285 286 287
-- | Create a 'SrcSpan' corresponding to a single point
srcLocSpan :: SrcLoc -> SrcSpan
srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str
Ian Lynagh's avatar
Ian Lynagh committed
288 289 290
srcLocSpan (RealSrcLoc l) = RealSrcSpan (realSrcLocSpan l)

realSrcLocSpan :: RealSrcLoc -> RealSrcSpan
291
realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col
batterseapower's avatar
batterseapower committed
292 293

-- | Create a 'SrcSpan' between two points in a file
Ian Lynagh's avatar
Ian Lynagh committed
294
mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan
295
mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2
batterseapower's avatar
batterseapower committed
296
  where
297 298 299 300 301
        line1 = srcLocLine loc1
        line2 = srcLocLine loc2
        col1 = srcLocCol loc1
        col2 = srcLocCol loc2
        file = srcLocFile loc1
batterseapower's avatar
batterseapower committed
302

303 304 305 306 307 308 309 310 311 312
-- | 'True' if the span is known to straddle only one line.
isOneLineRealSpan :: RealSrcSpan -> Bool
isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _)
  = line1 == line2

-- | 'True' if the span is a single point
isPointRealSpan :: RealSrcSpan -> Bool
isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2)
  = line1 == line2 && col1 == col2

Ian Lynagh's avatar
Ian Lynagh committed
313 314 315 316 317 318 319
-- | 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
320
-- | Combines two 'SrcSpan' into one that spans at least all the characters
321
-- within both spans. Returns UnhelpfulSpan if the files differ.
322 323 324 325
combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful
combineSrcSpans l (UnhelpfulSpan _) = l
combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2)
326 327 328
  | srcSpanFile span1 == srcSpanFile span2
      = RealSrcSpan (combineRealSrcSpans span1 span2)
  | otherwise = UnhelpfulSpan (fsLit "<combineSrcSpans: files differ>")
Ian Lynagh's avatar
Ian Lynagh committed
329 330 331 332 333

-- | 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
334
  = RealSrcSpan' 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

342 343 344 345 346 347 348
-- | Convert a SrcSpan into one that represents only its first character
srcSpanFirstCharacter :: SrcSpan -> SrcSpan
srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l
srcSpanFirstCharacter (RealSrcSpan span) = RealSrcSpan $ mkRealSrcSpan loc1 loc2
  where
    loc1@(SrcLoc f l c) = realSrcSpanStart span
    loc2 = SrcLoc f l (c+1)
349

Austin Seipp's avatar
Austin Seipp committed
350 351 352
{-
************************************************************************
*                                                                      *
batterseapower's avatar
batterseapower committed
353
\subsection[SrcSpan-predicates]{Predicates}
Austin Seipp's avatar
Austin Seipp committed
354 355 356
*                                                                      *
************************************************************************
-}
batterseapower's avatar
batterseapower committed
357 358

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

363
isOneLineSpan :: SrcSpan -> Bool
364
-- ^ True if the span is known to straddle only one line.
batterseapower's avatar
batterseapower committed
365
-- For "bad" 'SrcSpan', it returns False
Ian Lynagh's avatar
Ian Lynagh committed
366 367
isOneLineSpan (RealSrcSpan s) = srcSpanStartLine s == srcSpanEndLine s
isOneLineSpan (UnhelpfulSpan _) = False
368

Peter Wortmann's avatar
Peter Wortmann committed
369 370 371 372
-- | 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
David Feuer's avatar
David Feuer committed
373 374 375 376 377 378 379
  = (srcSpanStartLine s1, srcSpanStartCol s1)
       <= (srcSpanStartLine s2, srcSpanStartCol s2)
    && (srcSpanEndLine s1, srcSpanEndCol s1)
       >= (srcSpanEndLine s2, srcSpanEndCol s2)
    && (srcSpanFile s1 == srcSpanFile s2)
    -- We check file equality last because it is (presumably?) least
    -- likely to fail.
Austin Seipp's avatar
Austin Seipp committed
380
{-
Peter Wortmann's avatar
Peter Wortmann committed
381 382
%************************************************************************
%*                                                                      *
batterseapower's avatar
batterseapower committed
383
\subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions}
Austin Seipp's avatar
Austin Seipp committed
384 385 386
*                                                                      *
************************************************************************
-}
387

Ian Lynagh's avatar
Ian Lynagh committed
388 389 390 391
srcSpanStartLine :: RealSrcSpan -> Int
srcSpanEndLine :: RealSrcSpan -> Int
srcSpanStartCol :: RealSrcSpan -> Int
srcSpanEndCol :: RealSrcSpan -> Int
Simon Marlow's avatar
Simon Marlow committed
392

393 394 395 396
srcSpanStartLine RealSrcSpan'{ srcSpanSLine=l } = l
srcSpanEndLine RealSrcSpan'{ srcSpanELine=l } = l
srcSpanStartCol RealSrcSpan'{ srcSpanSCol=l } = l
srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c
397

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

-- | 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
408 409 410
srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str
srcSpanStart (RealSrcSpan s) = RealSrcLoc (realSrcSpanStart s)

batterseapower's avatar
batterseapower committed
411 412
-- | 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
413 414
srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str
srcSpanEnd (RealSrcSpan s) = RealSrcLoc (realSrcSpanEnd s)
Simon Marlow's avatar
Simon Marlow committed
415

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

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

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

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

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

446 447 448 449 450 451
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
452 453 454 455 456
  show span@(RealSrcSpan' file sl sc el ec)
    | isPointRealSpan span
    = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc])

    | isOneLineRealSpan span
457
    = "SrcSpanOneLine " ++ show file ++ " "
458 459 460
                        ++ intercalate " " (map show [sl,sc,ec])

    | otherwise
461 462 463
    = "SrcSpanMultiLine " ++ show file ++ " "
                          ++ intercalate " " (map show [sl,sc,el,ec])

464

Ian Lynagh's avatar
Ian Lynagh committed
465
instance Outputable RealSrcSpan where
466 467 468 469 470 471 472 473 474
    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 " #-}"]
475

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

479 480 481 482 483 484 485 486
-- 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
487

488 489 490 491 492
pprUserSpan :: Bool -> SrcSpan -> SDoc
pprUserSpan _         (UnhelpfulSpan s) = ftext s
pprUserSpan show_path (RealSrcSpan s)   = pprUserRealSpan show_path s

pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc
493 494
pprUserRealSpan show_path span@(RealSrcSpan' src_path line col _ _)
  | isPointRealSpan span
495 496
  = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
         , int line <> colon
497 498 499 500 501 502 503 504
         , int col ]

pprUserRealSpan show_path span@(RealSrcSpan' src_path line scol _ ecol)
  | isOneLineRealSpan span
  = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
         , int line <> colon
         , int scol
         , ppUnless (ecol - scol <= 1) (char '-' <> int (ecol - 1)) ]
505 506
            -- For single-character or point spans, we just
            -- output the starting column number
507

508
pprUserRealSpan show_path (RealSrcSpan' src_path sline scol eline ecol)
509 510 511 512 513 514 515
  = 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

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, Data, Functor, Foldable, Traversable)
527

528 529
type Located = GenLocated SrcSpan
type RealLocated = GenLocated RealSrcSpan
Ian Lynagh's avatar
Ian Lynagh committed
530

531 532 533
mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b
mapLoc = fmap

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

537 538
getLoc :: GenLocated l e -> l
getLoc (L l _) = l
539

540 541
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
combineLocs :: Located a -> Located b -> SrcSpan
547 548
combineLocs a b = combineSrcSpans (getLoc a) (getLoc b)

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

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

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

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

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

Ian Lynagh's avatar
Ian Lynagh committed
565 566 567 568 569
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))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
570
                whenPprDebug (braces (ppr l))
Ian Lynagh's avatar
Ian Lynagh committed
571
             $$ ppr e
572

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

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

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

batterseapower's avatar
batterseapower committed
595 596 597 598
-- | 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
599 600 601 602 603 604 605 606 607 608 609
isSubspanOf (RealSrcSpan src) (RealSrcSpan parent) = isRealSubspanOf src parent
isSubspanOf _ _ = False

-- | Determines whether a span is enclosed by another one
isRealSubspanOf :: RealSrcSpan -- ^ The span that may be enclosed by the other
                -> RealSrcSpan -- ^ The span it may be enclosed by
                -> Bool
isRealSubspanOf src parent
    | srcSpanFile parent /= srcSpanFile src = False
    | otherwise = realSrcSpanStart parent <= realSrcSpanStart src &&
                  realSrcSpanEnd parent   >= realSrcSpanEnd src
610

611 612
liftL :: Monad m => (a -> m b) -> GenLocated l a -> m (GenLocated l b)
liftL f (L loc a) = do
613
  a' <- f a
614
  return $ L loc a'
615 616 617 618 619 620

getRealSrcSpan :: RealLocated a -> RealSrcSpan
getRealSrcSpan (L l _) = l

unRealSrcSpan :: RealLocated a -> a
unRealSrcSpan  (L _ e) = e