module GHC.Types.SrcLoc (
RealSrcLoc,
SrcLoc(..),
mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc,
noSrcLoc,
generatedSrcLoc,
interactiveSrcLoc,
advanceSrcLoc,
advanceBufPos,
srcLocFile,
srcLocLine,
srcLocCol,
RealSrcSpan,
SrcSpan(..),
UnhelpfulSpanReason(..),
mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan,
noSrcSpan, generatedSrcSpan, isGeneratedSrcSpan,
wiredInSrcSpan,
interactiveSrcSpan,
srcLocSpan, realSrcLocSpan,
combineSrcSpans,
srcSpanFirstCharacter,
srcSpanStart, srcSpanEnd,
realSrcSpanStart, realSrcSpanEnd,
srcSpanFileName_maybe,
pprUserRealSpan, pprUnhelpfulSpanReason,
unhelpfulSpanFS,
srcSpanFile,
srcSpanStartLine, srcSpanEndLine,
srcSpanStartCol, srcSpanEndCol,
isGoodSrcSpan, isOneLineSpan,
containsSpan,
BufPos(..),
getBufPos,
BufSpan(..),
getBufSpan,
Located,
RealLocated,
GenLocated(..),
noLoc,
mkGeneralLocated,
getLoc, unLoc,
unRealSrcSpan, getRealSrcSpan,
mapLoc,
eqLocated, cmpLocated, cmpBufSpan,
combineLocs, addCLoc,
leftmost_smallest, leftmost_largest, rightmost_smallest,
spans, isSubspanOf, isRealSubspanOf,
sortLocated, sortRealLocated,
lookupSrcLoc, lookupSrcSpan,
liftL,
PsLoc(..),
PsSpan(..),
PsLocated,
advancePsLoc,
mkPsSpan,
psSpanStart,
psSpanEnd,
mkSrcSpanPs,
LayoutInfo(..),
leftmostColumn
) where
import GHC.Prelude
import GHC.Utils.Misc
import GHC.Utils.Json
import GHC.Utils.Outputable
import GHC.Data.FastString
import Control.DeepSeq
import Control.Applicative (liftA2)
import Data.Bits
import Data.Data
import Data.List (sortBy, intercalate)
import Data.Function (on)
import qualified Data.Map as Map
import qualified Data.Semigroup
data RealSrcLoc
= SrcLoc FastString
!Int
!Int
deriving (Eq, Ord)
newtype BufPos = BufPos { bufPos :: Int }
deriving (Eq, Ord, Show)
data SrcLoc
= RealSrcLoc !RealSrcLoc !(Maybe BufPos)
| UnhelpfulLoc FastString
deriving (Eq, Show)
mkSrcLoc :: FastString -> Int -> Int -> SrcLoc
mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Nothing
mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc x line col = SrcLoc x line col
getBufPos :: SrcLoc -> Maybe BufPos
getBufPos (RealSrcLoc _ mbpos) = mbpos
getBufPos (UnhelpfulLoc _) = Nothing
noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc
noSrcLoc = UnhelpfulLoc (fsLit "<no location info>")
generatedSrcLoc = UnhelpfulLoc (fsLit "<compiler-generated code>")
interactiveSrcLoc = UnhelpfulLoc (fsLit "<interactive>")
mkGeneralSrcLoc :: FastString -> SrcLoc
mkGeneralSrcLoc = UnhelpfulLoc
srcLocFile :: RealSrcLoc -> FastString
srcLocFile (SrcLoc fname _ _) = fname
srcLocLine :: RealSrcLoc -> Int
srcLocLine (SrcLoc _ l _) = l
srcLocCol :: RealSrcLoc -> Int
srcLocCol (SrcLoc _ _ c) = c
advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc
advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1
advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (advance_tabstop c)
advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1)
advance_tabstop :: Int -> Int
advance_tabstop c = ((((c 1) `shiftR` 3) + 1) `shiftL` 3) + 1
advanceBufPos :: BufPos -> BufPos
advanceBufPos (BufPos i) = BufPos (i+1)
sortLocated :: [Located a] -> [Located a]
sortLocated = sortBy (leftmost_smallest `on` getLoc)
sortRealLocated :: [RealLocated a] -> [RealLocated a]
sortRealLocated = sortBy (compare `on` getLoc)
lookupSrcLoc :: SrcLoc -> Map.Map RealSrcLoc a -> Maybe a
lookupSrcLoc (RealSrcLoc l _) = Map.lookup l
lookupSrcLoc (UnhelpfulLoc _) = const Nothing
lookupSrcSpan :: SrcSpan -> Map.Map RealSrcSpan a -> Maybe a
lookupSrcSpan (RealSrcSpan l _) = Map.lookup l
lookupSrcSpan (UnhelpfulSpan _) = const Nothing
instance Outputable RealSrcLoc where
ppr (SrcLoc src_path src_line src_col)
= hcat [ pprFastFilePath src_path <> colon
, int src_line <> colon
, int src_col ]
instance Outputable SrcLoc where
ppr (RealSrcLoc l _) = ppr l
ppr (UnhelpfulLoc s) = ftext s
instance Data RealSrcSpan where
toConstr _ = abstractConstr "RealSrcSpan"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "RealSrcSpan"
instance Data SrcSpan where
toConstr _ = abstractConstr "SrcSpan"
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "SrcSpan"
data RealSrcSpan
= RealSrcSpan'
{ srcSpanFile :: !FastString,
srcSpanSLine :: !Int,
srcSpanSCol :: !Int,
srcSpanELine :: !Int,
srcSpanECol :: !Int
}
deriving Eq
data BufSpan =
BufSpan { bufSpanStart, bufSpanEnd :: !BufPos }
deriving (Eq, Ord, Show)
instance Semigroup BufSpan where
BufSpan start1 end1 <> BufSpan start2 end2 =
BufSpan (min start1 start2) (max end1 end2)
data SrcSpan =
RealSrcSpan !RealSrcSpan !(Maybe BufSpan)
| UnhelpfulSpan !UnhelpfulSpanReason
deriving (Eq, Show)
data UnhelpfulSpanReason
= UnhelpfulNoLocationInfo
| UnhelpfulWiredIn
| UnhelpfulInteractive
| UnhelpfulGenerated
| UnhelpfulOther !FastString
deriving (Eq, Show)
instance ToJson SrcSpan where
json (UnhelpfulSpan {} ) = JSNull
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` ()
getBufSpan :: SrcSpan -> Maybe BufSpan
getBufSpan (RealSrcSpan _ mbspan) = mbspan
getBufSpan (UnhelpfulSpan _) = Nothing
noSrcSpan, generatedSrcSpan, wiredInSrcSpan, interactiveSrcSpan :: SrcSpan
noSrcSpan = UnhelpfulSpan UnhelpfulNoLocationInfo
wiredInSrcSpan = UnhelpfulSpan UnhelpfulWiredIn
interactiveSrcSpan = UnhelpfulSpan UnhelpfulInteractive
generatedSrcSpan = UnhelpfulSpan UnhelpfulGenerated
isGeneratedSrcSpan :: SrcSpan -> Bool
isGeneratedSrcSpan (UnhelpfulSpan UnhelpfulGenerated) = True
isGeneratedSrcSpan _ = False
mkGeneralSrcSpan :: FastString -> SrcSpan
mkGeneralSrcSpan = UnhelpfulSpan . UnhelpfulOther
srcLocSpan :: SrcLoc -> SrcSpan
srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan (UnhelpfulOther str)
srcLocSpan (RealSrcLoc l mb) = RealSrcSpan (realSrcLocSpan l) (fmap (\b -> BufSpan b b) mb)
realSrcLocSpan :: RealSrcLoc -> RealSrcSpan
realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col
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
isOneLineRealSpan :: RealSrcSpan -> Bool
isOneLineRealSpan (RealSrcSpan' _ line1 _ line2 _)
= line1 == line2
isPointRealSpan :: RealSrcSpan -> Bool
isPointRealSpan (RealSrcSpan' _ line1 col1 line2 col2)
= line1 == line2 && col1 == col2
mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan (UnhelpfulOther str)
mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan (UnhelpfulOther str)
mkSrcSpan (RealSrcLoc loc1 mbpos1) (RealSrcLoc loc2 mbpos2)
= RealSrcSpan (mkRealSrcSpan loc1 loc2) (liftA2 BufSpan mbpos1 mbpos2)
combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (UnhelpfulSpan _) r = r
combineSrcSpans l (UnhelpfulSpan _) = l
combineSrcSpans (RealSrcSpan span1 mbspan1) (RealSrcSpan span2 mbspan2)
| srcSpanFile span1 == srcSpanFile span2
= RealSrcSpan (combineRealSrcSpans span1 span2) (liftA2 combineBufSpans mbspan1 mbspan2)
| otherwise = UnhelpfulSpan $
UnhelpfulOther (fsLit "<combineSrcSpans: files differ>")
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
combineBufSpans :: BufSpan -> BufSpan -> BufSpan
combineBufSpans span1 span2 = BufSpan start end
where
start = min (bufSpanStart span1) (bufSpanStart span2)
end = max (bufSpanEnd span1) (bufSpanEnd span2)
srcSpanFirstCharacter :: SrcSpan -> SrcSpan
srcSpanFirstCharacter l@(UnhelpfulSpan {}) = l
srcSpanFirstCharacter (RealSrcSpan span mbspan) =
RealSrcSpan (mkRealSrcSpan loc1 loc2) (fmap mkBufSpan mbspan)
where
loc1@(SrcLoc f l c) = realSrcSpanStart span
loc2 = SrcLoc f l (c+1)
mkBufSpan bspan =
let bpos1@(BufPos i) = bufSpanStart bspan
bpos2 = BufPos (i+1)
in BufSpan bpos1 bpos2
isGoodSrcSpan :: SrcSpan -> Bool
isGoodSrcSpan (RealSrcSpan _ _) = True
isGoodSrcSpan (UnhelpfulSpan _) = False
isOneLineSpan :: SrcSpan -> Bool
isOneLineSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s
isOneLineSpan (UnhelpfulSpan _) = False
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)
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
srcSpanStart :: SrcSpan -> SrcLoc
srcSpanStart (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r)
srcSpanStart (RealSrcSpan s b) = RealSrcLoc (realSrcSpanStart s) (fmap bufSpanStart b)
srcSpanEnd :: SrcSpan -> SrcLoc
srcSpanEnd (UnhelpfulSpan r) = UnhelpfulLoc (unhelpfulSpanFS r)
srcSpanEnd (RealSrcSpan s b) = RealSrcLoc (realSrcSpanEnd s) (fmap bufSpanEnd b)
realSrcSpanStart :: RealSrcSpan -> RealSrcLoc
realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s)
(srcSpanStartLine s)
(srcSpanStartCol s)
realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc
realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s)
(srcSpanEndLine s)
(srcSpanEndCol s)
srcSpanFileName_maybe :: SrcSpan -> Maybe FastString
srcSpanFileName_maybe (RealSrcSpan s _) = Just (srcSpanFile s)
srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing
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
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
instance Outputable SrcSpan where
ppr span = pprUserSpan True span
instance Outputable UnhelpfulSpanReason where
ppr = pprUnhelpfulSpanReason
unhelpfulSpanFS :: UnhelpfulSpanReason -> FastString
unhelpfulSpanFS r = case r of
UnhelpfulOther s -> s
UnhelpfulNoLocationInfo -> fsLit "<no location info>"
UnhelpfulWiredIn -> fsLit "<wired into compiler>"
UnhelpfulInteractive -> fsLit "<interactive>"
UnhelpfulGenerated -> fsLit "<generated>"
pprUnhelpfulSpanReason :: UnhelpfulSpanReason -> SDoc
pprUnhelpfulSpanReason r = ftext (unhelpfulSpanFS r)
pprUserSpan :: Bool -> SrcSpan -> SDoc
pprUserSpan _ (UnhelpfulSpan r) = pprUnhelpfulSpanReason r
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)) ]
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
data GenLocated l e = L l e
deriving (Eq, Ord, Data, Functor, Foldable, Traversable)
type Located = GenLocated SrcSpan
type RealLocated = GenLocated RealSrcSpan
mapLoc :: (a -> b) -> GenLocated l a -> GenLocated l b
mapLoc = fmap
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)
addCLoc :: Located a -> Located b -> c -> Located c
addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c
eqLocated :: Eq a => GenLocated l a -> GenLocated l a -> Bool
eqLocated a b = unLoc a == unLoc b
cmpLocated :: Ord a => GenLocated l a -> GenLocated l a -> Ordering
cmpLocated a b = unLoc a `compare` unLoc b
cmpBufSpan :: HasDebugCallStack => Located a -> Located a -> Ordering
cmpBufSpan (L l1 _) (L l2 _)
| Just a <- getBufSpan l1
, Just b <- getBufSpan l2
= compare a b
| otherwise = panic "cmpBufSpan: no BufSpan"
instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where
ppr (L l e) =
whenPprDebug (braces (ppr l))
$$ ppr e
leftmost_smallest, leftmost_largest, rightmost_smallest :: SrcSpan -> SrcSpan -> Ordering
rightmost_smallest = compareSrcSpanBy (flip compare)
leftmost_smallest = compareSrcSpanBy compare
leftmost_largest = compareSrcSpanBy $ \a b ->
(realSrcSpanStart a `compare` realSrcSpanStart b)
`thenCmp`
(realSrcSpanEnd b `compare` realSrcSpanEnd a)
compareSrcSpanBy :: (RealSrcSpan -> RealSrcSpan -> Ordering) -> SrcSpan -> SrcSpan -> Ordering
compareSrcSpanBy cmp (RealSrcSpan a _) (RealSrcSpan b _) = cmp a b
compareSrcSpanBy _ (RealSrcSpan _ _) (UnhelpfulSpan _) = LT
compareSrcSpanBy _ (UnhelpfulSpan _) (RealSrcSpan _ _) = GT
compareSrcSpanBy _ (UnhelpfulSpan _) (UnhelpfulSpan _) = EQ
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
isSubspanOf :: SrcSpan
-> SrcSpan
-> Bool
isSubspanOf (RealSrcSpan src _) (RealSrcSpan parent _) = isRealSubspanOf src parent
isSubspanOf _ _ = False
isRealSubspanOf :: RealSrcSpan
-> RealSrcSpan
-> Bool
isRealSubspanOf src parent
| srcSpanFile parent /= srcSpanFile src = False
| otherwise = realSrcSpanStart parent <= realSrcSpanStart src &&
realSrcSpanEnd parent >= realSrcSpanEnd src
liftL :: Monad m => (a -> m b) -> GenLocated l a -> m (GenLocated l b)
liftL f (L loc a) = do
a' <- f a
return $ L loc a'
getRealSrcSpan :: RealLocated a -> RealSrcSpan
getRealSrcSpan (L l _) = l
unRealSrcSpan :: RealLocated a -> a
unRealSrcSpan (L _ e) = e
data PsLoc
= PsLoc { psRealLoc :: !RealSrcLoc, psBufPos :: !BufPos }
deriving (Eq, Ord, Show)
data PsSpan
= PsSpan { psRealSpan :: !RealSrcSpan, psBufSpan :: !BufSpan }
deriving (Eq, Ord, Show)
type PsLocated = GenLocated PsSpan
advancePsLoc :: PsLoc -> Char -> PsLoc
advancePsLoc (PsLoc real_loc buf_loc) c =
PsLoc (advanceSrcLoc real_loc c) (advanceBufPos buf_loc)
mkPsSpan :: PsLoc -> PsLoc -> PsSpan
mkPsSpan (PsLoc r1 b1) (PsLoc r2 b2) = PsSpan (mkRealSrcSpan r1 r2) (BufSpan b1 b2)
psSpanStart :: PsSpan -> PsLoc
psSpanStart (PsSpan r b) = PsLoc (realSrcSpanStart r) (bufSpanStart b)
psSpanEnd :: PsSpan -> PsLoc
psSpanEnd (PsSpan r b) = PsLoc (realSrcSpanEnd r) (bufSpanEnd b)
mkSrcSpanPs :: PsSpan -> SrcSpan
mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Just b)
data LayoutInfo =
ExplicitBraces
|
VirtualBraces
!Int
|
NoLayoutInfo
deriving (Eq, Ord, Show, Data)
leftmostColumn :: Int
leftmostColumn = 1