{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Language.Haskell.GHC.ExactPrint.Utils
where
import Control.Monad.State
import Data.Function
import Data.Ord (comparing)
import Data.Generics
import GHC.Hs.Dump
import Language.Haskell.GHC.ExactPrint.Lookup
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 (showSDocUnsafe, showPprUnsafe)
import Control.Arrow
import Data.List (sortBy, elemIndex)
import Debug.Trace
import Language.Haskell.GHC.ExactPrint.Types
debugEnabledFlag :: Bool
debugEnabledFlag :: Bool
debugEnabledFlag = Bool
False
debugPEnabledFlag :: Bool
debugPEnabledFlag :: Bool
debugPEnabledFlag = Bool
True
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
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 :: forall c. c -> String -> c
warn c
c String
_ = c
c
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 Bool -> Bool -> Bool
&& Int
co Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0
ss2delta :: Pos -> RealSrcSpan -> DeltaPos
ss2delta :: Pos -> RealSrcSpan -> DeltaPos
ss2delta Pos
ref RealSrcSpan
ss = Pos -> Pos -> DeltaPos
pos2delta Pos
ref (RealSrcSpan -> Pos
ss2pos RealSrcSpan
ss)
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)
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)
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
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
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 (KeywordId -> String
keywordToString (AnnKeywordId -> KeywordId
G 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 :: Int -> LayoutStartCol -> DeltaPos -> DeltaPos
adjustDeltaForOffset :: Int -> LayoutStartCol -> DeltaPos -> DeltaPos
adjustDeltaForOffset Int
_ LayoutStartCol
_colOffset dp :: DeltaPos
dp@(SameLine Int
_) = DeltaPos
dp
adjustDeltaForOffset Int
d (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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
d)
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
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
orderByKey :: [(RealSrcSpan,a)] -> [RealSrcSpan] -> [(RealSrcSpan,a)]
orderByKey :: forall a. [(RealSrcSpan, a)] -> [RealSrcSpan] -> [(RealSrcSpan, a)]
orderByKey [(RealSrcSpan, a)]
keys [RealSrcSpan]
order
= ((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
(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
(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
t :: LEpaComment
t@(L Anchor
lt EpaComment
_) = String -> Anchor -> Comment
mkComment (String -> String
normaliseCommentText (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ LEpaComment -> String
ghcCommentText LEpaComment
t) Anchor
lt
mkLEpaComment :: String -> Anchor -> LEpaComment
String
s Anchor
anc = (Anchor -> EpaComment -> LEpaComment
forall l e. l -> e -> GenLocated l e
L Anchor
anc (EpaCommentTok -> RealSrcSpan -> EpaComment
GHC.EpaComment (String -> EpaCommentTok
EpaLineComment String
s) (Anchor -> RealSrcSpan
anchor Anchor
anc)))
mkComment :: String -> Anchor -> Comment
String
c Anchor
anc = String -> Anchor -> Maybe AnnKeywordId -> Comment
Comment String
c Anchor
anc Maybe AnnKeywordId
forall a. Maybe a
Nothing
normaliseCommentText :: String -> String
[] = []
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
mkKWComment :: AnnKeywordId -> EpaLocation -> Comment
AnnKeywordId
kw (EpaSpan RealSrcSpan
ss)
= String -> Anchor -> Maybe AnnKeywordId -> Comment
Comment (KeywordId -> String
keywordToString (KeywordId -> String) -> KeywordId -> String
forall a b. (a -> b) -> a -> b
$ AnnKeywordId -> KeywordId
G AnnKeywordId
kw) (RealSrcSpan -> AnchorOperation -> Anchor
Anchor RealSrcSpan
ss AnchorOperation
UnchangedAnchor) (AnnKeywordId -> Maybe AnnKeywordId
forall a. a -> Maybe a
Just AnnKeywordId
kw)
mkKWComment AnnKeywordId
kw (EpaDelta DeltaPos
dp)
= String -> Anchor -> Maybe AnnKeywordId -> Comment
Comment (KeywordId -> String
keywordToString (KeywordId -> String) -> KeywordId -> String
forall a b. (a -> b) -> a -> b
$ AnnKeywordId -> KeywordId
G AnnKeywordId
kw) (RealSrcSpan -> AnchorOperation -> Anchor
Anchor RealSrcSpan
placeholderRealSpan (DeltaPos -> AnchorOperation
MovedAnchor DeltaPos
dp)) (AnnKeywordId -> Maybe AnnKeywordId
forall a. a -> Maybe a
Just AnnKeywordId
kw)
comment2dp :: (Comment, DeltaPos) -> (KeywordId, DeltaPos)
= (Comment -> KeywordId)
-> (Comment, DeltaPos) -> (KeywordId, DeltaPos)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Comment -> KeywordId
AnnComment
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))
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
showAst :: (Data a) => a -> String
showAst :: forall a. Data a => a -> String
showAst a
ast
= SDoc -> String
showSDocUnsafe
(SDoc -> String) -> SDoc -> String
forall a b. (a -> b) -> a -> b
$ BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc
forall a. Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan BlankEpAnnotations
NoBlankEpAnnotations a
ast