{-# LANGUAGE FlexibleContexts #-}
{-# 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.State
import Data.Function
import Data.Maybe
import Data.Ord (comparing)

import Language.Haskell.GHC.ExactPrint.Lookup
import 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.Data.FastString
import GHC.Utils.Outputable ( showPprUnsafe )

import Data.List (sortBy, elemIndex)

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

-- |Global switch to enable debug tracing in ghc-exactprint Pretty
debugPEnabledFlag :: Bool
debugPEnabledFlag :: Bool
debugPEnabledFlag = Bool
True
-- debugPEnabledFlag = 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

-- |Provide a version of trace for the Pretty module, which can be enabled
-- separately from 'debug' and 'debugM'
debugP :: String -> c -> c
debugP :: forall a. String -> a -> a
debugP String
s c
c = if Bool
debugPEnabledFlag
               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 -> EpaLocation
EpaSpan RealSrcSpan
sp)
  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 (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 (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

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

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

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

insertCppComments ::  ParsedSource -> [LEpaComment] -> ParsedSource
insertCppComments :: ParsedSource -> [LEpaComment] -> ParsedSource
insertCppComments (L SrcSpan
l HsModule
p) [LEpaComment]
cs = SrcSpan -> HsModule -> ParsedSource
forall l e. l -> e -> GenLocated l e
L SrcSpan
l HsModule
p'
  where
    ncs :: EpAnnComments
ncs = [LEpaComment] -> EpAnnComments
EpaComments [LEpaComment]
cs
    an' :: EpAnn AnnsModule
an' = case HsModule -> EpAnn AnnsModule
GHC.hsmodAnn HsModule
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 (EpAnnComments
ocs EpAnnComments -> EpAnnComments -> EpAnnComments
forall a. Semigroup a => a -> a -> a
<> EpAnnComments
ncs)
      EpAnn AnnsModule
unused -> EpAnn AnnsModule
unused
    p' :: HsModule
p' = HsModule
p { hsmodAnn :: EpAnn AnnsModule
GHC.hsmodAnn = EpAnn AnnsModule
an' }

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

ghcCommentText :: LEpaComment -> String
ghcCommentText :: LEpaComment -> String
ghcCommentText (L Anchor
_ (GHC.EpaComment (EpaDocCommentNext String
s) RealSrcSpan
_))  = String
s
ghcCommentText (L Anchor
_ (GHC.EpaComment (EpaDocCommentPrev String
s) RealSrcSpan
_))  = String
s
ghcCommentText (L Anchor
_ (GHC.EpaComment (EpaDocCommentNamed String
s) RealSrcSpan
_)) = String
s
ghcCommentText (L Anchor
_ (GHC.EpaComment (EpaDocSection Int
_ String
s) RealSrcSpan
_))    = String
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) = String -> Anchor -> RealSrcSpan -> Comment
mkComment (String -> String
normaliseCommentText (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ LEpaComment -> String
ghcCommentText LEpaComment
t) Anchor
lt (EpaComment -> RealSrcSpan
ac_prior_tok EpaComment
c)

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 [] = []
normaliseCommentText (Char
'\r':String
xs) = String -> String
normaliseCommentText String
xs
normaliseCommentText (Char
x:String
xs) = Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String -> String
normaliseCommentText String
xs

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

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

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

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

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 :: Maybe Anchor
al_anchor = Maybe Anchor
forall a. Maybe a
Nothing}) EpAnnComments
cs

setAnchorHsModule :: HsModule -> Anchor -> EpAnnComments -> HsModule
setAnchorHsModule :: HsModule -> Anchor -> EpAnnComments -> HsModule
setAnchorHsModule HsModule
hsmod Anchor
anc EpAnnComments
cs = HsModule
hsmod { hsmodAnn :: EpAnn AnnsModule
hsmodAnn = EpAnn AnnsModule
an' }
  where
    anc' :: Anchor
anc' = Anchor
anc { anchor_op :: AnchorOperation
anchor_op = AnchorOperation
UnchangedAnchor }
    an' :: EpAnn AnnsModule
an' = EpAnn AnnsModule -> Anchor -> EpAnnComments -> EpAnn AnnsModule
forall an.
Default an =>
EpAnn an -> Anchor -> EpAnnComments -> EpAnn an
setAnchorEpa (HsModule -> EpAnn AnnsModule
hsmodAnn HsModule
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

-- ---------------------------------------------------------------------
trailingAnnToAddEpAnn :: TrailingAnn -> AddEpAnn
trailingAnnToAddEpAnn :: TrailingAnn -> AddEpAnn
trailingAnnToAddEpAnn (AddSemiAnn EpaLocation
ss)    = AnnKeywordId -> EpaLocation -> AddEpAnn
AddEpAnn AnnKeywordId
AnnSemi EpaLocation
ss
trailingAnnToAddEpAnn (AddCommaAnn EpaLocation
ss)   = AnnKeywordId -> EpaLocation -> AddEpAnn
AddEpAnn AnnKeywordId
AnnComma EpaLocation
ss
trailingAnnToAddEpAnn (AddVbarAnn EpaLocation
ss)    = AnnKeywordId -> EpaLocation -> AddEpAnn
AddEpAnn AnnKeywordId
AnnVbar EpaLocation
ss
trailingAnnToAddEpAnn (AddRarrowAnn EpaLocation
ss)  = AnnKeywordId -> EpaLocation -> AddEpAnn
AddEpAnn AnnKeywordId
AnnRarrow EpaLocation
ss
trailingAnnToAddEpAnn (AddRarrowAnnU EpaLocation
ss) = AnnKeywordId -> EpaLocation -> AddEpAnn
AddEpAnn AnnKeywordId
AnnRarrowU EpaLocation
ss
trailingAnnToAddEpAnn (AddLollyAnnU EpaLocation
ss)  = AnnKeywordId -> EpaLocation -> AddEpAnn
AddEpAnn AnnKeywordId
AnnLollyU EpaLocation
ss

trailingAnnLoc :: TrailingAnn -> EpaLocation
trailingAnnLoc :: TrailingAnn -> EpaLocation
trailingAnnLoc (AddSemiAnn EpaLocation
ss)    = EpaLocation
ss
trailingAnnLoc (AddCommaAnn EpaLocation
ss)   = EpaLocation
ss
trailingAnnLoc (AddVbarAnn EpaLocation
ss)    = EpaLocation
ss
trailingAnnLoc (AddRarrowAnn EpaLocation
ss)  = EpaLocation
ss
trailingAnnLoc (AddRarrowAnnU EpaLocation
ss) = EpaLocation
ss
trailingAnnLoc (AddLollyAnnU 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)
setTrailingAnnLoc (AddRarrowAnn EpaLocation
_)  EpaLocation
ss = (EpaLocation -> TrailingAnn
AddRarrowAnn EpaLocation
ss)
setTrailingAnnLoc (AddRarrowAnnU EpaLocation
_) EpaLocation
ss = (EpaLocation -> TrailingAnn
AddRarrowAnnU EpaLocation
ss)
setTrailingAnnLoc (AddLollyAnnU EpaLocation
_)  EpaLocation
ss = (EpaLocation -> TrailingAnn
AddLollyAnnU 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 -> EpaLocation
EpaSpan RealSrcSpan
r
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
Nothing) = RealSrcSpan -> AnchorOperation -> Anchor
Anchor RealSrcSpan
r AnchorOperation
UnchangedAnchor
hackSrcSpanToAnchor (RealSrcSpan RealSrcSpan
r (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
Nothing
hackAnchorToSrcSpan (Anchor RealSrcSpan
r (MovedAnchor DeltaPos
dp))
  = RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan RealSrcSpan
r (BufSpan -> Maybe BufSpan
forall a. a -> Maybe a
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)

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