{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module GHC.Util.SrcLoc (
    getAncLoc
  , stripLocs
  , SrcSpanD(..)
  ) where

import GHC.Parser.Annotation
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Data.Strict qualified

import Data.Default
import Data.Data
import Data.Generics.Uniplate.DataOnly

-- Get the 'SrcSpan' out of a value located by an 'Anchor' (e.g.
-- comments).
getAncLoc :: GenLocated Anchor a -> SrcSpan
getAncLoc :: forall a. GenLocated Anchor a -> SrcSpan
getAncLoc GenLocated Anchor a
o = RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (Anchor -> RealSrcSpan
anchor (GenLocated Anchor a -> Anchor
forall l e. GenLocated l e -> l
getLoc GenLocated Anchor a
o)) Maybe BufSpan
forall a. Maybe a
GHC.Data.Strict.Nothing

-- 'stripLocs x' is 'x' with all contained source locs replaced by
-- 'noSrcSpan'.
stripLocs :: Data from => from -> from
stripLocs :: forall from. Data from => from -> from
stripLocs =
  (RealSrcSpan -> RealSrcSpan) -> from -> from
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi (RealSrcSpan -> RealSrcSpan -> RealSrcSpan
forall a b. a -> b -> a
const RealSrcSpan
dummySpan) (from -> from) -> (from -> from) -> from -> from
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SrcSpan -> SrcSpan) -> from -> from
forall from to. Biplate from to => (to -> to) -> from -> from
transformBi (SrcSpan -> SrcSpan -> SrcSpan
forall a b. a -> b -> a
const SrcSpan
noSrcSpan)
  where
    dummyLoc :: RealSrcLoc
dummyLoc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
fsLit String
"dummy") Int
1 Int
1
    dummySpan :: RealSrcSpan
dummySpan = RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan RealSrcLoc
dummyLoc RealSrcLoc
dummyLoc

-- TODO (2020-10-03, SF): Maybe move the following definitions down to
-- ghc-lib-parser at some point.

-- 'Duplicates.hs' requires 'SrcSpan' be in 'Default' and 'Ord'.
newtype SrcSpanD = SrcSpanD SrcSpan
  deriving (SrcSpanD -> SDoc
(SrcSpanD -> SDoc) -> Outputable SrcSpanD
forall a. (a -> SDoc) -> Outputable a
$cppr :: SrcSpanD -> SDoc
ppr :: SrcSpanD -> SDoc
Outputable, SrcSpanD -> SrcSpanD -> Bool
(SrcSpanD -> SrcSpanD -> Bool)
-> (SrcSpanD -> SrcSpanD -> Bool) -> Eq SrcSpanD
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SrcSpanD -> SrcSpanD -> Bool
== :: SrcSpanD -> SrcSpanD -> Bool
$c/= :: SrcSpanD -> SrcSpanD -> Bool
/= :: SrcSpanD -> SrcSpanD -> Bool
Eq)
instance Default SrcSpanD where def :: SrcSpanD
def = SrcSpan -> SrcSpanD
SrcSpanD SrcSpan
noSrcSpan

newtype FastStringD = FastStringD FastString
  deriving FastStringD -> FastStringD -> Bool
(FastStringD -> FastStringD -> Bool)
-> (FastStringD -> FastStringD -> Bool) -> Eq FastStringD
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FastStringD -> FastStringD -> Bool
== :: FastStringD -> FastStringD -> Bool
$c/= :: FastStringD -> FastStringD -> Bool
/= :: FastStringD -> FastStringD -> Bool
Eq
compareFastStrings :: FastStringD -> FastStringD -> Ordering
compareFastStrings (FastStringD FastString
f) (FastStringD FastString
g) =
  FastString -> FastString -> Ordering
lexicalCompareFS FastString
f FastString
g
instance Ord FastStringD where compare :: FastStringD -> FastStringD -> Ordering
compare = FastStringD -> FastStringD -> Ordering
compareFastStrings

-- SrcSpan no longer provides 'Ord' so we are forced to roll our own.
--
-- Note: This implementation chooses that any span compares 'EQ to an
-- 'UnhelpfulSpan'. Ex falso quodlibet!
compareSrcSpans :: SrcSpanD -> SrcSpanD -> Ordering
compareSrcSpans (SrcSpanD SrcSpan
a) (SrcSpanD SrcSpan
b) =
  case SrcSpan
a of
    RealSrcSpan RealSrcSpan
a1 Maybe BufSpan
_ ->
      case SrcSpan
b of
        RealSrcSpan RealSrcSpan
b1 Maybe BufSpan
_ ->
          RealSrcSpan
a1 RealSrcSpan -> RealSrcSpan -> Ordering
`compareRealSrcSpans` RealSrcSpan
b1
        SrcSpan
_ -> Ordering
EQ -- error "'Duplicate.hs' invariant error: can't compare unhelpful spans"
    SrcSpan
_ -> Ordering
EQ -- error "'Duplicate.hs' invariant error: can't compare unhelpful spans"
compareRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> Ordering
compareRealSrcSpans RealSrcSpan
a RealSrcSpan
b =
  let (LexicalFastString
a1, Int
a2, Int
a3, Int
a4, Int
a5) = (FastString -> LexicalFastString
LexicalFastString (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
a), RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
a, RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
a, RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
a, RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
a)
      (LexicalFastString
b1, Int
b2, Int
b3, Int
b4, Int
b5) = (FastString -> LexicalFastString
LexicalFastString (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
b), RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
b, RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
b, RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
b, RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
b)
  in (LexicalFastString, Int, Int, Int, Int)
-> (LexicalFastString, Int, Int, Int, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (LexicalFastString
a1, Int
a2, Int
a3, Int
a4, Int
a5) (LexicalFastString
b1, Int
b2, Int
b3, Int
b4, Int
b5)
instance Ord SrcSpanD where compare :: SrcSpanD -> SrcSpanD -> Ordering
compare = SrcSpanD -> SrcSpanD -> Ordering
compareSrcSpans