module Language.Haskell.Refact.Utils.TypeUtils
(
inScopeInfo, isInScopeAndUnqualified, isInScopeAndUnqualifiedGhc, inScopeNames
, isExported, isExplicitlyExported, modIsExported
, equivalentNameInNewMod
,isVarId,isConId,isOperator,isTopLevelPN,isLocalPN,isNonLibraryName
,isQualifiedPN, isFunOrPatName, isTypeSig, isTypeSigDecl
,isFunBindP,isFunBindR,isPatBindP,isPatBindR,isSimplePatBind,isSimplePatDecl
,isComplexPatBind,isComplexPatDecl,isFunOrPatBindP,isFunOrPatBindR
,usedWithoutQualR,isUsedInRhs
,findNameInRdr
,findPNT,findPN,findAllNameOccurences
,findPNs, findNamesRdr, findEntity, findEntity'
,findIdForName
,getTypeForName
,defines, definesP,definesTypeSig,definesTypeSigRdr
,sameBind,sameBindRdr
,UsedByRhs(..)
, isMainModule
, getModule
,defineLoc, useLoc, locToExp
,locToName, locToRdrName
,getName
,addDecl, addItemsToImport, addItemsToExport, addHiding
,addParamsToDecls, addActualParamsToRhs, addImportDecl, duplicateDecl
,rmDecl, rmTypeSig, rmTypeSigs
, rmQualifier, qualifyToplevelName, renamePN, autoRenameLocalVar
,ghcToPN,lghcToPN, expToName, expToNameRdr
,nameToString
,patToNameRdr
, patToPNT, pNtoPat
, divideDecls
, mkRdrName,mkNewGhcName,mkNewName,mkNewToplevelName
, causeNameClashInExports
, declsSybTransform
, getParsedForRenamedLPat
, getParsedForRenamedName
, getParsedForRenamedLocated
, rdrNameFromName
, stripLeadingSpaces
) where
import Control.Monad.State
import Data.Char
import Data.Foldable
import Data.List
import Data.Maybe
import Exception
import Language.Haskell.Refact.Utils.ExactPrint
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.TypeSyn
import Language.Haskell.Refact.Utils.Types
import Language.Haskell.Refact.Utils.Variables
import Language.Haskell.GHC.ExactPrint
import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Utils
import qualified Bag as GHC
import qualified FastString as GHC
import qualified GHC as GHC
import qualified Module as GHC
import qualified Name as GHC
import qualified RdrName 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 qualified Data.Map as Map
import Data.Generics.Strafunski.StrategyLib.StrategyLib hiding (liftIO,MonadPlus,mzero)
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 -> (showGhcQual x) /= (showGhcQual 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 []
equivalentNameInNewMod :: GHC.Name -> RefactGhc [GHC.Name]
equivalentNameInNewMod old = do
gnames <- GHC.getNamesInScope
let clientModule = GHC.nameModule old
let clientInscopes = filter (\n -> clientModule == GHC.nameModule n) gnames
let newNames = filter (\n -> showGhcQual n == showGhcQual old) clientInscopes
return newNames
defaultName :: GHC.Name
defaultName = n
where
un = GHC.mkUnique 'H' 0
n = GHC.localiseName $ GHC.mkSystemName un (GHC.mkVarOcc "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) }
return (mkNewGhcNamePure 'H' (u + 1) maybeMod name)
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 (GHC.L _ 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 (GHC.L _ 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
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 = SYB.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 = 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 = SYB.somethingStaged SYB.Parser Nothing (Nothing `SYB.mkQ` lname) t
lname :: (GHC.Located b) -> (Maybe (GHC.Located b))
lname p@(GHC.L lp _)
| lp == 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 = SYB.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 = Just p
lname _ = Nothing
usedWithoutQualR :: (SYB.Data t) => GHC.Name -> t -> Bool
usedWithoutQualR name parsed = fromMaybe False res
where
res = SYB.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
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 . SYB.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.LSig a -> Bool
isTypeSig (GHC.L _ (GHC.TypeSig _ _ _)) = True
isTypeSig _ = False
isTypeSigDecl :: GHC.LHsDecl a -> Bool
isTypeSigDecl (GHC.L _ (GHC.SigD (GHC.TypeSig _ _ _))) = True
isTypeSigDecl _ = 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
isSimplePatDecl :: (GHC.DataId t) => GHC.LHsDecl t-> Bool
isSimplePatDecl decl = case decl of
(GHC.L _l (GHC.ValD (GHC.PatBind p _rhs _ty _fvs _))) -> hsPNs p /= []
_ -> False
isSimplePatBind :: (GHC.DataId t) => GHC.LHsBind t-> Bool
isSimplePatBind decl = case decl of
(GHC.L _l (GHC.PatBind p _rhs _ty _fvs _)) -> hsPNs p /= []
_ -> False
isComplexPatDecl::GHC.LHsDecl name -> Bool
isComplexPatDecl (GHC.L l (GHC.ValD decl)) = isComplexPatBind (GHC.L l decl)
isComplexPatDecl _ = False
isComplexPatBind::GHC.LHsBind name -> Bool
isComplexPatBind decl
= case decl of
(GHC.L _l (GHC.PatBind (GHC.L _ (GHC.VarPat _)) _rhs _ty _fvs _)) -> True
_ -> False
isFunOrPatBindP :: HsDeclP -> Bool
isFunOrPatBindP decl = isFunBindP decl || isPatBindP decl
isFunOrPatBindR :: GHC.LHsBind t -> Bool
isFunOrPatBindR decl = isFunBindR decl || isPatBindR decl
findEntity':: (SYB.Data a, SYB.Data b)
=> a -> b -> Maybe (SimpPos,SimpPos)
findEntity' a b = res
where
res = SYB.somethingStaged SYB.Parser Nothing worker b
worker :: (SYB.Data c)
=> c -> Maybe (SimpPos,SimpPos)
worker x = if SYB.typeOf a == SYB.typeOf x
then Just (getStartEndLoc x)
else Nothing
sameBindRdr :: NameMap -> GHC.LHsDecl GHC.RdrName -> GHC.LHsDecl GHC.RdrName -> Bool
sameBindRdr nm b1 b2 = (definedNamesRdr nm b1) == (definedNamesRdr nm b2)
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
usedByRhsRdr :: NameMap -> t -> [GHC.Name] -> Bool
instance UsedByRhs GHC.RenamedSource where
usedByRhs _renamed _pns = False
usedByRhsRdr _ _ = assert False undefined
instance UsedByRhs (GHC.HsModule GHC.RdrName) where
usedByRhsRdr _ _parsed _pns = False
usedByRhs _ _ = assert False undefined
instance (UsedByRhs a) => UsedByRhs (GHC.Located a) where
usedByRhsRdr nm (GHC.L _ d) pns = usedByRhsRdr nm d pns
usedByRhs _ la = error $ "usedByRhs:Located a=" ++ SYB.showData SYB.Parser 0 la
instance UsedByRhs [GHC.LHsDecl GHC.RdrName] where
usedByRhs _ _ = assert False undefined
usedByRhsRdr nm ds pns = or $ map (\d -> usedByRhsRdr nm d pns) ds
instance UsedByRhs (GHC.HsDecl GHC.RdrName) where
usedByRhs _ _ = assert False undefined
usedByRhsRdr nm de pns =
case de of
GHC.TyClD d -> f d
GHC.InstD d -> f d
GHC.DerivD d -> f d
GHC.ValD d -> f d
GHC.SigD d -> f d
GHC.DefD d -> f d
GHC.ForD d -> f d
GHC.WarningD d -> f d
GHC.AnnD d -> f d
GHC.RuleD d -> f d
GHC.VectD d -> f d
GHC.SpliceD d -> f d
GHC.DocD d -> f d
GHC.RoleAnnotD d -> f d
#if __GLASGOW_HASKELL__ < 711
GHC.QuasiQuoteD d -> f d
#endif
where
f d' = usedByRhsRdr nm d' pns
instance UsedByRhs (GHC.TyClDecl GHC.RdrName) where
usedByRhsRdr = assert False undefined
usedByRhs _ _ = assert False undefined
instance UsedByRhs (GHC.InstDecl GHC.RdrName) where
usedByRhsRdr = assert False undefined
usedByRhs _ _ = assert False undefined
instance UsedByRhs (GHC.DerivDecl GHC.RdrName) where
usedByRhsRdr = assert False undefined
usedByRhs _ _ = assert False undefined
instance UsedByRhs (GHC.ForeignDecl GHC.RdrName) where
usedByRhsRdr = assert False undefined
usedByRhs _ _ = assert False undefined
instance UsedByRhs (GHC.WarnDecls GHC.RdrName) where
usedByRhsRdr = assert False undefined
usedByRhs _ _ = assert False undefined
instance UsedByRhs (GHC.AnnDecl GHC.RdrName) where
usedByRhsRdr = assert False undefined
usedByRhs _ _ = assert False undefined
instance UsedByRhs (GHC.RoleAnnotDecl GHC.RdrName) where
usedByRhsRdr = assert False undefined
usedByRhs _ _ = assert False undefined
instance UsedByRhs (GHC.HsQuasiQuote GHC.RdrName) where
usedByRhsRdr = assert False undefined
usedByRhs _ _ = assert False undefined
instance UsedByRhs (GHC.DefaultDecl GHC.RdrName) where
usedByRhsRdr = assert False undefined
usedByRhs _ _ = assert False undefined
instance UsedByRhs (GHC.SpliceDecl GHC.RdrName) where
usedByRhsRdr = assert False undefined
usedByRhs _ _ = assert False undefined
instance UsedByRhs (GHC.VectDecl GHC.RdrName) where
usedByRhsRdr = assert False undefined
usedByRhs _ _ = assert False undefined
instance UsedByRhs (GHC.RuleDecls GHC.RdrName) where
usedByRhs _ _ = assert False undefined
usedByRhsRdr = assert False undefined
instance UsedByRhs GHC.DocDecl where
usedByRhs _ _ = assert False undefined
usedByRhsRdr = assert False undefined
instance UsedByRhs (GHC.Sig GHC.RdrName) where
usedByRhsRdr _ _ _ = False
usedByRhs _ = assert False undefined
instance UsedByRhs (GHC.LHsBinds GHC.Name) where
usedByRhs binds pns = or $ map (\b -> usedByRhs b pns) $ GHC.bagToList binds
usedByRhsRdr _ _ = assert False undefined
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
usedByRhsRdr _ _ = assert False undefined
instance UsedByRhs (GHC.Match GHC.Name (GHC.LHsExpr GHC.Name)) where
usedByRhs (GHC.Match _ _ _ (GHC.GRHSs rhs _)) pns
= findPNs pns rhs
usedByRhsRdr _ _ = assert False undefined
instance UsedByRhs (GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where
usedByRhsRdr nm (GHC.Match _ _ _ (GHC.GRHSs rhs _)) pns
= findNamesRdr nm pns rhs
usedByRhs _ _ = assert False undefined
instance UsedByRhs [GHC.LHsBind GHC.Name] where
usedByRhs binds pns = or $ map (\b -> usedByRhs b pns) binds
usedByRhsRdr _ _ = assert False undefined
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
usedByRhs (GHC.PatSynBind _) _pns = error "To implement: usedByRhs PaySynBind"
usedByRhsRdr _ _ = assert False undefined
instance UsedByRhs (GHC.HsBind GHC.RdrName) where
usedByRhs _ _ = assert False undefined
usedByRhsRdr nm (GHC.FunBind _ _ matches _ _ _) pns = findNamesRdr nm pns matches
usedByRhsRdr nm (GHC.PatBind _ rhs _ _ _) pns = findNamesRdr nm pns rhs
usedByRhsRdr nm (GHC.PatSynBind (GHC.PSB _ _ _ rhs _)) pns = findNamesRdr nm pns rhs
usedByRhsRdr nm (GHC.VarBind _ rhs _) pns = findNamesRdr nm pns rhs
usedByRhsRdr _nm (GHC.AbsBinds _ _ _ _ _) _pns = False
instance UsedByRhs (GHC.HsExpr GHC.Name) where
usedByRhs (GHC.HsLet _lb e) pns = findPNs pns e
usedByRhs e _pns = error $ "undefined usedByRhs:" ++ (showGhc e)
usedByRhsRdr _ _ = assert False undefined
instance UsedByRhs (GHC.HsExpr GHC.RdrName) where
usedByRhsRdr nm (GHC.HsLet _lb e) pns = findNamesRdr nm pns e
usedByRhsRdr _ e _pns = error $ "undefined usedByRhsRdr:" ++ (showGhc e)
usedByRhs _ _ = assert False undefined
instance UsedByRhs (GHC.Stmt GHC.Name (GHC.LHsExpr GHC.Name)) where
usedByRhs (GHC.LetStmt lb) pns = findPNs pns lb
usedByRhs s _pns = error $ "undefined usedByRhs:" ++ (showGhc s)
usedByRhsRdr _ _ = assert False undefined
instance UsedByRhs (GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where
usedByRhsRdr nm (GHC.LetStmt lb) pns = findNamesRdr nm pns lb
usedByRhsRdr _ s _pns = error $ "undefined usedByRhsRdr:" ++ (showGhc s)
usedByRhs _ _ = assert False undefined
getName::(SYB.Data t)=> String
-> t
-> Maybe GHC.Name
getName str t
= res
where
res = SYB.somethingStaged SYB.Renamer Nothing
(Nothing `SYB.mkQ` worker `SYB.extQ` workerBind `SYB.extQ` workerExpr) t
worker ((GHC.L _ n) :: (GHC.Located GHC.Name))
| showGhcQual n == str = Just n
worker _ = Nothing
workerBind (GHC.L _ (GHC.VarPat name) :: (GHC.Located (GHC.Pat GHC.Name)))
| showGhcQual name == str = Just name
workerBind _ = Nothing
workerExpr ((GHC.L _ (GHC.HsVar name)) :: (GHC.Located (GHC.HsExpr GHC.Name)))
| showGhcQual name == str = Just name
workerExpr _ = Nothing
addImportDecl ::
GHC.ParsedSource
-> GHC.ModuleName
-> Maybe GHC.FastString
-> Bool -> Bool -> Bool
-> Maybe String
-> Bool
-> [GHC.RdrName]
-> RefactGhc GHC.ParsedSource
addImportDecl (GHC.L l p) modName pkgQual source safe qualify alias hide idNames
= do
let imp = GHC.hsmodImports p
impDecl <- mkImpDecl
newSpan <- liftT uniqueSrcSpanT
let newImp = GHC.L newSpan impDecl
liftT $ addSimpleAnnT newImp (DP (1,0)) [((G GHC.AnnImport),DP (0,0))]
return (GHC.L l p { GHC.hsmodImports = (imp++[newImp])})
where
alias' = case alias of
Just stringName -> Just $ GHC.mkModuleName stringName
_ -> Nothing
mkImpDecl = do
newSpan1 <- liftT uniqueSrcSpanT
newSpan2 <- liftT uniqueSrcSpanT
newEnts <- mkNewEntList idNames
let lNewEnts = GHC.L newSpan2 newEnts
liftT $ addSimpleAnnT lNewEnts (DP (0,1)) [((G GHC.AnnHiding),DP (0,0)),((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))]
let lmodname = GHC.L newSpan1 modName
liftT $ addSimpleAnnT lmodname (DP (0,1)) [((G GHC.AnnVal),DP (0,0))]
return $ GHC.ImportDecl
{ GHC.ideclSourceSrc = Nothing
, GHC.ideclName = lmodname
, 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, lNewEnts)))
}
addDecl:: (SYB.Data t,SYB.Typeable t)
=> t
-> Maybe GHC.Name
-> ([GHC.LHsDecl GHC.RdrName], Maybe Anns)
-> RefactGhc t
addDecl parent pn (declSig, mDeclAnns) = do
logm $ "addDecl:declSig=" ++ showGhc declSig
case mDeclAnns of
Nothing -> return ()
Just declAnns ->
liftT $ modifyAnnsT (mergeAnns declAnns)
case pn of
Just pn' -> appendDecl parent pn' declSig
Nothing -> addLocalDecl parent declSig
where
setDeclSpacing newDeclSig n c = do
mapM_ (\d -> setPrecedingLinesDeclT d 1 0) newDeclSig
setPrecedingLinesT (ghead "addDecl" newDeclSig) n c
appendDecl :: (SYB.Data t)
=> t
-> GHC.Name
-> [GHC.LHsDecl GHC.RdrName]
-> RefactGhc t
appendDecl parent1 pn' newDeclSig = do
hasDeclsSybTransform workerHsDecls workerBind parent1
where
workerHsDecls :: forall t. HasDecls t => t -> RefactGhc t
workerHsDecls parent' = do
liftT $ setDeclSpacing newDeclSig 2 0
nameMap <- getRefactNameMap
decls <- liftT $ hsDecls parent'
let
(before,after) = break (definesDeclRdr nameMap pn') decls
let (decls1,decls2) = case after of
[] -> (before,[])
_ -> (before ++ [ghead "appendDecl14" after],
gtail "appendDecl15" after)
liftT $ replaceDecls parent' (decls1++newDeclSig++decls2)
workerBind :: (GHC.LHsBind GHC.RdrName -> RefactGhc (GHC.LHsBind GHC.RdrName))
workerBind = assert False undefined
addLocalDecl :: (SYB.Typeable t,SYB.Data t)
=> t -> [GHC.LHsDecl GHC.RdrName]
-> RefactGhc t
addLocalDecl parent' newDeclSig = do
logm $ "addLocalDecl entered"
hasDeclsSybTransform workerHasDecls workerBind parent'
where
workerDecls :: [GHC.LHsDecl GHC.RdrName] -> RefactGhc [GHC.LHsDecl GHC.RdrName]
workerDecls decls = do
logm $ "workerDecls entered"
case decls of
[] -> liftT $ setDeclSpacing newDeclSig 2 0
ds -> do
DP (r,c) <- liftT (getEntryDPT (head ds))
liftT $ setDeclSpacing newDeclSig r c
liftT $ setPrecedingLinesT (head ds) 2 0
return (newDeclSig++decls)
workerHasDecls :: (HasDecls t) => t -> RefactGhc t
workerHasDecls p = do
logm $ "workerHasDecls entered"
decls <- liftT (hsDecls p)
decls' <- workerDecls decls
r <- liftT $ replaceDecls p decls'
return r
workerBind :: GHC.LHsBind GHC.RdrName -> RefactGhc (GHC.LHsBind GHC.RdrName)
workerBind b = do
logm $ "workerBind entered"
case b of
GHC.L l (GHC.FunBind n i (GHC.MG [match] a ptt o) co fvs t) -> do
match' <- workerHasDecls match
return (GHC.L l (GHC.FunBind n i (GHC.MG [match'] a ptt o) co fvs t))
GHC.L _ (GHC.FunBind _ _ (GHC.MG _matches _ _ _) _ _ _) -> do
error "addDecl:Cannot add a local decl to a FunBind with multiple matches"
p@(GHC.L _ (GHC.PatBind _pat _rhs _ty _fvs _t)) -> do
logm $ "workerBind.PatBind entered"
decls <- liftT (hsDeclsPatBind p)
decls' <- workerDecls decls
r <- liftT $ replaceDeclsPatBind p decls'
return r
x -> error $ "addLocalDecl.workerBind:not processing:" ++ SYB.showData SYB.Parser 0 x
rdrNameFromName :: Bool -> GHC.Name -> RefactGhc GHC.RdrName
rdrNameFromName useQual newName = do
mname <- case (GHC.nameModule_maybe newName) of
Just (GHC.Module _ mn) -> return mn
Nothing -> do
GHC.Module _ mn <- getRefactModule
return mn
if useQual
then return $ GHC.mkRdrQual mname (GHC.nameOccName newName)
else return $ GHC.mkRdrUnqual (GHC.nameOccName newName)
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.ParsedSource
-> [GHC.RdrName]
-> RefactGhc GHC.ParsedSource
addHiding mn p ns = do
logm $ "addHiding called for (module,names):" ++ showGhc (mn,ns)
p' <- addItemsToImport' mn p ns Hide
putRefactParsed p' emptyAnns
return p'
mkNewEntList :: [GHC.RdrName] -> RefactGhc [GHC.LIE GHC.RdrName]
mkNewEntList idNames = do
case idNames of
[] -> return []
_ -> do
newEntsInit <- mapM (mkNewEnt True) (init idNames)
newEntsLast <- mkNewEnt False (last idNames)
return (newEntsInit ++ [newEntsLast])
mkNewEnt :: Bool -> GHC.RdrName -> RefactGhc (GHC.LIE GHC.RdrName)
mkNewEnt addCommaAnn pn = do
newSpan <- liftT uniqueSrcSpanT
let lpn = GHC.L newSpan pn
if addCommaAnn
then liftT $ addSimpleAnnT lpn (DP (0,0)) [((G GHC.AnnVal),DP (0,0)),((G GHC.AnnComma),DP (0,0))]
else liftT $ addSimpleAnnT lpn (DP (0,0)) [((G GHC.AnnVal),DP (0,0))]
return (GHC.L newSpan (GHC.IEVar lpn))
data ImportType = Hide
| Import
addItemsToImport::
GHC.ModuleName
->GHC.ParsedSource
->[GHC.RdrName]
->RefactGhc GHC.ParsedSource
addItemsToImport mn r ns = addItemsToImport' mn r ns Import
addItemsToImport'::
GHC.ModuleName
-> GHC.ParsedSource
-> [GHC.RdrName]
-> ImportType
-> RefactGhc GHC.ParsedSource
addItemsToImport' serverModName (GHC.L l p) pns impType = do
let imps = GHC.hsmodImports p
imps' <- mapM inImport imps
return $ GHC.L l p {GHC.hsmodImports = imps'}
where
isHide = case impType of
Hide -> True
Import -> False
inImport :: GHC.LImportDecl GHC.RdrName -> RefactGhc (GHC.LImportDecl GHC.RdrName)
inImport imp@(GHC.L _ (GHC.ImportDecl _st (GHC.L _ modName) _qualify _source _safe isQualified _isImplicit _as h))
| serverModName == modName && not isQualified
= case h of
Nothing -> insertEnts imp [] True
Just (_isHide, (GHC.L _le ents)) -> insertEnts imp ents False
inImport x = return x
insertEnts ::
GHC.LImportDecl GHC.RdrName
-> [GHC.LIE GHC.RdrName]
-> Bool
-> RefactGhc ( GHC.LImportDecl GHC.RdrName )
insertEnts imp ents isNew = do
logm $ "addItemsToImport':insertEnts:(imp,ents,isNew):" ++ showGhc (imp,ents,isNew)
if isNew && not isHide then return imp
else do
logm $ "addItemsToImport':insertEnts:doing stuff"
newSpan <- liftT uniqueSrcSpanT
newEnts <- mkNewEntList pns
let lNewEnts = GHC.L newSpan (ents++newEnts)
logm $ "addImportDecl.mkImpDecl:adding anns for:" ++ showGhc lNewEnts
if isHide
then
liftT $ addSimpleAnnT lNewEnts (DP (0,1)) [((G GHC.AnnHiding),DP (0,0)),((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))]
else
liftT $ addSimpleAnnT lNewEnts (DP (0,1)) [((G GHC.AnnOpenP),DP (0,0)),((G GHC.AnnCloseP),DP (0,0))]
when (not (null ents)) $ do liftT (addTrailingCommaT (last ents))
return (replaceHiding imp (Just (isHide, lNewEnts)))
replaceHiding (GHC.L l1 (GHC.ImportDecl st mn q src safe isQ isImp as _h)) h1 =
(GHC.L l1 (GHC.ImportDecl st mn q src safe isQ isImp as h1))
addParamsToDecls::
[GHC.LHsDecl GHC.RdrName]
-> GHC.Name
-> [GHC.RdrName]
-> RefactGhc [GHC.LHsDecl GHC.RdrName]
addParamsToDecls decls pn paramPNames = do
nameMap <- getRefactNameMap
if (paramPNames /= [])
then mapM (addParamToDecl nameMap) decls
else return decls
where
addParamToDecl :: NameMap -> GHC.LHsDecl GHC.RdrName -> RefactGhc (GHC.LHsDecl GHC.RdrName)
addParamToDecl nameMap (GHC.L l1 (GHC.ValD (GHC.FunBind lp@(GHC.L l2 pname) i (GHC.MG matches a ptt o) co fvs t)))
| eqRdrNamePure nameMap lp pn
= do
matches' <- mapM addParamtoMatch matches
return (GHC.L l1 (GHC.ValD (GHC.FunBind (GHC.L l2 pname) i (GHC.MG matches' a ptt o) co fvs t)))
where
addParamtoMatch (GHC.L l (GHC.Match fn1 pats mtyp rhs))
= do
rhs' <- addActualParamsToRhs pn paramPNames rhs
pats' <- liftT $ mapM addParam paramPNames
return (GHC.L l (GHC.Match fn1 (pats'++pats) mtyp rhs'))
addParamToDecl _nameMap x@(GHC.L _l1 (GHC.ValD (GHC.PatBind _pat@(GHC.L _l2 (GHC.VarPat _p)) _rhs _ty _fvs _t)))
= return x
addParamToDecl _ x = return x
addParam n = do
newSpan <- uniqueSrcSpanT
let vn = (GHC.L newSpan (pNtoPat n))
addSimpleAnnT vn (DP (0,1)) [((G GHC.AnnVal),DP (0,0))]
return vn
addItemsToExport ::
GHC.ParsedSource
-> Maybe PName
-> Bool
-> Either [String] [GHC.LIE GHC.RdrName]
-> RefactGhc GHC.ParsedSource
addItemsToExport = assert False undefined
addActualParamsToRhs :: (SYB.Data t) =>
GHC.Name -> [GHC.RdrName] -> t -> RefactGhc t
addActualParamsToRhs pn paramPNames rhs = do
logm $ "addActualParamsToRhs:entered:(pn,paramPNames)=" ++ showGhc (pn,paramPNames)
nameMap <- getRefactNameMap
let
worker :: (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.LHsExpr GHC.RdrName)
worker oldExp@(GHC.L l2 (GHC.HsVar pname))
| eqRdrNamePure nameMap (GHC.L l2 pname) pn
= do
logDataWithAnns "addActualParamsToRhs:oldExp=" oldExp
newExp' <- liftT $ foldlM addParamToExp oldExp paramPNames
edp <- liftT $ getEntryDPT oldExp
liftT $ setEntryDPT oldExp (DP (0,0))
l2' <- liftT $ uniqueSrcSpanT
let newExp = (GHC.L l2' (GHC.HsPar newExp'))
liftT $ addSimpleAnnT newExp (DP (0,0)) [(G GHC.AnnOpenP,DP (0,0)),(G GHC.AnnCloseP,DP (0,0))]
liftT $ setEntryDPT newExp edp
return newExp
worker x = return x
addParamToExp :: (GHC.LHsExpr GHC.RdrName) -> GHC.RdrName -> Transform (GHC.LHsExpr GHC.RdrName)
addParamToExp expr param = do
ss1 <- uniqueSrcSpanT
ss2 <- uniqueSrcSpanT
let var = GHC.L ss2 (GHC.HsVar param)
let expr' = GHC.L ss1 (GHC.HsApp expr var)
addSimpleAnnT var (DP (0,0)) [(G GHC.AnnVal,DP (0,1))]
addSimpleAnnT expr' (DP (0,0)) []
return expr'
r <- applyTP (full_buTP (idTP `adhocTP` worker)) rhs
return r
duplicateDecl ::
[GHC.LHsDecl GHC.RdrName]
->GHC.Name
->GHC.Name
->RefactGhc [GHC.LHsDecl GHC.RdrName]
duplicateDecl decls n newFunName
= do
logm $ "duplicateDecl entered:(decls,n,newFunName)=" ++ showGhc (decls,n,newFunName)
nm <- getRefactNameMap
let
declsToDup = definingDeclsRdrNames nm [n] decls True False
funBinding = filter isFunOrPatBindP declsToDup
typeSig = map wrapSig $ definingSigsRdrNames nm [n] decls
funBinding'' <- renamePN n newFunName False funBinding
typeSig'' <- renamePN n newFunName False typeSig
logm $ "duplicateDecl:funBinding''=" ++ showGhc funBinding''
funBinding3 <- mapM (\f@(GHC.L _ fb) -> do
newSpan <- liftT uniqueSrcSpanT
let fb' = GHC.L newSpan fb
liftT $ modifyAnnsT (copyAnn f fb')
return fb'
) (typeSig'' ++ funBinding'')
when (not $ null funBinding3) $ do
liftT $ setEntryDPT (head funBinding3) (DP (2,0))
liftT $ mapM_ (\d -> setEntryDPT d (DP (1,0))) (tail funBinding3)
let (decls1,decls2) = break (definesDeclRdr nm n) decls
(declsToDup',declsRest) = break (not . definesDeclRdr nm n) decls2
return $ decls1 ++ declsToDup' ++ funBinding3 ++ declsRest
divideDecls :: SYB.Data t =>
[t] -> GHC.Located GHC.Name -> RefactGhc ([t], [t], [t])
divideDecls ds (GHC.L _ pnt) = do
nm <- getRefactNameMap
let (before,after) = break (\x -> findNameInRdr nm pnt x) ds
return $ if (not $ emptyList after)
then (before, [ghead "divideDecls" after], gtail "divideDecls" after)
else (ds,[],[])
rmDecl:: (SYB.Data t)
=> GHC.Name
-> Bool
-> t
-> RefactGhc
(t,
GHC.LHsDecl GHC.RdrName,
Maybe (GHC.LSig GHC.RdrName))
rmDecl pn incSig t = do
setStateStorage StorageNone
t' <- everywhereMStaged' SYB.Parser (SYB.mkM inModule
`SYB.extM` inLet
`SYB.extM` inMatch
) t
storage <- getStateStorage
let decl' = case storage of
StorageDeclRdr decl -> decl
x -> error $ "rmDecl: unexpected value in StateStorage:" ++ (show x)
setStateStorage StorageNone
(t'',sig') <- if incSig
then rmTypeSig pn t'
else return (t', Nothing)
return (t'',decl',sig')
where
inModule (p :: GHC.ParsedSource)
= doRmDeclList p
inMatch x@(((GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ _localDecls)))):: (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)))
= doRmDeclList x
inLet :: GHC.LHsExpr GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName)
inLet letExpr@(GHC.L _ (GHC.HsLet _localDecls expr))
= do
isDone <- getDone
if isDone
then return letExpr
else do
nameMap <- getRefactNameMap
decls <- liftT $ hsDecls letExpr
let (decls1,decls2) = break (definesDeclRdr nameMap pn) decls
if not $ emptyList decls2
then do
let decl = ghead "rmDecl" decls2
setStateStorage (StorageDeclRdr decl)
case length decls of
1 -> do
return expr
_ -> do
decls' <- doRmDecl decls1 decls2
letExpr' <- liftT $ replaceDecls letExpr decls'
return letExpr'
else do
return letExpr
inLet x = return x
doRmDeclList parent
= do
isDone <- getDone
if isDone
then return parent
else do
nameMap <- getRefactNameMap
decls <- liftT $ hsDecls parent
let (decls1,decls2) = break (definesDeclRdr nameMap pn) decls
if not $ emptyList decls2
then do
let decl = ghead "doRmDeclList" decls2
setStateStorage (StorageDeclRdr decl)
decls' <- doRmDecl decls1 decls2
parent' <- liftT $ replaceDecls parent decls'
return parent'
else do
return parent
getDone = do
s <- getStateStorage
case s of
StorageNone -> return False
_ -> return True
declsSybTransform :: (SYB.Typeable a)
=> (forall b. HasDecls b => b -> RefactGhc b)
-> a -> RefactGhc a
declsSybTransform transform = mt
where
mt = SYB.mkM inMatch
`SYB.extM` inPatDecl
`SYB.extM` inModule
`SYB.extM` inHsLet
inModule :: GHC.ParsedSource -> RefactGhc GHC.ParsedSource
inModule (modu :: GHC.ParsedSource)
= transform modu
inMatch :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))
inMatch x@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ _localDecls)))
= transform x
inPatDecl ::GHC.LHsDecl GHC.RdrName -> RefactGhc (GHC.LHsDecl GHC.RdrName)
inPatDecl x@(GHC.L _ (GHC.ValD (GHC.PatBind _ _ _ _ _)))
= error $ "declsSybTransform:need to reimplement PatBind case"
inPatDecl x = return x
inHsLet :: GHC.LHsExpr GHC.RdrName -> RefactGhc (GHC.LHsExpr GHC.RdrName)
inHsLet x@(GHC.L _ (GHC.HsLet{}))
= transform x
inHsLet x = return x
doRmDecl :: [GHC.LHsDecl GHC.RdrName] -> [GHC.LHsDecl GHC.RdrName] -> RefactGhc [GHC.LHsDecl GHC.RdrName]
doRmDecl decls1 decls2
= do
let decls2' = gtail "doRmDecl 1" decls2
declToRemove = head decls2
unless (null decls1) $ do liftT $ balanceComments (last decls1) declToRemove
unless (null decls2') $ do liftT $ balanceComments declToRemove (head decls2')
when (not (null decls2') && null decls1) $ do liftT $ transferEntryDPT declToRemove (head decls2')
when (not (null decls2') && not (null decls1) && not (isTypeSigDecl (last decls1)))
$ do liftT $ transferEntryDPT declToRemove (head decls2')
return $ (decls1 ++ decls2')
rmTypeSigs :: (SYB.Data t) =>
[GHC.Name]
-> t
-> RefactGhc (t,[GHC.LSig GHC.RdrName])
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.RdrName))
rmTypeSig pn t
= do
setStateStorage StorageNone
t' <- SYB.everywhereMStaged SYB.Renamer (SYB.mkM inMatch `SYB.extM` inPatDecl `SYB.extM` inModule) t
storage <- getStateStorage
let sig' = case storage of
StorageSigRdr sig -> Just sig
StorageNone -> Nothing
x -> error $ "rmTypeSig: unexpected value in StateStorage:" ++ (show x)
return (t',sig')
where
inModule :: GHC.ParsedSource -> RefactGhc GHC.ParsedSource
inModule (modu :: GHC.ParsedSource)
= doRmTypeSig modu
inMatch :: GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)
-> RefactGhc (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName))
inMatch x@(GHC.L _ (GHC.Match _ _ _ (GHC.GRHSs _ _localDecls)))
= doRmTypeSig x
inPatDecl ::GHC.LHsDecl GHC.RdrName -> RefactGhc (GHC.LHsDecl GHC.RdrName)
inPatDecl x@(GHC.L _ (GHC.ValD (GHC.PatBind _ _ _ _ _))) = do
decls <- liftT $ hsDeclsPatBindD x
decls' <- doRmTypeSigDecls decls
liftT $ replaceDeclsPatBindD x decls'
inPatDecl x = return x
doRmTypeSig :: (HasDecls t) => t -> RefactGhc t
doRmTypeSig parent = do
decls <- liftT $ hsDecls parent
decls' <- doRmTypeSigDecls decls
liftT $ replaceDecls parent decls'
doRmTypeSigDecls :: [GHC.LHsDecl GHC.RdrName] -> RefactGhc [GHC.LHsDecl GHC.RdrName]
doRmTypeSigDecls decls = do
isDone <- getDone
if isDone
then return decls
else do
nameMap <- getRefactNameMap
let (decls1,decls2)= break (definesSigDRdr nameMap pn) decls
if not $ null decls2
then do
let sig@(GHC.L sspan (GHC.SigD (GHC.TypeSig names typ p))) = ghead "rmTypeSig" decls2
if length names > 1
then do
let newNames = filter (\rn -> rdrName2NamePure nameMap rn /= pn) names
newSig = GHC.L sspan (GHC.SigD (GHC.TypeSig newNames typ p))
liftT $ removeTrailingCommaT (glast "doRmTypeSig" newNames)
let pnt = ghead "rmTypeSig" (filter (\rn -> rdrName2NamePure nameMap rn == pn) names)
liftT $ removeTrailingCommaT pnt
newSpan <- liftT uniqueSrcSpanT
let oldSig = (GHC.L newSpan (GHC.TypeSig [pnt] typ p))
liftT $ modifyAnnsT (copyAnn sig oldSig)
setStateStorage (StorageSigRdr oldSig)
return (decls1++[newSig]++gtail "doRmTypeSig" decls2)
else do
let [oldSig] = decl2Sig sig
setStateStorage (StorageSigRdr oldSig)
decls' <- doRmDecl decls1 decls2
return decls'
else do
return decls
getDone = do
s <- getStateStorage
case s of
StorageNone -> return False
_ -> return True
rmQualifier:: (SYB.Data t)
=>[GHC.Name]
->t
->RefactGhc t
rmQualifier pns t = do
nm <- getRefactNameMap
SYB.everywhereM (nameSybTransform (rename nm)) t
where
rename nm (ln@(GHC.L l pn)::GHC.Located GHC.RdrName)
| elem (rdrName2NamePure nm ln) pns
= do
case pn of
GHC.Qual _ n -> return (GHC.L l (GHC.Unqual n))
_ -> return ln
rename _ x = return x
qualifyToplevelName :: GHC.Name -> RefactGhc ()
qualifyToplevelName n = do
parsed <- getRefactParsed
parsed' <- renamePN n n True parsed
putRefactParsed parsed' emptyAnns
return ()
data HowToQual = Qualify | NoQualify | PreserveQualify
deriving (Show,Eq)
renamePN::(SYB.Data t)
=>GHC.Name
->GHC.Name
->Bool
->t
->RefactGhc t
renamePN oldPN newName useQual t = do
nameMap <- getRefactNameMap
newNameQual <- rdrNameFromName True newName
newNameUnqual <- rdrNameFromName False newName
newNameRdr <- rdrNameFromName useQual newName
let
cond :: GHC.Located GHC.RdrName -> Bool
cond (GHC.L ln _) =
case Map.lookup ln nameMap of
Nothing -> False
Just n -> GHC.nameUnique n == GHC.nameUnique oldPN
newNameCalcBool :: Bool -> GHC.RdrName -> GHC.RdrName
newNameCalcBool True n = newNameCalc Qualify n
newNameCalcBool False n = newNameCalc NoQualify n
newNameCalc :: HowToQual -> GHC.RdrName -> GHC.RdrName
newNameCalc uq old = newNameCalc' uq (GHC.isQual_maybe old)
where
newNameCalc' :: HowToQual -> (Maybe (GHC.ModuleName,GHC.OccName)) -> GHC.RdrName
newNameCalc' Qualify (Just (mn,_)) = GHC.Qual mn (GHC.occName newName)
newNameCalc' PreserveQualify (Just (mn,_)) = GHC.Qual mn (GHC.occName newName)
newNameCalc' NoQualify (Just (_n,_)) = GHC.Unqual (GHC.occName newName)
newNameCalc' uq' _ = if uq' == Qualify then newNameQual else newNameUnqual
rename :: Bool -> GHC.Located GHC.RdrName -> Transform (GHC.Located GHC.RdrName)
rename useQual' old@(GHC.L l n)
| cond (GHC.L l n)
= do
logTr $ "renamePN:rename at :" ++ showGhc l
let nn = newNameCalcBool useQual' n
let new = (GHC.L l nn)
modifyAnnsT (replaceAnnKey old new)
return new
rename _ x = return x
renameVar :: Bool -> (GHC.Located (GHC.HsExpr GHC.RdrName)) -> Transform (GHC.Located (GHC.HsExpr GHC.RdrName))
renameVar useQual' (GHC.L l (GHC.HsVar n))
| cond (GHC.L l n)
= do
logTr $ "renamePN:renameVar at :" ++ (showGhc l)
let
nn = if useQual'
then newNameCalcBool useQual' n
else newNameCalc PreserveQualify n
return (GHC.L l (GHC.HsVar nn))
renameVar _ x = return x
renameTyVar :: Bool -> (GHC.Located (GHC.HsType GHC.RdrName)) -> Transform (GHC.Located (GHC.HsType GHC.RdrName))
renameTyVar useQual' (GHC.L l (GHC.HsTyVar n))
| cond (GHC.L l n)
= do
logTr $ "renamePN:renameTyVar at :" ++ (showGhc l)
let nn = newNameCalcBool useQual' n
return (GHC.L l (GHC.HsTyVar nn))
renameTyVar _ x = return x
renameHsTyVarBndr :: Bool -> GHC.LHsTyVarBndr GHC.RdrName -> Transform (GHC.LHsTyVarBndr GHC.RdrName)
renameHsTyVarBndr useQual' (GHC.L l (GHC.UserTyVar n))
| cond (GHC.L l n)
= do
logTr $ "renamePN:renameHsTyVarBndr at :" ++ (showGhc l)
let nn = newNameCalcBool useQual' n
return (GHC.L l (GHC.UserTyVar nn))
renameHsTyVarBndr _ x = return x
renameLIE :: Bool -> (GHC.LIE GHC.RdrName) -> Transform (GHC.LIE GHC.RdrName)
renameLIE useQual' (GHC.L l (GHC.IEVar old@(GHC.L ln n)))
| cond (GHC.L ln n)
= do
let new = newNameCalcBool useQual' n
let newn = (GHC.L ln new)
modifyAnnsT (replaceAnnKey old newn)
return (GHC.L l (GHC.IEVar (GHC.L ln new)))
renameLIE useQual' (GHC.L l (GHC.IEThingAbs old@(GHC.L ln n)))
| cond (GHC.L l n)
= do
let new = newNameCalcBool useQual' n
let newn = (GHC.L ln new)
modifyAnnsT (replaceAnnKey old newn)
return (GHC.L l (GHC.IEThingAbs (GHC.L ln new)))
renameLIE useQual' (GHC.L l (GHC.IEThingAll old@(GHC.L ln n)))
| cond (GHC.L ln n)
= do
let new = newNameCalcBool useQual' n
let newn = (GHC.L ln new)
modifyAnnsT (replaceAnnKey old newn)
return (GHC.L l (GHC.IEThingAll (GHC.L ln new)))
renameLIE useQual' (GHC.L l (GHC.IEThingWith old@(GHC.L ln n) ns))
= do
old' <- if (cond (GHC.L ln n))
then do
logTr $ "renamePN:renameLIE.IEThingWith at :" ++ (showGhc l)
let new = newNameCalcBool useQual' n
let newn = (GHC.L ln new)
modifyAnnsT (replaceAnnKey old newn)
return (GHC.L ln new)
else return old
ns' <- if (any (\(GHC.L lnn nn) -> cond (GHC.L lnn nn)) ns)
then renameTransform useQual' ns
else return ns
return (GHC.L l (GHC.IEThingWith old' ns'))
renameLIE _ x = do
return x
renameLPat :: Bool -> (GHC.LPat GHC.RdrName) -> Transform (GHC.LPat GHC.RdrName)
renameLPat useQual' (GHC.L l (GHC.VarPat n))
| cond (GHC.L l n)
= do
logTr $ "renamePNworker:renameLPat at :" ++ (showGhc l)
let nn = newNameCalcBool useQual' n
return (GHC.L l (GHC.VarPat nn))
renameLPat _ x = return x
renameFunBind :: Bool -> GHC.HsBindLR GHC.RdrName GHC.RdrName -> Transform (GHC.HsBindLR GHC.RdrName GHC.RdrName)
renameFunBind _useQual (GHC.FunBind (GHC.L ln n) fi (GHC.MG matches a typ o) co fvs tick)
| cond (GHC.L ln n)
= do
logTr $ "renamePN.renameFunBind.renameFunBind:starting matches"
let w lmatch@(GHC.L lm (GHC.Match mln pats typ' grhss)) = do
case mln of
Just (old@(GHC.L lmn _),f) -> do
let new = (GHC.L lmn newNameUnqual)
modifyAnnsT (replaceAnnKey old new)
return (GHC.L lm (GHC.Match (Just (new,f)) pats typ' grhss))
Nothing -> return lmatch
matches' <- mapM w matches
logTr $ "renamePN.renameFunBind.renameFunBind.renameFunBind:matches done"
return (GHC.FunBind (GHC.L ln newNameRdr) fi (GHC.MG matches' a typ o) co fvs tick)
renameFunBind _ x = return x
renameImportDecl :: Bool -> (GHC.ImportDecl GHC.RdrName) -> Transform (GHC.ImportDecl GHC.RdrName)
renameImportDecl _useQual (GHC.ImportDecl src mn mq isrc isafe iq ii ma (Just (ij,GHC.L ll ies))) = do
ies' <- mapM (renameLIE False) ies
logTr $ "renamePN'.renameImportDecl:(ies,ies')=" ++ showGhc (ies,ies')
return (GHC.ImportDecl src mn mq isrc isafe iq ii ma (Just (ij,GHC.L ll ies')))
renameImportDecl _ x = return x
renameTypeSig :: Bool -> (GHC.Sig GHC.RdrName) -> Transform (GHC.Sig GHC.RdrName)
renameTypeSig _useQual (GHC.TypeSig ns typ p)
= do
logTr $ "renamePN:renameTypeSig"
ns' <- renameTransform False ns
typ' <- renameTransform False typ
logTr $ "renamePN:renameTypeSig done"
return (GHC.TypeSig ns' typ' p)
renameTypeSig _ x = return x
renameTransform useQual' t' =
(SYB.everywhereM (
SYB.mkM (rename useQual')
`SYB.extM` (renameVar useQual')
`SYB.extM` (renameTyVar useQual')
`SYB.extM` (renameHsTyVarBndr useQual')
`SYB.extM` (renameLIE useQual')
`SYB.extM` (renameLPat useQual')
`SYB.extM` (renameTypeSig useQual')
`SYB.extM` (renameImportDecl useQual')
`SYB.extM` (renameFunBind useQual')
) t')
t' <- liftT (renameTransform useQual t)
return t'
autoRenameLocalVar:: (SYB.Data t)
=> GHC.Name
-> t
-> RefactGhc t
autoRenameLocalVar pn t = do
logm $ "autoRenameLocalVar: (pn)=" ++ (showGhc (pn))
nm <- getRefactNameMap
decls <- liftT $ hsDeclsGeneric t
if isDeclaredInRdr nm pn decls
then do t' <- worker t
return t'
else do return t
where
worker :: (SYB.Data t) => t -> RefactGhc t
worker tt
=do (f,d) <- hsFDNamesFromInsideRdr tt
ds <- hsVisibleNamesRdr pn tt
let newNameStr = mkNewName (nameToString pn) (nub (f `union` d `union` ds)) 1
newName <- mkNewGhcName Nothing newNameStr
renamePN pn newName False tt
isMainModule :: GHC.Module -> Bool
isMainModule modu = GHC.modulePackageKey modu == GHC.mainPackageKey
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 $ SYB.somethingStaged SYB.Parser Nothing
(Nothing `SYB.mkQ` inMatch `SYB.extQ` inDecl) t
where
inMatch ((GHC.FunBind name _ (GHC.MG _matches _ _ _) _ _ _) :: GHC.HsBind GHC.Name)
| isJust (find (sameOccurrence pnt) [name]) = Just True
inMatch _ = Nothing
inDecl ((GHC.TypeSig is _ _) :: GHC.Sig GHC.Name)
|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 _ = []
findNameInRdr :: (SYB.Data t) => NameMap -> GHC.Name -> t -> Bool
findNameInRdr nm pn t =
isJust $ SYB.something (Nothing `SYB.mkQ` worker) t
where
worker (ln :: GHC.Located GHC.RdrName)
| GHC.nameUnique pn == GHC.nameUnique (rdrName2NamePure nm ln) = Just True
worker _ = Nothing
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 . SYB.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 . SYB.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
findNamesRdr :: (SYB.Data t) => NameMap -> [GHC.Name] -> t -> Bool
findNamesRdr nm pns t =
isJust $ SYB.something (inName) t
where
checker :: GHC.Located GHC.RdrName -> Maybe Bool
checker ln
| elem (GHC.nameUnique (rdrName2NamePure nm ln)) uns = Just True
checker _ = Nothing
inName :: (SYB.Typeable a) => a -> Maybe Bool
inName = nameSybQuery checker
uns = map GHC.nameUnique pns
findIdForName :: GHC.Name -> RefactGhc (Maybe GHC.Id)
findIdForName n = do
tm <- getTypecheckedModule
let t = GHC.tm_typechecked_source tm
let r = SYB.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 = SYB.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.LHsExpr GHC.Name -> GHC.Name
expToName (GHC.L _ (GHC.HsVar pnt)) = pnt
expToName (GHC.L _ (GHC.HsPar e)) = expToName e
expToName _ = defaultName
expToNameRdr :: NameMap -> GHC.LHsExpr GHC.RdrName -> Maybe GHC.Name
expToNameRdr nm (GHC.L l (GHC.HsVar pnt)) = Just (rdrName2NamePure nm (GHC.L l pnt))
expToNameRdr nm (GHC.L _ (GHC.HsPar e)) = expToNameRdr nm e
expToNameRdr _ _ = Nothing
nameToString :: GHC.Name -> String
nameToString name = showGhcQual name
patToNameRdr :: NameMap -> GHC.LPat GHC.RdrName -> Maybe GHC.Name
patToNameRdr nm (GHC.L l (GHC.VarPat n)) = Just (rdrName2NamePure nm (GHC.L l n))
patToNameRdr _ _ = Nothing
patToPNT :: GHC.LPat GHC.Name -> Maybe GHC.Name
patToPNT (GHC.L _ (GHC.VarPat n)) = Just n
patToPNT _ = Nothing
pNtoPat :: name -> GHC.Pat name
pNtoPat pname = GHC.VarPat pname