module Language.Haskell.Refact.Utils.TypeUtils
(
inScopeInfo, isInScopeAndUnqualified, isInScopeAndUnqualifiedGhc, inScopeNames
, isExported, isExplicitlyExported, modIsExported
, isFieldName
, isClassName
, isInstanceName
,hsPNs
, hsBinds, replaceBinds, HsValBinds(..)
,isDeclaredIn
,hsFreeAndDeclaredPNsOld, hsFreeAndDeclaredNameStrings
,hsFreeAndDeclaredPNs
,hsFreeAndDeclaredGhc
,getDeclaredTypes
,getFvs, getFreeVars, getDeclaredVars
,hsVisiblePNs , hsVisibleNames
,hsFDsFromInside, hsFDNamesFromInside
,hsVisibleDs
,isVarId,isConId,isOperator,isTopLevelPN,isLocalPN,isNonLibraryName
,isQualifiedPN , isFunOrPatName ,isTypeSig
,isFunBindP,isFunBindR,isPatBindP,isPatBindR,isSimplePatBind
,isComplexPatBind,isFunOrPatBindP,isFunOrPatBindR
,usedWithoutQualR ,isUsedInRhs
,findPNT,findPN,findAllNameOccurences
,findPNs, findEntity, findEntity'
, findIdForName
, getTypeForName
,sameOccurrence
,defines, definesP,definesTypeSig
,sameBind
,UsedByRhs(..)
, isMainModule
, getModule
,defineLoc, useLoc, locToExp
,locToName, locToRdrName
,getName
,addDecl, addItemsToImport, addHiding
,addParamsToDecls, addActualParamsToRhs , addImportDecl, duplicateDecl
,rmDecl, rmTypeSig, rmTypeSigs
,rmQualifier,qualifyToplevelName,renamePN ,autoRenameLocalVar
, showEntities,showPNwithLoc
,defaultPN ,defaultName ,defaultExp
,ghcToPN,lghcToPN, expToName
,nameToString
,patToPNT ,pNtoPat
, definedPNs
, definingDeclsNames, definingDeclsNames', definingSigsNames
, definingTyClDeclsNames
, allNames
, mkRdrName,mkNewGhcName,mkNewName,mkNewToplevelName
, causeNameClashInExports
, removeOffset
, getDeclAndToks, getSigAndToks
, getToksForDecl, removeToksOffset
, getParsedForRenamedLPat
, getParsedForRenamedName
, getParsedForRenamedLocated
, newNameTok
, stripLeadingSpaces
) where
import Exception
import Control.Monad.State
import Data.Char
import Data.List
import Data.Maybe
import Data.Monoid
import Language.Haskell.Refact.Utils.GhcUtils
import Language.Haskell.Refact.Utils.GhcVersionSpecific
import Language.Haskell.Refact.Utils.LocUtils
import Language.Haskell.Refact.Utils.Monad
import Language.Haskell.Refact.Utils.MonadFunctions
import Language.Haskell.Refact.Utils.TokenUtils
import Language.Haskell.Refact.Utils.TokenUtilsTypes
import Language.Haskell.Refact.Utils.TypeSyn
import qualified Bag as GHC
import qualified BasicTypes as GHC
import qualified FastString as GHC
import qualified GHC as GHC
import qualified Lexer as GHC hiding (getSrcLoc)
import qualified Module as GHC
import qualified Name as GHC
import qualified NameSet as GHC
import qualified Outputable as GHC
import qualified RdrName as GHC
import qualified SrcLoc as GHC
import qualified UniqSet as GHC
import qualified Unique as GHC
import qualified Var as GHC
import qualified Data.Generics as SYB
import qualified GHC.SYB.Utils as SYB
import Data.Generics.Strafunski.StrategyLib.StrategyLib
data FreeNames = FN [GHC.Name]
data DeclaredNames = DN [GHC.Name]
instance Show FreeNames where
show (FN ls) = "FN " ++ showGhc ls
instance Show DeclaredNames where
show (DN ls) = "DN " ++ showGhc ls
instance Monoid FreeNames where
mempty = FN []
mappend (FN a) (FN b) = FN (a `mappend` b)
instance Monoid DeclaredNames where
mempty = DN []
mappend (DN a) (DN b) = DN (a `mappend` b)
emptyFD :: (FreeNames,DeclaredNames)
emptyFD = (FN [], DN [])
inScopeInfo :: InScopes
->[(String, GHC.NameSpace, GHC.ModuleName, Maybe GHC.ModuleName)]
inScopeInfo names = nub $ map getEntInfo $ names
where
getEntInfo name
=(showGhc name,
GHC.occNameSpace $ GHC.nameOccName name,
GHC.moduleName $ GHC.nameModule name,
getQualMaybe $ GHC.nameRdrName name)
getQualMaybe rdrName = case rdrName of
GHC.Qual modName _occName -> Just modName
_ -> Nothing
isInScopeAndUnqualified::String
->InScopes
->Bool
isInScopeAndUnqualified n names
= isJust $ find (\ (x, _,_, qual) -> x == n && isNothing qual ) $ inScopeInfo names
isInScopeAndUnqualifiedGhc ::
String
-> (Maybe GHC.Name)
-> RefactGhc Bool
isInScopeAndUnqualifiedGhc n maybeExising = do
names <- ghandle handler (GHC.parseName n)
logm $ "isInScopeAndUnqualifiedGhc:(n,(maybeExising,names))=" ++ (show n) ++ ":" ++ (showGhc (maybeExising,names))
ctx <- GHC.getContext
logm $ "isInScopeAndUnqualifiedGhc:ctx=" ++ (showGhc ctx)
let nameList = case maybeExising of
Nothing -> names
Just n' -> filter (\x -> (showGhc x) /= (showGhc n')) names
logm $ "isInScopeAndUnqualifiedGhc:(n,nameList)=" ++ (show n) ++ ":" ++ (showGhc nameList)
return $ nameList /= []
where
handler:: SomeException -> RefactGhc [GHC.Name]
handler e = do
logm $ "isInScopeAndUnqualifiedGhc.handler e=" ++ (show e)
return []
inScopeNames :: String
-> RefactGhc [GHC.Name]
inScopeNames n = do
names <- ghandle handler (GHC.parseName n)
logm $ "inScopeNames:(n,names)=" ++ (show n) ++ ":" ++ (showGhc names)
return $ names
where
handler:: SomeException -> RefactGhc [GHC.Name]
handler e = do
logm $ "inScopeNames.handler e=" ++ (show e)
return []
showPNwithLoc:: GHC.Located GHC.Name -> String
showPNwithLoc pn@(GHC.L l _n)
= let (r,c) = getGhcLoc l
in " '"++showGhc pn++"'" ++"(at row:"++show r ++ ",col:" ++ show c ++")"
defaultPN :: PName
defaultPN = PN (mkRdrName "nothing")
defaultName :: GHC.Name
defaultName = n
where
un = GHC.mkUnique 'H' 0
n = GHC.localiseName $ GHC.mkSystemName un (GHC.mkVarOcc "nothing")
defaultExp::HsExpP
defaultExp=GHC.HsVar $ mkRdrName "nothing"
mkRdrName :: String -> GHC.RdrName
mkRdrName s = GHC.mkVarUnqual (GHC.mkFastString s)
mkNewGhcName :: Maybe GHC.Module -> String -> RefactGhc GHC.Name
mkNewGhcName maybeMod name = do
s <- get
u <- gets rsUniqState
put s { rsUniqState = (u+1) }
let un = GHC.mkUnique 'H' (u+1)
n = case maybeMod of
Nothing -> GHC.localiseName $ GHC.mkSystemName un (GHC.mkVarOcc name)
Just modu -> GHC.mkExternalName un modu (GHC.mkVarOcc name) nullSrcSpan
return n
mkNewToplevelName :: GHC.Module -> String -> GHC.SrcSpan -> RefactGhc GHC.Name
mkNewToplevelName modid name defLoc = do
s <- get
u <- gets rsUniqState
put s { rsUniqState = (u+1) }
let un = GHC.mkUnique 'H' (u+1)
n = GHC.mkExternalName un modid (GHC.mkVarOcc name) defLoc
return n
mkNewName::String
->[String]
->Int
->String
mkNewName oldName fds suffix
=let newName=if suffix==0 then oldName
else oldName++"_"++ show suffix
in if elem newName fds
then mkNewName oldName fds (suffix+1)
else newName
modIsExported:: GHC.ModuleName
-> GHC.RenamedSource
-> Bool
modIsExported modName (_g,_emps,mexps,_mdocs)
= let
modExported (GHC.L _ (GHC.IEModuleContents name)) = name == modName
modExported _ = False
moduleExports = filter modExported $ fromMaybe [] mexps
in if isNothing mexps
then True
else (nonEmptyList moduleExports)
isExported :: GHC.Name -> RefactGhc Bool
isExported n = do
typechecked <- getTypecheckedModule
let modInfo = GHC.tm_checked_module_info typechecked
return $ GHC.modInfoIsExportedName modInfo n
isExplicitlyExported::GHC.Name
->GHC.RenamedSource
->Bool
isExplicitlyExported pn (_g,_imps,exps,_docs)
= findEntity pn exps
causeNameClashInExports:: GHC.Name
-> GHC.Name
-> GHC.ModuleName
-> GHC.RenamedSource
-> Bool
causeNameClashInExports pn newName modName renamed@(_g,imps,maybeExps,_doc)
= let exps = fromMaybe [] maybeExps
varExps = filter isImpVar exps
withoutQual n = showGhc $ GHC.localiseName n
modNames=nub (concatMap (\(GHC.L _ (GHC.IEVar x))->if withoutQual x== withoutQual newName
then [GHC.moduleName $ GHC.nameModule x]
else []) varExps)
res = (isExplicitlyExported pn renamed) &&
( any (modIsUnQualifedImported renamed) modNames
|| elem modName modNames)
in res
where
isImpVar (GHC.L _ x) = case x of
GHC.IEVar _ -> True
_ -> False
modIsUnQualifedImported _mod' modName'
=let
in isJust $ find (\(GHC.L _ (GHC.ImportDecl (GHC.L _ modName1) _qualify _source _safe isQualified _isImplicit _as _h))
-> modName1 == modName' && (not isQualified)) imps
hsFreeAndDeclaredPNsOld:: (SYB.Data t) => t -> ([GHC.Name],[GHC.Name])
hsFreeAndDeclaredPNsOld t = res
where
fd = hsFreeAndDeclaredPNs' t
(f,d) = fromMaybe ([],[]) fd
res = (f \\ d, d)
hsFreeAndDeclaredPNs':: (SYB.Data t) => t -> Maybe ([GHC.Name],[GHC.Name])
hsFreeAndDeclaredPNs' t = do
(f,d) <- hsFreeAndDeclared'
let (f',d') = (nub f, nub d)
return (f',d')
where
hsFreeAndDeclared' = applyTU (stop_tdTUGhc (failTU
`adhocTU` expr
`adhocTU` pattern
`adhocTU` binds
`adhocTU` bindList
`adhocTU` match
`adhocTU` stmts
`adhocTU` rhs
)) t
expr (GHC.HsVar n) = return ([n],[])
expr (GHC.OpApp e1 (GHC.L _ (GHC.HsVar n)) _ e2) = do
efed <- hsFreeAndDeclaredPNs' [e1,e2]
fd <- addFree n efed
return fd
expr ((GHC.HsLam (GHC.MatchGroup matches _)) :: GHC.HsExpr GHC.Name) =
hsFreeAndDeclaredPNs' matches
expr ((GHC.HsLet decls e) :: GHC.HsExpr GHC.Name) =
do
(df,dd) <- hsFreeAndDeclaredPNs' decls
(ef,_) <- hsFreeAndDeclaredPNs' e
return ((df `union` (ef \\ dd)),[])
expr (GHC.RecordCon (GHC.L _ n) _ e) = do
fd <- (hsFreeAndDeclaredPNs' e)
addFree n fd
expr (GHC.EAsPat (GHC.L _ n) e) = do
fd <- (hsFreeAndDeclaredPNs' e)
addFree n fd
expr _ = mzero
rhs ((GHC.GRHSs g ds) :: GHC.GRHSs GHC.Name)
= do (df,dd) <- hsFreeAndDeclaredPNs' g
(ef,ed) <- hsFreeAndDeclaredPNs' ds
return (df ++ ef, dd ++ ed)
pattern (GHC.VarPat n) = return ([],[n])
pattern _ = mzero
bindList (ds :: [GHC.LHsBind GHC.Name])
=do (f,d) <- hsFreeAndDeclaredList ds
return (f\\d,d)
binds ((GHC.FunBind (GHC.L _ n) _ (GHC.MatchGroup matches _) _ _fvs _) :: GHC.HsBind GHC.Name)
= do
(pf,_pd) <- hsFreeAndDeclaredPNs' matches
return (pf \\ [n] ,[n])
binds (GHC.PatBind pat prhs _ ds _) =
do
(pf,pd) <- hsFreeAndDeclaredPNs' pat
(rf,rd) <- hsFreeAndDeclaredPNs' prhs
return (pf `union` (rf \\pd),pd ++ GHC.uniqSetToList ds ++ rd)
binds _ = mzero
match ((GHC.Match pats _mtype mrhs) :: GHC.Match GHC.Name )
= do
(pf,pd) <- hsFreeAndDeclaredPNs' pats
(rf,rd) <- hsFreeAndDeclaredPNs' mrhs
return ((pf `union` (rf \\ (pd `union` rd))),[])
stmts ((GHC.BindStmt pat expre _bindOp _failOp) :: GHC.Stmt GHC.Name) = do
(pf,pd) <- hsFreeAndDeclaredPNs' pat
(ef,_ed) <- hsFreeAndDeclaredPNs' expre
let sf1 = []
return (pf `union` ef `union` (sf1\\pd),[])
stmts ((GHC.LetStmt binds') :: GHC.Stmt GHC.Name) =
hsFreeAndDeclaredPNs' binds'
stmts _ = mzero
addFree :: GHC.Name -> ([GHC.Name],[GHC.Name])
-> Maybe ([GHC.Name],[GHC.Name])
addFree free (fr,de) = return ([free] `union` fr, de)
hsFreeAndDeclaredList l=do fds<-mapM hsFreeAndDeclaredPNs' l
return (foldr union [] (map fst fds),
foldr union [] (map snd fds))
hsFreeAndDeclaredNameStrings::(SYB.Data t,GHC.Outputable t) => t -> RefactGhc ([String],[String])
hsFreeAndDeclaredNameStrings t = do
(f1,d1) <- hsFreeAndDeclaredPNs t
return ((nub.map showGhc) f1, (nub.map showGhc) d1)
hsFreeAndDeclaredPNs :: (SYB.Data t, GHC.Outputable t) => t -> RefactGhc ([GHC.Name],[GHC.Name])
hsFreeAndDeclaredPNs t = do
(FN f,DN d) <- hsFreeAndDeclaredGhc t
return (f,d)
hsFreeAndDeclaredGhc :: (SYB.Data t, GHC.Outputable t) => t -> RefactGhc (FreeNames,DeclaredNames)
hsFreeAndDeclaredGhc t = do
(FN f,DN d) <- res
let f' = nub f
let d' = nub d
return (FN (f' \\ d'), DN d')
where
res = (const err
`SYB.extQ` renamed
`SYB.extQ` lhsbind
`SYB.extQ` hsbind
`SYB.extQ` lhsbinds
`SYB.extQ` lhsbindslrs
`SYB.extQ` lhsbindslr
`SYB.extQ` hslocalbinds
`SYB.extQ` hsvalbinds
`SYB.extQ` lpats
`SYB.extQ` lpat
#if __GLASGOW_HASKELL__ > 704
`SYB.extQ` bndrs
#endif
`SYB.extQ` ltydecls
`SYB.extQ` ltydecl
#if __GLASGOW_HASKELL__ > 704
`SYB.extQ` lfaminstdecls
`SYB.extQ` lfaminstdecl
#endif
`SYB.extQ` lsigs
`SYB.extQ` lsig
`SYB.extQ` lexprs
`SYB.extQ` lexpr
`SYB.extQ` expr
`SYB.extQ` name
`SYB.extQ` lstmts
`SYB.extQ` lstmt
`SYB.extQ` lhstype
`SYB.extQ` hstype
`SYB.extQ` grhs_s
`SYB.extQ` grhs
`SYB.extQ` grhsss
`SYB.extQ` grhss
`SYB.extQ` matchgroup
`SYB.extQ` lmatches
`SYB.extQ` lmatch
`SYB.extQ` hsrecordbinds
`SYB.extQ` hsrecordbind
) t
renamed :: GHC.RenamedSource -> RefactGhc (FreeNames,DeclaredNames)
renamed (g,_i,_e,_d) = do
gfds <- hsFreeAndDeclaredGhc $ GHC.hs_valds g
let tds = concatMap getDeclaredTypes $ concat (GHC.hs_tyclds g)
return $ gfds <> (FN [],DN tds)
lhsbinds :: [GHC.LHsBind GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)
lhsbinds bs = do
(FN fn,DN dn) <- recurseList bs
let r = (FN (fn \\ dn),DN dn)
return r
lhsbind :: GHC.LHsBind GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
lhsbind (GHC.L _ b) = hsFreeAndDeclaredGhc b
hsbind :: GHC.HsBind GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
hsbind b@(GHC.FunBind _n _ (GHC.MatchGroup matches _) _ _ _) = do
let d = GHC.collectHsBindBinders b
(fp,_dp) <- hsFreeAndDeclaredGhc matches
let r = (fp,DN []) <> (FN [],DN d)
return $ r
hsbind b@(GHC.PatBind pa rhs _ _ _) = do
let d = GHC.collectHsBindBinders b
(FN fr,DN _dr) <- hsFreeAndDeclaredGhc rhs
(fp,_) <- lpat pa
return $ (fp,DN []) <> (FN fr,DN d)
hsbind b = do
let d = GHC.collectHsBindBinders b
return (FN [],DN d)
lhsbindslrs :: [GHC.LHsBindsLR GHC.Name GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)
lhsbindslrs bs = recurseList bs
lhsbindslr :: GHC.LHsBindsLR GHC.Name GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
lhsbindslr bs = do
hsFreeAndDeclaredGhc $ GHC.bagToList bs
hslocalbinds :: GHC.HsLocalBinds GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
hslocalbinds (GHC.HsValBinds binds) = hsFreeAndDeclaredGhc binds
hslocalbinds (GHC.HsIPBinds binds) = hsFreeAndDeclaredGhc binds
hslocalbinds GHC.EmptyLocalBinds = return emptyFD
hsvalbinds :: GHC.HsValBinds GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
hsvalbinds (GHC.ValBindsIn binds sigs) = do
bfds <- hsFreeAndDeclaredGhc binds
sfds <- hsFreeAndDeclaredGhc sigs
return $ bfds <> sfds
hsvalbinds (GHC.ValBindsOut binds sigs) = do
bfds <- hsFreeAndDeclaredGhc $ map snd binds
sfds <- hsFreeAndDeclaredGhc sigs
return $ bfds <> sfds
lpats :: [GHC.LPat GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)
lpats xs = recurseList xs
lpat :: GHC.LPat GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
lpat lp@(GHC.L _ p) = do
let
dn = GHC.collectPatBinders lp
(FN fn,DN _dn) <- pat p
return (FN fn,DN dn)
pat :: GHC.Pat GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
pat (GHC.WildPat _) = return emptyFD
pat (GHC.VarPat n) = return (FN [],DN [n])
pat (GHC.LazyPat (GHC.L _ p)) = pat p
pat (GHC.AsPat (GHC.L _ n) (GHC.L _ p)) = do
fd <- pat p
return $ (FN [], DN [n]) <> fd
pat (GHC.ParPat (GHC.L _ p)) = pat p
pat (GHC.BangPat (GHC.L _ p)) = pat p
pat (GHC.ListPat ps _) = do
fds <- mapM pat $ map GHC.unLoc ps
return $ mconcat fds
pat (GHC.TuplePat ps _ _) = do
fds <- mapM pat $ map GHC.unLoc ps
return $ mconcat fds
pat (GHC.PArrPat ps _) = do
fds <- mapM pat $ map GHC.unLoc ps
return $ mconcat fds
pat (GHC.ConPatIn (GHC.L _ n) det) = do
(FN f,DN _d) <- details det
return $ (FN [n],DN []) <> (FN [],DN f)
pat (GHC.ViewPat e (GHC.L _ p) _) = do
fde <- hsFreeAndDeclaredGhc e
fdp <- pat p
return $ fde <> fdp
pat (GHC.LitPat _) = return emptyFD
pat (GHC.NPat _ _ _) = return emptyFD
pat (GHC.NPlusKPat (GHC.L _ n) _ _ _) = return (FN [],DN [n])
pat _p@(GHC.SigPatIn (GHC.L _ p) b) = do
fdp <- pat p
(FN fb,DN _db) <- hsFreeAndDeclaredGhc b
#if __GLASGOW_HASKELL__ > 704
return $ fdp <> (FN fb,DN [])
#else
return $ fdp <> (FN _db,DN [])
#endif
pat (GHC.SigPatOut (GHC.L _ p) _) = pat p
pat (GHC.CoPat _ p _) = pat p
pat p = error $ "hsFreeAndDeclaredGhc.pat:unimplemented:" ++ (showGhc p)
details :: GHC.HsConPatDetails GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
details (GHC.PrefixCon args) = do
fds <- mapM pat $ map GHC.unLoc args
return $ mconcat fds
details (GHC.RecCon recf) =
recfields recf
details (GHC.InfixCon arg1 arg2) = do
fds <- mapM pat $ map GHC.unLoc [arg1,arg2]
return $ mconcat fds
recfields :: (GHC.HsRecFields GHC.Name (GHC.LPat GHC.Name)) -> RefactGhc (FreeNames,DeclaredNames)
recfields (GHC.HsRecFields fields _) = do
let args = map (\(GHC.HsRecField _ (GHC.L _ arg) _) -> arg) fields
fds <- mapM pat args
return $ mconcat fds
#if __GLASGOW_HASKELL__ > 704
bndrs :: GHC.HsWithBndrs (GHC.LHsType GHC.Name) -> RefactGhc (FreeNames,DeclaredNames)
bndrs (GHC.HsWB (GHC.L _ thing) _kindVars _typeVars) = do
(_ft,DN dt) <- hsFreeAndDeclaredGhc thing
return (FN dt,DN [])
#endif
ltydecls :: [GHC.LTyClDecl GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)
ltydecls ds = do
fds <- mapM hsFreeAndDeclaredGhc ds
return $ mconcat fds
ltydecl :: GHC.LTyClDecl GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
ltydecl (GHC.L _ (GHC.ForeignType (GHC.L _ n) _)) = return (FN [],DN [n])
ltydecl (GHC.L _ (GHC.TyFamily _ (GHC.L _ n) _bndrs _)) = return (FN [],DN [n])
#if __GLASGOW_HASKELL__ > 704
ltydecl (GHC.L _ (GHC.TyDecl (GHC.L _ n) _bndrs _defn fvs))
= return (FN (GHC.nameSetToList fvs),DN [n])
#else
ltydecl (GHC.L _ (GHC.TyData _ _ctx (GHC.L _ n) _vars _pats _kind _cons _derivs))
= return (FN [],DN [n])
ltydecl (GHC.L _ (GHC.TySynonym (GHC.L _ n) _vars _pats _rhs))
= return (FN [],DN [n])
#endif
#if __GLASGOW_HASKELL__ > 704
ltydecl (GHC.L _ (GHC.ClassDecl _ctx (GHC.L _ n) _tyvars
_fds _sigs meths ats atds _docs fvs)) = do
#else
ltydecl (GHC.L _ (GHC.ClassDecl _ctx (GHC.L _ n) _tyvars
_fds _sigs meths ats atds _docs)) = do
#endif
(_,md) <- hsFreeAndDeclaredGhc meths
(_,ad) <- hsFreeAndDeclaredGhc ats
(_,atd) <- hsFreeAndDeclaredGhc atds
#if __GLASGOW_HASKELL__ > 704
return (FN (GHC.nameSetToList fvs),DN [n] <> md <> ad <> atd)
#else
return (FN [],DN [n] <> md <> ad <> atd)
#endif
#if __GLASGOW_HASKELL__ > 704
lfaminstdecls :: [GHC.LFamInstDecl GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)
lfaminstdecls ds = do
fds <- mapM hsFreeAndDeclaredGhc ds
return $ mconcat fds
#endif
#if __GLASGOW_HASKELL__ > 704
lfaminstdecl :: GHC.LFamInstDecl GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
lfaminstdecl _f@(GHC.L _ (GHC.FamInstDecl (GHC.L _ n) _pats _defn fvs)) = do
return (FN (GHC.nameSetToList fvs), DN [n])
#else
#endif
lsigs :: [GHC.LSig GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)
lsigs ss = do
fds <- mapM hsFreeAndDeclaredGhc ss
return $ mconcat fds
lsig :: GHC.LSig GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
lsig (GHC.L _ (GHC.TypeSig ns typ)) = do
tfds <- hsFreeAndDeclaredGhc typ
return $ (FN [],DN (map GHC.unLoc ns)) <> tfds
lsig (GHC.L _ (GHC.GenericSig n typ)) = do
tfds <- hsFreeAndDeclaredGhc typ
return $ (FN [],DN (map GHC.unLoc n)) <> tfds
lsig (GHC.L _ (GHC.IdSig _)) = return emptyFD
lsig (GHC.L _ (GHC.InlineSig _ _)) = return emptyFD
lsig (GHC.L _ (GHC.SpecSig n typ _)) = do
tfds <- hsFreeAndDeclaredGhc typ
return $ (FN [],DN [GHC.unLoc n]) <> tfds
lsig (GHC.L _ (GHC.SpecInstSig _)) = return emptyFD
lsig (GHC.L _ (GHC.FixSig _)) = return emptyFD
lexprs :: [GHC.LHsExpr GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)
lexprs es = recurseList es
lexpr :: GHC.LHsExpr GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
lexpr (GHC.L _ e) = hsFreeAndDeclaredGhc e
expr :: GHC.HsExpr GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
expr ((GHC.HsVar n)) = return (FN [n],DN [])
expr ((GHC.HsIPVar _)) = return emptyFD
expr ((GHC.HsOverLit _)) = return emptyFD
expr ((GHC.HsLit _)) = return emptyFD
expr ((GHC.HsLam mg)) = hsFreeAndDeclaredGhc mg
#if __GLASGOW_HASKELL__ > 704
expr ((GHC.HsLamCase _ mg)) = hsFreeAndDeclaredGhc mg
#endif
expr ((GHC.HsApp e1 e2)) = do
fde1 <- hsFreeAndDeclaredGhc e1
fde2 <- hsFreeAndDeclaredGhc e2
return $ fde1 <> fde2
expr ((GHC.OpApp e1 eop _fix e2)) = do
fde1 <- hsFreeAndDeclaredGhc e1
fdeop <- hsFreeAndDeclaredGhc eop
fde2 <- hsFreeAndDeclaredGhc e2
return $ fde1 <> fdeop <> fde2
expr ((GHC.NegApp e _)) = hsFreeAndDeclaredGhc e
expr ((GHC.HsPar e)) = hsFreeAndDeclaredGhc e
expr ((GHC.SectionL e1 e2)) = do
fde1 <- hsFreeAndDeclaredGhc e1
fde2 <- hsFreeAndDeclaredGhc e2
return $ fde1 <> fde2
expr ((GHC.SectionR e1 e2)) = do
fde1 <- hsFreeAndDeclaredGhc e1
fde2 <- hsFreeAndDeclaredGhc e2
return $ fde1 <> fde2
expr ((GHC.ExplicitTuple args _boxity)) = do
let argse = concatMap bb args
bb (GHC.Missing _) = []
bb (GHC.Present a) = [a]
fds <- mapM hsFreeAndDeclaredGhc argse
return $ mconcat fds
expr ((GHC.HsCase e body)) = do
fdes <- hsFreeAndDeclaredGhc e
fdbs <- hsFreeAndDeclaredGhc body
return $ fdes <> fdbs
expr ((GHC.HsIf _ms e1 e2 e3)) = do
fde1 <- hsFreeAndDeclaredGhc e1
fde2 <- hsFreeAndDeclaredGhc e2
fde3 <- hsFreeAndDeclaredGhc e3
return $ fde1 <> fde2 <> fde3
#if __GLASGOW_HASKELL__ > 704
expr ((GHC.HsMultiIf _typ rhs))
= hsFreeAndDeclaredGhc rhs
#endif
expr ((GHC.HsLet binds e)) = do
fdb <- hsFreeAndDeclaredGhc binds
fde <- hsFreeAndDeclaredGhc e
return $ fdb <> fde
expr ((GHC.HsDo _ctx stmts _typ))
= hsFreeAndDeclaredGhc stmts
expr ((GHC.ExplicitList _typ es))
= hsFreeAndDeclaredGhc es
expr ((GHC.ExplicitPArr _typ es))
= hsFreeAndDeclaredGhc es
expr ((GHC.RecordCon (GHC.L _ n) _typ binds)) = do
fdb <- hsFreeAndDeclaredGhc binds
return $ (FN [],DN [n]) <> fdb
expr ((GHC.RecordUpd e1 binds _cons _typ1 _typ2)) = do
fde <- hsFreeAndDeclaredGhc e1
fdb <- hsFreeAndDeclaredGhc binds
return $ fde <> fdb
expr ((GHC.ExprWithTySig e _typ))
= hsFreeAndDeclaredGhc e
expr ((GHC.ExprWithTySigOut e _typ))
= hsFreeAndDeclaredGhc e
expr ((GHC.ArithSeq _typ as)) = do
fds <- case as of
GHC.From e -> hsFreeAndDeclaredGhc e
GHC.FromThen e1 e2 -> recurseList [e1,e2]
GHC.FromTo e1 e2 -> recurseList [e1,e2]
GHC.FromThenTo e1 e2 e3 -> recurseList [e1,e2,e3]
return fds
expr ((GHC.PArrSeq _typ as))
= hsFreeAndDeclaredGhc as
expr ((GHC.HsSCC _ e))
= hsFreeAndDeclaredGhc e
expr ((GHC.HsCoreAnn _ e))
= hsFreeAndDeclaredGhc e
expr ((GHC.HsBracket (GHC.ExpBr b)))
= hsFreeAndDeclaredGhc b
expr ((GHC.HsBracket (GHC.PatBr b)))
= hsFreeAndDeclaredGhc b
expr ((GHC.HsBracket (GHC.DecBrL b)))
= hsFreeAndDeclaredGhc b
expr ((GHC.HsBracket (GHC.DecBrG b)))
= hsFreeAndDeclaredGhc b
expr ((GHC.HsBracket (GHC.TypBr b)))
= hsFreeAndDeclaredGhc b
expr ((GHC.HsBracket (GHC.VarBr _ n)))
= return (FN [],DN [n])
expr ((GHC.HsBracketOut b _ps))
= hsFreeAndDeclaredGhc b
expr ((GHC.HsSpliceE (GHC.HsSplice _ e)))
= hsFreeAndDeclaredGhc e
expr ((GHC.HsQuasiQuoteE _q))
= return emptyFD
expr ((GHC.HsProc pa cmd)) = do
fdp <- hsFreeAndDeclaredGhc pa
fdc <- hsFreeAndDeclaredGhc cmd
return $ fdp <> fdc
expr ((GHC.HsArrApp e1 e2 _typ _atyp _)) = do
fd1 <- hsFreeAndDeclaredGhc e1
fd2 <- hsFreeAndDeclaredGhc e2
return $ fd1 <> fd2
expr ((GHC.HsArrForm e1 _fix cmds)) = do
fd1 <- hsFreeAndDeclaredGhc e1
fdc <- hsFreeAndDeclaredGhc cmds
return $ fd1 <> fdc
expr ((GHC.HsTick _ e))
= hsFreeAndDeclaredGhc e
expr ((GHC.HsBinTick _ _ e))
= hsFreeAndDeclaredGhc e
expr ((GHC.HsTickPragma _ e))
= hsFreeAndDeclaredGhc e
expr ((GHC.EWildPat)) = return emptyFD
expr ((GHC.EAsPat (GHC.L _ n) e)) = do
fde <- hsFreeAndDeclaredGhc e
return $ (FN [],DN [n]) <> fde
expr ((GHC.EViewPat e1 e2)) = do
fd1 <- hsFreeAndDeclaredGhc e1
fd2 <- hsFreeAndDeclaredGhc e2
return $ fd1 <> fd2
expr ((GHC.ELazyPat e))
= hsFreeAndDeclaredGhc e
expr ((GHC.HsType typ))
= hsFreeAndDeclaredGhc typ
expr ((GHC.HsWrap _wrap e))
= hsFreeAndDeclaredGhc e
name :: GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
name n = return (FN [],DN [n])
lstmts :: [GHC.LStmt GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)
lstmts ss = recurseList ss
lstmt :: GHC.LStmt GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
lstmt (GHC.L _ (GHC.LastStmt e _)) = hsFreeAndDeclaredGhc e
lstmt (GHC.L _ (GHC.BindStmt pa e _ _)) = do
fdp <- hsFreeAndDeclaredGhc pa
fde <- hsFreeAndDeclaredGhc e
return (fdp <> fde)
lstmt (GHC.L _ (GHC.ExprStmt e _ _ _)) = hsFreeAndDeclaredGhc e
lstmt (GHC.L _ (GHC.LetStmt bs)) = hsFreeAndDeclaredGhc bs
#if __GLASGOW_HASKELL__ > 704
lstmt (GHC.L _ (GHC.ParStmt ps _ _)) = hsFreeAndDeclaredGhc ps
#else
lstmt (GHC.L _ (GHC.ParStmt ps _ _ _)) = hsFreeAndDeclaredGhc ps
#endif
lstmt (GHC.L _ (GHC.TransStmt _ stmts _ using mby _ _ _)) = do
fds <- hsFreeAndDeclaredGhc stmts
fdu <- hsFreeAndDeclaredGhc using
fdb <- case mby of
Nothing -> return emptyFD
Just e -> hsFreeAndDeclaredGhc e
return $ fds <> fdu <> fdb
lstmt (GHC.L _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _)) = hsFreeAndDeclaredGhc stmts
lhstype :: GHC.LHsType GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
lhstype (GHC.L _ typ) = hstype typ
hstype :: GHC.HsType GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
hstype (GHC.HsForAllTy _ _ _ typ) = hsFreeAndDeclaredGhc typ
hstype (GHC.HsTyVar n) = return (FN [],DN [n])
hstype (GHC.HsAppTy t1 t2) = recurseList [t1,t2]
hstype (GHC.HsFunTy t1 t2) = recurseList [t1,t2]
hstype (GHC.HsListTy typ) = hsFreeAndDeclaredGhc typ
hstype (GHC.HsPArrTy typ) = hsFreeAndDeclaredGhc typ
hstype (GHC.HsTupleTy _ typs) = recurseList typs
hstype (GHC.HsOpTy t1 _ t2) = recurseList [t1,t2]
hstype (GHC.HsParTy typ) = hsFreeAndDeclaredGhc typ
hstype (GHC.HsIParamTy _ typ) = hsFreeAndDeclaredGhc typ
hstype (GHC.HsEqTy t1 t2) = recurseList [t1,t2]
hstype (GHC.HsKindSig t1 t2) = recurseList [t1,t2]
hstype (GHC.HsQuasiQuoteTy _) = return emptyFD
hstype (GHC.HsSpliceTy _ fvs _) = return (FN (GHC.nameSetToList fvs),DN [])
hstype (GHC.HsDocTy _ typ) = hsFreeAndDeclaredGhc typ
hstype (GHC.HsBangTy _ typ) = hsFreeAndDeclaredGhc typ
hstype (GHC.HsRecTy cons) = recurseList cons
hstype (GHC.HsCoreTy _) = return emptyFD
hstype (GHC.HsExplicitListTy _ typs) = recurseList typs
hstype (GHC.HsExplicitTupleTy _ typs) = recurseList typs
#if __GLASGOW_HASKELL__ > 704
hstype (GHC.HsTyLit _) = return emptyFD
#endif
hstype (GHC.HsWrapTy _ typ) = hsFreeAndDeclaredGhc typ
grhs_s :: [GHC.LGRHS GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)
grhs_s gs = recurseList gs
grhs :: GHC.LGRHS GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
grhs (GHC.L _ (GHC.GRHS stmts e)) = do
fds <- hsFreeAndDeclaredGhc stmts
fde <- hsFreeAndDeclaredGhc e
return $ fds <> fde
grhsss :: [GHC.GRHSs GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)
grhsss gs = recurseList gs
grhss :: GHC.GRHSs GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
grhss (GHC.GRHSs g binds) = do
(fg,_dg) <- hsFreeAndDeclaredGhc g
fdb <- hsFreeAndDeclaredGhc binds
return $ (fg,DN[]) <> fdb
matchgroup :: GHC.MatchGroup GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
matchgroup (GHC.MatchGroup matches _) = recurseList matches
lmatches :: [GHC.LMatch GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)
lmatches ms = recurseList ms
lmatch :: GHC.LMatch GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
lmatch (GHC.L _ _m@(GHC.Match pats _ rhs)) = do
(fp,DN dp) <- recurseList pats
(FN fr,DN dr) <- hsFreeAndDeclaredGhc rhs
let r = (fp,DN []) <> (FN (fr \\ (dr ++ dp)), DN [])
return $ r
hsrecordbinds :: (GHC.HsRecordBinds GHC.Name) -> RefactGhc (FreeNames,DeclaredNames)
hsrecordbinds (GHC.HsRecFields fields _) = recurseList fields
hsrecordbind :: (GHC.HsRecField GHC.Name (GHC.LHsExpr GHC.Name)) -> RefactGhc (FreeNames,DeclaredNames)
hsrecordbind (GHC.HsRecField (GHC.L _ n) arg _) = do
fda <- hsFreeAndDeclaredGhc arg
return $ (FN [n],DN []) <> fda
err = error $ "hsFreeAndDeclaredGhc:not matched:" ++ (SYB.showData SYB.Renamer 0 t)
recurseList xs = do
fds <- mapM hsFreeAndDeclaredGhc xs
return $ mconcat fds
getParsedForRenamedLPat :: GHC.ParsedSource -> GHC.LPat GHC.Name -> GHC.LPat GHC.RdrName
getParsedForRenamedLPat parsed lpatParam@(GHC.L l _pat) = r
where
mres = res parsed
r = case mres of
Just rr -> rr
Nothing -> error $ "HaRe error: could not find Parsed LPat for"
++ (SYB.showData SYB.Renamer 0 lpatParam)
res t = somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` lpat) t
lpat :: (GHC.LPat GHC.RdrName) -> (Maybe (GHC.LPat GHC.RdrName))
lpat p@(GHC.L lp _)
| lp == l ||
stripForestLineFromGhc lp == stripForestLineFromGhc l = Just p
lpat _ = Nothing
getParsedForRenamedLocated :: ( SYB.Typeable b )
=> GHC.Located a -> RefactGhc (GHC.Located b)
getParsedForRenamedLocated (GHC.L l _n) = do
parsed <- getRefactParsed
let
mres = res parsed
r = case mres of
Just rr -> rr
Nothing -> error $ "HaRe error: could not find Parsed Location for"
++ (showGhc l)
res t = somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` lname) t
lname :: (GHC.Located b) -> (Maybe (GHC.Located b))
lname p@(GHC.L lp _)
| lp == l ||
stripForestLineFromGhc lp == stripForestLineFromGhc l = Just p
lname _ = Nothing
return r
getParsedForRenamedName :: GHC.ParsedSource -> GHC.Located GHC.Name -> GHC.Located GHC.RdrName
getParsedForRenamedName parsed n@(GHC.L l _n) = r
where
mres = res parsed
r = case mres of
Just rr -> rr
Nothing -> error $ "HaRe error: could not find Parsed LPat for"
++ (SYB.showData SYB.Renamer 0 n)
res t = somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` lname) t
lname :: (GHC.Located GHC.RdrName) -> (Maybe (GHC.Located GHC.RdrName))
lname p@(GHC.L lp _)
| lp == l ||
stripForestLineFromGhc lp == stripForestLineFromGhc l = Just p
lname _ = Nothing
getDeclaredTypes :: GHC.LTyClDecl GHC.Name -> [GHC.Name]
getDeclaredTypes (GHC.L _ (GHC.ForeignType (GHC.L _ n) _)) = [n]
getDeclaredTypes (GHC.L _ (GHC.TyFamily _ (GHC.L _ n) _bs _)) = [n]
#if __GLASGOW_HASKELL__ > 704
getDeclaredTypes (GHC.L _ (GHC.TyDecl (GHC.L _ n) _vars defn _fvs)) = nub $ [n] ++ dsn
where
dsn = getHsTyDefn defn
#else
getDeclaredTypes (GHC.L _ (GHC.TyData _ _ctx (GHC.L _ n) _vars _pats _kind cons _derivs))
= nub $ [n] ++ cs
where
getConDecl (GHC.L _ (GHC.ConDecl (GHC.L _ n2) _ _ _ _ _ _ _)) = n2
cs = map getConDecl cons
getDeclaredTypes (GHC.L _ (GHC.TySynonym (GHC.L _ n) _vars _pats _rhs)) = [n]
#endif
#if __GLASGOW_HASKELL__ > 704
getDeclaredTypes (GHC.L _ (GHC.ClassDecl _ (GHC.L _ n) _vars _fds sigs meths ats _atdefs _ _fvs))
#else
getDeclaredTypes (GHC.L _ (GHC.ClassDecl _ (GHC.L _ n) _vars _fds sigs meths ats _atdefs _))
#endif
= nub $ [n] ++ ssn ++ msn ++ asn
where
getLSig :: GHC.LSig GHC.Name -> [GHC.Name]
getLSig (GHC.L _ (GHC.TypeSig ns _)) = map GHC.unLoc ns
getLSig (GHC.L _ (GHC.GenericSig ns _)) = map GHC.unLoc ns
getLSig (GHC.L _ (GHC.IdSig _n)) = []
getLSig (GHC.L _ (GHC.InlineSig (GHC.L _ n2) _)) = [n2]
getLSig (GHC.L _ (GHC.SpecSig (GHC.L _ n2) _ _)) = [n2]
getLSig (GHC.L _ (GHC.SpecInstSig _)) = []
getLSig (GHC.L _ (GHC.FixSig _)) = []
ssn = concatMap getLSig sigs
msn = getDeclaredVars $ hsBinds meths
asn = concatMap getDeclaredTypes ats
#if __GLASGOW_HASKELL__ > 704
getHsTyDefn :: GHC.HsTyDefn GHC.Name -> [GHC.Name]
getHsTyDefn (GHC.TySynonym _) = []
getHsTyDefn (GHC.TyData _ _ _ _ cons _) = r
where
getConDecl (GHC.L _ (GHC.ConDecl (GHC.L _ n) _ _ _ _ _ _ _)) = n
r = map getConDecl cons
#endif
getFvs :: [GHC.LHsBind GHC.Name] -> [([GHC.Name], GHC.NameSet)]
getFvs bs = concatMap binds bs
where
binds :: (GHC.LHsBind GHC.Name) -> [([GHC.Name],GHC.NameSet)]
binds (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ fvs _)) = [([pname], fvs)]
binds (GHC.L _ (GHC.PatBind p _rhs _ty fvs _)) = [((hsNamess p),fvs)]
binds _ = []
getFreeVars :: [GHC.LHsBind GHC.Name] -> [GHC.Name]
getFreeVars bs = concatMap binds bs
where
binds :: (GHC.LHsBind GHC.Name) -> [GHC.Name]
binds (GHC.L _ (GHC.FunBind (GHC.L _ _pname) _ _ _ fvs _)) = (GHC.nameSetToList fvs)
binds (GHC.L _ (GHC.PatBind _p _rhs _ty fvs _)) = (GHC.nameSetToList fvs)
binds _ = []
getDeclaredVars :: [GHC.LHsBind GHC.Name] -> [GHC.Name]
getDeclaredVars bs = concatMap vars bs
where
vars :: (GHC.LHsBind GHC.Name) -> [GHC.Name]
vars (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _fvs _)) = [pname]
vars (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _)) = (hsNamess p)
vars _ = []
hsVisibleNames:: (FindEntity t1, SYB.Data t1, SYB.Data t2,HsValBinds t2,GHC.Outputable t1)
=> t1 -> t2 -> RefactGhc [String]
hsVisibleNames e t = do
d <- hsVisiblePNs e t
return ((nub . map showGhc) d)
hsVisiblePNs :: (FindEntity e, SYB.Data e, SYB.Data t,HsValBinds t,GHC.Outputable e)
=> e -> t -> RefactGhc [GHC.Name]
hsVisiblePNs e t = do
(DN dn) <- hsVisibleDs e t
return dn
hsVisibleDs :: (FindEntity e, SYB.Data e, SYB.Data t,HsValBinds t,GHC.Outputable e)
=> e -> t -> RefactGhc DeclaredNames
hsVisibleDs e t = do
(DN d) <- res
return (DN (nub d))
where
res = (const err
`SYB.extQ` renamed
`SYB.extQ` valbinds
`SYB.extQ` lhsbindslr
`SYB.extQ` hsbinds
`SYB.extQ` hsbind
`SYB.extQ` hslocalbinds
`SYB.extQ` lmatch
`SYB.extQ` grhss
`SYB.extQ` lgrhs
`SYB.extQ` lexpr
`SYB.extQ` tycldeclss
`SYB.extQ` tycldecls
`SYB.extQ` tycldecl
`SYB.extQ` instdecls
`SYB.extQ` instdecl
`SYB.extQ` lhstype
`SYB.extQ` lsigs
`SYB.extQ` lsig
) t
renamed :: GHC.RenamedSource -> RefactGhc DeclaredNames
renamed (g,_i,_ex,_d)
| findEntity e g = do
dfds <- hsVisibleDs e $ GHC.hs_valds g
tfds <- hsVisibleDs e $ GHC.hs_tyclds g
ifds <- hsVisibleDs e $ GHC.hs_instds g
return $ dfds <> tfds <> ifds
renamed _ = return (DN [])
valbinds :: (GHC.HsValBindsLR GHC.Name GHC.Name) -> RefactGhc DeclaredNames
valbinds vb@(GHC.ValBindsIn bindsBag sigs)
| findEntity e vb = do
fdsb <- mapM (hsVisibleDs e) $ hsBinds bindsBag
fdss <- mapM (hsVisibleDs e) sigs
return $ mconcat fdss <> mconcat fdsb
valbinds vb@(GHC.ValBindsOut binds sigs)
| findEntity e vb = do
logm $ "hsVisibleDs.valbinds:ValBindsOut"
fdsb <- mapM (hsVisibleDs e) $ map snd binds
fdss <- mapM (hsVisibleDs e) sigs
return $ mconcat fdss <> mconcat fdsb
valbinds _ = do
logm $ "hsVisibleDs.valbinds:not matched"
return (DN [])
lhsbindslr :: GHC.LHsBindsLR GHC.Name GHC.Name -> RefactGhc DeclaredNames
lhsbindslr bs = do
fds <- mapM (hsVisibleDs e) $ GHC.bagToList bs
return $ mconcat fds
hsbinds :: [GHC.LHsBind GHC.Name] -> RefactGhc DeclaredNames
hsbinds ds
| findEntity e ds = do
fds <- mapM (hsVisibleDs e) ds
return $ mconcat fds
hsbinds _ = return (DN [])
hsbind :: (GHC.LHsBind GHC.Name) -> RefactGhc DeclaredNames
hsbind ((GHC.L _ (GHC.FunBind _n _ (GHC.MatchGroup matches _) _ _ _)))
| findEntity e matches = do
fds <- mapM (hsVisibleDs e) matches
logm $ "hsVisibleDs.hsbind:fds=" ++ show fds
return $ mconcat fds
hsbind _ = return (DN [])
hslocalbinds :: (GHC.HsLocalBinds GHC.Name) -> RefactGhc DeclaredNames
hslocalbinds (GHC.HsValBinds binds)
| findEntity e binds = hsVisibleDs e binds
hslocalbinds (GHC.HsIPBinds binds)
| findEntity e binds = hsVisibleDs e binds
hslocalbinds (GHC.EmptyLocalBinds) = return (DN [])
hslocalbinds _ = return (DN [])
lmatch :: (GHC.LMatch GHC.Name) -> RefactGhc DeclaredNames
lmatch (GHC.L _ (GHC.Match pats _mtyp rhs))
| findEntity e pats = do
logm $ "hsVisibleDs.lmatch:in pats="
return (DN [])
| findEntity e rhs = do
( pf,pd) <- hsFreeAndDeclaredGhc pats
logm $ "hsVisibleDs.lmatch:(pf,pd)=" ++ (show (pf,pd))
( rd) <- hsVisibleDs e rhs
return (pd <> rd)
lmatch _ =return (DN [])
grhss :: (GHC.GRHSs GHC.Name) -> RefactGhc DeclaredNames
grhss (GHC.GRHSs guardedRhss lstmts)
| findEntity e guardedRhss = do
fds <- mapM (hsVisibleDs e) guardedRhss
return $ mconcat fds
| findEntity e lstmts = hsVisibleDs e lstmts
grhss _ = return (DN [])
lgrhs :: GHC.LGRHS GHC.Name -> RefactGhc DeclaredNames
lgrhs (GHC.L _ (GHC.GRHS stmts ex))
| findEntity e stmts = hsVisibleDs e stmts
| findEntity e ex = hsVisibleDs e ex
lgrhs _ = return (DN [])
lexpr :: GHC.LHsExpr GHC.Name -> RefactGhc DeclaredNames
lexpr (GHC.L _ (GHC.HsVar n))
| findEntity e n = return (DN [n])
lexpr (GHC.L _ (GHC.HsLet lbinds expr))
| findEntity e lbinds || findEntity e expr = do
(_,lds) <- hsFreeAndDeclaredGhc lbinds
(_,eds) <- hsFreeAndDeclaredGhc expr
return $ lds <> eds
lexpr expr
| findEntity e expr = do
(FN efs,_) <- hsFreeAndDeclaredGhc expr
(FN _eefs,DN eeds) <- hsFreeAndDeclaredGhc e
return (DN (efs \\ eeds))
lexpr _ = return (DN [])
tycldeclss :: [[GHC.LTyClDecl GHC.Name]] -> RefactGhc DeclaredNames
tycldeclss tcds
| findEntity e tcds = do
fds <- mapM (hsVisibleDs e) tcds
return $ mconcat fds
tycldeclss _ = return (DN [])
tycldecls :: [GHC.LTyClDecl GHC.Name] -> RefactGhc DeclaredNames
tycldecls tcds
| findEntity e tcds = do
fds <- mapM (hsVisibleDs e) tcds
return $ mconcat fds
tycldecls _ = return (DN [])
tycldecl :: GHC.LTyClDecl GHC.Name -> RefactGhc DeclaredNames
tycldecl tcd
| findEntity e tcd = do
(_,ds) <- hsFreeAndDeclaredGhc tcd
return ds
tycldecl _ = return (DN [])
instdecls :: [GHC.LInstDecl GHC.Name] -> RefactGhc DeclaredNames
instdecls ds
| findEntity e ds = do
fds <- mapM (hsVisibleDs e) ds
return $ mconcat fds
instdecls _ = return (DN [])
instdecl :: GHC.LInstDecl GHC.Name -> RefactGhc DeclaredNames
#if __GLASGOW_HASKELL__ > 704
instdecl (GHC.L _ (GHC.ClsInstD polytyp binds sigs faminsts))
#else
instdecl (GHC.L _ (GHC.InstDecl polytyp binds sigs faminsts))
#endif
| findEntity e polytyp = hsVisibleDs e polytyp
| findEntity e binds = hsVisibleDs e binds
| findEntity e sigs = hsVisibleDs e sigs
| findEntity e faminsts = hsVisibleDs e faminsts
instdecl _ = return (DN [])
lhstype :: GHC.LHsType GHC.Name -> RefactGhc DeclaredNames
lhstype tv@(GHC.L _ (GHC.HsTyVar n))
| findEntity e tv = return (DN [n])
lhstype _ = return (DN [])
lsigs :: [GHC.LSig GHC.Name] -> RefactGhc DeclaredNames
lsigs ss = do
fds <- mapM (hsVisibleDs e) ss
return $ mconcat fds
lsig :: GHC.LSig GHC.Name -> RefactGhc DeclaredNames
lsig (GHC.L _ (GHC.TypeSig _ns typ))
| findEntity e typ = hsVisibleDs e typ
lsig (GHC.L _ (GHC.GenericSig _n typ))
| findEntity e typ = hsVisibleDs e typ
lsig (GHC.L _ (GHC.IdSig _)) = return (DN [])
lsig (GHC.L _ (GHC.InlineSig _ _)) = return (DN [])
lsig (GHC.L _ (GHC.SpecSig _n typ _))
| findEntity e typ = hsVisibleDs e typ
lsig (GHC.L _ (GHC.SpecInstSig _)) = return (DN [])
lsig _ = return (DN [])
err = error $ "hsVisibleDs:no match for:" ++ (SYB.showData SYB.Renamer 0 t)
usedWithoutQualR :: (SYB.Data t) => GHC.Name -> t -> Bool
usedWithoutQualR name parsed = fromMaybe False res
where
res = somethingStaged SYB.Parser Nothing
(Nothing `SYB.mkQ` worker
`SYB.extQ` workerBind
`SYB.extQ` workerExpr
) parsed
worker (pname :: GHC.Located GHC.RdrName) =
checkName pname
workerBind (GHC.L l (GHC.VarPat n) :: (GHC.Located (GHC.Pat GHC.RdrName))) =
checkName (GHC.L l n)
workerBind _ = Nothing
workerExpr ((GHC.L l (GHC.HsVar n)) :: (GHC.Located (GHC.HsExpr GHC.RdrName)))
= checkName (GHC.L l n)
workerExpr _ = Nothing
checkName ((GHC.L l pn)::GHC.Located GHC.RdrName)
| ((GHC.rdrNameOcc pn) == (GHC.nameOccName name)) &&
isUsedInRhs (GHC.L l name) parsed &&
GHC.isUnqual pn = Just True
checkName _ = Nothing
hsFDsFromInside:: (SYB.Data t) => t-> RefactGhc ([GHC.Name],[GHC.Name])
hsFDsFromInside t = do
r <- hsFDsFromInside' t
return r
where
hsFDsFromInside' :: (SYB.Data t) => t -> RefactGhc ([GHC.Name],[GHC.Name])
hsFDsFromInside' t1 = do
r1 <- applyTU (once_tdTU (failTU `adhocTU` renamed
`adhocTU` decl
`adhocTU` match
`adhocTU` expr
`adhocTU` stmts )) t1
let (f',d') = r1
return (nub f', nub d')
renamed :: GHC.RenamedSource -> RefactGhc ([GHC.Name],[GHC.Name])
renamed ((grp,_,_,_)::GHC.RenamedSource)
= hsFreeAndDeclaredPNs $ GHC.hs_valds grp
match :: GHC.Match GHC.Name -> RefactGhc ([GHC.Name],[GHC.Name])
match ((GHC.Match pats _type rhs):: GHC.Match GHC.Name ) = do
(pf, pd) <- hsFreeAndDeclaredPNs pats
(rf, rd) <- hsFreeAndDeclaredPNs rhs
return (nub (pf `union` (rf \\ pd)),
nub (pd `union` rd))
decl :: GHC.HsBind GHC.Name -> RefactGhc ([GHC.Name],[GHC.Name])
decl ((GHC.FunBind (GHC.L _ _) _ (GHC.MatchGroup matches _) _ _ _) :: GHC.HsBind GHC.Name) =
do
fds <- mapM hsFDsFromInside' matches
return (nub (concatMap fst fds), nub (concatMap snd fds))
decl ((GHC.PatBind p rhs _ _ _) :: GHC.HsBind GHC.Name) =
do
(pf, pd) <- hsFreeAndDeclaredPNs p
(rf, rd) <- hsFreeAndDeclaredPNs rhs
return
(nub (pf `union` (rf \\ pd)),
nub (pd `union` rd))
decl ((GHC.VarBind p rhs _) :: GHC.HsBind GHC.Name) =
do
(pf, pd) <- hsFreeAndDeclaredPNs p
(rf, rd) <- hsFreeAndDeclaredPNs rhs
return
(nub (pf `union` (rf \\ pd)),
nub (pd `union` rd))
decl _ = return ([],[])
expr ((GHC.HsLet decls e) :: GHC.HsExpr GHC.Name) =
do
(df,dd) <- hsFreeAndDeclaredPNs decls
(ef,_) <- hsFreeAndDeclaredPNs e
return (nub (df `union` (ef \\ dd)), nub dd)
expr ((GHC.HsLam (GHC.MatchGroup matches _)) :: GHC.HsExpr GHC.Name) =
hsFreeAndDeclaredPNs matches
expr ((GHC.HsCase e (GHC.MatchGroup matches _)) :: GHC.HsExpr GHC.Name) =
do
(ef,_) <- hsFreeAndDeclaredPNs e
(df,dd) <- hsFreeAndDeclaredPNs matches
return (nub (df `union` (ef \\ dd)), nub dd)
expr _ = mzero
stmts ((GHC.BindStmt pat e1 e2 e3) :: GHC.Stmt GHC.Name) =
do
(pf,pd) <- hsFreeAndDeclaredPNs pat
(ef,_ed) <- hsFreeAndDeclaredPNs e1
(df,dd) <- hsFreeAndDeclaredPNs [e2,e3]
return
(nub (pf `union` (((ef \\ dd) `union` df) \\ pd)), nub (pd `union` dd))
stmts ((GHC.LetStmt binds) :: GHC.Stmt GHC.Name) =
hsFreeAndDeclaredPNs binds
stmts _ = mzero
hsFDNamesFromInside::(SYB.Data t) => t -> RefactGhc ([String],[String])
hsFDNamesFromInside t = do
(f,d) <- hsFDsFromInside t
return
((nub.map showGhc) f, (nub.map showGhc) d)
isFieldName :: GHC.Name -> Bool
isFieldName _n = error "undefined isFieldName"
isClassName :: GHC.Name -> Bool
isClassName _n = error "undefined isClassName"
isInstanceName :: GHC.Name -> Bool
isInstanceName _n = error "undefined isInstanceName"
hsPNs::(SYB.Data t)=> t -> [PName]
hsPNs t = (nub.ghead "hsPNs") res
where
res = SYB.everythingStaged SYB.Parser (++) [] ([] `SYB.mkQ` inPnt) t
inPnt (pname :: GHC.RdrName) = return [(PN pname)]
hsNamess :: (SYB.Data t) => t -> [GHC.Name]
hsNamess t = nub $ concat res
where
res = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` inName) t
inName (pname :: GHC.Name) = return [pname]
getModule :: RefactGhc GHC.Module
getModule = do
typechecked <- getTypecheckedModule
return $ GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module typechecked
isVarId :: String -> Bool
isVarId mid = isId mid && isSmall (ghead "isVarId" mid)
where isSmall c=isLower c || c=='_'
isConId :: String -> Bool
isConId mid = isId mid && isUpper (ghead "isConId" mid)
isOperator :: String->Bool
isOperator mid = mid /= [] && isOpSym (ghead "isOperator" mid) &&
isLegalOpTail (tail mid) && not (isReservedOp mid)
where
isOpSym mid' = elem mid' opSymbols
where opSymbols = ['!', '#', '$', '%', '&', '*', '+','.','/','<','=','>','?','@','\'','^','|','-','~']
isLegalOpTail tail' = all isLegal tail'
where isLegal c = isOpSym c || c==':'
isReservedOp mid' = elem mid' reservedOps
where reservedOps = ["..", ":","::","=","\"", "|","<-","@","~","=>"]
isId::String->Bool
isId mid = mid/=[] && isLegalIdTail (tail mid) && not (isReservedId mid)
where
isLegalIdTail tail' = all isLegal tail'
where isLegal c=isSmall c|| isUpper c || isDigit c || c=='\''
isReservedId mid' = elem mid' reservedIds
where reservedIds=["case", "class", "data", "default", "deriving","do","else" ,"if",
"import", "in", "infix","infixl","infixr","instance","let","module",
"newtype", "of","then","type","where","_"]
isSmall c=isLower c || c=='_'
isTopLevelPN::GHC.Name -> RefactGhc Bool
isTopLevelPN n = do
typechecked <- getTypecheckedModule
let maybeNames = GHC.modInfoTopLevelScope $ GHC.tm_checked_module_info typechecked
let names = fromMaybe [] maybeNames
return $ n `elem` names
isLocalPN::GHC.Name -> Bool
isLocalPN = GHC.isInternalName
isNonLibraryName :: GHC.Name -> Bool
isNonLibraryName n = case (GHC.nameSrcSpan n) of
GHC.UnhelpfulSpan _ -> False
_ -> True
isFunOrPatName::(SYB.Data t) => GHC.Name -> t -> Bool
isFunOrPatName pn
=isJust.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker)
where
worker (decl::GHC.LHsBind GHC.Name)
| defines pn decl = Just True
worker _ = Nothing
isQualifiedPN :: GHC.Name -> RefactGhc Bool
isQualifiedPN name = return $ GHC.isQual $ GHC.nameRdrName name
isTypeSig :: GHC.Located (GHC.Sig a) -> Bool
isTypeSig (GHC.L _ (GHC.TypeSig _ _)) = True
isTypeSig _ = False
isFunBindP::HsDeclP -> Bool
isFunBindP (GHC.L _ (GHC.ValD (GHC.FunBind _ _ _ _ _ _))) = True
isFunBindP _ =False
isFunBindR::GHC.LHsBind t -> Bool
isFunBindR (GHC.L _l (GHC.FunBind _ _ _ _ _ _)) = True
isFunBindR _ =False
isPatBindP::HsDeclP->Bool
isPatBindP (GHC.L _ (GHC.ValD (GHC.PatBind _ _ _ _ _))) = True
isPatBindP _=False
isPatBindR::GHC.LHsBind t -> Bool
isPatBindR (GHC.L _ (GHC.PatBind _ _ _ _ _)) = True
isPatBindR _=False
isSimplePatBind :: (SYB.Data t) => GHC.LHsBind t-> Bool
isSimplePatBind decl = case decl of
(GHC.L _l (GHC.PatBind p _rhs _ty _fvs _)) -> hsPNs p /= []
_ -> False
isComplexPatBind::GHC.LHsBind GHC.Name -> Bool
isComplexPatBind decl = case decl of
(GHC.L _l (GHC.PatBind p _rhs _ty _fvs _)) -> patToPNT p /= Nothing
_ -> False
isFunOrPatBindP::HsDeclP->Bool
isFunOrPatBindP decl = isFunBindP decl || isPatBindP decl
isFunOrPatBindR::GHC.LHsBind t -> Bool
isFunOrPatBindR decl = isFunBindR decl || isPatBindR decl
getValBindSigs :: GHC.HsValBinds GHC.Name -> [GHC.LSig GHC.Name]
getValBindSigs binds = case binds of
GHC.ValBindsIn _ sigs -> sigs
GHC.ValBindsOut _ sigs -> sigs
emptyValBinds :: GHC.HsValBinds GHC.Name
emptyValBinds = GHC.ValBindsIn (GHC.listToBag []) []
unionBinds :: [GHC.HsValBinds GHC.Name] -> GHC.HsValBinds GHC.Name
unionBinds [] = emptyValBinds
unionBinds [x] = x
unionBinds (x1:x2:xs) = unionBinds ((mergeBinds x1 x2):xs)
where
mergeBinds :: GHC.HsValBinds GHC.Name -> GHC.HsValBinds GHC.Name -> GHC.HsValBinds GHC.Name
mergeBinds (GHC.ValBindsIn b1 s1) (GHC.ValBindsIn b2 s2) = (GHC.ValBindsIn (GHC.unionBags b1 b2) (s1++s2))
mergeBinds (GHC.ValBindsOut b1 s1) (GHC.ValBindsOut b2 s2) = (GHC.ValBindsOut (b1++b2) (s1++s2))
mergeBinds y1@(GHC.ValBindsIn _ _) y2@(GHC.ValBindsOut _ _) = mergeBinds y2 y1
mergeBinds (GHC.ValBindsOut b1 s1) (GHC.ValBindsIn b2 s2) = (GHC.ValBindsOut (b1++[(GHC.NonRecursive,b2)]) (s1++s2))
hsBinds :: (HsValBinds t) => t -> [GHC.LHsBind GHC.Name]
hsBinds t = case hsValBinds t of
GHC.ValBindsIn binds _sigs -> GHC.bagToList binds
GHC.ValBindsOut bs _sigs -> concatMap (\(_,b) -> GHC.bagToList b) bs
replaceBinds :: (HsValBinds t) => t -> [GHC.LHsBind GHC.Name] -> t
replaceBinds t bs = replaceValBinds t (GHC.ValBindsIn (GHC.listToBag bs) sigs)
where
sigs = case hsValBinds t of
GHC.ValBindsIn _ s -> s
GHC.ValBindsOut _ s -> s
class (SYB.Data t) => HsValBinds t where
hsValBinds :: t -> GHC.HsValBinds GHC.Name
replaceValBinds :: t -> GHC.HsValBinds GHC.Name -> t
hsTyDecls :: t -> [[GHC.LTyClDecl GHC.Name]]
isDeclaredIn :: (HsValBinds t) => GHC.Name -> t -> Bool
isDeclaredIn name t = nonEmptyList $ definingDeclsNames [name] (hsBinds t) False True
instance HsValBinds (GHC.RenamedSource) where
hsValBinds (grp,_,_,_) = (GHC.hs_valds grp)
replaceValBinds (grp,imps,exps,docs) binds = (grp',imps,exps,docs)
where
grp' = grp {GHC.hs_valds = binds}
hsTyDecls (grp,_,_,_) = (GHC.hs_tyclds grp)
instance HsValBinds (GHC.HsValBinds GHC.Name) where
hsValBinds vb = vb
replaceValBinds _old new = new
hsTyDecls _ = []
instance HsValBinds (GHC.HsGroup GHC.Name) where
hsValBinds grp = (GHC.hs_valds grp)
replaceValBinds (GHC.HsGroup b t i d f de fo w a r v doc) binds
= (GHC.HsGroup b' t i d f de fo w a r v doc)
where b' = replaceValBinds b binds
hsTyDecls _ = []
instance HsValBinds (GHC.HsLocalBinds GHC.Name) where
hsValBinds lb = case lb of
GHC.HsValBinds b -> b
GHC.HsIPBinds _ -> emptyValBinds
GHC.EmptyLocalBinds -> emptyValBinds
replaceValBinds (GHC.HsValBinds _b) new = (GHC.HsValBinds new)
replaceValBinds (GHC.HsIPBinds _b) _new = error "undefined replaceValBinds HsIPBinds"
replaceValBinds (GHC.EmptyLocalBinds) new = (GHC.HsValBinds new)
hsTyDecls _ = []
instance HsValBinds (GHC.GRHSs GHC.Name) where
hsValBinds (GHC.GRHSs _ lb) = hsValBinds lb
replaceValBinds (GHC.GRHSs rhss b) new = (GHC.GRHSs rhss (replaceValBinds b new))
hsTyDecls _ = []
instance HsValBinds (GHC.MatchGroup GHC.Name) where
hsValBinds (GHC.MatchGroup matches _) = hsValBinds matches
replaceValBinds (GHC.MatchGroup matches a) newBinds
= (GHC.MatchGroup (replaceValBinds matches newBinds) a)
hsTyDecls _ = []
instance HsValBinds [GHC.LMatch GHC.Name] where
hsValBinds ms = unionBinds $ map (\m -> hsValBinds $ GHC.unLoc m) ms
replaceValBinds [] _ = error "empty match list in replaceValBinds [GHC.LMatch GHC.Name]"
replaceValBinds ms newBinds = (replaceValBinds (ghead "replaceValBinds" ms) newBinds):(tail ms)
hsTyDecls _ = []
instance HsValBinds (GHC.LMatch GHC.Name) where
hsValBinds m = hsValBinds $ GHC.unLoc m
replaceValBinds (GHC.L l m) newBinds = (GHC.L l (replaceValBinds m newBinds))
hsTyDecls _ = []
instance HsValBinds (GHC.Match GHC.Name) where
hsValBinds (GHC.Match _ _ grhs) = hsValBinds grhs
replaceValBinds (GHC.Match p t (GHC.GRHSs rhs _binds)) newBinds
= (GHC.Match p t (GHC.GRHSs rhs binds'))
where
binds' = (GHC.HsValBinds newBinds)
hsTyDecls _ = []
instance HsValBinds (GHC.HsBind GHC.Name) where
hsValBinds (GHC.PatBind _p rhs _typ _fvs _) = hsValBinds rhs
hsValBinds (GHC.FunBind _ _ matches _ _ _) = hsValBinds matches
hsValBinds other = error $ "hsValBinds (GHC.HsBind GHC.Name) undefined for:" ++ (showGhc other)
replaceValBinds (GHC.PatBind p (GHC.GRHSs rhs _binds) typ fvs pt) newBinds
= (GHC.PatBind p (GHC.GRHSs rhs binds') typ fvs pt)
where
binds' = (GHC.HsValBinds newBinds)
replaceValBinds x _newBinds
= error $ "replaceValBinds (GHC.HsBind GHC.Name) undefined for:" ++ (showGhc x)
hsTyDecls _ = []
instance HsValBinds (GHC.HsExpr GHC.Name) where
hsValBinds (GHC.HsLet ds _) = hsValBinds ds
hsValBinds x = error $ "TypeUtils.hsValBinds undefined for:" ++ showGhc x
replaceValBinds (GHC.HsLet binds ex) new = (GHC.HsLet (replaceValBinds binds new) ex)
replaceValBinds old _new = error $ "undefined replaceValBinds (GHC.HsExpr GHC.Name) for:" ++ (showGhc old)
hsTyDecls _ = []
instance HsValBinds (GHC.Stmt GHC.Name) where
hsValBinds (GHC.LetStmt ds) = hsValBinds ds
hsValBinds other = error $ "hsValBinds (GHC.Stmt GHC.Name) undefined for:" ++ (showGhc other)
replaceValBinds (GHC.LetStmt ds) new = (GHC.LetStmt (replaceValBinds ds new))
replaceValBinds old _new = error $ "replaceValBinds (GHC.Stmt GHC.Name) undefined for:" ++ (showGhc old)
hsTyDecls _ = []
instance HsValBinds (GHC.LHsBinds GHC.Name) where
hsValBinds binds = hsValBinds $ GHC.bagToList binds
replaceValBinds old _new = error $ "replaceValBinds (GHC.LHsBinds GHC.Name) undefined for:" ++ (showGhc old)
hsTyDecls _ = []
instance HsValBinds (GHC.LHsBind GHC.Name) where
hsValBinds (GHC.L _ (GHC.FunBind _ _ matches _ _ _)) = hsValBinds matches
hsValBinds (GHC.L _ (GHC.PatBind _ rhs _ _ _)) = hsValBinds rhs
hsValBinds (GHC.L _ (GHC.VarBind _ rhs _)) = hsValBinds rhs
hsValBinds (GHC.L _ (GHC.AbsBinds _ _ _ _ binds)) = hsValBinds binds
replaceValBinds (GHC.L l (GHC.FunBind a b matches c d e)) newBinds
= (GHC.L l (GHC.FunBind a b (replaceValBinds matches newBinds) c d e))
replaceValBinds (GHC.L l (GHC.PatBind a rhs b c d)) newBinds
= (GHC.L l (GHC.PatBind a (replaceValBinds rhs newBinds) b c d))
replaceValBinds (GHC.L l (GHC.VarBind a rhs b)) newBinds
= (GHC.L l (GHC.VarBind a (replaceValBinds rhs newBinds) b))
replaceValBinds (GHC.L l (GHC.AbsBinds a b c d binds)) newBinds
= (GHC.L l (GHC.AbsBinds a b c d (replaceValBinds binds newBinds)))
hsTyDecls _ = []
instance HsValBinds ([GHC.LHsBind GHC.Name]) where
hsValBinds xs = GHC.ValBindsIn (GHC.listToBag xs) []
replaceValBinds _old (GHC.ValBindsIn b _sigs) = GHC.bagToList b
replaceValBinds _old (GHC.ValBindsOut rbinds _sigs) = GHC.bagToList $ GHC.unionManyBags $ map (\(_,b) -> b) rbinds
hsTyDecls _ = []
instance HsValBinds (GHC.LHsExpr GHC.Name) where
hsValBinds (GHC.L _ (GHC.HsLet binds _ex)) = hsValBinds binds
hsValBinds _ = emptyValBinds
replaceValBinds (GHC.L l (GHC.HsLet binds ex)) newBinds
= (GHC.L l (GHC.HsLet (replaceValBinds binds newBinds) ex))
replaceValBinds old _new = error $ "replaceValBinds (GHC.LHsExpr GHC.Name) undefined for:" ++ (showGhc old)
hsTyDecls _ = []
instance HsValBinds [GHC.LGRHS GHC.Name] where
hsValBinds xs = unionBinds $ map hsValBinds xs
replaceValBinds _old _new = error $ "replaceValBinds [GHC.LGRHS GHC.Name] undefined for:"
hsTyDecls _ = []
instance HsValBinds (GHC.LGRHS GHC.Name) where
hsValBinds (GHC.L _ (GHC.GRHS stmts _expr)) = hsValBinds stmts
replaceValBinds _old _new = error $ "replaceValBinds (GHC.LHGRHS GHC.Name) undefined for:"
hsTyDecls _ = []
instance HsValBinds [GHC.LStmt GHC.Name] where
hsValBinds xs = unionBinds $ map hsValBinds xs
replaceValBinds old _new = error $ "replaceValBinds [GHC.LStmt GHC.Name] undefined for:" ++ (showGhc old)
hsTyDecls _ = []
instance HsValBinds (GHC.LStmt GHC.Name) where
hsValBinds (GHC.L _ (GHC.LetStmt binds)) = hsValBinds binds
hsValBinds _ = emptyValBinds
replaceValBinds old _new = error $ "replaceValBinds (GHC.LStmt GHC.Name) undefined for:" ++ (showGhc old)
hsTyDecls _ = []
instance HsValBinds [GHC.LPat GHC.Name] where
hsValBinds _ = emptyValBinds
replaceValBinds old _new = error $ "replaceValBinds (GHC.LPat GHC.Name) undefined for:" ++ (showGhc old)
hsTyDecls _ = []
instance HsValBinds (GHC.LPat GHC.Name) where
hsValBinds _ = emptyValBinds
replaceValBinds old _new = error $ "replaceValBinds (GHC.LPat GHC.Name) undefined for:" ++ (showGhc old)
hsTyDecls _ = []
instance HsValBinds (GHC.Name) where
hsValBinds _ = emptyValBinds
replaceValBinds old _new = error $ "replaceValBinds (GHC.Name) undefined for:" ++ (showGhc old)
hsTyDecls _ = []
instance HsValBinds [GHC.SyntaxExpr GHC.Name] where
hsValBinds _ = emptyValBinds
replaceValBinds old _new = error $ "replaceValBinds (GHC.SyntaxExpr GHC.Name) undefined for:" ++ (showGhc old)
hsTyDecls _ = []
instance HsValBinds [[GHC.LTyClDecl GHC.Name]] where
hsValBinds _ = emptyValBinds
replaceValBinds old _new = error $ "replaceValBinds [[GHC.LTyClDecl GHC.Name]] undefined for:" ++ (showGhc old)
hsTyDecls _ = []
instance HsValBinds [GHC.LTyClDecl GHC.Name] where
hsValBinds _ = emptyValBinds
replaceValBinds old _new = error $ "replaceValBinds [GHC.LTyClDecl GHC.Name] undefined for:" ++ (showGhc old)
hsTyDecls _ = []
instance HsValBinds (GHC.LTyClDecl GHC.Name) where
hsValBinds _ = error $ "hsValBinds (GHC.LTyClDecl GHC.Name) must pull out tcdMeths"
replaceValBinds old _new = error $ "replaceValBinds (GHC.LTyClDecl GHC.Name) undefined for:" ++ (showGhc old)
hsTyDecls _ = []
instance HsValBinds [GHC.LInstDecl GHC.Name] where
hsValBinds _ = emptyValBinds
replaceValBinds old _new = error $ "replaceValBinds [GHC.LInstDecl GHC.Name] undefined for:" ++ (showGhc old)
hsTyDecls _ = []
instance HsValBinds (GHC.LInstDecl GHC.Name) where
hsValBinds _ = emptyValBinds
replaceValBinds old _new = error $ "replaceValBinds (GHC.LInstDecl GHC.Name) undefined for:" ++ (showGhc old)
hsTyDecls _ = []
instance HsValBinds (GHC.LHsType GHC.Name) where
hsValBinds _ = emptyValBinds
replaceValBinds old _new = error $ "replaceValBinds (GHC.LHsType GHC.Name) undefined for:" ++ (showGhc old)
hsTyDecls _ = []
instance HsValBinds [GHC.LSig GHC.Name] where
hsValBinds _ = emptyValBinds
replaceValBinds old _new = error $ "replaceValBinds [GHC.LSig GHC.Name] undefined for:" ++ (showGhc old)
hsTyDecls _ = []
instance HsValBinds (GHC.LSig GHC.Name) where
hsValBinds _ = emptyValBinds
replaceValBinds old _new = error $ "replaceValBinds (GHC.LSig GHC.Name) undefined for:" ++ (showGhc old)
hsTyDecls _ = []
#if __GLASGOW_HASKELL__ > 704
instance HsValBinds [GHC.LFamInstDecl GHC.Name] where
hsValBinds _ = emptyValBinds
replaceValBinds old _new = error $ "replaceValBinds [GHC.LFamInstDecl GHC.Name] undefined for:" ++ (showGhc old)
hsTyDecls _ = []
#endif
#if __GLASGOW_HASKELL__ > 704
instance HsValBinds (GHC.LFamInstDecl GHC.Name) where
hsValBinds _ = emptyValBinds
replaceValBinds old _new = error $ "replaceValBinds (GHC.LFamInstDecl GHC.Name) undefined for:" ++ (showGhc old)
hsTyDecls _ = []
#endif
instance HsValBinds (GHC.HsIPBinds GHC.Name) where
hsValBinds _ = emptyValBinds
replaceValBinds old _new = error $ "replaceValBinds (GHC.HsIPBinds GHC.Name) undefined for:" ++ (showGhc old)
hsTyDecls _ = []
class (SYB.Data a, SYB.Typeable a) => FindEntity a where
findEntity:: (SYB.Data b, SYB.Typeable b) => a -> b -> Bool
instance FindEntity GHC.Name where
findEntity n t = fromMaybe False res
where
res = somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t
worker (name::GHC.Name)
| n == name = Just True
worker _ = Nothing
instance FindEntity (GHC.Located GHC.Name) where
findEntity n t = fromMaybe False res
where
res = somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t
worker (name::GHC.Located GHC.Name)
| n == name = Just True
worker _ = Nothing
instance FindEntity (GHC.Located (GHC.HsExpr GHC.Name)) where
findEntity e t = fromMaybe False res
where
res = somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t
worker (expr::GHC.Located (GHC.HsExpr GHC.Name))
| sameOccurrence e expr = Just True
worker _ = Nothing
instance FindEntity (GHC.Located (GHC.HsBindLR GHC.Name GHC.Name)) where
findEntity e t = fromMaybe False res
where
res = somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t
worker (expr::(GHC.Located (GHC.HsBindLR GHC.Name GHC.Name)))
| sameOccurrence e expr = Just True
worker _ = Nothing
instance FindEntity (GHC.Located (GHC.HsDecl GHC.Name)) where
findEntity d t = fromMaybe False res
where
res = somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t
worker (decl::(GHC.Located (GHC.HsDecl GHC.Name)))
| sameOccurrence d decl = Just True
worker _ = Nothing
findEntity':: (SYB.Data a, SYB.Data b)
=> a -> b -> Maybe (SimpPos,SimpPos)
findEntity' a b = res
where
res = somethingStaged SYB.Parser Nothing worker b
worker :: (SYB.Typeable c,SYB.Data c)
=> c -> Maybe (SimpPos,SimpPos)
worker x = if SYB.typeOf a == SYB.typeOf x
then Just (getStartEndLoc x)
else Nothing
definingDeclsNames::
[GHC.Name]
->[GHC.LHsBind GHC.Name]
->Bool
->Bool
->[GHC.LHsBind GHC.Name]
definingDeclsNames pns ds _incTypeSig recursive = concatMap defining ds
where
defining decl
= if recursive
then SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` defines') decl
else defines' decl
where
defines' :: (GHC.LHsBind GHC.Name) -> [GHC.LHsBind GHC.Name]
defines' decl'@(GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _))
|isJust (find (==(pname)) pns) = [decl']
defines' decl'@(GHC.L _l (GHC.PatBind p _rhs _ty _fvs _))
|(hsNamess p) `intersect` pns /= [] = [decl']
defines' _ = []
definingDeclsNames':: (SYB.Data t)
=> [GHC.Name]
-> t
->[GHC.LHsBind GHC.Name]
definingDeclsNames' pns t = defining t
where
defining decl
= SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` defines') decl
where
defines' :: (GHC.LHsBind GHC.Name) -> [GHC.LHsBind GHC.Name]
defines' decl'@(GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _))
|isJust (find (==(pname)) pns) = [decl']
defines' decl'@(GHC.L _l (GHC.PatBind p _rhs _ty _fvs _))
|(hsNamess p) `intersect` pns /= [] = [decl']
defines' _ = []
definingSigsNames :: (SYB.Data t) =>
[GHC.Name]
->t
->[GHC.LSig GHC.Name]
definingSigsNames pns ds = def ds
where
def decl
= SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` inSig) decl
where
inSig :: (GHC.LSig GHC.Name) -> [GHC.LSig GHC.Name]
inSig (GHC.L l (GHC.TypeSig ns t))
| defines' ns /= [] = [(GHC.L l (GHC.TypeSig (defines' ns) t))]
inSig _ = []
defines' (p::[GHC.Located GHC.Name])
= filter (\(GHC.L _ n) -> n `elem` pns) p
definingTyClDeclsNames:: (SYB.Data t)
=> [GHC.Name]
-> t
->[GHC.LTyClDecl GHC.Name]
definingTyClDeclsNames pns t = defining t
where
defining decl
= SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` defines') decl
where
defines' :: (GHC.LTyClDecl GHC.Name) -> [GHC.LTyClDecl GHC.Name]
defines' decl'@(GHC.L _ (GHC.ForeignType (GHC.L _ pname) _ ))
|isJust (find (==(pname)) pns) = [decl']
defines' decl'@(GHC.L _ (GHC.TyFamily _ (GHC.L _ pname) _ _))
|isJust (find (==(pname)) pns) = [decl']
#if __GLASGOW_HASKELL__ > 704
defines' decl'@(GHC.L _ (GHC.TyDecl (GHC.L _ pname) _ _ _))
#else
defines' decl'@(GHC.L _ (GHC.TyData _ _ (GHC.L _ pname) _ _ _ __ _))
#endif
|isJust (find (==(pname)) pns) = [decl']
#if __GLASGOW_HASKELL__ > 704
#else
defines' decl'@(GHC.L _ (GHC.TySynonym (GHC.L _ pname) _ _ _))
|isJust (find (==(pname)) pns) = [decl']
#endif
#if __GLASGOW_HASKELL__ > 704
defines' decl'@(GHC.L _ (GHC.ClassDecl _ (GHC.L _ pname) _ _ _ _ _ _ _ _))
#else
defines' decl'@(GHC.L _ (GHC.ClassDecl _ (GHC.L _ pname) _ _ _ _ _ _ _))
#endif
|isJust (find (==(pname)) pns) = [decl']
defines' _ = []
sameOccurrence :: (GHC.Located t) -> (GHC.Located t) -> Bool
sameOccurrence (GHC.L l1 _) (GHC.L l2 _)
= l1 == l2
defines:: GHC.Name -> GHC.LHsBind GHC.Name -> Bool
defines n (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _))
= pname == n
defines n (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _))
= elem n (hsNamess p)
defines _ _= False
definesP::PName->HsDeclP->Bool
definesP pn (GHC.L _ (GHC.ValD (GHC.FunBind (GHC.L _ pname) _ _ _ _ _)))
= PN pname == pn
definesP pn (GHC.L _ (GHC.ValD (GHC.PatBind p _rhs _ty _fvs _)))
= elem pn (hsPNs p)
definesP _ _= False
definesTypeSig :: GHC.Name -> GHC.LSig GHC.Name -> Bool
definesTypeSig pn (GHC.L _ (GHC.TypeSig names _typ)) = elem pn $ map (\(GHC.L _ n)->n) names
definesTypeSig _ _ =False
definedPNs::GHC.LHsBind GHC.Name -> [GHC.Name]
definedPNs (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _)) = [pname]
definedPNs (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _)) = (hsNamess p)
definedPNs (GHC.L _ (GHC.VarBind pname _rhs _)) = [pname]
definedPNs _ = []
sameBind :: GHC.LHsBind GHC.Name -> GHC.LHsBind GHC.Name -> Bool
sameBind b1 b2 = (definedPNs b1) == (definedPNs b2)
class (SYB.Data t) => UsedByRhs t where
usedByRhs:: t -> [GHC.Name] -> Bool
instance UsedByRhs GHC.RenamedSource where
usedByRhs _renamed _pns = False
instance UsedByRhs (GHC.LHsBinds GHC.Name) where
usedByRhs binds pns = or $ map (\b -> usedByRhs b pns) $ GHC.bagToList binds
instance UsedByRhs (GHC.HsValBinds GHC.Name) where
usedByRhs (GHC.ValBindsIn binds _sigs) pns = usedByRhs (GHC.bagToList binds) pns
usedByRhs (GHC.ValBindsOut binds _sigs) pns = or $ map (\(_,b) -> usedByRhs b pns) binds
instance UsedByRhs (GHC.Match GHC.Name) where
usedByRhs (GHC.Match _ _ (GHC.GRHSs rhs _)) pns
= findPNs pns rhs
instance UsedByRhs [GHC.LHsBind GHC.Name] where
usedByRhs binds pns = or $ map (\b -> usedByRhs b pns) binds
instance UsedByRhs (GHC.HsBind GHC.Name) where
usedByRhs (GHC.FunBind _ _ matches _ _ _) pns = findPNs pns matches
usedByRhs (GHC.PatBind _ rhs _ _ _) pns = findPNs pns rhs
usedByRhs (GHC.VarBind _ rhs _) pns = findPNs pns rhs
usedByRhs (GHC.AbsBinds _ _ _ _ _) _pns = False
instance UsedByRhs (GHC.LHsBind GHC.Name) where
usedByRhs (GHC.L _ bind) pns = usedByRhs bind pns
instance UsedByRhs (GHC.LHsExpr GHC.Name) where
usedByRhs (GHC.L _ e) pns = usedByRhs e pns
instance UsedByRhs (GHC.HsExpr GHC.Name) where
usedByRhs (GHC.HsLet _lb e) pns = findPNs pns e
usedByRhs e _pns = error $ "undefined usedByRhs:" ++ (showGhc e)
instance UsedByRhs (GHC.Stmt GHC.Name) where
usedByRhs (GHC.LetStmt lb) pns = findPNs pns lb
usedByRhs s _pns = error $ "undefined usedByRhs:" ++ (showGhc s)
locToName::(SYB.Data t)
=>SimpPos
->t
-> Maybe (GHC.Located GHC.Name)
locToName (row,col) t = locToName' SYB.Renamer (row,col) t
locToRdrName::(SYB.Data t)
=>SimpPos
->t
-> Maybe (GHC.Located GHC.RdrName)
locToRdrName (row,col) t = locToName' SYB.Parser (row,col) t
locToName'::(SYB.Data t, SYB.Data a, Eq a,GHC.Outputable a)
=>SYB.Stage
->SimpPos
->t
-> Maybe (GHC.Located a)
locToName' stage (row,col) t =
if res1 /= Nothing
then res1
else res2
where
res1 = somethingStaged stage Nothing
(Nothing `SYB.mkQ` worker
`SYB.extQ` workerBind
`SYB.extQ` workerExpr
`SYB.extQ` workerLIE
`SYB.extQ` workerHsTyVarBndr
`SYB.extQ` workerLHsType
) t
res2 = somethingStaged stage Nothing
(Nothing `SYB.mkQ` workerFunBind) t
workerFunBind ((GHC.FunBind pnt _ (GHC.MatchGroup matches _) _ _ _) :: (GHC.HsBindLR a a))
| nonEmptyList match = Just pnt
where
match = filter inScope (tail matches)
workerFunBind _ = Nothing
worker (pnt :: (GHC.Located a))
| inScope pnt = Just pnt
worker _ = Nothing
workerBind pnt@(GHC.L l (GHC.VarPat name) :: (GHC.Located (GHC.Pat a)))
| inScope pnt = Just (GHC.L l name)
workerBind _ = Nothing
workerExpr (pnt@(GHC.L l (GHC.HsVar name)) :: (GHC.Located (GHC.HsExpr a)))
| inScope pnt = Just (GHC.L l name)
workerExpr _ = Nothing
workerLIE (pnt@(GHC.L l (GHC.IEVar name)) :: (GHC.LIE a))
| inScope pnt = Just (GHC.L l name)
workerLIE _ = Nothing
#if __GLASGOW_HASKELL__ > 704
workerHsTyVarBndr (pnt@(GHC.L l (GHC.UserTyVar name)):: (GHC.LHsTyVarBndr a))
#else
workerHsTyVarBndr (pnt@(GHC.L l (GHC.UserTyVar name _typ)):: (GHC.LHsTyVarBndr a))
#endif
| inScope pnt = Just (GHC.L l name)
workerHsTyVarBndr _ = Nothing
workerLHsType (pnt@(GHC.L l (GHC.HsTyVar name)):: (GHC.LHsType a))
| inScope pnt = Just (GHC.L l name)
workerLHsType _ = Nothing
inScope :: GHC.Located e -> Bool
inScope (GHC.L l _) =
case l of
(GHC.UnhelpfulSpan _) -> False
(GHC.RealSrcSpan ss) ->
(GHC.srcSpanStartLine ss <= row) &&
(GHC.srcSpanEndLine ss >= row) &&
(col >= (GHC.srcSpanStartCol ss)) &&
(col <= (GHC.srcSpanEndCol ss))
allNames::(SYB.Data t)
=>t
->[GHC.Located GHC.Name]
allNames t
= res
where
res = SYB.everythingStaged SYB.Parser (++) []
([] `SYB.mkQ` worker `SYB.extQ` workerBind `SYB.extQ` workerExpr) t
worker (pnt :: (GHC.Located GHC.Name))
= [pnt]
workerBind (GHC.L l (GHC.VarPat name) :: (GHC.Located (GHC.Pat GHC.Name)))
= [(GHC.L l name)]
workerBind _ = []
workerExpr ((GHC.L l (GHC.HsVar name)) :: (GHC.Located (GHC.HsExpr GHC.Name)))
= [(GHC.L l name)]
workerExpr _ = []
getName::(SYB.Data t)=> String
-> t
-> Maybe GHC.Name
getName str t
= res
where
res = somethingStaged SYB.Renamer Nothing
(Nothing `SYB.mkQ` worker `SYB.extQ` workerBind `SYB.extQ` workerExpr) t
worker ((GHC.L _ n) :: (GHC.Located GHC.Name))
| showGhc n == str = Just n
worker _ = Nothing
workerBind (GHC.L _ (GHC.VarPat name) :: (GHC.Located (GHC.Pat GHC.Name)))
| showGhc name == str = Just name
workerBind _ = Nothing
workerExpr ((GHC.L _ (GHC.HsVar name)) :: (GHC.Located (GHC.HsExpr GHC.Name)))
| showGhc name == str = Just name
workerExpr _ = Nothing
addImportDecl ::
GHC.RenamedSource
-> GHC.ModuleName
-> Maybe GHC.FastString
-> Bool -> Bool -> Bool
-> Maybe String
-> Bool
-> [GHC.Name]
-> RefactGhc GHC.RenamedSource
addImportDecl (groupedDecls,imp, b, c) modName pkgQual source safe qualify alias hide idNames
= do
toks <- fetchToks
let toks1
=if length imps' > 0
then let (_startLoc, endLoc) = getStartEndLoc $ last imps'
toks1' = getToks ((1,1),endLoc) toks
in toks1'
else if not $ isEmptyGroup groupedDecls
then
let startLoc = fst $ startEndLocIncComments toks groupedDecls
(toks1', _toks2') = break (\t ->tokenPos t==startLoc) toks
in toks1'
else toks
logm $ "addImportDecl:toks =" ++ show toks
logm $ "addImportDecl:toks1=" ++ show toks1
let lastTok = ghead "addImportDecl" $ dropWhile isWhiteSpace $ reverse toks1
let startPos = tokenPos lastTok
let endPos = tokenPosEnd lastTok
newToks <- liftIO $ basicTokenise (showGhc impDecl)
logm $ "addImportDecl:newToks=" ++ (show newToks)
void $ putToksAfterPos (startPos,endPos) (PlaceOffset 1 0 1) newToks
return (groupedDecls, (imp++[(mkNewLSomething impDecl)]), b, c)
where
alias' = case alias of
Just stringName -> Just $ GHC.mkModuleName stringName
_ -> Nothing
impDecl = GHC.ImportDecl {
GHC.ideclName = mkNewLModuleName modName
, GHC.ideclPkgQual = pkgQual
, GHC.ideclSource = source
, GHC.ideclSafe = safe
, GHC.ideclQualified = qualify
, GHC.ideclImplicit = False
, GHC.ideclAs = alias'
, GHC.ideclHiding =
(if idNames == [] && hide == False then
Nothing
else
(Just (hide, map mkNewEnt idNames)))
}
imps' = rmPreludeImports imp
mkNewLSomething :: a -> GHC.Located a
mkNewLSomething a = (GHC.L l a) where
filename = (GHC.mkFastString "f")
l = GHC.mkSrcSpan (GHC.mkSrcLoc filename 1 1) (GHC.mkSrcLoc filename 1 1)
mkNewLModuleName :: GHC.ModuleName -> GHC.Located GHC.ModuleName
mkNewLModuleName moduName = mkNewLSomething moduName
isEmptyGroup :: GHC.HsGroup id -> Bool
isEmptyGroup x = (==0) $ sum $
[valds, tyclds, instds, derivds, fixds, defds, fords, warnds, annds, ruleds, vects, docs]
where
valds = size $ GHC.hs_valds x
size :: GHC.HsValBindsLR idL idR -> Int
size (GHC.ValBindsIn lhsBinds sigs) = (length sigs) + (length . GHC.bagToList $ lhsBinds)
size (GHC.ValBindsOut recFlags lsigs) = (length lsigs) + (length recFlags)
tyclds = length $ GHC.hs_tyclds x
instds = length $ GHC.hs_instds x
derivds = length $ GHC.hs_derivds x
fixds = length $ GHC.hs_fixds x
defds = length $ GHC.hs_defds x
fords = length $ GHC.hs_fords x
warnds = length $ GHC.hs_warnds x
annds = length $ GHC.hs_annds x
ruleds = length $ GHC.hs_ruleds x
vects = length $ GHC.hs_vects x
docs = length $ GHC.hs_docs x
rmPreludeImports ::
[GHC.Located (GHC.ImportDecl GHC.Name)]
-> [GHC.Located (GHC.ImportDecl GHC.Name)]
rmPreludeImports = filter isPrelude where
isPrelude = (/="Prelude") . GHC.moduleNameString . GHC.unLoc . GHC.ideclName . GHC.unLoc
makeNewToks :: (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken])
-> RefactGhc [PosToken]
makeNewToks (decl, maybeSig, declToks) = do
let
declStr = case declToks of
Just ts -> "\n" ++ (unlines $ dropWhile (\l -> l == "") $ lines $ GHC.showRichTokenStream $ reAlignMarked ts)
Nothing -> "\n"++(prettyprint decl)++"\n\n"
sigStr = case declToks of
Just _ts -> ""
Nothing -> "\n" ++ (intercalate "\n" $ map prettyprint maybeSig)
newToks <- liftIO $ tokenise (realSrcLocFromTok mkZeroToken) 0 True (sigStr ++ declStr)
return newToks
addDecl:: (SYB.Data t,HsValBinds t)
=> t
-> Maybe GHC.Name
-> (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken])
-> Bool
-> RefactGhc t
addDecl parent pn (decl, msig, declToks) topLevel
= if isJust pn
then appendDecl parent (gfromJust "addDecl" pn) (decl, msig, declToks)
else if topLevel
then addTopLevelDecl (decl, msig, declToks) parent
else addLocalDecl parent (decl,msig,declToks)
where
addTopLevelDecl :: (SYB.Data t, HsValBinds t)
=> (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken])
-> t -> RefactGhc t
addTopLevelDecl (newDecl, maybeSig, maybeDeclToks) parent'
= do let binds = hsValBinds parent'
decls = hsBinds parent'
(decls1,decls2) = break (\x->isFunOrPatBindR x ) decls
newToks <- makeNewToks (newDecl,maybeSig,maybeDeclToks)
logm $ "addTopLevelDecl:newToks=" ++ (show newToks)
let Just sspan = if (emptyList decls2)
then getSrcSpan (glast "addTopLevelDecl" decls1)
else getSrcSpan (ghead "addTopLevelDecl" decls2)
decl' <- putDeclToksAfterSpan sspan newDecl (PlaceOffset 2 0 2) newToks
return (replaceValBinds parent' (GHC.ValBindsIn (GHC.listToBag (decls1++[decl']++decls2)) (maybeSig++(getValBindSigs binds))))
appendDecl :: (SYB.Data t, HsValBinds t)
=> t
-> GHC.Name
-> (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken])
-> RefactGhc t
appendDecl parent' pn' (newDecl, maybeSig, declToks')
= do let binds = hsValBinds parent'
newToks <- makeNewToks (newDecl,maybeSig,declToks')
let Just sspan = getSrcSpan $ ghead "appendDecl" after
decl' <- putDeclToksAfterSpan sspan newDecl (PlaceOffset 2 0 2) newToks
let decls1 = before ++ [ghead "appendDecl14" after]
decls2 = gtail "appendDecl15" after
return (replaceValBinds parent' (GHC.ValBindsIn (GHC.listToBag (decls1++[decl']++decls2)) (maybeSig++(getValBindSigs binds))))
where
decls = hsBinds parent'
(before,after) = break (defines pn') decls
addLocalDecl :: (SYB.Data t, HsValBinds t)
=> t -> (GHC.LHsBind GHC.Name, [GHC.LSig GHC.Name], Maybe [PosToken])
-> RefactGhc t
addLocalDecl parent' (newFun, maybeSig, newFunToks)
=do
let binds = hsValBinds parent'
let (startLoc@((_,prevCol)),endLoc)
= if (emptyList localDecls)
then getStartEndLoc parent'
else getStartEndLoc localDecls
newToks <- liftIO $ basicTokenise newSource
(newFun',_) <- addLocInfo (newFun, newToks)
let rowIndent = 1
if (emptyList localDecls)
then
void $ putToksAfterPos (startLoc,endLoc) (PlaceOffset rowIndent 4 2) newToks
else
void $ putToksAfterPos (startLoc,endLoc) (PlaceAbsCol (rowIndent+1) prevCol 2) newToks
return (replaceValBinds parent' (GHC.ValBindsIn (GHC.listToBag ((hsBinds parent' ++ [newFun']))) (maybeSig++(getValBindSigs binds))))
where
localDecls = hsBinds parent'
newSource = if (emptyList localDecls)
then "where\n"++ concatMap (\l-> " "++l++"\n") (lines newFun')
else ("" ++ newFun'++"\n")
where
newFun' = unlines $ stripLeadingSpaces $ lines $ sigStr ++ newFunBody
newFunBody = case newFunToks of
Just ts -> unlines $ dropWhile (\l -> l == "") $ lines $ GHC.showRichTokenStream $ reAlignMarked ts
Nothing -> prettyprint newFun
sigStr = case newFunToks of
Just _ts -> ""
Nothing -> if (emptyList maybeSig)
then ""
else (intercalate "\n" $ map prettyprint maybeSig) ++ "\n"
stripLeadingSpaces :: [String] -> [String]
stripLeadingSpaces xs = map (drop n) xs
where
n = minimum $ map oneLen xs
oneLen x = length prefix
where
(prefix,_) = break (/=' ') x
addHiding::
GHC.ModuleName
->GHC.RenamedSource
->[GHC.Name]
->RefactGhc GHC.RenamedSource
addHiding a b c = addItemsToImport' a b c Hide
mkNewEnt :: GHC.Name -> GHC.LIE GHC.Name
mkNewEnt pn = (GHC.L l (GHC.IEVar pn))
where
filename = (GHC.mkFastString "f")
l = GHC.mkSrcSpan (GHC.mkSrcLoc filename 1 1) (GHC.mkSrcLoc filename 1 1)
data ImportType = Hide
| Import
addItemsToImport::
GHC.ModuleName
->GHC.RenamedSource
->[GHC.Name]
->RefactGhc GHC.RenamedSource
addItemsToImport a b c = addItemsToImport' a b c Import
addItemsToImport'::
GHC.ModuleName
->GHC.RenamedSource
->[GHC.Name]
->ImportType
->RefactGhc GHC.RenamedSource
addItemsToImport' serverModName (g,imps,e,d) pns impType = do
imps' <- mapM inImport imps
return (g,imps',e,d)
where
isHide = case impType of
Hide -> True
Import -> False
inImport :: GHC.LImportDecl GHC.Name -> RefactGhc (GHC.LImportDecl GHC.Name)
inImport imp@(GHC.L _ (GHC.ImportDecl (GHC.L _ modName) _qualify _source _safe isQualified _isImplicit _as h))
| serverModName == modName && not isQualified
= case h of
Nothing -> insertEnts imp [] True
Just (_isHide, ents) -> insertEnts imp ents False
inImport x = return x
insertEnts ::
GHC.LImportDecl GHC.Name
-> [GHC.LIE GHC.Name]
-> Bool
-> RefactGhc ( GHC.LImportDecl GHC.Name )
insertEnts imp ents isNew =
if isNew && not isHide then return imp
else do
toks <- fetchToks
let (startPos,endPos) = getStartEndLoc imp
((GHC.L l t),s) = ghead "addHiding" $ reverse $ getToks (startPos,endPos) toks
start = getGhcLoc l
end = getGhcLocEnd l
beginning =
if isNew then
s ++ (if isHide then " hiding " else " ")++"("
else ","
ending = if isNew then ")" else s
newToken=mkToken t start (beginning++showEntities showGhc pns ++ending)
void $ putToksForPos (start,end) [newToken]
return (replaceHiding imp (Just (isHide, (map mkNewEnt pns)++ents)))
replaceHiding (GHC.L l (GHC.ImportDecl mn q src safe isQ isImp as _h)) h1 =
(GHC.L l (GHC.ImportDecl mn q src safe isQ isImp as h1))
addParamsToDecls::
[GHC.LHsBind GHC.Name]
->GHC.Name
->[GHC.Name]
->Bool
->RefactGhc [GHC.LHsBind GHC.Name]
addParamsToDecls decls pn paramPNames modifyToks = do
logm $ "addParamsToDecls (pn,paramPNames,modifyToks)=" ++ (showGhc (pn,paramPNames,modifyToks))
if (paramPNames/=[])
then mapM addParamToDecl decls
else return decls
where
addParamToDecl :: GHC.LHsBind GHC.Name -> RefactGhc (GHC.LHsBind GHC.Name)
addParamToDecl (GHC.L l1 (GHC.FunBind (GHC.L l2 pname) i (GHC.MatchGroup matches ptt) co fvs t))
| pname == pn
= do matches' <- mapM addParamtoMatch matches
return (GHC.L l1 (GHC.FunBind (GHC.L l2 pname) i (GHC.MatchGroup matches' ptt) co fvs t))
where
addParamtoMatch (GHC.L l (GHC.Match pats mtyp rhs))
= do rhs' <- addActualParamsToRhs modifyToks pn paramPNames rhs
let pats' = map GHC.noLoc $ map pNtoPat paramPNames
_pats'' <- if modifyToks
then do
logm $ "addParamtoMatch:l=" ++ (showGhc l)
if emptyList pats
then addFormalParams (Left l2) pats'
else addFormalParams (Right pats) pats'
return pats'
else return pats'
return (GHC.L l (GHC.Match (pats'++pats) mtyp rhs'))
addParamToDecl (GHC.L l1 (GHC.PatBind pat@(GHC.L _l2 (GHC.VarPat p)) rhs ty fvs t))
| p == pn
= do _rhs'<-addActualParamsToRhs modifyToks pn paramPNames rhs
let pats' = map GHC.noLoc $ map pNtoPat paramPNames
_pats'' <- if modifyToks then do _ <- addFormalParams (Right [pat]) pats'
return pats'
else return pats'
return (GHC.L l1 (GHC.PatBind pat rhs ty fvs t))
addParamToDecl x=return x
addFormalParams
:: Either GHC.SrcSpan [(GHC.LPat GHC.Name)]
-> [(GHC.LPat GHC.Name)]
-> RefactGhc ()
addFormalParams place newParams
= do
let newStr = (prettyprintPatList prettyprint True newParams)
case place of
Left l@(GHC.RealSrcSpan ss) -> do
newToks' <- liftIO $ tokenise (GHC.realSrcSpanStart ss) 0 False newStr
let newToks = map markToken newToks'
_ <- putToksAfterSpan l PlaceAdjacent newToks
return ()
Left ss -> error $ "addFormalParams: expecting RealSrcSpan, got:" ++ (showGhc ss)
Right pats -> do
let l = GHC.combineLocs (ghead "addFormalParams" pats) (glast "addFormalParams" pats)
toks <- getToksForSpan l
let oldStr = GHC.showRichTokenStream $ rmOffsetFromToks toks
combinedToks <- liftIO $ tokenise (realSrcLocFromTok
$ ghead "addFormalParams" toks)
0 False (newStr ++ " " ++ oldStr)
_ <- putToksForSpan l combinedToks
return ()
addActualParamsToRhs :: (SYB.Typeable t, SYB.Data t) =>
Bool -> GHC.Name -> [GHC.Name] -> t -> RefactGhc t
addActualParamsToRhs modifyToks pn paramPNames rhs = do
r <- applyTP (stop_tdTPGhc (failTP `adhocTP` grhs)) rhs
return r
where
grhs :: (GHC.GRHSs GHC.Name) -> RefactGhc (GHC.GRHSs GHC.Name)
grhs (GHC.GRHSs g lb) = do
g' <- everywhereMStaged SYB.Renamer (SYB.mkM worker) g
return (GHC.GRHSs g' lb)
worker :: (GHC.Located (GHC.HsExpr GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.Name))
worker oldExp@(GHC.L l2 (GHC.HsVar pname))
| pname == pn = do
let newExp' = foldl addParamToExp oldExp paramPNames
let newExp = (GHC.L l2 (GHC.HsPar newExp'))
if modifyToks then do _ <- updateToks oldExp newExp prettyprint False
return newExp
else return newExp
worker x = return x
addParamToExp :: (GHC.LHsExpr GHC.Name) -> GHC.Name -> (GHC.LHsExpr GHC.Name)
addParamToExp expr param = GHC.noLoc (GHC.HsApp expr (GHC.noLoc (GHC.HsVar param)))
duplicateDecl::(SYB.Data t) =>
[GHC.LHsBind GHC.Name]
->t
->GHC.Name
->GHC.Name
->RefactGhc [GHC.LHsBind GHC.Name]
duplicateDecl decls sigs n newFunName
= do
let Just sspan = getSrcSpan funBinding
toks <- getToksForSpan sspan
newSpan <- case typeSig of
[] -> return sspan
_ -> do
let Just sspanSig = getSrcSpan typeSig
toksSig <- getToksForSpan sspanSig
let colStart = tokenCol $ ghead "duplicateDecl.sig"
$ dropWhile isWhiteSpace toksSig
typeSig' <- putDeclToksAfterSpan sspan (ghead "duplicateDecl" typeSig) (PlaceAbsCol 2 colStart 0) toksSig
_typeSig'' <- renamePN n newFunName True False typeSig'
let (GHC.L sspanSig' _) = typeSig'
return sspanSig'
let rowOffset = case typeSig of
[] -> 2
_ -> 1
let colStart = tokenCol $ ghead "duplicateDecl.decl"
$ dropWhile isWhiteSpace toks
funBinding' <- putDeclToksAfterSpan newSpan (ghead "duplicateDecl" funBinding) (PlaceAbsCol rowOffset colStart 2) toks
funBinding'' <- renamePN n newFunName True False funBinding'
return [funBinding'']
where
declsToDup = definingDeclsNames [n] decls True False
funBinding = filter isFunOrPatBindR declsToDup
typeSig = definingSigsNames [n] sigs
rmDecl:: (SYB.Data t)
=> GHC.Name
-> Bool
-> t
-> RefactGhc
(t,
GHC.LHsBind GHC.Name,
Maybe (GHC.LSig GHC.Name))
rmDecl pn incSig t = do
logm $ "rmDecl:(pn,incSig)= " ++ (showGhc (pn,incSig))
setStateStorage StorageNone
t2 <- everywhereMStaged' SYB.Renamer (SYB.mkM inLet) t
t' <- everywhereMStaged' SYB.Renamer (SYB.mkM inDecls `SYB.extM` inGRHSs) t2
(t'',sig') <- if incSig
then rmTypeSig pn t'
else return (t', Nothing)
storage <- getStateStorage
let decl' = case storage of
StorageBind bind -> bind
x -> error $ "rmDecl: unexpected value in StateStorage:" ++ (show x)
return (t'',decl',sig')
where
inGRHSs ((GHC.GRHSs a localDecls)::GHC.GRHSs GHC.Name)
| not $ emptyList (snd (break (defines pn) (hsBinds localDecls)))
= do
let decls = hsBinds localDecls
let (_decls1, decls2) = break (defines pn) decls
decl = ghead "rmDecl" decls2
topLevel <- isTopLevelPN pn
decls' <- case topLevel of
True -> rmTopLevelDecl decl decls
False -> rmLocalDecl decl decls
return (GHC.GRHSs a (replaceBinds localDecls decls'))
inGRHSs x = return x
inDecls (decls::[GHC.LHsBind GHC.Name])
| not $ emptyList (snd (break (defines pn) decls))
= do let (_decls1, decls2) = break (defines pn) decls
decl = ghead "rmDecl" decls2
topLevel <- isTopLevelPN pn
case topLevel of
True -> rmTopLevelDecl decl decls
False -> rmLocalDecl decl decls
inDecls x = return x
inLet :: GHC.LHsExpr GHC.Name -> RefactGhc (GHC.LHsExpr GHC.Name)
inLet (GHC.L ss (GHC.HsLet localDecls expr@(GHC.L l _)))
| not $ emptyList (snd (break (defines pn) (hsBinds localDecls)))
= do
let decls = hsBinds localDecls
let (decls1, decls2) = break (defines pn) decls
decl = ghead "rmDecl" decls2
toks <- getToksForSpan l
removeToksForPos (getStartEndLoc decl)
decl' <- syncDeclToLatestStash decl
setStateStorage (StorageBind decl')
case length decls of
1 -> do
(_,expr') <- putDeclToksForSpan ss expr $ dropWhile (\tok -> isEmpty tok || isIn tok) toks
return expr'
_ -> do
logm $ "rmDecl.inLet:length decls /= 1"
let decls2' = gtail "inLet" decls2
return $ (GHC.L ss (GHC.HsLet (replaceBinds localDecls (decls1 ++ decls2')) expr))
inLet x = return x
rmTopLevelDecl :: GHC.LHsBind GHC.Name -> [GHC.LHsBind GHC.Name]
-> RefactGhc [GHC.LHsBind GHC.Name]
rmTopLevelDecl decl decls
=do
logm $ "rmTopLevelDecl:"
removeToksForPos (getStartEndLoc decl)
decl' <- syncDeclToLatestStash decl
setStateStorage (StorageBind decl')
let (decls1, decls2) = break (defines pn) decls
decls2' = gtail "rmTopLevelDecl 1" decls2
return $ (decls1 ++ decls2')
rmLocalDecl :: GHC.LHsBind GHC.Name -> [GHC.LHsBind GHC.Name]
-> RefactGhc [GHC.LHsBind GHC.Name]
rmLocalDecl decl@(GHC.L sspan _) decls
= do
logm $ "rmLocalDecl: decls=" ++ (showGhc decls)
prevToks <- getToksBeforeSpan sspan
removeToksForPos (getStartEndLoc decl)
decl' <- syncDeclToLatestStash decl
setStateStorage (StorageBind decl')
case length decls of
1 -> do
let startPos = getGhcLoc sspan
(_toks1,toks2)=break (\t1->tokenPos t1 < startPos) $ reversedToks prevToks
rvToks1 = dropWhile (not.isWhereOrLet) toks2
whereOrLet = ghead "rmLocalDecl:whereOrLet" rvToks1
rmEndPos = tokenPosEnd whereOrLet
rmStartPos = tokenPos whereOrLet
logm $ "rmLocalDecl: where/let tokens are at" ++ (show (rmStartPos,rmEndPos))
removeToksForPos (rmStartPos,rmEndPos)
return ()
_ -> return ()
let (decls1, decls2) = break (defines pn) decls
decls2' = gtail "rmLocalDecl 3" decls2
return $ (decls1 ++ decls2')
rmTypeSigs :: (SYB.Data t) =>
[GHC.Name]
-> t
-> RefactGhc (t,[GHC.LSig GHC.Name])
rmTypeSigs pns t = do
(t',demotedSigsMaybe) <- foldM (\(tee,ds) n -> do { (tee',d) <- rmTypeSig n tee; return (tee', ds++[d])}) (t,[]) pns
return (t',catMaybes demotedSigsMaybe)
rmTypeSig :: (SYB.Data t) =>
GHC.Name
-> t
-> RefactGhc (t,Maybe (GHC.LSig GHC.Name))
rmTypeSig pn t
= do
setStateStorage StorageNone
t' <- everywhereMStaged SYB.Renamer (SYB.mkM inSigs) t
storage <- getStateStorage
let sig' = case storage of
StorageSig sig -> Just sig
StorageNone -> Nothing
x -> error $ "rmTypeSig: unexpected value in StateStorage:" ++ (show x)
return (t',sig')
where
inSigs (sigs::[GHC.LSig GHC.Name])
| not $ emptyList (snd (break (definesTypeSig pn) sigs))
= do
let (decls1,decls2)= break (definesTypeSig pn) sigs
let sig@(GHC.L sspan (GHC.TypeSig names typ)) = ghead "rmTypeSig" decls2
if length names > 1
then do
let newSig=(GHC.L sspan (GHC.TypeSig (filter (\(GHC.L _ x) -> x /= pn) names) typ))
toks <- getToksForSpan sspan
logm $ "rmTypeSig: fetched toks:" ++ (show toks)
let pnt = ghead "rmTypeSig" (filter (\(GHC.L _ x) -> x == pn) names)
(startPos1, endPos1) =
let (startPos1', endPos1') = getStartEndLoc pnt
in if gfromJust "rmTypeSig" (elemIndex pnt names) == 0
then extendForwards toks (startPos1',endPos1') isComma
else extendBackwards toks (startPos1',endPos1') isComma
toks' = deleteToks toks startPos1 endPos1
void $ putToksForSpan sspan toks'
let oldSig = (GHC.L sspan (GHC.TypeSig [pnt] typ))
sig'@(GHC.L sspan' _) <- syncDeclToLatestStash oldSig
let typeLoc = extendBackwards toks (getStartEndLoc typ) isDoubleColon
let (_,typTok,_) = splitToks typeLoc toks
let (_,pntTok,_) = splitToks (getStartEndLoc pnt) toks
void $ putToksForSpan sspan' (pntTok ++ typTok)
setStateStorage (StorageSig sig')
return (decls1++[newSig]++tail decls2)
else do
removeToksForSpan sspan
sig' <- syncDeclToLatestStash sig
setStateStorage (StorageSig sig')
return (decls1++tail decls2)
inSigs x = return x
rmQualifier:: (SYB.Data t)
=>[GHC.Name]
->t
->RefactGhc t
rmQualifier pns t =
everywhereMStaged SYB.Renamer (SYB.mkM rename) t
where
rename ((GHC.L l pn)::GHC.Located GHC.Name)
| elem pn pns
= do do
let (rs,_) = break (=='.') $ reverse $ showGhc pn
s = reverse rs
return (GHC.L l (GHC.mkInternalName (GHC.nameUnique pn) (GHC.mkVarOcc s) l))
rename x = return x
qualifyToplevelName :: GHC.Name -> RefactGhc ()
qualifyToplevelName n = do
renamed <- getRefactRenamed
_ <- renamePN n n True True renamed
return ()
renamePN::(SYB.Data t)
=>GHC.Name
->GHC.Name
->Bool
->Bool
->t
->RefactGhc t
renamePN oldPN newName updateTokens useQual t = do
let isRenamed = somethingStaged SYB.Renamer Nothing
(Nothing `SYB.mkQ` isRenamedSource `SYB.extQ` isRenamedGroup) t
t' <- if isRenamed == (Just True)
then
everywhereMStaged SYB.Renamer
(SYB.mkM renameRenamedSource
`SYB.extM` renameGroup
) t
else
renamePNworker oldPN newName updateTokens useQual t
return t'
where
isRenamedSource :: GHC.RenamedSource -> Maybe Bool
isRenamedSource (_g,_i,_e,_d) = Just True
isRenamedGroup :: GHC.HsGroup GHC.Name -> Maybe Bool
isRenamedGroup _g = Just True
renameRenamedSource :: GHC.RenamedSource -> RefactGhc GHC.RenamedSource
renameRenamedSource (g,i,e,d) = do
i' <- renamePNworker oldPN newName updateTokens False i
e' <- renamePNworker oldPN newName updateTokens useQual e
return (g,i',e',d)
renameGroup :: (GHC.HsGroup GHC.Name) -> RefactGhc (GHC.HsGroup GHC.Name)
renameGroup g
= do
logm $ "renamePN:renameGroup"
g' <- renamePNworker oldPN newName updateTokens useQual g
return g'
renamePNworker::(SYB.Data t)
=>GHC.Name
->GHC.Name
->Bool
->Bool
->t
->RefactGhc t
renamePNworker oldPN newName updateTokens useQual t = do
everywhereMStaged SYB.Renamer (SYB.mkM rename
`SYB.extM` renameVar
`SYB.extM` renameTyVar
`SYB.extM` renameHsTyVarBndr
`SYB.extM` renameLIE
`SYB.extM` renameLPat
`SYB.extM` renameTypeSig
`SYB.extM` renameFunBind
) t
where
rename :: (GHC.Located GHC.Name) -> RefactGhc (GHC.Located GHC.Name)
rename (GHC.L l n)
| (GHC.nameUnique n == GHC.nameUnique oldPN)
= do
logm $ "renamePNworker:rename at :" ++ (show l) ++ (showSrcSpanF l)
worker useQual l Nothing
return (GHC.L l newName)
rename x = return x
renameVar :: (GHC.Located (GHC.HsExpr GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsExpr GHC.Name))
renameVar v@(GHC.L l (GHC.HsVar n))
| (GHC.nameUnique n == GHC.nameUnique oldPN)
= do
logm $ "renamePNworker:renameVar at :" ++ (showGhc l)
rn <- (getParsedForRenamedLocated v :: RefactGhc (GHC.LHsExpr GHC.RdrName))
let (GHC.L _ (GHC.HsVar mqn)) = rn
let mrnq = GHC.isQual_maybe mqn
logm $ "renamePNworker:renameVar mrn,mrnq :" ++ (showGhc (rn,mrnq))
worker useQual l mrnq
return (GHC.L l (GHC.HsVar newName))
renameVar x = return x
renameTyVar :: (GHC.Located (GHC.HsType GHC.Name)) -> RefactGhc (GHC.Located (GHC.HsType GHC.Name))
renameTyVar v@(GHC.L l (GHC.HsTyVar n))
| (GHC.nameUnique n == GHC.nameUnique oldPN)
= do
logm $ "renamePNworker:renameTyVar at :" ++ (showGhc l)
rn <- (getParsedForRenamedLocated v :: RefactGhc (GHC.LHsType GHC.RdrName))
let (GHC.L _ (GHC.HsTyVar mqn)) = rn
let mrnq = GHC.isQual_maybe mqn
logm $ "renamePNworker:renameVar mrn,mrnq :" ++ (showGhc (rn,mrnq))
worker useQual l mrnq
return (GHC.L l (GHC.HsTyVar newName))
renameTyVar x = return x
renameHsTyVarBndr :: (GHC.LHsTyVarBndr GHC.Name) -> RefactGhc (GHC.LHsTyVarBndr GHC.Name)
#if __GLASGOW_HASKELL__ > 704
renameHsTyVarBndr v@(GHC.L l (GHC.UserTyVar n))
#else
renameHsTyVarBndr v@(GHC.L l (GHC.UserTyVar n typ))
#endif
| (GHC.nameUnique n == GHC.nameUnique oldPN)
= do
logm $ "renamePNworker:renameHsTyVarBndr at :" ++ (showGhc l)
rn <- (getParsedForRenamedLocated v :: RefactGhc (GHC.LHsTyVarBndr GHC.RdrName))
#if __GLASGOW_HASKELL__ > 704
let (GHC.L _ (GHC.UserTyVar mqn)) = rn
#else
let (GHC.L _ (GHC.UserTyVar mqn _)) = rn
#endif
let mrnq = GHC.isQual_maybe mqn
logm $ "renamePNworker:renameVar mrn,mrnq :" ++ (showGhc (rn,mrnq))
worker useQual l mrnq
#if __GLASGOW_HASKELL__ > 704
return (GHC.L l (GHC.UserTyVar newName))
#else
return (GHC.L l (GHC.UserTyVar newName typ))
#endif
renameHsTyVarBndr x = return x
renameLIE :: (GHC.LIE GHC.Name) -> RefactGhc (GHC.LIE GHC.Name)
renameLIE (GHC.L l (GHC.IEVar n))
| (GHC.nameUnique n == GHC.nameUnique oldPN)
= do
worker useQual l Nothing
return (GHC.L l (GHC.IEVar newName))
renameLIE (GHC.L l (GHC.IEThingAbs n))
| (GHC.nameUnique n == GHC.nameUnique oldPN)
= do
worker useQual l Nothing
return (GHC.L l (GHC.IEThingAbs newName))
renameLIE (GHC.L l (GHC.IEThingAll n))
| (GHC.nameUnique n == GHC.nameUnique oldPN)
= do
worker useQual l Nothing
return (GHC.L l (GHC.IEThingAll newName))
renameLIE (GHC.L l (GHC.IEThingWith n ns))
| (GHC.nameUnique n == GHC.nameUnique oldPN)
= do
logm $ "renamePNworker:renameLIE.IEThingWith at :" ++ (showGhc l)
worker useQual l Nothing
return (GHC.L l (GHC.IEThingWith newName ns))
| any (\nn -> (GHC.nameUnique nn == GHC.nameUnique oldPN)) ns
= do
toks <- getToksForSpan l
let (_,pt) = break isOpenParen $ filter (not . isWhiteSpaceOrIgnored) toks
let nstoks = gtail "renamePNworker" pt
let unQualOld = (GHC.occNameString $ GHC.getOccName oldPN)
let _tok@(GHC.L lt _,_) = ghead "renamePNworker" $ filter (\tt -> tokenCon tt == showGhc oldPN || tokenCon tt == unQualOld) nstoks
logm $ "renamePNworker:renameLIE.IEThingWith ns at :" ++ (showGhc lt)
worker useQual lt Nothing
return (GHC.L l (GHC.IEThingWith newName ns))
renameLIE x = do
return x
renameLPat :: (GHC.LPat GHC.Name) -> RefactGhc (GHC.LPat GHC.Name)
renameLPat v@(GHC.L l (GHC.VarPat n))
| (GHC.nameUnique n == GHC.nameUnique oldPN)
= do
logm $ "renamePNworker:renameLPat at :" ++ (showGhc l)
rn <- (getParsedForRenamedLocated v :: RefactGhc (GHC.LPat GHC.RdrName))
let (GHC.L _ (GHC.VarPat mqn)) = rn
let mrnq = GHC.isQual_maybe mqn
logm $ "renamePNworker:renameVar mrn,mrnq :" ++ (showGhc (rn,mrnq))
worker False l mrnq
return (GHC.L l (GHC.VarPat newName))
renameLPat x = return x
renameFunBind :: (GHC.LHsBindLR GHC.Name GHC.Name) -> RefactGhc (GHC.LHsBindLR GHC.Name GHC.Name)
renameFunBind (GHC.L l (GHC.FunBind (GHC.L ln n) fi (GHC.MatchGroup matches typ) co fvs tick))
| (GHC.nameUnique n == GHC.nameUnique oldPN) || (GHC.nameUnique n == GHC.nameUnique newName)
= do
worker False ln Nothing
logm $ "renamePNWorker.renameFunBind.renameFunBind:starting matches"
let w (GHC.L lm _match) = worker False lm' Nothing
where
((GHC.L lm' _),_) = newNameTok False lm oldPN
mapM_ w $ tail matches
logm $ "renamePNWorker.renameFunBind.renameFunBind.renameFunBind:matches done"
return (GHC.L l (GHC.FunBind (GHC.L ln newName) fi (GHC.MatchGroup matches typ) co fvs tick))
renameFunBind x = return x
renameTypeSig :: (GHC.LSig GHC.Name) -> RefactGhc (GHC.LSig GHC.Name)
renameTypeSig (GHC.L l (GHC.TypeSig ns typ))
= do
_ns' <- renamePN oldPN newName updateTokens False ns
ns' <- renamePN newName newName updateTokens False ns
typ' <- renamePN oldPN newName updateTokens False typ
return (GHC.L l (GHC.TypeSig ns' typ'))
renameTypeSig x = return x
worker :: Bool -> GHC.SrcSpan -> Maybe (GHC.ModuleName, GHC.OccName) -> RefactGhc ()
worker useQual' l mmo
= do if updateTokens
then do
newTok <- case mmo of
Nothing -> return $ newNameTok useQual' l newName
Just (modu,_) -> do
newName' <- mkNewGhcName (Just $ GHC.mkModule GHC.mainPackageId modu) (GHC.occNameString $ GHC.getOccName newName)
return $ newNameTok True l newName'
replaceToken l (markToken $ newTok)
return ()
else return ()
newNameTok :: Bool -> GHC.SrcSpan -> GHC.Name -> PosToken
newNameTok useQual l newName =
((GHC.L l' (GHC.ITvarid (GHC.mkFastString newNameStr))),newNameStr)
where
newNameStr = if useQual then (showGhc newName)
else (GHC.occNameString $ GHC.getOccName newName)
l' = case l of
GHC.RealSrcSpan ss ->
let
((ForestLine _ _ _ startRow,startCol),_) = srcSpanToForestSpan l
locStart = GHC.mkSrcLoc (GHC.srcSpanFile ss) startRow startCol
locEnd = GHC.mkSrcLoc (GHC.srcSpanFile ss) startRow (length newNameStr + startCol)
in
GHC.mkSrcSpan locStart locEnd
_ -> l
autoRenameLocalVar:: (HsValBinds t)
=>Bool
->GHC.Name
->t
-> RefactGhc t
autoRenameLocalVar modifyToks pn t = do
logm $ "autoRenameLocalVar: (modifyToks,pn)=" ++ (showGhc (modifyToks,pn))
if isDeclaredIn pn t
then do t' <- worker t
return t'
else do return t
where
worker tt =do (f,d) <- hsFDNamesFromInside tt
ds <- hsVisibleNames pn (hsValBinds tt)
let newNameStr=mkNewName (nameToString pn) (nub (f `union` d `union` ds)) 1
newName <- mkNewGhcName Nothing newNameStr
if modifyToks
then renamePN pn newName True False tt
else renamePN pn newName False False tt
showEntities:: (t->String) -> [t] ->String
showEntities _ [] = ""
showEntities f [pn] = f pn
showEntities f (pn:pns) =f pn ++ "," ++ showEntities f pns
isMainModule :: GHC.Module -> Bool
isMainModule modu = GHC.modulePackageId modu == GHC.mainPackageId
defineLoc :: GHC.Located GHC.Name -> GHC.SrcLoc
defineLoc (GHC.L _ name) = GHC.nameSrcLoc name
useLoc:: (GHC.Located GHC.Name) -> GHC.SrcLoc
useLoc (GHC.L l _) = GHC.srcSpanStart l
isUsedInRhs::(SYB.Data t) => (GHC.Located GHC.Name) -> t -> Bool
isUsedInRhs pnt t = useLoc pnt /= defineLoc pnt && not (notInLhs)
where
notInLhs = fromMaybe False $ somethingStaged SYB.Parser Nothing
(Nothing `SYB.mkQ` inMatch `SYB.extQ` inDecl) t
where
inMatch ((GHC.FunBind name _ (GHC.MatchGroup _matches _) _ _ _) :: GHC.HsBind t)
| isJust (find (sameOccurrence pnt) [name]) = Just True
inMatch _ = Nothing
inDecl ((GHC.TypeSig is _) :: GHC.Sig t)
|isJust (find (sameOccurrence pnt) is) = Just True
inDecl _ = Nothing
findAllNameOccurences :: (SYB.Data t) => GHC.Name -> t -> [(GHC.Located GHC.Name)]
findAllNameOccurences name t
= res
where
res = SYB.everythingStaged SYB.Renamer (++) []
([] `SYB.mkQ` worker `SYB.extQ` workerBind `SYB.extQ` workerExpr) t
worker (ln@(GHC.L _l n) :: (GHC.Located GHC.Name))
| GHC.nameUnique n == GHC.nameUnique name = [ln]
worker _ = []
workerBind (GHC.L l (GHC.VarPat n) :: (GHC.Located (GHC.Pat GHC.Name)))
| GHC.nameUnique n == GHC.nameUnique name = [(GHC.L l n)]
workerBind _ = []
workerExpr (GHC.L l (GHC.HsVar n) :: (GHC.Located (GHC.HsExpr GHC.Name)))
| GHC.nameUnique n == GHC.nameUnique name = [(GHC.L l n)]
workerExpr _ = []
findPNT::(SYB.Data t) => GHC.Located GHC.Name -> t -> Bool
findPNT (GHC.L _ pn) = findPN pn
findPN::(SYB.Data t)=> GHC.Name -> t -> Bool
findPN pn
= isJust.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker)
where
worker (n::GHC.Name)
| GHC.nameUnique pn == GHC.nameUnique n = Just True
worker _ = Nothing
findPNs::(SYB.Data t)=> [GHC.Name] -> t -> Bool
findPNs pns
= isJust.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker)
where
uns = map GHC.nameUnique pns
worker (n::GHC.Name)
| elem (GHC.nameUnique n) uns = Just True
worker _ = Nothing
findIdForName :: GHC.Name -> RefactGhc (Maybe GHC.Id)
findIdForName n = do
tm <- getTypecheckedModule
let t = GHC.tm_typechecked_source tm
let r = somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` worker) t
worker (i::GHC.Id)
| (GHC.nameUnique n) == (GHC.varUnique i) = Just i
worker _ = Nothing
return r
getTypeForName :: GHC.Name -> RefactGhc (Maybe GHC.Type)
getTypeForName n = do
mId <- findIdForName n
case mId of
Nothing -> return Nothing
Just i -> return $ Just (GHC.varType i)
locToExp:: (SYB.Data t,SYB.Typeable n) =>
SimpPos
-> SimpPos
-> t
-> Maybe (GHC.Located (GHC.HsExpr n))
locToExp beginPos endPos t = res
where
res = somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` expr) t
expr :: GHC.Located (GHC.HsExpr n) -> (Maybe (GHC.Located (GHC.HsExpr n)))
expr e
|inScope e = Just e
expr _ = Nothing
inScope :: GHC.Located e -> Bool
inScope (GHC.L l _) =
let
(startLoc,endLoc) = case l of
(GHC.RealSrcSpan ss) ->
((GHC.srcSpanStartLine ss,GHC.srcSpanStartCol ss),
(GHC.srcSpanEndLine ss,GHC.srcSpanEndCol ss))
(GHC.UnhelpfulSpan _) -> ((0,0),(0,0))
in
(startLoc>=beginPos) && (startLoc<= endPos) && (endLoc>= beginPos) && (endLoc<=endPos)
ghcToPN :: GHC.RdrName -> PName
ghcToPN rdr = PN rdr
lghcToPN :: GHC.Located GHC.RdrName -> PName
lghcToPN (GHC.L _ rdr) = PN rdr
expToName:: GHC.Located (GHC.HsExpr GHC.Name) -> GHC.Name
expToName (GHC.L _ (GHC.HsVar pnt)) = pnt
expToName (GHC.L _ (GHC.HsPar e)) = expToName e
expToName _ = defaultName
nameToString :: GHC.Name -> String
nameToString name = showGhc name
patToPNT::GHC.LPat GHC.Name -> Maybe GHC.Name
patToPNT (GHC.L _ (GHC.VarPat n)) = Just n
patToPNT _ = Nothing
pNtoPat :: GHC.Name -> GHC.Pat GHC.Name
pNtoPat pname = GHC.VarPat pname
getToksForDecl :: SYB.Data t =>
t -> [PosToken] -> [PosToken]
getToksForDecl decl toks
= let (startPos, endPos) = startEndLocIncComments toks decl
(toks1, _) =let(ts1,(_t:ts2'))= break (\t -> tokenPos t >= endPos) toks
in (ts1, ts2')
in dropWhile (\t -> tokenPos t < startPos ) toks1
getDeclAndToks :: (HsValBinds t)
=> GHC.Name -> Bool -> [PosToken] -> t
-> ([GHC.LHsBind GHC.Name],[PosToken])
getDeclAndToks pn _incSig toks t =
let
decls = definingDeclsNames [pn] (hsBinds t) True True
declToks = getToksForDecl decls toks
in (decls, removeToksOffset declToks)
getSigAndToks :: (SYB.Data t) => GHC.Name -> t -> [PosToken]
-> Maybe (GHC.LSig GHC.Name,[PosToken])
getSigAndToks pn t toks
= case (getSig pn t) of
Nothing -> Nothing
Just sig -> Just (sig, removeToksOffset $ getToksForDecl sig toks)
removeToksOffset :: [PosToken] -> [PosToken]
removeToksOffset toks = toks'
where
toks' = case toks of
[] -> []
_ -> removeOffset offset toks
where
(_r,c) = tokenPos $ head toks
offset = c
removeOffset :: Int -> [PosToken] -> [PosToken]
removeOffset offset toks = map (\(t,s) -> (adjust t,s)) toks
where
adjust (GHC.L l t) = (GHC.L l' t)
where
l' = case l of
GHC.RealSrcSpan ss ->
let
locs = GHC.mkSrcLoc (GHC.srcSpanFile ss) (GHC.srcSpanStartLine ss) ((GHC.srcSpanStartCol ss) offset)
loce = GHC.mkSrcLoc (GHC.srcSpanFile ss) (GHC.srcSpanEndLine ss) ((GHC.srcSpanEndCol ss) offset)
in
GHC.mkSrcSpan locs loce
_ -> l
getSig :: (SYB.Data t) => GHC.Name -> t
-> Maybe (GHC.LSig GHC.Name)
getSig pn t = maybeSig
where
maybeSig = if (emptyList sigList)
then Nothing
else Just $ head sigList
sigList = SYB.everythingStaged SYB.Renamer (++) []
([] `SYB.mkQ` inDecls) t
inDecls (sigs::[GHC.LSig GHC.Name])
| not $ emptyList (snd (break (definesTypeSig pn) sigs))
= let (_decls1,decls2)= break (definesTypeSig pn) sigs
sig@(GHC.L l (GHC.TypeSig names typ)) = ghead "getSigsAndToks" decls2
sig' = if length names > 1
then (GHC.L l (GHC.TypeSig (filter (\(GHC.L _ x) -> x /= pn) names) typ))
else sig
in [sig']
inDecls _ = []