{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Language.Haskell.GHC.ExactPrint.Utils
  -- (
  --  -- * Manipulating Positons
  --   ss2pos
  -- , ss2posEnd
  -- , undelta
  -- , isPointSrcSpan
  -- , pos2delta
  -- , ss2delta
  -- , addDP
  -- , spanLength
  -- , isGoodDelta
  -- ) where
  where

import Control.Monad (when)
import Data.Function
import Data.List
import Data.Maybe
import Data.Ord (comparing)

import Language.Haskell.GHC.ExactPrint.Lookup

import qualified Language.Haskell.GHC.ExactPrint.Orphans()

import GHC hiding (EpaComment)
import qualified GHC
import GHC.Types.Name
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Driver.Ppr
import GHC.Data.FastString
import qualified GHC.Data.Strict as Strict
import GHC.Base (NonEmpty(..))

import Debug.Trace
import Language.Haskell.GHC.ExactPrint.Types
import Data.Default

-- ---------------------------------------------------------------------

-- |Global switch to enable debug tracing in ghc-exactprint Delta / Print
debugEnabledFlag :: Bool
-- debugEnabledFlag = True
debugEnabledFlag :: Bool
debugEnabledFlag = Bool
False

-- |Provide a version of trace that comes at the end of the line, so it can
-- easily be commented out when debugging different things.
debug :: c -> String -> c
debug :: forall c. c -> String -> c
debug c
c String
s = if Bool
debugEnabledFlag
              then String -> c -> c
forall a. String -> a -> a
trace String
s c
c
              else c
c
debugM :: Monad m => String -> m ()
debugM :: forall (m :: * -> *). Monad m => String -> m ()
debugM String
s = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debugEnabledFlag (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall (f :: * -> *). Applicative f => String -> f ()
traceM String
s

-- ---------------------------------------------------------------------

warn :: c -> String -> c
-- warn = flip trace
warn :: forall c. c -> String -> c
warn c
c String
_ = c
c

-- | A good delta has no negative values.
isGoodDelta :: DeltaPos -> Bool
isGoodDelta :: DeltaPos -> Bool
isGoodDelta (SameLine Int
co) = Int
co Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
isGoodDelta (DifferentLine Int
ro Int
_co) = Int
ro Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
  -- Note: DifferentLine invariant is ro is nonzero and positive


-- | Create a delta from the current position to the start of the given
-- @RealSrcSpan@.
ss2delta :: Pos -> RealSrcSpan -> DeltaPos
ss2delta :: Pos -> RealSrcSpan -> DeltaPos
ss2delta Pos
ref RealSrcSpan
ss = Pos -> Pos -> DeltaPos
pos2delta Pos
ref (RealSrcSpan -> Pos
ss2pos RealSrcSpan
ss)

-- | create a delta from the end of a current span.  The +1 is because
-- the stored position ends up one past the span, this is prior to
-- that adjustment
ss2deltaEnd :: RealSrcSpan -> RealSrcSpan -> DeltaPos
ss2deltaEnd :: RealSrcSpan -> RealSrcSpan -> DeltaPos
ss2deltaEnd RealSrcSpan
rrs RealSrcSpan
ss = Pos -> RealSrcSpan -> DeltaPos
ss2delta Pos
ref RealSrcSpan
ss
  where
    (Int
r,Int
c) = RealSrcSpan -> Pos
ss2posEnd RealSrcSpan
rrs
    ref :: Pos
ref = if Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
             then (Int
r,Int
cInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
             else (Int
r,Int
c)

-- | create a delta from the start of a current span.  The +1 is
-- because the stored position ends up one past the span, this is
-- prior to that adjustment
ss2deltaStart :: RealSrcSpan -> RealSrcSpan -> DeltaPos
ss2deltaStart :: RealSrcSpan -> RealSrcSpan -> DeltaPos
ss2deltaStart RealSrcSpan
rrs RealSrcSpan
ss = Pos -> RealSrcSpan -> DeltaPos
ss2delta Pos
ref RealSrcSpan
ss
  where
    (Int
r,Int
c) = RealSrcSpan -> Pos
ss2pos RealSrcSpan
rrs
    ref :: Pos
ref = if Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
             then (Int
r,Int
c)
             else (Int
r,Int
c)

-- | Convert the start of the second @Pos@ to be an offset from the
-- first. The assumption is the reference starts before the second @Pos@
pos2delta :: Pos -> Pos -> DeltaPos
pos2delta :: Pos -> Pos -> DeltaPos
pos2delta (Int
refl,Int
refc) (Int
l,Int
c) = Int -> Int -> DeltaPos
deltaPos Int
lo Int
co
  where
    lo :: Int
lo = Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
refl
    co :: Int
co = if Int
lo Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
refc
                    else Int
c

-- | Apply the delta to the current position, taking into account the
-- current column offset if advancing to a new line
undelta :: Pos -> DeltaPos -> LayoutStartCol -> Pos
undelta :: Pos -> DeltaPos -> LayoutStartCol -> Pos
undelta (Int
l,Int
c) (SameLine Int
dc)         (LayoutStartCol Int
_co) = (Int
l, Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dc)
undelta (Int
l,Int
_) (DifferentLine Int
dl Int
dc) (LayoutStartCol Int
co) = (Int
fl,Int
fc)
  where
    -- Note: invariant: dl > 0
    fl :: Int
fl = Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dl
    fc :: Int
fc = Int
co Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
dc

undeltaSpan :: RealSrcSpan -> AnnKeywordId -> DeltaPos -> AddEpAnn
undeltaSpan :: RealSrcSpan -> AnnKeywordId -> DeltaPos -> AddEpAnn
undeltaSpan RealSrcSpan
anchor AnnKeywordId
kw DeltaPos
dp = AnnKeywordId -> EpaLocation -> AddEpAnn
AddEpAnn AnnKeywordId
kw (RealSrcSpan -> Maybe BufSpan -> EpaLocation
EpaSpan RealSrcSpan
sp Maybe BufSpan
forall a. Maybe a
Strict.Nothing)
  where
    (Int
l,Int
c) = Pos -> DeltaPos -> LayoutStartCol -> Pos
undelta (RealSrcSpan -> Pos
ss2pos RealSrcSpan
anchor) DeltaPos
dp (Int -> LayoutStartCol
LayoutStartCol Int
0)
    len :: Int
len = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (AnnKeywordId -> String
keywordToString AnnKeywordId
kw)
    sp :: RealSrcSpan
sp = (Pos, Pos) -> RealSrcSpan
range2rs ((Int
l,Int
c),(Int
l,Int
cInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
len))

-- ---------------------------------------------------------------------

adjustDeltaForOffset :: LayoutStartCol -> DeltaPos -> DeltaPos
adjustDeltaForOffset :: LayoutStartCol -> DeltaPos -> DeltaPos
adjustDeltaForOffset LayoutStartCol
_colOffset                      dp :: DeltaPos
dp@(SameLine Int
_) = DeltaPos
dp
adjustDeltaForOffset (LayoutStartCol Int
colOffset) (DifferentLine Int
l Int
c)
  = Int -> Int -> DeltaPos
DifferentLine Int
l (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
colOffset)

-- ---------------------------------------------------------------------

ss2pos :: RealSrcSpan -> Pos
ss2pos :: RealSrcSpan -> Pos
ss2pos RealSrcSpan
ss = (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
ss,RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
ss)

ss2posEnd :: RealSrcSpan -> Pos
ss2posEnd :: RealSrcSpan -> Pos
ss2posEnd RealSrcSpan
ss = (RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
ss,RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
ss)

ss2range :: SrcSpan -> (Pos,Pos)
ss2range :: SrcSpan -> (Pos, Pos)
ss2range SrcSpan
ss = (RealSrcSpan -> Pos
ss2pos (RealSrcSpan -> Pos) -> RealSrcSpan -> Pos
forall a b. (a -> b) -> a -> b
$ SrcSpan -> RealSrcSpan
rs SrcSpan
ss, RealSrcSpan -> Pos
ss2posEnd (RealSrcSpan -> Pos) -> RealSrcSpan -> Pos
forall a b. (a -> b) -> a -> b
$ SrcSpan -> RealSrcSpan
rs SrcSpan
ss)

rs2range :: RealSrcSpan -> (Pos,Pos)
rs2range :: RealSrcSpan -> (Pos, Pos)
rs2range RealSrcSpan
ss = (RealSrcSpan -> Pos
ss2pos RealSrcSpan
ss, RealSrcSpan -> Pos
ss2posEnd RealSrcSpan
ss)

rs :: SrcSpan -> RealSrcSpan
rs :: SrcSpan -> RealSrcSpan
rs (RealSrcSpan RealSrcSpan
s Maybe BufSpan
_) = RealSrcSpan
s
rs SrcSpan
_ = RealSrcSpan
badRealSrcSpan

range2rs :: (Pos,Pos) -> RealSrcSpan
range2rs :: (Pos, Pos) -> RealSrcSpan
range2rs (Pos
s,Pos
e) = RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan (Pos -> RealSrcLoc
mkLoc Pos
s) (Pos -> RealSrcLoc
mkLoc Pos
e)
  where
    mkLoc :: Pos -> RealSrcLoc
mkLoc (Int
l,Int
c) = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
fsLit String
"ghc-exactprint") Int
l Int
c

badRealSrcSpan :: RealSrcSpan
badRealSrcSpan :: RealSrcSpan
badRealSrcSpan = RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan RealSrcLoc
bad RealSrcLoc
bad
  where
    bad :: RealSrcLoc
bad = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc (String -> FastString
fsLit String
"ghc-exactprint-nospan") Int
0 Int
0

spanLength :: RealSrcSpan -> Int
spanLength :: RealSrcSpan -> Int
spanLength = (-) (Int -> Int -> Int)
-> (RealSrcSpan -> Int) -> RealSrcSpan -> Int -> Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RealSrcSpan -> Int
srcSpanEndCol (RealSrcSpan -> Int -> Int)
-> (RealSrcSpan -> Int) -> RealSrcSpan -> Int
forall a b.
(RealSrcSpan -> a -> b) -> (RealSrcSpan -> a) -> RealSrcSpan -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RealSrcSpan -> Int
srcSpanStartCol

-- ---------------------------------------------------------------------
-- | Checks whether a SrcSpan has zero length.
isPointSrcSpan :: RealSrcSpan -> Bool
isPointSrcSpan :: RealSrcSpan -> Bool
isPointSrcSpan RealSrcSpan
ss = RealSrcSpan -> Int
spanLength RealSrcSpan
ss Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                  Bool -> Bool -> Bool
&& RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
ss Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
ss

-- ---------------------------------------------------------------------

-- |Given a list of items and a list of keys, returns a list of items
-- ordered by their position in the list of keys.
orderByKey :: [(RealSrcSpan,a)] -> [RealSrcSpan] -> [(RealSrcSpan,a)]
orderByKey :: forall a. [(RealSrcSpan, a)] -> [RealSrcSpan] -> [(RealSrcSpan, a)]
orderByKey [(RealSrcSpan, a)]
keys [RealSrcSpan]
order
    -- AZ:TODO: if performance becomes a problem, consider a Map of the order
    -- SrcSpan to an index, and do a lookup instead of elemIndex.

    -- Items not in the ordering are placed to the start
 = ((RealSrcSpan, a) -> (RealSrcSpan, a) -> Ordering)
-> [(RealSrcSpan, a)] -> [(RealSrcSpan, a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((RealSrcSpan, a) -> Maybe Int)
-> (RealSrcSpan, a) -> (RealSrcSpan, a) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((RealSrcSpan -> [RealSrcSpan] -> Maybe Int)
-> [RealSrcSpan] -> RealSrcSpan -> Maybe Int
forall a b c. (a -> b -> c) -> b -> a -> c
flip RealSrcSpan -> [RealSrcSpan] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex [RealSrcSpan]
order (RealSrcSpan -> Maybe Int)
-> ((RealSrcSpan, a) -> RealSrcSpan)
-> (RealSrcSpan, a)
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RealSrcSpan, a) -> RealSrcSpan
forall a b. (a, b) -> a
fst)) [(RealSrcSpan, a)]
keys

-- ---------------------------------------------------------------------

isListComp :: HsDoFlavour -> Bool
isListComp :: HsDoFlavour -> Bool
isListComp = HsDoFlavour -> Bool
isDoComprehensionContext

-- ---------------------------------------------------------------------

needsWhere :: DataDefnCons (LConDecl (GhcPass p)) -> Bool
needsWhere :: forall (p :: Pass). DataDefnCons (LConDecl (GhcPass p)) -> Bool
needsWhere (NewTypeCon LConDecl (GhcPass p)
_) = Bool
True
needsWhere (DataTypeCons Bool
_ []) = Bool
True
needsWhere (DataTypeCons Bool
_ ((L SrcSpanAnnA
_ (ConDeclGADT{})):[LConDecl (GhcPass p)]
_)) = Bool
True
needsWhere DataDefnCons (LConDecl (GhcPass p))
_ = Bool
False

-- ---------------------------------------------------------------------

insertCppComments ::  ParsedSource -> [LEpaComment] -> ParsedSource
insertCppComments :: ParsedSource -> [LEpaComment] -> ParsedSource
insertCppComments (L SrcSpan
l HsModule GhcPs
p) [LEpaComment]
cs = SrcSpan -> HsModule GhcPs -> ParsedSource
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsModule GhcPs
p'
  where
    an' :: EpAnn AnnsModule
an' = case XModulePs -> EpAnn AnnsModule
GHC.hsmodAnn (XModulePs -> EpAnn AnnsModule) -> XModulePs -> EpAnn AnnsModule
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs -> XCModule GhcPs
forall p. HsModule p -> XCModule p
GHC.hsmodExt HsModule GhcPs
p of
      (EpAnn Anchor
a AnnsModule
an EpAnnComments
ocs) -> Anchor -> AnnsModule -> EpAnnComments -> EpAnn AnnsModule
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn Anchor
a AnnsModule
an ([LEpaComment] -> EpAnnComments
EpaComments [LEpaComment]
cs')
        where
          cs' :: [LEpaComment]
cs' = [LEpaComment] -> [LEpaComment]
sortEpaComments ([LEpaComment] -> [LEpaComment]) -> [LEpaComment] -> [LEpaComment]
forall a b. (a -> b) -> a -> b
$ EpAnnComments -> [LEpaComment]
priorComments EpAnnComments
ocs [LEpaComment] -> [LEpaComment] -> [LEpaComment]
forall a. [a] -> [a] -> [a]
++ EpAnnComments -> [LEpaComment]
getFollowingComments EpAnnComments
ocs [LEpaComment] -> [LEpaComment] -> [LEpaComment]
forall a. [a] -> [a] -> [a]
++ [LEpaComment]
cs
      EpAnn AnnsModule
unused -> EpAnn AnnsModule
unused
    p' :: HsModule GhcPs
p' = HsModule GhcPs
p { GHC.hsmodExt = (GHC.hsmodExt p) { GHC.hsmodAnn = an' } }

-- ---------------------------------------------------------------------

ghcCommentText :: LEpaComment -> String
ghcCommentText :: LEpaComment -> String
ghcCommentText (L Anchor
_ (GHC.EpaComment (EpaDocComment HsDocString
s) RealSrcSpan
_))      = HsDocString -> String
exactPrintHsDocString HsDocString
s
ghcCommentText (L Anchor
_ (GHC.EpaComment (EpaDocOptions String
s) RealSrcSpan
_))      = String
s
ghcCommentText (L Anchor
_ (GHC.EpaComment (EpaLineComment String
s) RealSrcSpan
_))     = String
s
ghcCommentText (L Anchor
_ (GHC.EpaComment (EpaBlockComment String
s) RealSrcSpan
_))    = String
s
ghcCommentText (L Anchor
_ (GHC.EpaComment (EpaCommentTok
EpaEofComment) RealSrcSpan
_))        = String
""

tokComment :: LEpaComment -> [Comment]
tokComment :: LEpaComment -> [Comment]
tokComment t :: LEpaComment
t@(L Anchor
lt EpaComment
c) =
  case EpaComment
c of
    (GHC.EpaComment (EpaDocComment HsDocString
dc) RealSrcSpan
pt) -> Anchor -> RealSrcSpan -> HsDocString -> [Comment]
hsDocStringComments Anchor
lt RealSrcSpan
pt HsDocString
dc
    EpaComment
_ -> [String -> Anchor -> RealSrcSpan -> Comment
mkComment (String -> String
normaliseCommentText (LEpaComment -> String
ghcCommentText LEpaComment
t)) Anchor
lt (EpaComment -> RealSrcSpan
ac_prior_tok EpaComment
c)]

hsDocStringComments :: Anchor -> RealSrcSpan -> GHC.HsDocString -> [Comment]
hsDocStringComments :: Anchor -> RealSrcSpan -> HsDocString -> [Comment]
hsDocStringComments Anchor
_ RealSrcSpan
pt (MultiLineDocString HsDocStringDecorator
dec (LHsDocStringChunk
x :| [LHsDocStringChunk]
xs)) =
  let
    decStr :: String
decStr = HsDocStringDecorator -> String
printDecorator HsDocStringDecorator
dec
    L SrcSpan
lx HsDocStringChunk
x' = Int -> LHsDocStringChunk -> LHsDocStringChunk
dedentDocChunkBy (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
decStr) LHsDocStringChunk
x
    str :: String
str = String
"-- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
decStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ HsDocStringChunk -> String
unpackHDSC HsDocStringChunk
x'
    docChunk :: RealSrcSpan -> [LHsDocStringChunk] -> [Comment]
docChunk RealSrcSpan
_ [] = []
    docChunk RealSrcSpan
pt' (L SrcSpan
l HsDocStringChunk
chunk:[LHsDocStringChunk]
cs)
      = String -> Anchor -> RealSrcSpan -> Maybe AnnKeywordId -> Comment
Comment (String
"--" String -> String -> String
forall a. [a] -> [a] -> [a]
++ HsDocStringChunk -> String
unpackHDSC HsDocStringChunk
chunk) (SrcSpan -> Anchor
spanAsAnchor SrcSpan
l) RealSrcSpan
pt' Maybe AnnKeywordId
forall a. Maybe a
Nothing Comment -> [Comment] -> [Comment]
forall a. a -> [a] -> [a]
: RealSrcSpan -> [LHsDocStringChunk] -> [Comment]
docChunk (SrcSpan -> RealSrcSpan
rs SrcSpan
l) [LHsDocStringChunk]
cs
  in
    (String -> Anchor -> RealSrcSpan -> Maybe AnnKeywordId -> Comment
Comment String
str (SrcSpan -> Anchor
spanAsAnchor SrcSpan
lx) RealSrcSpan
pt Maybe AnnKeywordId
forall a. Maybe a
Nothing Comment -> [Comment] -> [Comment]
forall a. a -> [a] -> [a]
: RealSrcSpan -> [LHsDocStringChunk] -> [Comment]
docChunk (SrcSpan -> RealSrcSpan
rs SrcSpan
lx) ((LHsDocStringChunk -> LHsDocStringChunk)
-> [LHsDocStringChunk] -> [LHsDocStringChunk]
forall a b. (a -> b) -> [a] -> [b]
map LHsDocStringChunk -> LHsDocStringChunk
dedentDocChunk [LHsDocStringChunk]
xs))
hsDocStringComments Anchor
anc RealSrcSpan
pt (NestedDocString dec :: HsDocStringDecorator
dec@(HsDocStringNamed String
_) (L SrcSpan
_ HsDocStringChunk
chunk))
  = [String -> Anchor -> RealSrcSpan -> Maybe AnnKeywordId -> Comment
Comment (String
"{- " String -> String -> String
forall a. [a] -> [a] -> [a]
++ HsDocStringDecorator -> String
printDecorator HsDocStringDecorator
dec String -> String -> String
forall a. [a] -> [a] -> [a]
++ HsDocStringChunk -> String
unpackHDSC HsDocStringChunk
chunk String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-}") Anchor
anc RealSrcSpan
pt Maybe AnnKeywordId
forall a. Maybe a
Nothing ]
hsDocStringComments Anchor
anc RealSrcSpan
pt (NestedDocString HsDocStringDecorator
dec (L SrcSpan
_ HsDocStringChunk
chunk))
  = [String -> Anchor -> RealSrcSpan -> Maybe AnnKeywordId -> Comment
Comment (String
"{-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ HsDocStringDecorator -> String
printDecorator HsDocStringDecorator
dec String -> String -> String
forall a. [a] -> [a] -> [a]
++ HsDocStringChunk -> String
unpackHDSC HsDocStringChunk
chunk String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-}") Anchor
anc RealSrcSpan
pt Maybe AnnKeywordId
forall a. Maybe a
Nothing ]

hsDocStringComments Anchor
_ RealSrcSpan
_ (GeneratedDocString HsDocStringChunk
_) = [] -- Should not appear in user-written code

-- Temporary until https://gitlab.haskell.org/ghc/ghc/-/issues/23459 is landed
-- At the moment the locations of the 'HsDocStringChunk's are from the start of
-- the string part, leaving aside the "--". So we need to subtract 2 columns from it
dedentDocChunk :: LHsDocStringChunk -> LHsDocStringChunk
dedentDocChunk :: LHsDocStringChunk -> LHsDocStringChunk
dedentDocChunk LHsDocStringChunk
chunk = Int -> LHsDocStringChunk -> LHsDocStringChunk
dedentDocChunkBy Int
2 LHsDocStringChunk
chunk

dedentDocChunkBy :: Int -> LHsDocStringChunk -> LHsDocStringChunk
dedentDocChunkBy :: Int -> LHsDocStringChunk -> LHsDocStringChunk
dedentDocChunkBy  Int
dedent (L (RealSrcSpan RealSrcSpan
l Maybe BufSpan
mb) HsDocStringChunk
c) = SrcSpan -> HsDocStringChunk -> LHsDocStringChunk
forall l e. l -> e -> GenLocated l e
L (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
l' Maybe BufSpan
mb) HsDocStringChunk
c
  where
    f :: FastString
f = RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
l
    sl :: Int
sl = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
l
    sc :: Int
sc = RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
l
    el :: Int
el = RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
l
    ec :: Int
ec = RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
l
    l' :: RealSrcSpan
l' = RealSrcLoc -> RealSrcLoc -> RealSrcSpan
mkRealSrcSpan (FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
f Int
sl (Int
sc Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
dedent))
                       (FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc FastString
f Int
el (Int
ec Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
dedent))

dedentDocChunkBy Int
_ LHsDocStringChunk
x = LHsDocStringChunk
x

-- Temporary until https://gitlab.haskell.org/ghc/ghc/-/issues/23459 is landed
printDecorator :: HsDocStringDecorator -> String
printDecorator :: HsDocStringDecorator -> String
printDecorator HsDocStringDecorator
HsDocStringNext = String
"|"
printDecorator HsDocStringDecorator
HsDocStringPrevious = String
"^"
printDecorator (HsDocStringNamed String
n) = Char
'$'Char -> String -> String
forall a. a -> [a] -> [a]
:String
n
printDecorator (HsDocStringGroup Int
n) = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
'*'



mkEpaComments :: [Comment] -> [Comment] -> EpAnnComments
mkEpaComments :: [Comment] -> [Comment] -> EpAnnComments
mkEpaComments [Comment]
priorCs []
  = [LEpaComment] -> EpAnnComments
EpaComments ((Comment -> LEpaComment) -> [Comment] -> [LEpaComment]
forall a b. (a -> b) -> [a] -> [b]
map Comment -> LEpaComment
comment2LEpaComment [Comment]
priorCs)
mkEpaComments [Comment]
priorCs [Comment]
postCs
  = [LEpaComment] -> [LEpaComment] -> EpAnnComments
EpaCommentsBalanced ((Comment -> LEpaComment) -> [Comment] -> [LEpaComment]
forall a b. (a -> b) -> [a] -> [b]
map Comment -> LEpaComment
comment2LEpaComment [Comment]
priorCs) ((Comment -> LEpaComment) -> [Comment] -> [LEpaComment]
forall a b. (a -> b) -> [a] -> [b]
map Comment -> LEpaComment
comment2LEpaComment [Comment]
postCs)

comment2LEpaComment :: Comment -> LEpaComment
comment2LEpaComment :: Comment -> LEpaComment
comment2LEpaComment (Comment String
s Anchor
anc RealSrcSpan
r Maybe AnnKeywordId
_mk) = String -> Anchor -> RealSrcSpan -> LEpaComment
mkLEpaComment String
s Anchor
anc RealSrcSpan
r

mkLEpaComment :: String -> Anchor -> RealSrcSpan -> LEpaComment
mkLEpaComment :: String -> Anchor -> RealSrcSpan -> LEpaComment
mkLEpaComment String
"" Anchor
anc RealSrcSpan
r = (Anchor -> EpaComment -> LEpaComment
forall l e. l -> e -> GenLocated l e
L Anchor
anc (EpaCommentTok -> RealSrcSpan -> EpaComment
GHC.EpaComment (EpaCommentTok
EpaEofComment) RealSrcSpan
r))
mkLEpaComment String
s Anchor
anc RealSrcSpan
r = (Anchor -> EpaComment -> LEpaComment
forall l e. l -> e -> GenLocated l e
L Anchor
anc (EpaCommentTok -> RealSrcSpan -> EpaComment
GHC.EpaComment (String -> EpaCommentTok
EpaLineComment String
s) RealSrcSpan
r))

mkComment :: String -> Anchor -> RealSrcSpan -> Comment
mkComment :: String -> Anchor -> RealSrcSpan -> Comment
mkComment String
c Anchor
anc RealSrcSpan
r = String -> Anchor -> RealSrcSpan -> Maybe AnnKeywordId -> Comment
Comment String
c Anchor
anc RealSrcSpan
r Maybe AnnKeywordId
forall a. Maybe a
Nothing

-- Windows comments include \r in them from the lexer.
normaliseCommentText :: String -> String
normaliseCommentText :: String -> String
normaliseCommentText = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r')

-- |Must compare without span filenames, for CPP injected comments with fake filename
cmpComments :: Comment -> Comment -> Ordering
cmpComments :: Comment -> Comment -> Ordering
cmpComments (Comment String
_ Anchor
l1 RealSrcSpan
_ Maybe AnnKeywordId
_) (Comment String
_ Anchor
l2 RealSrcSpan
_ Maybe AnnKeywordId
_) = Pos -> Pos -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (RealSrcSpan -> Pos
ss2pos (RealSrcSpan -> Pos) -> RealSrcSpan -> Pos
forall a b. (a -> b) -> a -> b
$ Anchor -> RealSrcSpan
anchor Anchor
l1) (RealSrcSpan -> Pos
ss2pos (RealSrcSpan -> Pos) -> RealSrcSpan -> Pos
forall a b. (a -> b) -> a -> b
$ Anchor -> RealSrcSpan
anchor Anchor
l2)

-- |Sort, comparing without span filenames, for CPP injected comments with fake filename
sortComments :: [Comment] -> [Comment]
sortComments :: [Comment] -> [Comment]
sortComments [Comment]
cs = (Comment -> Comment -> Ordering) -> [Comment] -> [Comment]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Comment -> Comment -> Ordering
cmpComments [Comment]
cs

-- |Sort, comparing without span filenames, for CPP injected comments with fake filename
sortEpaComments :: [LEpaComment] -> [LEpaComment]
sortEpaComments :: [LEpaComment] -> [LEpaComment]
sortEpaComments [LEpaComment]
cs = (LEpaComment -> LEpaComment -> Ordering)
-> [LEpaComment] -> [LEpaComment]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy LEpaComment -> LEpaComment -> Ordering
forall {e} {e}.
GenLocated Anchor e -> GenLocated Anchor e -> Ordering
cmp [LEpaComment]
cs
  where
    cmp :: GenLocated Anchor e -> GenLocated Anchor e -> Ordering
cmp (L Anchor
l1 e
_) (L Anchor
l2 e
_) = Pos -> Pos -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (RealSrcSpan -> Pos
ss2pos (RealSrcSpan -> Pos) -> RealSrcSpan -> Pos
forall a b. (a -> b) -> a -> b
$ Anchor -> RealSrcSpan
anchor Anchor
l1) (RealSrcSpan -> Pos
ss2pos (RealSrcSpan -> Pos) -> RealSrcSpan -> Pos
forall a b. (a -> b) -> a -> b
$ Anchor -> RealSrcSpan
anchor Anchor
l2)

-- | Makes a comment which originates from a specific keyword.
mkKWComment :: AnnKeywordId -> EpaLocation -> Comment
mkKWComment :: AnnKeywordId -> EpaLocation -> Comment
mkKWComment AnnKeywordId
kw (EpaSpan RealSrcSpan
ss Maybe BufSpan
_)
  = String -> Anchor -> RealSrcSpan -> Maybe AnnKeywordId -> Comment
Comment (AnnKeywordId -> String
keywordToString AnnKeywordId
kw) (RealSrcSpan -> AnchorOperation -> Anchor
Anchor RealSrcSpan
ss AnchorOperation
UnchangedAnchor) RealSrcSpan
ss (AnnKeywordId -> Maybe AnnKeywordId
forall a. a -> Maybe a
Just AnnKeywordId
kw)
mkKWComment AnnKeywordId
kw (EpaDelta DeltaPos
dp [LEpaComment]
_)
  = String -> Anchor -> RealSrcSpan -> Maybe AnnKeywordId -> Comment
Comment (AnnKeywordId -> String
keywordToString AnnKeywordId
kw) (RealSrcSpan -> AnchorOperation -> Anchor
Anchor RealSrcSpan
placeholderRealSpan (DeltaPos -> AnchorOperation
MovedAnchor DeltaPos
dp)) RealSrcSpan
placeholderRealSpan (AnnKeywordId -> Maybe AnnKeywordId
forall a. a -> Maybe a
Just AnnKeywordId
kw)

-- | Detects a comment which originates from a specific keyword.
isKWComment :: Comment -> Bool
isKWComment :: Comment -> Bool
isKWComment Comment
c = Maybe AnnKeywordId -> Bool
forall a. Maybe a -> Bool
isJust (Comment -> Maybe AnnKeywordId
commentOrigin Comment
c)

noKWComments :: [Comment] -> [Comment]
noKWComments :: [Comment] -> [Comment]
noKWComments = (Comment -> Bool) -> [Comment] -> [Comment]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Comment
c -> Bool -> Bool
not (Comment -> Bool
isKWComment Comment
c))

sortAnchorLocated :: [GenLocated Anchor a] -> [GenLocated Anchor a]
sortAnchorLocated :: forall a. [GenLocated Anchor a] -> [GenLocated Anchor a]
sortAnchorLocated = (GenLocated Anchor a -> GenLocated Anchor a -> Ordering)
-> [GenLocated Anchor a] -> [GenLocated Anchor a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (RealSrcSpan -> RealSrcSpan -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (RealSrcSpan -> RealSrcSpan -> Ordering)
-> (GenLocated Anchor a -> RealSrcSpan)
-> GenLocated Anchor a
-> GenLocated Anchor a
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Anchor -> RealSrcSpan
anchor (Anchor -> RealSrcSpan)
-> (GenLocated Anchor a -> Anchor)
-> GenLocated Anchor a
-> RealSrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated Anchor a -> Anchor
forall l e. GenLocated l e -> l
getLoc))

-- | Calculates the distance from the start of a string to the end of
-- a string.
dpFromString ::  String -> DeltaPos
dpFromString :: String -> DeltaPos
dpFromString String
xs = String -> Int -> Int -> DeltaPos
dpFromString' String
xs Int
0 Int
0
  where
    dpFromString' :: String -> Int -> Int -> DeltaPos
dpFromString' String
"" Int
line Int
col =
      if Int
line Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        then Int -> DeltaPos
SameLine Int
col
        else Int -> Int -> DeltaPos
DifferentLine Int
line Int
col
    dpFromString' (Char
'\n': String
cs) Int
line Int
_   = String -> Int -> Int -> DeltaPos
dpFromString' String
cs (Int
line Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Int
0
    dpFromString' (Char
_:String
cs)     Int
line Int
col = String -> Int -> Int -> DeltaPos
dpFromString' String
cs Int
line       (Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)

-- ---------------------------------------------------------------------

isSymbolRdrName :: RdrName -> Bool
isSymbolRdrName :: RdrName -> Bool
isSymbolRdrName RdrName
n = OccName -> Bool
isSymOcc (OccName -> Bool) -> OccName -> Bool
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
rdrNameOcc RdrName
n

rdrName2String :: RdrName -> String
rdrName2String :: RdrName -> String
rdrName2String RdrName
r =
  case RdrName -> Maybe Name
isExact_maybe RdrName
r of
    Just Name
n  -> Name -> String
name2String Name
n
    Maybe Name
Nothing ->
      case RdrName
r of
        Unqual OccName
occ       -> OccName -> String
occNameString OccName
occ
        Qual ModuleName
modname OccName
occ -> ModuleName -> String
moduleNameString ModuleName
modname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
                                String -> String -> String
forall a. [a] -> [a] -> [a]
++ OccName -> String
occNameString OccName
occ
        Orig Module
_ OccName
occ       -> OccName -> String
occNameString OccName
occ
        Exact Name
n          -> Name -> String
forall a. NamedThing a => a -> String
getOccString Name
n

name2String :: Name -> String
name2String :: Name -> String
name2String = Name -> String
forall a. Outputable a => a -> String
showPprUnsafe

-- ---------------------------------------------------------------------

-- occAttributes :: OccName.OccName -> String
-- occAttributes o = "(" ++ ns ++ vo ++ tv ++ tc ++ d ++ ds ++ s ++ v ++ ")"
--   where
--     -- ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", "
--     ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", "
--     vo = if isVarOcc     o then "Var "     else ""
--     tv = if isTvOcc      o then "Tv "      else ""
--     tc = if isTcOcc      o then "Tc "      else ""
--     d  = if isDataOcc    o then "Data "    else ""
--     ds = if isDataSymOcc o then "DataSym " else ""
--     s  = if isSymOcc     o then "Sym "     else ""
--     v  = if isValOcc     o then "Val "     else ""

 -- ---------------------------------------------------------------------

locatedAnAnchor :: LocatedAn a t -> RealSrcSpan
locatedAnAnchor :: forall a t. LocatedAn a t -> RealSrcSpan
locatedAnAnchor (L (SrcSpanAnn EpAnn a
EpAnnNotUsed SrcSpan
l) t
_) = SrcSpan -> RealSrcSpan
realSrcSpan SrcSpan
l
locatedAnAnchor (L (SrcSpanAnn (EpAnn Anchor
a a
_ EpAnnComments
_) SrcSpan
_) t
_) = Anchor -> RealSrcSpan
anchor Anchor
a

-- ---------------------------------------------------------------------

-- Note: moved to Language.Haskell.GHC.ExactPrint.ExactPrint as a hack
-- to avoid import loop problems while we have to use the local
-- version of Dump
-- showAst :: (Data a) => a -> String
-- showAst ast
--   = showSDocUnsafe
--     $ showAstData NoBlankSrcSpan NoBlankEpAnnotations ast

-- ---------------------------------------------------------------------

setAnchorAn :: (Default an) => LocatedAn an a -> Anchor -> EpAnnComments -> LocatedAn an a
setAnchorAn :: forall an a.
Default an =>
LocatedAn an a -> Anchor -> EpAnnComments -> LocatedAn an a
setAnchorAn (L (SrcSpanAnn EpAnn an
EpAnnNotUsed SrcSpan
l)    a
a) Anchor
anc EpAnnComments
cs
  = (SrcAnn an -> a -> GenLocated (SrcAnn an) a
forall l e. l -> e -> GenLocated l e
L (EpAnn an -> SrcSpan -> SrcAnn an
forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn (Anchor -> an -> EpAnnComments -> EpAnn an
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn Anchor
anc an
forall a. Default a => a
def EpAnnComments
cs) SrcSpan
l) a
a)
     -- `debug` ("setAnchorAn: anc=" ++ showAst anc)
setAnchorAn (L (SrcSpanAnn (EpAnn Anchor
_ an
an EpAnnComments
_) SrcSpan
l) a
a) Anchor
anc EpAnnComments
cs
  = (SrcAnn an -> a -> GenLocated (SrcAnn an) a
forall l e. l -> e -> GenLocated l e
L (EpAnn an -> SrcSpan -> SrcAnn an
forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn (Anchor -> an -> EpAnnComments -> EpAnn an
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn Anchor
anc an
an EpAnnComments
cs) SrcSpan
l) a
a)
     -- `debug` ("setAnchorAn: anc=" ++ showAst anc)

setAnchorEpa :: (Default an) => EpAnn an -> Anchor -> EpAnnComments -> EpAnn an
setAnchorEpa :: forall an.
Default an =>
EpAnn an -> Anchor -> EpAnnComments -> EpAnn an
setAnchorEpa EpAnn an
EpAnnNotUsed   Anchor
anc EpAnnComments
cs = Anchor -> an -> EpAnnComments -> EpAnn an
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn Anchor
anc an
forall a. Default a => a
def EpAnnComments
cs
setAnchorEpa (EpAnn Anchor
_ an
an EpAnnComments
_) Anchor
anc EpAnnComments
cs = Anchor -> an -> EpAnnComments -> EpAnn an
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn Anchor
anc an
an          EpAnnComments
cs

setAnchorEpaL :: EpAnn AnnList -> Anchor -> EpAnnComments -> EpAnn AnnList
setAnchorEpaL :: EpAnn AnnList -> Anchor -> EpAnnComments -> EpAnn AnnList
setAnchorEpaL EpAnn AnnList
EpAnnNotUsed   Anchor
anc EpAnnComments
cs = Anchor -> AnnList -> EpAnnComments -> EpAnn AnnList
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn Anchor
anc AnnList
forall a. Monoid a => a
mempty EpAnnComments
cs
setAnchorEpaL (EpAnn Anchor
_ AnnList
an EpAnnComments
_) Anchor
anc EpAnnComments
cs = Anchor -> AnnList -> EpAnnComments -> EpAnn AnnList
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn Anchor
anc (AnnList
an {al_anchor = Nothing}) EpAnnComments
cs

setAnchorHsModule :: HsModule GhcPs -> Anchor -> EpAnnComments -> HsModule GhcPs
setAnchorHsModule :: HsModule GhcPs -> Anchor -> EpAnnComments -> HsModule GhcPs
setAnchorHsModule HsModule GhcPs
hsmod Anchor
anc EpAnnComments
cs = HsModule GhcPs
hsmod { hsmodExt = (hsmodExt hsmod) {hsmodAnn = an'} }
  where
    anc' :: Anchor
anc' = Anchor
anc { anchor_op = UnchangedAnchor }
    an' :: EpAnn AnnsModule
an' = EpAnn AnnsModule -> Anchor -> EpAnnComments -> EpAnn AnnsModule
forall an.
Default an =>
EpAnn an -> Anchor -> EpAnnComments -> EpAnn an
setAnchorEpa (XModulePs -> EpAnn AnnsModule
hsmodAnn (XModulePs -> EpAnn AnnsModule) -> XModulePs -> EpAnn AnnsModule
forall a b. (a -> b) -> a -> b
$ HsModule GhcPs -> XCModule GhcPs
forall p. HsModule p -> XCModule p
hsmodExt HsModule GhcPs
hsmod) Anchor
anc' EpAnnComments
cs

-- |Version of l2l that preserves the anchor, immportant if it has an
-- updated AnchorOperation
moveAnchor :: Monoid b => SrcAnn a -> SrcAnn b
moveAnchor :: forall b a. Monoid b => SrcAnn a -> SrcAnn b
moveAnchor (SrcSpanAnn EpAnn a
EpAnnNotUsed SrcSpan
l) = SrcSpan -> SrcAnn b
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
l
moveAnchor (SrcSpanAnn (EpAnn Anchor
anc a
_ EpAnnComments
cs) SrcSpan
l) = EpAnn b -> SrcSpan -> SrcAnn b
forall a. a -> SrcSpan -> SrcSpanAnn' a
SrcSpanAnn (Anchor -> b -> EpAnnComments -> EpAnn b
forall ann. Anchor -> ann -> EpAnnComments -> EpAnn ann
EpAnn Anchor
anc b
forall a. Monoid a => a
mempty EpAnnComments
cs) SrcSpan
l

-- ---------------------------------------------------------------------

trailingAnnLoc :: TrailingAnn -> EpaLocation
trailingAnnLoc :: TrailingAnn -> EpaLocation
trailingAnnLoc (AddSemiAnn EpaLocation
ss)    = EpaLocation
ss
trailingAnnLoc (AddCommaAnn EpaLocation
ss)   = EpaLocation
ss
trailingAnnLoc (AddVbarAnn EpaLocation
ss)    = EpaLocation
ss

setTrailingAnnLoc :: TrailingAnn -> EpaLocation -> TrailingAnn
setTrailingAnnLoc :: TrailingAnn -> EpaLocation -> TrailingAnn
setTrailingAnnLoc (AddSemiAnn EpaLocation
_)    EpaLocation
ss = (EpaLocation -> TrailingAnn
AddSemiAnn EpaLocation
ss)
setTrailingAnnLoc (AddCommaAnn EpaLocation
_)   EpaLocation
ss = (EpaLocation -> TrailingAnn
AddCommaAnn EpaLocation
ss)
setTrailingAnnLoc (AddVbarAnn EpaLocation
_)    EpaLocation
ss = (EpaLocation -> TrailingAnn
AddVbarAnn EpaLocation
ss)

addEpAnnLoc :: AddEpAnn -> EpaLocation
addEpAnnLoc :: AddEpAnn -> EpaLocation
addEpAnnLoc (AddEpAnn AnnKeywordId
_ EpaLocation
l) = EpaLocation
l

-- ---------------------------------------------------------------------

-- TODO: move this to GHC
anchorToEpaLocation :: Anchor -> EpaLocation
anchorToEpaLocation :: Anchor -> EpaLocation
anchorToEpaLocation (Anchor RealSrcSpan
r AnchorOperation
UnchangedAnchor) = RealSrcSpan -> Maybe BufSpan -> EpaLocation
EpaSpan RealSrcSpan
r Maybe BufSpan
forall a. Maybe a
Strict.Nothing
anchorToEpaLocation (Anchor RealSrcSpan
_ (MovedAnchor DeltaPos
dp)) = DeltaPos -> [LEpaComment] -> EpaLocation
EpaDelta DeltaPos
dp []

-- ---------------------------------------------------------------------
-- Horrible hack for dealing with some things still having a SrcSpan,
-- not an Anchor.

{-
A SrcSpan is defined as

data SrcSpan =
    RealSrcSpan !RealSrcSpan !(Maybe BufSpan)  -- See Note [Why Maybe BufPos]
  | UnhelpfulSpan !UnhelpfulSpanReason

data BufSpan =
  BufSpan { bufSpanStart, bufSpanEnd :: {-# UNPACK #-} !BufPos }
  deriving (Eq, Ord, Show)

newtype BufPos = BufPos { bufPos :: Int }


We use the BufPos to encode a delta, using bufSpanStart for the line,
and bufSpanEnd for the col.

To be absolutely sure, we make the delta versions use -ve values.

-}

hackSrcSpanToAnchor :: SrcSpan -> Anchor
hackSrcSpanToAnchor :: SrcSpan -> Anchor
hackSrcSpanToAnchor (UnhelpfulSpan UnhelpfulSpanReason
s) = String -> Anchor
forall a. HasCallStack => String -> a
error (String -> Anchor) -> String -> Anchor
forall a b. (a -> b) -> a -> b
$ String
"hackSrcSpanToAnchor : UnhelpfulSpan:" String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnhelpfulSpanReason -> String
forall a. Show a => a -> String
show UnhelpfulSpanReason
s
hackSrcSpanToAnchor (RealSrcSpan RealSrcSpan
r Maybe BufSpan
Strict.Nothing) = RealSrcSpan -> AnchorOperation -> Anchor
Anchor RealSrcSpan
r AnchorOperation
UnchangedAnchor
hackSrcSpanToAnchor (RealSrcSpan RealSrcSpan
r (Strict.Just (BufSpan (BufPos Int
s) (BufPos Int
e))))
  = if Int
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
&& Int
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0
    then RealSrcSpan -> AnchorOperation -> Anchor
Anchor RealSrcSpan
r (DeltaPos -> AnchorOperation
MovedAnchor (Int -> Int -> DeltaPos
deltaPos (-Int
s) (-Int
e)))
    else RealSrcSpan -> AnchorOperation -> Anchor
Anchor RealSrcSpan
r AnchorOperation
UnchangedAnchor

hackAnchorToSrcSpan :: Anchor -> SrcSpan
hackAnchorToSrcSpan :: Anchor -> SrcSpan
hackAnchorToSrcSpan (Anchor RealSrcSpan
r AnchorOperation
UnchangedAnchor) = RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
r Maybe BufSpan
forall a. Maybe a
Strict.Nothing
hackAnchorToSrcSpan (Anchor RealSrcSpan
r (MovedAnchor DeltaPos
dp))
  = RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
r (BufSpan -> Maybe BufSpan
forall a. a -> Maybe a
Strict.Just (BufPos -> BufPos -> BufSpan
BufSpan (Int -> BufPos
BufPos Int
s) (Int -> BufPos
BufPos Int
e)))
  where
    s :: Int
s = - (DeltaPos -> Int
getDeltaLine DeltaPos
dp)
    e :: Int
e = - (DeltaPos -> Int
deltaColumn DeltaPos
dp)

-- ---------------------------------------------------------------------