{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Refact.Utils
(
Module,
Stmt,
Expr,
Decl,
Name,
Pat,
Type,
Import,
FunBind,
AnnKeyMap,
pattern RealSrcLoc',
pattern RealSrcSpan',
M,
mergeAnns,
modifyAnnKey,
replaceAnnKey,
getAnnSpan,
toGhcSrcSpan,
toGhcSrcSpan',
annSpanToSrcSpan,
srcSpanToAnnSpan,
setAnnSpanFile,
setSrcSpanFile,
setRealSrcSpanFile,
findParent,
foldAnnKey,
)
where
import Control.Monad.Trans.State (StateT, gets, modify)
import Data.Bifunctor (bimap)
import Data.Data
( Data (gmapQi, toConstr),
Proxy (..),
splitTyConApp,
typeOf,
typeRep,
typeRepTyCon,
)
import Data.Generics.Schemes (something)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, isJust)
import Data.Typeable (Typeable, eqT, (:~:) (Refl))
import qualified GHC
import Language.Haskell.GHC.ExactPrint
import Language.Haskell.GHC.ExactPrint.Types
import Refact.Compat
( AnnKeyMap,
AnnKeywordId (..),
FastString,
FunBind,
Module,
annSpanToSrcSpan,
mkFastString,
setAnnSpanFile,
setRealSrcSpanFile,
setSrcSpanFile,
srcSpanToAnnSpan,
pattern RealSrcLoc',
pattern RealSrcSpan',
)
import qualified Refact.Types as R
import Unsafe.Coerce (unsafeCoerce)
type M a = StateT (Anns, AnnKeyMap) IO a
type Expr = GHC.Located (GHC.HsExpr GHC.GhcPs)
type Type = GHC.Located (GHC.HsType GHC.GhcPs)
type Decl = GHC.Located (GHC.HsDecl GHC.GhcPs)
type Pat = GHC.Located (GHC.Pat GHC.GhcPs)
type Name = GHC.Located GHC.RdrName
type Stmt = GHC.ExprLStmt GHC.GhcPs
type Import = GHC.LImportDecl GHC.GhcPs
replace ::
AnnKey ->
AnnKey ->
AnnKey ->
AnnKey ->
Anns ->
Maybe Anns
replace :: AnnKey -> AnnKey -> AnnKey -> AnnKey -> Anns -> Maybe Anns
replace AnnKey
old AnnKey
new AnnKey
inp AnnKey
parent Anns
anns = do
Annotation
oldan <- AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKey
old Anns
anns
Annotation
newan <- AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKey
new Anns
anns
DeltaPos
oldDelta <- Annotation -> DeltaPos
annEntryDelta (Annotation -> DeltaPos) -> Maybe Annotation -> Maybe DeltaPos
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKey
parent Anns
anns
Anns -> Maybe Anns
forall (m :: * -> *) a. Monad m => a -> m a
return (Anns -> Maybe Anns) -> Anns -> Maybe Anns
forall a b. (a -> b) -> a -> b
$ AnnKey -> Annotation -> Anns -> Anns
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert AnnKey
inp (DeltaPos -> AnnKey -> Annotation -> Annotation -> Annotation
combine DeltaPos
oldDelta AnnKey
new Annotation
oldan Annotation
newan) Anns
anns
combine :: DeltaPos -> AnnKey -> Annotation -> Annotation -> Annotation
combine :: DeltaPos -> AnnKey -> Annotation -> Annotation -> Annotation
combine DeltaPos
oldDelta AnnKey
newkey Annotation
oldann Annotation
newann =
Ann :: DeltaPos
-> [(Comment, DeltaPos)]
-> [(Comment, DeltaPos)]
-> [(KeywordId, DeltaPos)]
-> Maybe [SrcSpan]
-> Maybe AnnKey
-> Annotation
Ann
{ annEntryDelta :: DeltaPos
annEntryDelta = DeltaPos
newEntryDelta,
annPriorComments :: [(Comment, DeltaPos)]
annPriorComments = Annotation -> [(Comment, DeltaPos)]
annPriorComments Annotation
oldann [(Comment, DeltaPos)]
-> [(Comment, DeltaPos)] -> [(Comment, DeltaPos)]
forall a. [a] -> [a] -> [a]
++ Annotation -> [(Comment, DeltaPos)]
annPriorComments Annotation
newann,
annFollowingComments :: [(Comment, DeltaPos)]
annFollowingComments = Annotation -> [(Comment, DeltaPos)]
annFollowingComments Annotation
oldann [(Comment, DeltaPos)]
-> [(Comment, DeltaPos)] -> [(Comment, DeltaPos)]
forall a. [a] -> [a] -> [a]
++ Annotation -> [(Comment, DeltaPos)]
annFollowingComments Annotation
newann,
annsDP :: [(KeywordId, DeltaPos)]
annsDP = [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
removeComma (Annotation -> [(KeywordId, DeltaPos)]
annsDP Annotation
newann) [(KeywordId, DeltaPos)]
-> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
forall a. [a] -> [a] -> [a]
++ [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
forall b. [(KeywordId, b)] -> [(KeywordId, b)]
extraComma (Annotation -> [(KeywordId, DeltaPos)]
annsDP Annotation
oldann),
annSortKey :: Maybe [SrcSpan]
annSortKey = Annotation -> Maybe [SrcSpan]
annSortKey Annotation
newann,
annCapturedSpan :: Maybe AnnKey
annCapturedSpan = Annotation -> Maybe AnnKey
annCapturedSpan Annotation
newann
}
where
removeComma :: [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
removeComma =
((KeywordId, DeltaPos) -> Bool)
-> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
forall a. (a -> Bool) -> [a] -> [a]
filter
( \(KeywordId
kw, DeltaPos
_) -> case KeywordId
kw of
G AnnKeywordId
AnnComma
| AnnKey SrcSpan
_ (CN [Char]
"ArithSeq") <- AnnKey
newkey -> Bool
True
| Bool
otherwise -> Bool
False
KeywordId
AnnSemiSep -> Bool
False
KeywordId
_ -> Bool
True
)
extraComma :: [(KeywordId, b)] -> [(KeywordId, b)]
extraComma [] = []
extraComma ([(KeywordId, b)] -> (KeywordId, b)
forall a. [a] -> a
last -> (KeywordId, b)
x) = case (KeywordId, b) -> KeywordId
forall a b. (a, b) -> a
fst (KeywordId, b)
x of
G AnnKeywordId
AnnComma -> [(KeywordId, b)
x]
KeywordId
AnnSemiSep -> [(KeywordId, b)
x]
G AnnKeywordId
AnnSemi -> [(KeywordId, b)
x]
KeywordId
_ -> []
newEntryDelta :: DeltaPos
newEntryDelta
| DeltaPos -> Int
deltaRow DeltaPos
oldDelta Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = DeltaPos
oldDelta
| Bool
otherwise = Annotation -> DeltaPos
annEntryDelta Annotation
oldann
findParent :: Data a => AnnSpan -> Anns -> a -> Maybe AnnKey
findParent :: SrcSpan -> Anns -> a -> Maybe AnnKey
findParent SrcSpan
ss Anns
as = GenericQ (Maybe AnnKey) -> GenericQ (Maybe AnnKey)
forall u. GenericQ (Maybe u) -> GenericQ (Maybe u)
something (SrcSpan -> Anns -> a -> Maybe AnnKey
forall a. Data a => SrcSpan -> Anns -> a -> Maybe AnnKey
findParentWorker SrcSpan
ss Anns
as)
findParentWorker ::
forall a.
(Data a) =>
AnnSpan ->
Anns ->
a ->
Maybe AnnKey
findParentWorker :: SrcSpan -> Anns -> a -> Maybe AnnKey
findParentWorker SrcSpan
oldSS Anns
as a
a
| TyCon
con TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TypeRep -> TyCon
typeRepTyCon (Proxy (Located RdrName) -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy (Located RdrName)
forall k (t :: k). Proxy t
Proxy :: Proxy (GHC.Located GHC.RdrName))) Bool -> Bool -> Bool
&& TypeRep
x TypeRep -> TypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy SrcSpan -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy SrcSpan
forall k (t :: k). Proxy t
Proxy :: Proxy AnnSpan) =
if SrcSpan
ss SrcSpan -> SrcSpan -> Bool
forall a. Eq a => a -> a -> Bool
== SrcSpan
oldSS
Bool -> Bool -> Bool
&& Maybe Annotation -> Bool
forall a. Maybe a -> Bool
isJust (AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (SrcSpan -> AnnConName -> AnnKey
AnnKey SrcSpan
ss AnnConName
cn) Anns
as)
then AnnKey -> Maybe AnnKey
forall a. a -> Maybe a
Just (AnnKey -> Maybe AnnKey) -> AnnKey -> Maybe AnnKey
forall a b. (a -> b) -> a -> b
$ SrcSpan -> AnnConName -> AnnKey
AnnKey SrcSpan
ss AnnConName
cn
else Maybe AnnKey
forall a. Maybe a
Nothing
| Bool
otherwise = Maybe AnnKey
forall a. Maybe a
Nothing
where
(TyCon
con, ~[TypeRep
x, TypeRep
_]) = TypeRep -> (TyCon, [TypeRep])
splitTyConApp (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
a)
ss :: AnnSpan
ss :: SrcSpan
ss = Int -> (forall d. Data d => d -> SrcSpan) -> a -> SrcSpan
forall a u. Data a => Int -> (forall d. Data d => d -> u) -> a -> u
gmapQi Int
0 forall d. Data d => d -> SrcSpan
forall a b. a -> b
unsafeCoerce a
a
cn :: AnnConName
cn = Int -> (forall d. Data d => d -> AnnConName) -> a -> AnnConName
forall a u. Data a => Int -> (forall d. Data d => d -> u) -> a -> u
gmapQi Int
1 ([Char] -> AnnConName
CN ([Char] -> AnnConName) -> (d -> [Char]) -> d -> AnnConName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Constr -> [Char]
forall a. Show a => a -> [Char]
show (Constr -> [Char]) -> (d -> Constr) -> d -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. d -> Constr
forall a. Data a => a -> Constr
toConstr) a
a
getAnnSpan :: forall a. GHC.Located a -> AnnSpan
getAnnSpan :: Located a -> SrcSpan
getAnnSpan = SrcSpan -> SrcSpan
srcSpanToAnnSpan (SrcSpan -> SrcSpan)
-> (Located a -> SrcSpan) -> Located a -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located a -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
GHC.getLoc
modifyAnnKey ::
(Data old, Data new, Data mod) =>
mod ->
GHC.Located old ->
GHC.Located new ->
M (GHC.Located new)
modifyAnnKey :: mod -> Located old -> Located new -> M (Located new)
modifyAnnKey mod
m Located old
e1 Located new
e2 = do
Anns
as <- ((Anns, AnnKeyMap) -> Anns) -> StateT (Anns, AnnKeyMap) IO Anns
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets (Anns, AnnKeyMap) -> Anns
forall a b. (a, b) -> a
fst
let parentKey :: AnnKey
parentKey = AnnKey -> Maybe AnnKey -> AnnKey
forall a. a -> Maybe a -> a
fromMaybe (Located new -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located new
e2) (SrcSpan -> Anns -> mod -> Maybe AnnKey
forall a. Data a => SrcSpan -> Anns -> a -> Maybe AnnKey
findParent (Located new -> SrcSpan
forall a. Located a -> SrcSpan
getAnnSpan Located new
e2) Anns
as mod
m)
Located new
e2
Located new -> StateT (Anns, AnnKeyMap) IO () -> M (Located new)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ((Anns, AnnKeyMap) -> (Anns, AnnKeyMap))
-> StateT (Anns, AnnKeyMap) IO ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify
( (Anns -> Anns)
-> (AnnKeyMap -> AnnKeyMap)
-> (Anns, AnnKeyMap)
-> (Anns, AnnKeyMap)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap
( Located old -> Located new -> Anns -> Anns
forall old new.
(Typeable old, Typeable new) =>
Located old -> Located new -> Anns -> Anns
dropContextParens Located old
e1 Located new
e2
(Anns -> Anns) -> (Anns -> Anns) -> Anns -> Anns
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located old -> Located new -> Anns -> Anns
forall old new. Located old -> Located new -> Anns -> Anns
recoverBackquotes Located old
e1 Located new
e2
(Anns -> Anns) -> (Anns -> Anns) -> Anns -> Anns
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnnKey -> AnnKey -> AnnKey -> AnnKey -> Anns -> Anns
replaceAnnKey (Located old -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located old
e1) (Located new -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located new
e2) (Located new -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located new
e2) AnnKey
parentKey
)
(([AnnKey] -> [AnnKey] -> [AnnKey])
-> AnnKey -> [AnnKey] -> AnnKeyMap -> AnnKeyMap
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [AnnKey] -> [AnnKey] -> [AnnKey]
forall a. [a] -> [a] -> [a]
(++) (Located old -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located old
e1) [Located new -> AnnKey
forall a. Constraints a => a -> AnnKey
mkAnnKey Located new
e2])
)
dropContextParens ::
forall old new.
(Typeable old, Typeable new) =>
GHC.Located old ->
GHC.Located new ->
Anns ->
Anns
dropContextParens :: Located old -> Located new -> Anns -> Anns
dropContextParens Located old
old Located new
new Anns
anns
| Just old :~: HsType GhcPs
Refl <- (Typeable old, Typeable (HsType GhcPs)) =>
Maybe (old :~: HsType GhcPs)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @old @(GHC.HsType GHC.GhcPs),
Just new :~: HsType GhcPs
Refl <- (Typeable new, Typeable (HsType GhcPs)) =>
Maybe (new :~: HsType GhcPs)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @new @(GHC.HsType GHC.GhcPs),
GenLocated SrcSpan (HsType GhcPs) -> Bool
forall l pass. GenLocated l (HsType pass) -> Bool
isParTy Located old
GenLocated SrcSpan (HsType GhcPs)
old,
Bool -> Bool
not (GenLocated SrcSpan (HsType GhcPs) -> Bool
forall l pass. GenLocated l (HsType pass) -> Bool
isParTy Located new
GenLocated SrcSpan (HsType GhcPs)
new),
Just Annotation
annOld <- AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup AnnKey
key Anns
anns,
(G AnnKeywordId
AnnOpenP, DeltaPos
_) : (G AnnKeywordId
AnnCloseP, DeltaPos
_) : [(KeywordId, DeltaPos)]
rest <- Annotation -> [(KeywordId, DeltaPos)]
annsDP Annotation
annOld =
(Annotation -> Annotation) -> AnnKey -> Anns -> Anns
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\Annotation
x -> Annotation
x {annsDP :: [(KeywordId, DeltaPos)]
annsDP = [(KeywordId, DeltaPos)]
rest}) AnnKey
key Anns
anns
| Bool
otherwise = Anns
anns
where
key :: AnnKey
key = SrcSpan -> AnnConName -> AnnKey
AnnKey (Located old -> SrcSpan
forall a. Located a -> SrcSpan
getAnnSpan Located old
old) ([Char] -> AnnConName
CN [Char]
"(:)")
isParTy :: GenLocated l (HsType pass) -> Bool
isParTy = \case (GHC.L l
_ GHC.HsParTy {}) -> Bool
True; GenLocated l (HsType pass)
_ -> Bool
False
recoverBackquotes :: GHC.Located old -> GHC.Located new -> Anns -> Anns
recoverBackquotes :: Located old -> Located new -> Anns -> Anns
recoverBackquotes (Located old -> SrcSpan
forall a. Located a -> SrcSpan
getAnnSpan -> SrcSpan
old) (Located new -> SrcSpan
forall a. Located a -> SrcSpan
getAnnSpan -> SrcSpan
new) Anns
anns
| Just Annotation
annOld <- AnnKey -> Anns -> Maybe Annotation
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (SrcSpan -> AnnConName -> AnnKey
AnnKey SrcSpan
old ([Char] -> AnnConName
CN [Char]
"Unqual")) Anns
anns,
( (G AnnKeywordId
AnnBackquote, DP (Int
i, Int
j))
: rest :: [(KeywordId, DeltaPos)]
rest@( (G AnnKeywordId
AnnVal, DeltaPos
_)
: (G AnnKeywordId
AnnBackquote, DeltaPos
_)
: [(KeywordId, DeltaPos)]
_
)
) <-
Annotation -> [(KeywordId, DeltaPos)]
annsDP Annotation
annOld =
let f :: Annotation -> Annotation
f Annotation
annNew = case Annotation -> [(KeywordId, DeltaPos)]
annsDP Annotation
annNew of
[(G AnnKeywordId
AnnVal, DP (Int
i', Int
j'))] ->
Annotation
annNew {annsDP :: [(KeywordId, DeltaPos)]
annsDP = (AnnKeywordId -> KeywordId
G AnnKeywordId
AnnBackquote, (Int, Int) -> DeltaPos
DP (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i', Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j')) (KeywordId, DeltaPos)
-> [(KeywordId, DeltaPos)] -> [(KeywordId, DeltaPos)]
forall a. a -> [a] -> [a]
: [(KeywordId, DeltaPos)]
rest}
[(KeywordId, DeltaPos)]
_ -> Annotation
annNew
in (Annotation -> Annotation) -> AnnKey -> Anns -> Anns
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust Annotation -> Annotation
f (SrcSpan -> AnnConName -> AnnKey
AnnKey SrcSpan
new ([Char] -> AnnConName
CN [Char]
"Unqual")) Anns
anns
| Bool
otherwise = Anns
anns
replaceAnnKey :: AnnKey -> AnnKey -> AnnKey -> AnnKey -> Anns -> Anns
replaceAnnKey :: AnnKey -> AnnKey -> AnnKey -> AnnKey -> Anns -> Anns
replaceAnnKey AnnKey
old AnnKey
new AnnKey
inp AnnKey
deltainfo Anns
a =
Anns -> Maybe Anns -> Anns
forall a. a -> Maybe a -> a
fromMaybe Anns
a (AnnKey -> AnnKey -> AnnKey -> AnnKey -> Anns -> Maybe Anns
replace AnnKey
old AnnKey
new AnnKey
inp AnnKey
deltainfo Anns
a)
toGhcSrcSpan :: FilePath -> R.SrcSpan -> GHC.SrcSpan
toGhcSrcSpan :: [Char] -> SrcSpan -> SrcSpan
toGhcSrcSpan = FastString -> SrcSpan -> SrcSpan
toGhcSrcSpan' (FastString -> SrcSpan -> SrcSpan)
-> ([Char] -> FastString) -> [Char] -> SrcSpan -> SrcSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> FastString
mkFastString
toGhcSrcSpan' :: FastString -> R.SrcSpan -> GHC.SrcSpan
toGhcSrcSpan' :: FastString -> SrcSpan -> SrcSpan
toGhcSrcSpan' FastString
file R.SrcSpan {Int
startLine :: SrcSpan -> Int
startCol :: SrcSpan -> Int
endLine :: SrcSpan -> Int
endCol :: SrcSpan -> Int
endCol :: Int
endLine :: Int
startCol :: Int
startLine :: Int
..} = SrcLoc -> SrcLoc -> SrcSpan
GHC.mkSrcSpan (Int -> Int -> SrcLoc
f Int
startLine Int
startCol) (Int -> Int -> SrcLoc
f Int
endLine Int
endCol)
where
f :: Int -> Int -> SrcLoc
f = FastString -> Int -> Int -> SrcLoc
GHC.mkSrcLoc FastString
file
foldAnnKey ::
forall a.
(AnnKey -> a) ->
(GHC.RealSrcSpan -> AnnConName -> a) ->
AnnKey ->
a
foldAnnKey :: (AnnKey -> a) -> (RealSrcSpan -> AnnConName -> a) -> AnnKey -> a
foldAnnKey AnnKey -> a
f RealSrcSpan -> AnnConName -> a
g key :: AnnKey
key@(AnnKey (SrcSpan -> SrcSpan
annSpanToSrcSpan -> SrcSpan
ss) AnnConName
con) = case SrcSpan
ss of
RealSrcSpan' RealSrcSpan
r -> RealSrcSpan -> AnnConName -> a
g RealSrcSpan
r AnnConName
con
SrcSpan
_ -> AnnKey -> a
f AnnKey
key