{-# LANGUAGE GeneralizedNewtypeDeriving #-}

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

import GHC.Types.SrcLoc
import GHC.Utils.Outputable

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

-- 'stripLocs x' is 'x' with all contained source locs replaced by
-- 'noSrcSpan'.
stripLocs :: Data from => from -> from
stripLocs :: from -> from
stripLocs = (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)

-- 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 (Rational -> SrcSpanD -> SDoc
SrcSpanD -> SDoc
(SrcSpanD -> SDoc)
-> (Rational -> SrcSpanD -> SDoc) -> Outputable SrcSpanD
forall a. (a -> SDoc) -> (Rational -> a -> SDoc) -> Outputable a
pprPrec :: Rational -> SrcSpanD -> SDoc
$cpprPrec :: Rational -> SrcSpanD -> SDoc
ppr :: SrcSpanD -> SDoc
$cppr :: SrcSpanD -> SDoc
Outputable, SrcSpanD -> SrcSpanD -> Bool
(SrcSpanD -> SrcSpanD -> Bool)
-> (SrcSpanD -> SrcSpanD -> Bool) -> Eq SrcSpanD
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SrcSpanD -> SrcSpanD -> Bool
$c/= :: SrcSpanD -> SrcSpanD -> Bool
== :: SrcSpanD -> SrcSpanD -> Bool
$c== :: SrcSpanD -> SrcSpanD -> Bool
Eq)
instance Default SrcSpanD where def :: SrcSpanD
def = SrcSpan -> SrcSpanD
SrcSpanD SrcSpan
noSrcSpan

-- 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 (FastString
a1, Int
a2, Int
a3, Int
a4, Int
a5) = (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)
      (FastString
b1, Int
b2, Int
b3, Int
b4, Int
b5) = (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 (FastString, Int, Int, Int, Int)
-> (FastString, Int, Int, Int, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (FastString
a1, Int
a2, Int
a3, Int
a4, Int
a5) (FastString
b1, Int
b2, Int
b3, Int
b4, Int
b5)
instance Ord SrcSpanD where compare :: SrcSpanD -> SrcSpanD -> Ordering
compare = SrcSpanD -> SrcSpanD -> Ordering
compareSrcSpans