basicTypes/SrcLoc.hs

    -- (c) The University of Glasgow, 1992-2006

    {-# LANGUAGE DeriveDataTypeable #-}
    {-# LANGUAGE StandaloneDeriving #-}
    {-# LANGUAGE DeriveFunctor      #-}
    {-# LANGUAGE DeriveFoldable     #-}
    {-# LANGUAGE DeriveTraversable  #-}
    {-# LANGUAGE FlexibleInstances  #-}
    {-# LANGUAGE RecordWildCards    #-}
    {-# 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

    -- | This module contains types that relate to the positions of things
    -- in source files, and allow tagging of those things with locations
    module SrcLoc (
            -- * SrcLoc
            RealSrcLoc,             -- Abstract
            SrcLoc(..),

            -- ** Constructing SrcLoc
            mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc,

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

            advanceSrcLoc,

            -- ** 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

            -- * SrcSpan
            RealSrcSpan,            -- Abstract
            SrcSpan(..),

            -- ** Constructing SrcSpan
            mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,
            noSrcSpan,
            wiredInSrcSpan,         -- Something wired into the compiler
            interactiveSrcSpan,
            srcLocSpan, realSrcLocSpan,
            combineSrcSpans,
            srcSpanFirstCharacter,

            -- ** Deconstructing SrcSpan
            srcSpanStart, srcSpanEnd,
            realSrcSpanStart, realSrcSpanEnd,
            srcSpanFileName_maybe,
            pprUserRealSpan,

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

            -- ** Predicates on SrcSpan
            isGoodSrcSpan, isOneLineSpan,
            containsSpan,

            -- * Located
            Located,
            RealLocated,
            GenLocated(..),

            -- ** Constructing Located
            noLoc,
            mkGeneralLocated,

            -- ** Deconstructing Located
            getLoc, unLoc,

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

    import Util
    import Json
    import Outputable
    import FastString

    import Control.DeepSeq
    import Data.Bits
    import Data.Data
    import Data.List
    import Data.Ord

    {-
    ************************************************************************
    *                                                                      *
    \subsection[SrcLoc-SrcLocations]{Source-location information}
    *                                                                      *
    ************************************************************************

    We keep information about the {\em definition} point for each entity;
    this is the obvious stuff:
    -}

    -- | Real Source Location
    --
    -- Represents a single point within a file
    data RealSrcLoc
      = SrcLoc      FastString              -- A precise location (file name)
                    {-# UNPACK #-} !Int     -- line number, begins at 1
                    {-# UNPACK #-} !Int     -- column number, begins at 1
      deriving (Eq, Ord)

    -- | Source Location
    data SrcLoc
      = RealSrcLoc {-# UNPACK #-}!RealSrcLoc
      | UnhelpfulLoc FastString     -- Just a general indication
      deriving (Eq, Ord, Show)

    {-
    ************************************************************************
    *                                                                      *
    \subsection[SrcLoc-access-fns]{Access functions}
    *                                                                      *
    ************************************************************************
    -}

    mkSrcLoc :: FastString -> Int -> Int -> SrcLoc
    mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col)

    mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc
    mkRealSrcLoc x line col = SrcLoc x line col

    -- | Built-in "bad" 'SrcLoc' values for particular locations
    noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc
    noSrcLoc          = UnhelpfulLoc (fsLit "<no location info>")
    generatedSrcLoc   = UnhelpfulLoc (fsLit "<compiler-generated code>")
    interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive>")

    -- | Creates a "bad" 'SrcLoc' that has no detailed information about its location
    mkGeneralSrcLoc :: FastString -> SrcLoc
    mkGeneralSrcLoc = UnhelpfulLoc

    -- | Gives the filename of the 'RealSrcLoc'
    srcLocFile :: RealSrcLoc -> FastString
    srcLocFile (SrcLoc fname _ _) = fname

    -- | Raises an error when used on a "bad" 'SrcLoc'
    srcLocLine :: RealSrcLoc -> Int
    srcLocLine (SrcLoc _ l _) = l

    -- | Raises an error when used on a "bad" 'SrcLoc'
    srcLocCol :: RealSrcLoc -> Int
    srcLocCol (SrcLoc _ _ c) = c

    -- | 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
    advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc
    advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f  (l + 1) 1
    advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f  l (((((c - 1) `shiftR` 3) + 1)
                                                      `shiftL` 3) + 1)
    advanceSrcLoc (SrcLoc f l c) _    = SrcLoc f  l (c + 1)

    {-
    ************************************************************************
    *                                                                      *
    \subsection[SrcLoc-instances]{Instance declarations for various names}
    *                                                                      *
    ************************************************************************
    -}

    sortLocated :: [Located a] -> [Located a]
    sortLocated things = sortBy (comparing getLoc) things

    instance Outputable RealSrcLoc where
        ppr (SrcLoc src_path src_line src_col)
          = 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 " #-}"]

    instance Outputable SrcLoc where
        ppr (RealSrcLoc l) = ppr l
        ppr (UnhelpfulLoc s)  = ftext s

    instance Data RealSrcSpan where
      -- don't traverse?
      toConstr _   = abstractConstr "RealSrcSpan"
      gunfold _ _  = error "gunfold"
      dataTypeOf _ = mkNoRepType "RealSrcSpan"

    instance Data SrcSpan where
      -- don't traverse?
      toConstr _   = abstractConstr "SrcSpan"
      gunfold _ _  = error "gunfold"
      dataTypeOf _ = mkNoRepType "SrcSpan"

    {-
    ************************************************************************
    *                                                                      *
    \subsection[SrcSpan]{Source Spans}
    *                                                                      *
    ************************************************************************
    -}

    {- |
    A 'RealSrcSpan' 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.

    The end position is defined to be the column /after/ the end of the
    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.
    -}

    -- | Real Source Span
    data RealSrcSpan
      = RealSrcSpan'
            { srcSpanFile     :: !FastString,
              srcSpanSLine    :: {-# UNPACK #-} !Int,
              srcSpanSCol     :: {-# UNPACK #-} !Int,
              srcSpanELine    :: {-# UNPACK #-} !Int,
              srcSpanECol     :: {-# UNPACK #-} !Int
            }
      deriving Eq

    -- | Source Span
    --
    -- A 'SrcSpan' identifies either a specific portion of a text file
    -- or a human-readable description of a location.
    data SrcSpan =
        RealSrcSpan !RealSrcSpan
      | UnhelpfulSpan !FastString   -- Just a general indication
                                    -- also used to indicate an empty span

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

    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)
                                         ]

    instance NFData SrcSpan where
      rnf x = x `seq` ()

    -- | Built-in "bad" 'SrcSpan's for common sources of location uncertainty
    noSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan
    noSrcSpan          = UnhelpfulSpan (fsLit "<no location info>")
    wiredInSrcSpan     = UnhelpfulSpan (fsLit "<wired into compiler>")
    interactiveSrcSpan = UnhelpfulSpan (fsLit "<interactive>")

    -- | Create a "bad" 'SrcSpan' that has not location information
    mkGeneralSrcSpan :: FastString -> SrcSpan
    mkGeneralSrcSpan = UnhelpfulSpan

    -- | Create a 'SrcSpan' corresponding to a single point
    srcLocSpan :: SrcLoc -> SrcSpan
    srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str
    srcLocSpan (RealSrcLoc l) = RealSrcSpan (realSrcLocSpan l)

    realSrcLocSpan :: RealSrcLoc -> RealSrcSpan
    realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col

    -- | Create a 'SrcSpan' between two points in a file
    mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan
    mkRealSrcSpan loc1 loc2 = RealSrcSpan' file line1 col1 line2 col2
      where
            line1 = srcLocLine loc1
            line2 = srcLocLine loc2
            col1 = srcLocCol loc1
            col2 = srcLocCol loc2
            file = srcLocFile loc1

    -- | '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

    -- | 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)

    -- | 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
    combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan
    combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful
    combineSrcSpans l (UnhelpfulSpan _) = l
    combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2)
        = 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
      = RealSrcSpan' file line_start col_start line_end col_end
      where
        (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1)
                                      (srcSpanStartLine span2, srcSpanStartCol span2)
        (line_end, col_end)     = max (srcSpanEndLine span1, srcSpanEndCol span1)
                                      (srcSpanEndLine span2, srcSpanEndCol span2)
        file = srcSpanFile span1

    -- | 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)
    {-
    ************************************************************************
    *                                                                      *
    \subsection[SrcSpan-predicates]{Predicates}
    *                                                                      *
    ************************************************************************
    -}

    -- | Test if a 'SrcSpan' is "good", i.e. has precise location information
    isGoodSrcSpan :: SrcSpan -> Bool
    isGoodSrcSpan (RealSrcSpan _) = True
    isGoodSrcSpan (UnhelpfulSpan _) = False

    isOneLineSpan :: SrcSpan -> Bool
    -- ^ True if the span is known to straddle only one line.
    -- For "bad" 'SrcSpan', it returns False
    isOneLineSpan (RealSrcSpan s) = srcSpanStartLine s == srcSpanEndLine s
    isOneLineSpan (UnhelpfulSpan _) = False

    -- | 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
      = (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.
    {-
    %************************************************************************
    %*                                                                      *
    \subsection[SrcSpan-unsafe-access-fns]{Unsafe access functions}
    *                                                                      *
    ************************************************************************
    -}

    srcSpanStartLine :: RealSrcSpan -> Int
    srcSpanEndLine :: RealSrcSpan -> Int
    srcSpanStartCol :: RealSrcSpan -> Int
    srcSpanEndCol :: RealSrcSpan -> Int

    srcSpanStartLine RealSrcSpan'{ srcSpanSLine=l } = l
    srcSpanEndLine RealSrcSpan'{ srcSpanELine=l } = l
    srcSpanStartCol RealSrcSpan'{ srcSpanSCol=l } = l
    srcSpanEndCol RealSrcSpan'{ srcSpanECol=c } = c

    {-
    ************************************************************************
    *                                                                      *
    \subsection[SrcSpan-access-fns]{Access functions}
    *                                                                      *
    ************************************************************************
    -}

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

    -- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable
    srcSpanEnd :: SrcSpan -> SrcLoc
    srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str
    srcSpanEnd (RealSrcSpan s) = RealSrcLoc (realSrcSpanEnd s)

    realSrcSpanStart :: RealSrcSpan -> RealSrcLoc
    realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s)
                                      (srcSpanStartLine s)
                                      (srcSpanStartCol s)

    realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc
    realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s)
                                    (srcSpanEndLine s)
                                    (srcSpanEndCol s)

    -- | Obtains the filename for a 'SrcSpan' if it is "good"
    srcSpanFileName_maybe :: SrcSpan -> Maybe FastString
    srcSpanFileName_maybe (RealSrcSpan s)   = Just (srcSpanFile s)
    srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing

    {-
    ************************************************************************
    *                                                                      *
    \subsection[SrcSpan-instances]{Instances}
    *                                                                      *
    ************************************************************************
    -}

    -- We want to order RealSrcSpans first by the start point, then by the
    -- end point.
    instance Ord RealSrcSpan where
      a `compare` b =
         (realSrcSpanStart a `compare` realSrcSpanStart b) `thenCmp`
         (realSrcSpanEnd   a `compare` realSrcSpanEnd   b)

    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 span@(RealSrcSpan' file sl sc el ec)
        | isPointRealSpan span
        = "SrcSpanPoint " ++ show file ++ " " ++ intercalate " " (map show [sl,sc])

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

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

    instance Outputable RealSrcSpan where
        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 " #-}"]

    instance Outputable SrcSpan where
        ppr span = pprUserSpan True span

    -- 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

    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 span@(RealSrcSpan' src_path line col _ _)
      | isPointRealSpan span
      = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon)
             , int line <> colon
             , 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)) ]
                -- For single-character or point spans, we just
                -- output the starting column number

    pprUserRealSpan show_path (RealSrcSpan' 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

    {-
    ************************************************************************
    *                                                                      *
    \subsection[Located]{Attaching SrcSpans to things}
    *                                                                      *
    ************************************************************************
    -}

    -- | We attach SrcSpans to lots of things, so let's have a datatype for it.
    data GenLocated l e = L l e
      deriving (Eq, Ord, Data, Functor, Foldable, Traversable)

    type Located e = GenLocated SrcSpan e
    type RealLocated e = GenLocated RealSrcSpan e

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

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

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

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

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

    -- | Combine locations from two 'Located' things and add them to a third thing
    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:

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

    -- not clear whether to add a general Ord instance, but this is useful sometimes:

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

    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

    {-
    ************************************************************************
    *                                                                      *
    \subsection{Ordering SrcSpans for InteractiveUI}
    *                                                                      *
    ************************************************************************
    -}

    -- | Alternative strategies for ordering 'SrcSpan's
    leftmost_smallest, leftmost_largest, rightmost :: SrcSpan -> SrcSpan -> Ordering
    rightmost            = flip compare
    leftmost_smallest    = compare
    leftmost_largest a b = (srcSpanStart a `compare` srcSpanStart b)
                                    `thenCmp`
                           (srcSpanEnd b `compare` srcSpanEnd a)

    -- | Determines whether a span encloses a given line and column index
    spans :: SrcSpan -> (Int, Int) -> Bool
    spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan"
    spans (RealSrcSpan span) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span
       where loc = mkRealSrcLoc (srcSpanFile span) l c

    -- | 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
    isSubspanOf src parent
        | srcSpanFileName_maybe parent /= srcSpanFileName_maybe src = False
        | otherwise = srcSpanStart parent <= srcSpanStart src &&
                      srcSpanEnd parent   >= srcSpanEnd src