HaRe-0.8.4.0: src/Language/Haskell/Refact/Utils/Variables.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
--------------------------------------------------------------------------------
-- Module : Variables
-- |
--
-- ---------------------------------------------------------------------
module Language.Haskell.Refact.Utils.Variables
(
-- ** Variable analysis
isFieldName
, isClassName
, isInstanceName
, isDeclaredInRdr
, FreeNames(..),DeclaredNames(..)
, hsFreeAndDeclaredRdr
, hsFreeAndDeclaredNameStrings
, hsFreeAndDeclaredPNs
, getDeclaredTypesRdr
, getDeclaredVarsRdr
, hsVisibleNamesRdr, hsVisibleDsRdr
, hsFDsFromInsideRdr, hsFDNamesFromInsideRdr, hsFDNamesFromInsideRdrPure
, rdrName2Name, rdrName2NamePure
, eqRdrNamePure
-- , rdrName2Name'
, sameNameSpace
-- ** Identifiers, expressions, patterns and declarations
, FindEntity(..)
, findNameInRdr
, findNamesRdr
, sameOccurrence
, definedPNsRdr,definedNamesRdr
, definingDeclsRdrNames,definingDeclsRdrNames',definingSigsRdrNames
, definingTyClDeclsNames
, definesRdr,definesDeclRdr,definesNameRdr
, definesTypeSigRdr,definesSigDRdr
, hsTypeVbls
, hsNamessRdr
, findLRdrName
, locToNameRdr, locToNameRdrPure
, locToRdrName
) where
import Control.Monad.State
import Data.List
import Data.Maybe
import Data.Monoid
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.Types
import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.GHC.ExactPrint
import Language.Haskell.GHC.ExactPrint.Utils
-- Modules from GHC
import qualified Bag as GHC
import qualified GHC as GHC
import qualified Name as GHC
-- import qualified Outputable as GHC
import qualified RdrName 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)
-- ---------------------------------------------------------------------
class (SYB.Data a, SYB.Typeable a) => FindEntity a where
-- | Returns True is a syntax phrase, say a, is part of another
-- syntax phrase, say b.
-- NOTE: very important: only do a shallow check
findEntity:: (SYB.Data b) => a -> b -> Bool
-- ---------------------------------------------------------------------
{-# DEPRECATED FindEntity "Can't use Renamed in GHC 8" #-}
instance FindEntity GHC.Name where
findEntity n t = fromMaybe False res
where
res = SYB.somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t
worker (name::GHC.Name)
| n == name = Just True
worker _ = Nothing
-- This instance does not make sense, it will only find the specific RdrName
-- where it was found, not any other instances of it.
instance FindEntity (GHC.Located GHC.RdrName) where
findEntity ln t =
case SYB.something (nameSybQuery checkRdr) t of
Nothing -> False
_ -> True
where
checkRdr :: GHC.Located GHC.RdrName -> Maybe Bool
checkRdr n
| sameOccurrence n ln = Just True
| otherwise = Nothing
-- ---------------------------------------------------------------------
-- TODO: should the location be matched too in this case?
instance FindEntity (GHC.Located GHC.Name) where
findEntity n t = fromMaybe False res
where
res = SYB.somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t
worker (name::GHC.Located GHC.Name)
| n == name = Just True
worker _ = Nothing
-- ---------------------------------------------------------------------
instance FindEntity (GHC.LHsExpr GHC.RdrName) where
findEntity e t = fromMaybe False res
where
res = SYB.something (Nothing `SYB.mkQ` worker) t
worker (expr :: GHC.LHsExpr GHC.RdrName)
| sameOccurrence e expr = Just True
worker _ = Nothing
-- TODO: remove this instance
instance FindEntity (GHC.LHsExpr GHC.Name) where
findEntity e t = fromMaybe False res
where
res = SYB.something (Nothing `SYB.mkQ` worker) t
worker (expr :: GHC.LHsExpr 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 = SYB.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 = SYB.somethingStaged SYB.Renamer Nothing (Nothing `SYB.mkQ` worker) t
worker (decl::(GHC.Located (GHC.HsDecl GHC.Name)))
| sameOccurrence d decl = Just True
worker _ = Nothing
-- ---------------------------------------------------------------------
-- TODO: AZ: pretty sure this can be simplified, depends if we need to
-- manage transformed stuff too though.
-- | Return True if syntax phrases t1 and t2 refer to the same one.
sameOccurrence :: (GHC.Located t) -> (GHC.Located t) -> Bool
sameOccurrence (GHC.L l1 _) (GHC.L l2 _)
= l1 == l2
-- ---------------------------------------------------------------------
-- | For free variables
data FreeNames = FN { fn :: [GHC.Name] }
-- | For declared variables
data DeclaredNames = DN { dn :: [GHC.Name] }
instance Show FreeNames where
show (FN ls) = "FN " ++ showGhcQual ls
instance Show DeclaredNames where
show (DN ls) = "DN " ++ showGhcQual 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 [])
-- ---------------------------------------------------------------------
-- | True if the name is a field name
isFieldName :: GHC.Name -> Bool
isFieldName _n = error "undefined isFieldName"
-- ---------------------------------------------------------------------
-- | True if the name is a field name
isClassName :: GHC.Name -> Bool
isClassName _n = error "undefined isClassName"
-- ---------------------------------------------------------------------
-- | True if the name is a class instance
isInstanceName :: GHC.Name -> Bool
isInstanceName _n = error "undefined isInstanceName"
-- ---------------------------------------------------------------------
-- | Collect those type variables that are declared in a given syntax phrase t. In
-- the returned result, the first list is always be empty.
hsTypeVbls::(SYB.Data t) => t -> ([GHC.RdrName],[GHC.RdrName])
hsTypeVbls =ghead "hsTypeVbls".(applyTU (stop_tdTU (failTU `adhocTU` pnt)))
where
-- pnt (PNT (PN i (UniqueNames.S loc)) (Type _) _) = return ([], [(PN i (UniqueNames.S loc))])
pnt n | GHC.rdrNameSpace n == GHC.tvName = return ([], [n])
pnt _ = mzero
-------------------------------------------------------------------------------
isDeclaredInRdr :: NameMap -> GHC.Name -> [GHC.LHsDecl GHC.RdrName] -> Bool
isDeclaredInRdr nm name decls = nonEmptyList $ definingDeclsRdrNames nm [name] decls False True
-- ---------------------------------------------------------------------
-- |The same as `hsFreeAndDeclaredPNs` except that the returned
-- variables are in the String format.
hsFreeAndDeclaredNameStrings :: (SYB.Data t)
=> t -> RefactGhc ([String],[String])
hsFreeAndDeclaredNameStrings t = do
(f,d) <- hsFreeAndDeclaredPNs t
return ((nub.map showGhc) f, (nub.map showGhc) d)
-- ---------------------------------------------------------------------
-- | Return the free and declared Names in the given syntax fragment. The syntax
-- fragment MUST be parameterised by RdrName, else the empty list will be
-- returned.
hsFreeAndDeclaredPNs :: (SYB.Data t) => t -> RefactGhc ([GHC.Name],[GHC.Name])
hsFreeAndDeclaredPNs t = do
nm <- getRefactNameMap
-- TODO: Change the return type to (FreeNames,DeclaredNames)
let (FN f,DN d) = hsFreeAndDeclaredRdr nm t
return (f,d)
-- ---------------------------------------------------------------------
-- | Collect the free and declared variables (in the GHC.Name format)
-- in a given syntax phrase t. In the result, the first list contains
-- the free variables, and the second list contains the declared
-- variables.
-- Expects ParsedSource
hsFreeAndDeclaredRdr :: (SYB.Data t) => NameMap -> t -> (FreeNames,DeclaredNames)
hsFreeAndDeclaredRdr nm t = res
where
fd = hsFreeAndDeclaredRdr' nm t
(FN f,DN d) = case fd of
Left _err -> mempty
Right v -> v
res = (FN (f \\ d),DN d)
hsFreeAndDeclaredRdr':: (SYB.Data t) => NameMap -> t -> Either String (FreeNames,DeclaredNames)
hsFreeAndDeclaredRdr' nm t = do
(FN f,DN d) <- hsFreeAndDeclared'
-- let (f',d') = ( filter (not . GHC.isTyVarName) $ nub f
-- , filter (not . GHC.isTyVarName) $ nub d)
let (f',d') = ( nub f
, nub d)
return (FN f',DN d')
where
hsFreeAndDeclared' :: Either String (FreeNames,DeclaredNames)
hsFreeAndDeclared' = applyTU (stop_tdTU (failTU
`adhocTU` expr
`adhocTU` pat
`adhocTU` bndrs
`adhocTU` binds
`adhocTU` bindList
`adhocTU` match
`adhocTU` stmtlist
`adhocTU` stmts
`adhocTU` rhs
`adhocTU` ltydecl
`adhocTU` tyvarbndrs
`adhocTU` lhstyvarbndr
#if __GLASGOW_HASKELL__ > 710
`adhocTU` lsigtype
#endif
`adhocTU` sig
`adhocTU` datadefn
`adhocTU` condecl
`adhocTU` condetails
`adhocTU` condeclfield
`adhocTU` hstype
)) t
-- expr --
#if __GLASGOW_HASKELL__ <= 710
expr (GHC.L l (GHC.HsVar n))
#else
expr (GHC.L l (GHC.HsVar (GHC.L _ n)))
#endif
= return (FN [rdrName2NamePure nm (GHC.L l n)],DN [])
#if __GLASGOW_HASKELL__ <= 710
expr (GHC.L _ (GHC.OpApp e1 (GHC.L l (GHC.HsVar n)) _ e2)) = do
#else
expr (GHC.L _ (GHC.OpApp e1 (GHC.L l (GHC.HsVar (GHC.L _ n))) _ e2)) = do
#endif
efed <- hsFreeAndDeclaredRdr' nm [e1,e2]
fd <- addFree (rdrName2NamePure nm (GHC.L l n)) efed
return fd
expr (GHC.L _ ((GHC.HsLam (GHC.MG matches _ _ _))) :: GHC.LHsExpr GHC.RdrName) =
hsFreeAndDeclaredRdr' nm matches
expr (GHC.L _ ((GHC.HsLet decls e)) :: GHC.LHsExpr GHC.RdrName) =
do
(FN df,DN dd) <- hsFreeAndDeclaredRdr' nm decls
(FN ef,_) <- hsFreeAndDeclaredRdr' nm e
return (FN (df `union` (ef \\ dd)),DN [])
#if __GLASGOW_HASKELL__ <= 710
expr (GHC.L _ (GHC.RecordCon ln _ e)) = do
#else
expr (GHC.L _ (GHC.RecordCon ln _ _ e)) = do
#endif
fd <- hsFreeAndDeclaredRdr' nm e
addFree (rdrName2NamePure nm ln) fd --Need Testing
expr (GHC.L _ (GHC.EAsPat ln e)) = do
fd <- (hsFreeAndDeclaredRdr' nm e)
addFree (rdrName2NamePure nm ln) fd
expr _ = mzero
-- rhs --
rhs ((GHC.GRHSs g ds) :: GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName))
= do (FN df,DN dd) <- hsFreeAndDeclaredRdr' nm g
(FN ef,DN ed) <- hsFreeAndDeclaredRdr' nm ds
return (FN $ df ++ ef, DN $ dd ++ ed)
-- pat --
pat :: GHC.LPat GHC.RdrName -> Either String (FreeNames,DeclaredNames)
pat (GHC.L _ (GHC.WildPat _)) = mzero
#if __GLASGOW_HASKELL__ <= 710
pat (GHC.L l (GHC.VarPat n))
#else
pat (GHC.L l (GHC.VarPat (GHC.L _ n)))
#endif
= return (FN [],DN [rdrName2NamePure nm (GHC.L l n)])
pat (GHC.L _ (GHC.AsPat ln p)) = do
(f,DN d) <- hsFreeAndDeclaredRdr' nm p
return (f,DN (rdrName2NamePure nm ln:d))
pat (GHC.L _ (GHC.ParPat p)) = pat p
pat (GHC.L _ (GHC.BangPat p)) = pat p
pat (GHC.L _ (GHC.ListPat ps _ _)) = do
fds <- mapM pat ps
return $ mconcat fds
pat (GHC.L _ (GHC.TuplePat ps _ _)) = do
fds <- mapM pat ps
return $ mconcat fds
pat (GHC.L _ (GHC.PArrPat ps _)) = do
fds <- mapM pat ps
return $ mconcat fds
pat (GHC.L _ (GHC.ConPatIn n det)) = do
(FN f,DN d) <- details det
return $ (FN [rdrName2NamePure nm n],DN d) <> (FN [],DN f)
pat (GHC.L _ (GHC.ViewPat e p _)) = do
fde <- hsFreeAndDeclaredRdr' nm e
fdp <- pat p
return $ fde <> fdp
-- pat (GHC.QuasiQuotePat _)
pat (GHC.L _ (GHC.LitPat _)) = return emptyFD
#if __GLASGOW_HASKELL__ <= 710
pat (GHC.L _ (GHC.NPat _ _ _)) = return emptyFD
pat (GHC.L _ (GHC.NPlusKPat n _ _ _)) = return (FN [],DN [rdrName2NamePure nm n])
#else
pat (GHC.L _ (GHC.NPat _ _ _ _)) = return emptyFD
pat (GHC.L _ (GHC.NPlusKPat n _ _ _ _ _)) = return (FN [],DN [rdrName2NamePure nm n])
#endif
pat (GHC.L _ _p@(GHC.SigPatIn p b)) = do
fdp <- pat p
(FN fb,DN _db) <- hsFreeAndDeclaredRdr' nm b
-- error $ "pat.SigPatIn:(b,fb,db)" ++ showGhc (b,fb,db)
return $ fdp <> (FN fb,DN [])
pat (GHC.L _ (GHC.SigPatOut p _)) = pat p
pat (GHC.L l (GHC.CoPat _ p _)) = pat (GHC.L l p)
pat (GHC.L _ (GHC.LazyPat p)) = pat p
pat (GHC.L _ (GHC.ConPatOut {})) = error $ "hsFreeAndDeclaredRdr'.pat:impossible: ConPatOut"
#if __GLASGOW_HASKELL__ <= 710
pat (GHC.L _ (GHC.SplicePat (GHC.HsSplice _ e))) = hsFreeAndDeclaredRdr' nm e
#else
pat (GHC.L _ (GHC.SplicePat (GHC.HsQuasiQuote {}))) = return (FN [], DN [])
pat (GHC.L _ (GHC.SplicePat (GHC.HsTypedSplice _ e))) = hsFreeAndDeclaredRdr' nm e
pat (GHC.L _ (GHC.SplicePat (GHC.HsUntypedSplice _ e))) = hsFreeAndDeclaredRdr' nm e
#endif
#if __GLASGOW_HASKELL__ <= 710
pat (GHC.L _ (GHC.QuasiQuotePat _)) = return (FN [], DN [])
#endif
-- pat p = error $ "hsFreeAndDeclaredRdr'.pat:unimplemented:" ++ (showGhc p)
-- ---------------------------
details :: GHC.HsConPatDetails GHC.RdrName -> Either String (FreeNames,DeclaredNames)
details (GHC.PrefixCon args) = do
fds <- mapM pat args
return $ mconcat fds
details (GHC.RecCon recf) =
recfields recf
details (GHC.InfixCon arg1 arg2) = do
fds <- mapM pat [arg1,arg2]
return $ mconcat fds
-- Note: this one applies to HsRecFields in LPats
recfields :: (GHC.HsRecFields GHC.RdrName (GHC.LPat GHC.RdrName)) -> Either String (FreeNames,DeclaredNames)
recfields (GHC.HsRecFields fields _) = do
let args = map (\(GHC.L _ (GHC.HsRecField _ arg _)) -> arg) fields
fds <- mapM pat args
return $ mconcat fds
-- -----------------------
#if __GLASGOW_HASKELL__ <= 710
bndrs :: GHC.HsWithBndrs GHC.RdrName (GHC.LHsType GHC.RdrName) -> Either String (FreeNames,DeclaredNames)
bndrs (GHC.HsWB thing _ _ _) = do
(FN ft,DN _dt) <- hsFreeAndDeclaredRdr' nm thing
return (FN ft,DN [])
#else
bndrs :: GHC.LHsSigWcType GHC.RdrName -> Either String (FreeNames,DeclaredNames)
bndrs (GHC.HsIB _ (GHC.HsWC _ _ ty)) = do
(FN ft,DN _dt) <- hsFreeAndDeclaredRdr' nm ty
-- return (FN dt,DN [])
return (FN ft,DN [])
#endif
-- ---------------------------
bindList (ds :: [GHC.LHsBind GHC.RdrName])
=do (FN f,DN d) <- recurseList ds
return (FN (f\\d),DN d)
-- match and patBind, same type--
#if __GLASGOW_HASKELL__ <= 710
binds ((GHC.FunBind ln _ (GHC.MG matches _ _ _) _ _fvs _) :: GHC.HsBind GHC.RdrName)
#else
binds ((GHC.FunBind ln (GHC.MG matches _ _ _) _ _fvs _) :: GHC.HsBind GHC.RdrName)
#endif
= do
(FN pf,_pd) <- hsFreeAndDeclaredRdr' nm matches
let n = rdrName2NamePure nm ln
return (FN (pf \\ [n]) ,DN [n])
-- patBind --
binds (GHC.PatBind pat' prhs _ _ds _) =
do
(FN pf,DN pd) <- hsFreeAndDeclaredRdr' nm pat'
(FN rf,DN rd) <- hsFreeAndDeclaredRdr' nm prhs
return (FN $ pf `union` (rf \\ pd),DN $ pd ++ rd)
binds _ = mzero
match ((GHC.Match _fn pats _mtype mrhs) :: GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName))
= do
(FN pf,DN pd) <- hsFreeAndDeclaredRdr' nm pats
(FN rf,DN rd) <- hsFreeAndDeclaredRdr' nm mrhs
return (FN (pf `union` (rf \\ (pd `union` rd))),DN [])
stmtlist (ds :: [GHC.ExprLStmt GHC.RdrName]) = do
(FN f,DN d) <- recurseList ds
-- unless (null ds) $ do
-- -- error $ "hsFreeAndDeclaredRdr'.stmtlist ds=" ++ showGhc ds
-- error $ "hsFreeAndDeclaredRdr'.stmtlist (f,d)=" ++ showGhc (f,d)
return (FN (f\\d),DN d)
-- stmts --
#if __GLASGOW_HASKELL__ <= 710
stmts ((GHC.BindStmt pat' expre _bindOp _failOp) :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do
#else
stmts ((GHC.BindStmt pat' expre _bindOp _failOp _) :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do
#endif
-- TODO ++AZ++ : Not sure it is meaningful to pull
-- anything out of bindOp/failOp
(FN pf,DN pd) <- hsFreeAndDeclaredRdr' nm pat'
-- error $ "hsFreeAndDeclaredRdr'.stmts.BindStmt (pf,pd)=" ++ showGhc (pf,pd)
(FN ef,_ed) <- hsFreeAndDeclaredRdr' nm expre
let sf1 = []
return (FN $ pf `union` ef `union` (sf1\\pd),DN pd) -- pd) -- Check this
stmts ((GHC.LetStmt binds') :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) =
hsFreeAndDeclaredRdr' nm binds'
stmts _ = mzero
-- tycldecls -----------------
ltydecl :: GHC.TyClDecl GHC.RdrName -> Either String (FreeNames,DeclaredNames)
ltydecl (GHC.FamDecl fd) = hsFreeAndDeclaredRdr' nm fd
ltydecl (GHC.SynDecl ln _bndrs _rhs _fvs)
= return (FN [],DN [rdrName2NamePure nm ln])
#if __GLASGOW_HASKELL__ <= 710
ltydecl (GHC.DataDecl ln tyvars defn _fvs) = do
-- let dds = map (rdrName2NamePure nm) $ concatMap (GHC.con_names . GHC.unLoc) $ GHC.dd_cons defn
#else
ltydecl (GHC.DataDecl ln tyvars defn _c _fvs) = do
#endif
(FN fs,DN dds) <- hsFreeAndDeclaredRdr' nm defn
(FN _ft,DN dt) <- hsFreeAndDeclaredRdr' nm tyvars
return (FN (fs \\ dt),DN (rdrName2NamePure nm ln:dds))
ltydecl (GHC.ClassDecl ctx ln tyvars
_fds sigs meths ats atds _docs _fvs) = do
ct <- hsFreeAndDeclaredRdr' nm ctx
(_,DN tv) <- hsFreeAndDeclaredRdr' nm tyvars
ss <- recurseList sigs
md <- hsFreeAndDeclaredRdr' nm meths
ad <- hsFreeAndDeclaredRdr' nm ats
atd <- hsFreeAndDeclaredRdr' nm atds
let (FN ff,DN df) = ((FN [],DN [rdrName2NamePure nm ln]) <> md <> ad <> atd <> ct <> ss)
return (FN (nub ff \\ tv), DN df)
------------------------------
#if __GLASGOW_HASKELL__ <= 710
tyvarbndrs :: GHC.LHsTyVarBndrs GHC.RdrName -> Either String (FreeNames,DeclaredNames)
tyvarbndrs (GHC.HsQTvs _implicit explicit) = do
recurseList explicit
#else
tyvarbndrs :: GHC.LHsQTyVars GHC.RdrName -> Either String (FreeNames,DeclaredNames)
tyvarbndrs (GHC.HsQTvs _implicit explicit _dependent ) = recurseList explicit
#endif
lhstyvarbndr :: GHC.LHsTyVarBndr GHC.RdrName -> Either String (FreeNames,DeclaredNames)
#if __GLASGOW_HASKELL__ <= 710
lhstyvarbndr (GHC.L l (GHC.UserTyVar n)) = return (FN [], DN [rdrName2NamePure nm (GHC.L l n)])
#else
lhstyvarbndr (GHC.L _ (GHC.UserTyVar ln)) = return (FN [], DN [rdrName2NamePure nm ln])
#endif
lhstyvarbndr (GHC.L _ (GHC.KindedTyVar ln lk)) = do
ks <- hsFreeAndDeclaredRdr' nm lk
return ((FN [], DN [rdrName2NamePure nm ln]) <> ks)
------------------------------
#if __GLASGOW_HASKELL__ > 710
lsigtype :: GHC.LHsSigType GHC.RdrName -> Either String (FreeNames,DeclaredNames)
lsigtype (GHC.HsIB _ typ) = do
hsFreeAndDeclaredRdr' nm typ
#endif
------------------------------
sig :: GHC.Sig GHC.RdrName -> Either String (FreeNames,DeclaredNames)
#if __GLASGOW_HASKELL__ <= 710
sig (GHC.TypeSig lns typ _) = do
#else
sig (GHC.TypeSig lns typ) = do
#endif
(FN ft, dt) <- hsFreeAndDeclaredRdr' nm typ
-- error $ "sig:ft=" ++ (intercalate "," $ map (\n -> showGhc n ++ (occAttributes $ GHC.occName n)) ft)
return ((FN [],DN (map (rdrName2NamePure nm ) lns))
<> (FN (filter (not . GHC.isTyVarName) ft), dt))
#if __GLASGOW_HASKELL__ <= 710
sig (GHC.PatSynSig ln (_ef,GHC.HsQTvs _ns bndrs) ctx1 ctx2 typ) = do
(_, DN bs) <- hsFreeAndDeclaredRdr' nm bndrs
c1s <- hsFreeAndDeclaredRdr' nm ctx1
c2s <- hsFreeAndDeclaredRdr' nm ctx2
ts <- hsFreeAndDeclaredRdr' nm typ
let (FN f,DN d) = c1s <> c2s <> ts
fd = (FN (f \\ bs), DN d )
return ((FN [],DN [rdrName2NamePure nm ln]) <> fd)
#else
sig (GHC.PatSynSig ln typ) = do
ts <- hsFreeAndDeclaredRdr' nm typ
return ((FN [],DN [rdrName2NamePure nm ln]) <> ts)
#endif
#if __GLASGOW_HASKELL__ <= 710
sig (GHC.GenericSig lns typ) = do
#else
sig (GHC.ClassOpSig _ lns typ) = do
#endif
ts <- hsFreeAndDeclaredRdr' nm typ
return ((FN [],DN (map (rdrName2NamePure nm) lns)) <> ts)
sig (GHC.IdSig _ ) = error $ "hsFreeAndDeclaredRdr:IdSig should not occur"
sig (GHC.FixSig fsig) = hsFreeAndDeclaredRdr' nm fsig
sig (GHC.InlineSig ln _) = do
return ((FN [],DN [rdrName2NamePure nm ln]) )
sig (GHC.SpecSig ln typs _) = do
ts <- recurseList typs
return ((FN [rdrName2NamePure nm ln],DN []) <> ts)
sig (GHC.SpecInstSig _ ssig) = hsFreeAndDeclaredRdr' nm ssig
sig (GHC.MinimalSig _ _) = return mempty
------------------------------
datadefn :: GHC.HsDataDefn GHC.RdrName -> Either String (FreeNames,DeclaredNames)
datadefn (GHC.HsDataDefn _ ctxt mtyp mkind cons mderivs) = do
cts <- mapM (hsFreeAndDeclaredRdr' nm) $ GHC.unLoc ctxt
ts <- maybeHelper mtyp
ks <- maybeHelper mkind
cs <- mapM (hsFreeAndDeclaredRdr' nm) cons
ds <- case mderivs of
Nothing -> return (FN [],DN [])
Just (GHC.L _ ds) -> recurseList ds
-- error $ "hit datadefn:[cts,ts,ks,cs,ds]=" ++ show (cts++ [ts,ks,ds] ++ cs)
return $ mconcat [mconcat cts,ts,ks,mconcat cs,ds]
------------------------------
condecl :: GHC.LConDecl GHC.RdrName -> Either String (FreeNames,DeclaredNames)
#if __GLASGOW_HASKELL__ <= 710
condecl (GHC.L _ (GHC.ConDecl ns _expr (GHC.HsQTvs _ns bndrs) ctxt
dets res _ depc_syntax)) =
case res of
GHC.ResTyGADT ls typ -> do
(ft,_) <- hsFreeAndDeclaredRdr' nm typ
return (ft,DN (map (rdrName2NamePure nm) ns))
GHC.ResTyH98 -> do
cs <- hsFreeAndDeclaredRdr' nm ctxt
ds <- hsFreeAndDeclaredRdr' nm dets
return ((FN [], DN (map (rdrName2NamePure nm) ns)) <> cs <> ds)
#else
condecl (GHC.L _ (GHC.ConDeclGADT ns typ _)) = do
(ft,_) <- hsFreeAndDeclaredRdr' nm typ
return (ft,DN (map (rdrName2NamePure nm) ns))
condecl (GHC.L _ (GHC.ConDeclH98 n _ mctxt dets _)) = do
cs <- maybeHelper mctxt
ds <- hsFreeAndDeclaredRdr' nm dets
return ((FN [], DN ([rdrName2NamePure nm n])) <> cs <> ds)
#endif
------------------------------
-- condetails :: GHC.HsConDetails (GHC.LBangType GHC.RdrName) (GHC.Located [GHC.LConDeclField GHC.RdrName])
condetails :: GHC.HsConDeclDetails GHC.RdrName -> Either String (FreeNames,DeclaredNames)
condetails (GHC.PrefixCon args) = do
-- TODO: get rid of the tyvars
(FN fs,d) <- recurseList args
return (FN (filter (not . GHC.isTyVarName) fs),d)
condetails (GHC.RecCon (GHC.L _ fs)) = recurseList fs
condetails (GHC.InfixCon a1 a2) = do
-- TODO: get rid of the tyvars
(FN fs,d) <- recurseList [a1,a2]
return (FN (filter (not . GHC.isTyVarName) fs),d)
------------------------------
condeclfield :: GHC.LConDeclField GHC.RdrName -> Either String (FreeNames,DeclaredNames)
condeclfield (GHC.L _ (GHC.ConDeclField fns typ _)) = do
#if __GLASGOW_HASKELL__ <= 710
let ns = fns
#else
let ns = map (GHC.rdrNameFieldOcc . GHC.unLoc) fns
#endif
dt <- hsFreeAndDeclaredRdr' nm typ
return ((FN [],DN (map (rdrName2NamePure nm) ns)) <> dt)
------------------------------
hstype :: GHC.LHsType GHC.RdrName -> Either String (FreeNames,DeclaredNames)
#if __GLASGOW_HASKELL__ <= 710
hstype (GHC.L _ (GHC.HsForAllTy _ _ _ _ typ)) = hsFreeAndDeclaredRdr' nm typ
#else
hstype (GHC.L _ (GHC.HsForAllTy _ typ)) = hsFreeAndDeclaredRdr' nm typ
#endif
#if __GLASGOW_HASKELL__ <= 710
hstype (GHC.L l (GHC.HsTyVar n)) = return (FN [rdrName2NamePure nm (GHC.L l n)],DN [])
#else
hstype (GHC.L _ (GHC.HsTyVar n)) = return (FN [rdrName2NamePure nm n],DN [])
#endif
hstype (GHC.L _ (GHC.HsAppTy t1 t2)) = recurseList [t1,t2]
hstype (GHC.L _ (GHC.HsFunTy t1 t2)) = recurseList [t1,t2]
hstype (GHC.L _ (GHC.HsListTy typ)) = hsFreeAndDeclaredRdr' nm typ
hstype (GHC.L _ (GHC.HsPArrTy typ)) = hsFreeAndDeclaredRdr' nm typ
hstype (GHC.L _ (GHC.HsTupleTy _ typs)) = recurseList typs
hstype (GHC.L _ (GHC.HsOpTy t1 _ t2)) = recurseList [t1,t2]
hstype (GHC.L _ (GHC.HsParTy typ)) = hsFreeAndDeclaredRdr' nm typ
hstype (GHC.L _ (GHC.HsIParamTy _ typ)) = hsFreeAndDeclaredRdr' nm typ
hstype (GHC.L _ (GHC.HsEqTy t1 t2)) = recurseList [t1,t2]
hstype (GHC.L _ (GHC.HsKindSig t1 t2)) = recurseList [t1,t2]
#if __GLASGOW_HASKELL__ <= 710
hstype (GHC.L _ (GHC.HsQuasiQuoteTy _)) = return emptyFD
#endif
hstype (GHC.L _ (GHC.HsSpliceTy _ _)) = return (FN [],DN [])
hstype (GHC.L _ (GHC.HsDocTy _ typ)) = hsFreeAndDeclaredRdr' nm typ
hstype (GHC.L _ (GHC.HsBangTy _ typ)) = hsFreeAndDeclaredRdr' nm typ
hstype (GHC.L _ (GHC.HsRecTy cons)) = recurseList cons
hstype (GHC.L _ (GHC.HsCoreTy _)) = return emptyFD
hstype (GHC.L _ (GHC.HsExplicitListTy _ typs)) = recurseList typs
hstype (GHC.L _ (GHC.HsExplicitTupleTy _ typs)) = recurseList typs
hstype (GHC.L _ (GHC.HsTyLit _)) = return emptyFD
#if __GLASGOW_HASKELL__ <= 710
hstype (GHC.L _ (GHC.HsWrapTy _ typ)) = hsFreeAndDeclaredRdr' nm typ
#endif
#if __GLASGOW_HASKELL__ <= 710
hstype (GHC.L _ (GHC.HsWildcardTy)) = return (FN [],DN [])
hstype (GHC.L l (GHC.HsNamedWildcardTy n)) = return (FN [rdrName2NamePure nm (GHC.L l n)],DN [])
#else
hstype (GHC.L _ (GHC.HsWildCardTy _)) = return (FN [],DN [])
#endif
#if __GLASGOW_HASKELL__ > 710
hstype (GHC.L _ (GHC.HsQualTy (GHC.L _ ctxt) ty)) = recurseList (ty:ctxt)
hstype (GHC.L _ (GHC.HsAppsTy as)) = do
fds <- mapM doApp as
return $ mconcat fds
where
doApp (GHC.L _ (GHC.HsAppInfix n)) = return (FN [rdrName2NamePure nm n],DN [])
doApp (GHC.L _ (GHC.HsAppPrefix ty)) = hstype ty
#endif
-- ---------------------------------
recurseList xs = do
fds <- mapM (hsFreeAndDeclaredRdr' nm) xs
return $ mconcat fds
maybeHelper mv = case mv of
Nothing -> return (FN [], DN [])
Just v -> hsFreeAndDeclaredRdr' nm v
------------------------------
addFree :: GHC.Name -> (FreeNames,DeclaredNames)
-> Either String (FreeNames,DeclaredNames)
addFree free (FN fr,de) = return (FN $ [free] `union` fr, de)
-- ---------------------------------------------------------------------
-- |Get the names of all types declared in the given declaration
-- getDeclaredTypesRdr :: GHC.LTyClDecl GHC.RdrName -> RefactGhc [GHC.Name]
getDeclaredTypesRdr :: GHC.LHsDecl GHC.RdrName -> RefactGhc [GHC.Name]
getDeclaredTypesRdr (GHC.L _ (GHC.TyClD decl)) = do
nm <- getRefactNameMap
case decl of
#if __GLASGOW_HASKELL__ <= 710
(GHC.FamDecl (GHC.FamilyDecl _ ln _ _)) -> return [rdrName2NamePure nm ln]
#else
(GHC.FamDecl (GHC.FamilyDecl _ ln _ _ _)) -> return [rdrName2NamePure nm ln]
#endif
(GHC.SynDecl ln _ _ _) -> return [rdrName2NamePure nm ln]
#if __GLASGOW_HASKELL__ <= 710
(GHC.DataDecl ln _ defn _) -> do
let dds = concatMap (GHC.con_names . GHC.unLoc) $ GHC.dd_cons defn
#else
(GHC.DataDecl ln _ defn _ _) -> do
let dds = concatMap (GHC.getConNames . GHC.unLoc) $ GHC.dd_cons defn
#endif
let ddns = map (rdrName2NamePure nm) dds
return $ [rdrName2NamePure nm ln] ++ ddns
(GHC.ClassDecl _ ln _vars _fds sigs meths ats _atdefs _ _fvs) -> do
-- msn <- getMsn meths
let msn = getDeclaredVarsRdr nm (map wrapDecl $ GHC.bagToList meths)
let fds = map (GHC.fdLName . GHC.unLoc) ats
fds' = map (rdrName2NamePure nm) fds
return $ nub $ [rdrName2NamePure nm ln] ++ ssn ++ msn ++ fds' -- ++ asn
where
getLSig :: GHC.LSig GHC.RdrName -> [GHC.Name]
#if __GLASGOW_HASKELL__ <= 710
getLSig (GHC.L _ (GHC.TypeSig ns _ _)) = map (rdrName2NamePure nm) ns
#else
getLSig (GHC.L _ (GHC.TypeSig ns _)) = map (rdrName2NamePure nm) ns
#endif
#if __GLASGOW_HASKELL__ <= 710
getLSig (GHC.L _ (GHC.GenericSig ns _)) = map (rdrName2NamePure nm) ns
#else
getLSig (GHC.L _ (GHC.ClassOpSig _ ns _)) = map (rdrName2NamePure nm) ns
#endif
getLSig (GHC.L _ (GHC.IdSig _n)) = []
getLSig (GHC.L _ (GHC.InlineSig ln2 _)) = [rdrName2NamePure nm ln2]
getLSig (GHC.L _ (GHC.SpecSig ln2 _ _)) = [rdrName2NamePure nm ln2]
getLSig (GHC.L _ (GHC.SpecInstSig _ _)) = []
getLSig (GHC.L _ (GHC.FixSig _)) = []
#if __GLASGOW_HASKELL__ <= 710
getLSig (GHC.L _ (GHC.PatSynSig _ _ _ _ _)) = error "To implement: getLSig PatSynSig"
#else
getLSig (GHC.L _ (GHC.PatSynSig _ _)) = error "To implement: getLSig PatSynSig"
#endif
getLSig (GHC.L _ (GHC.MinimalSig _ _)) = error "To implement: getLSig PatSynSig"
ssn = concatMap getLSig sigs
getDeclaredTypesRdr _ = return []
-- ---------------------------------------------------------------------
-- | Return True if the specified Name ocuurs in the given syntax phrase.
findNameInRdr :: (SYB.Data t) => NameMap -> GHC.Name -> t -> Bool
findNameInRdr nm pn t = findNamesRdr nm [pn] t
-- ---------------------------------------------------------------------
-- | Return True if any of the specified PNames ocuur in the given syntax phrase.
findNamesRdr :: (SYB.Data t) => NameMap -> [GHC.Name] -> t -> Bool
findNamesRdr nm pns t =
isJust $ SYB.something (inName) t
where
-- r = (SYB.everythingStaged SYB.Parser mappend mempty (inName) t)
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
-- ---------------------------------------------------------------------
definedPNsRdr :: GHC.LHsDecl GHC.RdrName -> [GHC.Located GHC.RdrName]
#if __GLASGOW_HASKELL__ <= 710
definedPNsRdr (GHC.L _ (GHC.ValD (GHC.FunBind pname _ _ _ _ _))) = [pname]
#else
definedPNsRdr (GHC.L _ (GHC.ValD (GHC.FunBind pname _ _ _ _))) = [pname]
#endif
definedPNsRdr (GHC.L _ (GHC.ValD (GHC.PatBind p _rhs _ty _fvs _))) = (hsNamessRdr p)
-- VarBind will never occur in ParsedSource
-- TODO: what about GHC.AbsBinds?
definedPNsRdr _ = []
-- ---------------------------------------------------------------------
definedNamesRdr :: NameMap -> GHC.LHsDecl GHC.RdrName -> [GHC.Name]
definedNamesRdr nameMap bind = map (rdrName2NamePure nameMap) (definedPNsRdr bind)
-- ---------------------------------------------------------------------
-- |Find those declarations(function\/pattern binding) which define
-- the specified GHC.Names. incTypeSig indicates whether the
-- corresponding type signature will be included.
definingDeclsRdrNames ::
NameMap
-> [GHC.Name] -- ^ The specified identifiers.
-> [GHC.LHsDecl GHC.RdrName] -- ^ A collection of declarations.
-> Bool -- ^ True means to include the type signature.
-> Bool -- ^ True means to look at the local declarations as well.
-> [GHC.LHsDecl GHC.RdrName] -- ^ The result.
definingDeclsRdrNames nameMap pns ds incTypeSig recursive = concatMap defining ds
-- TODO: Maybe Use hsFreeAndDeclaredRdr to see what is declared in a decl. Recursive?
where
defining decl
= if recursive
then SYB.everything (++) ([] `SYB.mkQ` definesDecl `SYB.extQ` definesBind) decl
else definesDecl decl
where
definesDecl :: (GHC.LHsDecl GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName]
#if __GLASGOW_HASKELL__ <= 710
definesDecl decl'@(GHC.L _ (GHC.ValD (GHC.FunBind _ _ _ _ _ _)))
#else
definesDecl decl'@(GHC.L _ (GHC.ValD (GHC.FunBind _ _ _ _ _)))
#endif
| any (\n -> definesDeclRdr nameMap n decl') pns = [decl']
definesDecl decl'@(GHC.L _l (GHC.ValD (GHC.PatBind _p _rhs _ty _fvs _)))
| any (\n -> definesDeclRdr nameMap n decl') pns = [decl']
definesDecl decl'@(GHC.L _l (GHC.TyClD _))
| any (\n -> definesNameRdr nameMap n decl') pns = [decl']
definesDecl decl'@(GHC.L _l (GHC.SigD _))
| incTypeSig && any (\n -> definesNameRdr nameMap n decl') pns = [decl']
definesDecl _ = []
definesBind :: (GHC.LHsBind GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName]
definesBind (GHC.L l b) = definesDecl (GHC.L l (GHC.ValD b))
-- ---------------------------------------------------------------------
-- |Find those declarations(function\/pattern binding) which define
-- the specified GHC.Names. incTypeSig indicates whether the corresponding type
-- signature will be included.
definingDeclsRdrNames' :: (SYB.Data t)
=> NameMap
-> [GHC.Name] -- ^ The specified identifiers.
-> t -- ^ A collection of declarations.
-> [GHC.LHsDecl GHC.RdrName] -- ^ The result.
definingDeclsRdrNames' nameMap pns ds = defining ds
where
defining decl
= SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` defines' `SYB.extQ` definesBind) decl
where
defines' :: (GHC.LHsDecl GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName]
defines' decl'@(GHC.L _ (GHC.ValD (GHC.FunBind{})))
| any (\n -> definesDeclRdr nameMap n decl') pns = [decl']
defines' decl'@(GHC.L _l (GHC.ValD (GHC.PatBind _p _rhs _ty _fvs _)))
| any (\n -> definesDeclRdr nameMap n decl') pns = [decl']
defines' decl'@(GHC.L _l (GHC.TyClD _))
| any (\n -> definesDeclRdr nameMap n decl') pns = [decl']
defines' _ = []
definesBind :: (GHC.LHsBind GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName]
definesBind (GHC.L l b) = defines' (GHC.L l (GHC.ValD b))
-- ---------------------------------------------------------------------
-- |Find those type signatures for the specified GHC.Names.
definingSigsRdrNames :: (SYB.Data t) =>
NameMap
->[GHC.Name] -- ^ The specified identifiers.
->t -- ^ A collection of declarations.
->[GHC.LSig GHC.RdrName] -- ^ The result.
definingSigsRdrNames nameMap pns ds = def ds
where
def decl
-- = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` inSig) decl
= SYB.everything (++) ([] `SYB.mkQ` inSig `SYB.extQ` inSigDecl) decl
where
inSigDecl :: GHC.LHsDecl GHC.RdrName -> [GHC.LSig GHC.RdrName]
inSigDecl (GHC.L l (GHC.SigD s)) = inSig (GHC.L l s)
inSigDecl _ = []
inSig :: (GHC.LSig GHC.RdrName) -> [GHC.LSig GHC.RdrName]
#if __GLASGOW_HASKELL__ <= 710
inSig (GHC.L l (GHC.TypeSig ns t p))
| defines' ns /= [] = [(GHC.L l (GHC.TypeSig (defines' ns) t p))]
#else
inSig (GHC.L l (GHC.TypeSig ns t))
| defines' ns /= [] = [(GHC.L l (GHC.TypeSig (defines' ns) t))]
#endif
inSig _ = []
defines' :: [GHC.Located GHC.RdrName] -> [GHC.Located GHC.RdrName]
defines' p
-- = filter (\(GHC.L _ n) -> n `elem` pns) p
= let
isDefined :: GHC.Located GHC.RdrName -> [GHC.Located GHC.RdrName]
isDefined ln = if (rdrName2NamePure nameMap ln) `elem` pns
then [ln]
else []
in concatMap isDefined p
-- ---------------------------------------------------------------------
-- |Find those declarations which define the specified GHC.Names.
definingTyClDeclsNames:: (SYB.Data t)
=> NameMap
-> [GHC.Name] -- ^ The specified identifiers.
-> t -- ^ A collection of declarations.
-> [GHC.LTyClDecl GHC.RdrName] -- ^ The result.
definingTyClDeclsNames nm pns t = defining t
where
defining decl
= SYB.everythingStaged SYB.Parser (++) []
([] `SYB.mkQ` defines'
`SYB.extQ` definesDecl) decl
where
defines' :: (GHC.LTyClDecl GHC.RdrName) -> [GHC.LTyClDecl GHC.RdrName]
#if __GLASGOW_HASKELL__ <= 710
defines' decl'@(GHC.L _ (GHC.FamDecl (GHC.FamilyDecl _ pname _ _)))
#else
defines' decl'@(GHC.L _ (GHC.FamDecl (GHC.FamilyDecl _ pname _ _ _)))
#endif
| elem (GHC.nameUnique $ rdrName2NamePure nm pname) uns = [decl']
| otherwise = []
defines' decl'@(GHC.L _ (GHC.SynDecl pname _ _ _))
| elem (GHC.nameUnique $ rdrName2NamePure nm pname) uns = [decl']
| otherwise = []
#if __GLASGOW_HASKELL__ <= 710
defines' decl'@(GHC.L _ (GHC.DataDecl _ _ _ _))
#else
defines' decl'@(GHC.L _ (GHC.DataDecl _ _ _ _ _))
#endif
-- elem (GHC.nameUnique $ rdrName2NamePure nm pname) uns = [decl']
| not $ null (dus `intersect` uns) = [decl']
| otherwise = []
where
(_,DN ds) = hsFreeAndDeclaredRdr nm decl'
dus = map GHC.nameUnique ds
defines' decl'@(GHC.L _ (GHC.ClassDecl _ pname _ _ _ _ _ _ _ _))
| elem (GHC.nameUnique $ rdrName2NamePure nm pname) uns = [decl']
| otherwise = []
definesDecl (GHC.L l (GHC.TyClD d)) = defines' (GHC.L l d)
definesDecl _ = []
uns = map (\n -> GHC.nameUnique n) pns
-- ---------------------------------------------------------------------
-- | Return True if the function\/pattern binding defines the
-- specified identifier.
definesRdr :: NameMap -> GHC.Name -> GHC.LHsBind GHC.RdrName -> Bool
#if __GLASGOW_HASKELL__ <= 710
definesRdr nm nin (GHC.L _ (GHC.FunBind ln _ _ _ _ _))
#else
definesRdr nm nin (GHC.L _ (GHC.FunBind ln _ _ _ _))
#endif
= GHC.nameUnique (rdrName2NamePure nm ln) == GHC.nameUnique nin
definesRdr nm n (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _))
= elem n (map (rdrName2NamePure nm) (hsNamessRdr p))
definesRdr _ _ _= False
-- |Unwraps a LHsDecl and calls definesRdr on the result if a HsBind or calls clsDeclDefinesRdr if a TyClD
definesDeclRdr :: NameMap -> GHC.Name -> GHC.LHsDecl GHC.RdrName -> Bool
definesDeclRdr nameMap nin (GHC.L l (GHC.ValD d)) = definesRdr nameMap nin (GHC.L l d)
definesDeclRdr nameMap nin (GHC.L _ (GHC.TyClD ty)) = clsDeclDefinesRdr nameMap nin ty
definesDeclRdr _ _ _ = False
-- | Return True of the type class declaration defines the
-- specified identifier
clsDeclDefinesRdr :: NameMap -> GHC.Name -> GHC.TyClDecl GHC.RdrName -> Bool
clsDeclDefinesRdr nameMap nin (GHC.SynDecl (GHC.L ln _nm) _ty _rhs _) =
case Map.lookup ln nameMap of
Nothing -> False
Just n -> GHC.nameUnique n == GHC.nameUnique nin
clsDeclDefinesRdr _ _ _ = False
-- | Returns True if the provided Name is defined in the LHsDecl
definesNameRdr :: NameMap -> GHC.Name -> GHC.LHsDecl GHC.RdrName -> Bool
definesNameRdr nameMap nin (GHC.L l (GHC.ValD d)) = definesRdr nameMap nin (GHC.L l d)
definesNameRdr nameMap nin d = nin `elem` declared
where
(_,DN declared) = hsFreeAndDeclaredRdr nameMap d
-- definesDeclRdr _ _ _ = False
-- ---------------------------------------------------------------------
-- | Return True if the declaration defines the type signature of the
-- specified identifier.
definesTypeSigRdr :: NameMap -> GHC.Name -> GHC.Sig GHC.RdrName -> Bool
#if __GLASGOW_HASKELL__ <= 710
definesTypeSigRdr nameMap pn (GHC.TypeSig names _typ _)
#else
definesTypeSigRdr nameMap pn (GHC.TypeSig names _typ)
#endif
= elem (GHC.nameUnique pn) (map (GHC.nameUnique . rdrName2NamePure nameMap) names)
-- definesTypeSigRdr _ _ _ = False
definesTypeSigRdr _ _ x = error $ "definesTypeSigRdr : got " ++ SYB.showData SYB.Parser 0 x
-- |Unwraps a LHsDecl and calls definesRdr on the result if a Sig
definesSigDRdr :: NameMap -> GHC.Name -> GHC.LHsDecl GHC.RdrName -> Bool
definesSigDRdr nameMap nin (GHC.L _ (GHC.SigD d)) = definesTypeSigRdr nameMap nin d
definesSigDRdr _ _ _ = False
-- ---------------------------------------------------------------------
-- |Get all the names in the given syntax element
hsNamessRdr :: (SYB.Data t) => t -> [GHC.Located GHC.RdrName]
hsNamessRdr t = nub $ fromMaybe [] r
where
r = (SYB.everythingStaged SYB.Parser mappend mempty (inName) t)
checker :: GHC.Located GHC.RdrName -> Maybe [GHC.Located GHC.RdrName]
checker x = Just [x]
inName :: (SYB.Typeable a) => a -> Maybe [GHC.Located GHC.RdrName]
inName = nameSybQuery checker
-- ---------------------------------------------------------------------
-- |Does the given 'GHC.Name' appear as a 'GHC.Located' 'GHC.RdrName' anywhere in 't'?
findLRdrName :: (SYB.Data t) => NameMap -> GHC.Name -> t -> Bool
findLRdrName nm n t = isJust $ SYB.something isMatch t
where
checker :: GHC.Located GHC.RdrName -> Maybe Bool
checker x
| GHC.nameUnique (rdrName2NamePure nm x) == GHC.nameUnique n = Just True
| otherwise = Nothing
isMatch :: (SYB.Typeable a) => a -> Maybe Bool
isMatch = nameSybQuery checker
-- ---------------------------------------------------------------------
getDeclaredVarsRdr :: NameMap -> [GHC.LHsDecl GHC.RdrName] -> [GHC.Name]
getDeclaredVarsRdr nm bs = concatMap vars bs
where
vars :: (GHC.LHsDecl GHC.RdrName) -> [GHC.Name]
#if __GLASGOW_HASKELL__ <= 710
vars (GHC.L _ (GHC.ValD (GHC.FunBind ln _ _ _ _fvs _))) = [rdrName2NamePure nm ln]
#else
vars (GHC.L _ (GHC.ValD (GHC.FunBind ln _ _ _ _fvs))) = [rdrName2NamePure nm ln]
#endif
vars (GHC.L _ (GHC.ValD (GHC.PatBind p _rhs _ty _fvs _))) = (map (rdrName2NamePure nm) $ hsNamessRdr p)
vars _ = []
--------------------------------------------------------------------------------
-- | Same as `hsVisiblePNsRdr' except that the returned identifiers are
-- in String format.
hsVisibleNamesRdr:: (SYB.Data t2)
=> GHC.Name -> t2 -> RefactGhc [String]
hsVisibleNamesRdr e t = do
nm <- getRefactNameMap
(DN d) <- hsVisibleDsRdr nm e t
return ((nub . map showGhc) d)
------------------------------------------------------------------------
-- | Given a 'Name' n and a syntax phrase t, if n occurs in t, then return those
-- variables which are declared in t and accessible to n, otherwise
-- return [].
hsVisibleDsRdr :: (SYB.Data t)
=> NameMap -> GHC.Name -> t -> RefactGhc DeclaredNames
-- TODO: DeclaredNames is probably the wrong type. Perhaps create VisibleNames
-- And perhaps use a NameSet or Set, to avoid the nub call
hsVisibleDsRdr nm e t = do
-- logm $ "hsVisibleDsRdr:(e,t)=" ++ (SYB.showData SYB.Renamer 0 (e,t))
(DN d) <- res
return (DN (nub d))
where
-- TODO: this is effectively a recursive descent approach, where
-- each syntax element processor knows exactly what it needs
-- in terms of sub-elements. Hence as an optimisation,
-- consider calling the relevent element directly, instead
-- of looping back into the main function.
-- OR, use a more effective recursion scheme
res = (const err -- (DN [])
`SYB.extQ` parsed
`SYB.extQ` lvalbinds
`SYB.extQ` valbinds
`SYB.extQ` lhsdecls
`SYB.extQ` lhsdecl
`SYB.extQ` lhsbindslr
`SYB.extQ` hsbinds
`SYB.extQ` hsbind
`SYB.extQ` hslocalbinds
`SYB.extQ` lmatch
`SYB.extQ` match
`SYB.extQ` grhss
`SYB.extQ` lgrhs
`SYB.extQ` lexpr
`SYB.extQ` tyclgroups
`SYB.extQ` tyclgroup
`SYB.extQ` tycldeclss
`SYB.extQ` tycldecls
`SYB.extQ` ltycldecl
`SYB.extQ` tycldecl
`SYB.extQ` hsdatadefn
`SYB.extQ` condecl
`SYB.extQ` instdecls
`SYB.extQ` instdecl
`SYB.extQ` lhstype
`SYB.extQ` lsigs
`SYB.extQ` lsig
`SYB.extQ` lstmts
`SYB.extQ` lstmt
`SYB.extQ` lpats
`SYB.extQ` lpat
#if __GLASGOW_HASKELL__ > 710
`SYB.extQ` ibndrs
`SYB.extQ` lsigty
#endif
`SYB.extQ` lanndecl
) t
-- err2 = error $ "hsVisibleDsRdr:err2:no match for:" ++ (SYB.showData SYB.Renamer 0 t)
parsed :: GHC.ParsedSource -> RefactGhc DeclaredNames
parsed p
| findNameInRdr nm e p = do
-- dfds <- mapM (hsVisibleDsRdr nm e) $ GHC.hsmodDecls $ GHC.unLoc p
-- logm $ "hsVisibleDsRdr parsedSource:decls starting"
dfds <- mapM (declFun ( hsVisibleDsRdr nm e) ) $ GHC.hsmodDecls $ GHC.unLoc p
-- logm $ "hsVisibleDsRdr parsedSource:decls done"
return $ mconcat dfds
parsed _ = return (DN [])
lvalbinds :: (GHC.Located (GHC.HsLocalBinds GHC.RdrName)) -> RefactGhc DeclaredNames
lvalbinds (GHC.L _ (GHC.HsValBinds vb)) = valbinds vb
lvalbinds (GHC.L _ (GHC.HsIPBinds _)) = return (DN [])
lvalbinds (GHC.L _ GHC.EmptyLocalBinds) = return (DN [])
valbinds :: (GHC.HsValBinds GHC.RdrName) -> RefactGhc DeclaredNames
valbinds vb@(GHC.ValBindsIn bindsBag sigs)
| findNameInRdr nm e vb = do
fdsb <- mapM (hsVisibleDsRdr nm e) $ GHC.bagToList bindsBag
fdss <- mapM (hsVisibleDsRdr nm e) sigs
return $ mconcat fdss <> mconcat fdsb
valbinds vb@(GHC.ValBindsOut _binds _sigs)
| findNameInRdr nm e vb = do
-- logm $ "hsVisibleDsRdr valbinds:ValBindsOut:impossible for RdrName"
return (DN [])
valbinds _ = do
-- logm $ "hsVisibleDsRdr nm.valbinds:not matched"
return (DN [])
lhsdecls :: [GHC.LHsDecl GHC.RdrName] -> RefactGhc DeclaredNames
lhsdecls ds
| findNameInRdr nm e ds = do
dfds <- mapM (declFun ( hsVisibleDsRdr nm e) ) ds
return $ mconcat dfds
lhsdecls _ = return (DN [])
lhsdecl :: GHC.LHsDecl GHC.RdrName -> RefactGhc DeclaredNames
lhsdecl (GHC.L l dd) = do
-- logm $ "hsVisibleDsRdr.lhsdecl"
case dd of
GHC.TyClD d -> hsVisibleDsRdr nm e (GHC.L l d)
GHC.InstD d -> hsVisibleDsRdr nm e (GHC.L l d)
GHC.DerivD d -> hsVisibleDsRdr nm e (GHC.L l d)
GHC.ValD d -> hsVisibleDsRdr nm e (GHC.L l d)
GHC.SigD d -> hsVisibleDsRdr nm e (GHC.L l d)
GHC.DefD d -> hsVisibleDsRdr nm e (GHC.L l d)
GHC.ForD d -> hsVisibleDsRdr nm e (GHC.L l d)
GHC.WarningD d -> hsVisibleDsRdr nm e (GHC.L l d)
GHC.AnnD d -> hsVisibleDsRdr nm e (GHC.L l d)
GHC.RuleD d -> hsVisibleDsRdr nm e (GHC.L l d)
GHC.VectD d -> hsVisibleDsRdr nm e (GHC.L l d)
GHC.SpliceD d -> hsVisibleDsRdr nm e (GHC.L l d)
GHC.DocD d -> hsVisibleDsRdr nm e (GHC.L l d)
GHC.RoleAnnotD d -> hsVisibleDsRdr nm e (GHC.L l d)
#if __GLASGOW_HASKELL__ < 711
GHC.QuasiQuoteD d -> hsVisibleDsRdr nm e (GHC.L l d)
#endif
lhsbindslr :: GHC.LHsBinds GHC.RdrName -> RefactGhc DeclaredNames
lhsbindslr bs = do
fds <- mapM (hsVisibleDsRdr nm e) $ GHC.bagToList bs
return $ mconcat fds
hsbinds :: [GHC.LHsBind GHC.RdrName] -> RefactGhc DeclaredNames
hsbinds ds
| findNameInRdr nm e ds = do
fds <- mapM (hsVisibleDsRdr nm e) ds
return $ mconcat fds
hsbinds _ = return (DN [])
hsbind :: (GHC.LHsBind GHC.RdrName) -> RefactGhc DeclaredNames
#if __GLASGOW_HASKELL__ <= 710
hsbind ((GHC.L _ (GHC.FunBind _n _ (GHC.MG matches _ _ _) _ _ _)))
#else
hsbind ((GHC.L _ (GHC.FunBind _n (GHC.MG (GHC.L _ matches) _ _ _) _ _ _)))
#endif
| findNameInRdr nm e matches = do
fds <- mapM (hsVisibleDsRdr nm e) matches
return $ mconcat fds
hsbind _ = do
return (DN [])
hslocalbinds :: (GHC.HsLocalBinds GHC.RdrName) -> RefactGhc DeclaredNames
hslocalbinds (GHC.HsValBinds binds)
| findNameInRdr nm e binds = hsVisibleDsRdr nm e binds
hslocalbinds (GHC.HsIPBinds binds)
| findNameInRdr nm e binds = hsVisibleDsRdr nm e binds
hslocalbinds (GHC.EmptyLocalBinds) = return (DN [])
hslocalbinds _ = return (DN [])
lmatch :: (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) -> RefactGhc DeclaredNames
lmatch (GHC.L _ m) = match m
match :: (GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName)) -> RefactGhc DeclaredNames
match (GHC.Match _fn pats _mtyp rhs)
| findNameInRdr nm e rhs || findNameInRdr nm e pats = do
-- logm $ "hsVisibleDsRdr nm.lmatch:doing rhs"
let (_pf,pd) = hsFreeAndDeclaredRdr nm pats
-- logm $ "hsVisibleDsRdr nm.lmatch:(pf,pd)=" ++ (show (_pf,pd))
rd <- hsVisibleDsRdr nm e rhs
-- logm $ "hsVisibleDsRdr nm.lmatch:rd=" ++ (show rd)
return (pd <> rd)
match _ =return (DN [])
grhss :: (GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)) -> RefactGhc DeclaredNames
grhss (GHC.GRHSs guardedRhss lstmts')
| findNameInRdr nm e guardedRhss || findNameInRdr nm e lstmts' = do
-- logm "hsVisibleDsRdr nm.grhss:about to do lstmts"
fds <- mapM (hsVisibleDsRdr nm e) guardedRhss
-- sfds <- hsVisibleDsRdr nm e lstmts'
let (_,sfds) = hsFreeAndDeclaredRdr nm lstmts'
return $ mconcat (sfds:fds)
grhss _ = do
-- logm $ "hsVisibleDsRdr.grhss: no match"
return (DN [])
lgrhs :: GHC.LGRHS GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc DeclaredNames
lgrhs (GHC.L _ (GHC.GRHS guards ex))
| findNameInRdr nm e guards = hsVisibleDsRdr nm e guards
| findNameInRdr nm e ex = do
r <- hsVisibleDsRdr nm e ex
-- logm $ "hsVisibleDsRdr.lgrhs:r=" ++ show r
return r
lgrhs _ = do
-- logm $ "hsVisibleDsRdr.lgrhs: no match"
return (DN [])
lexpr :: GHC.LHsExpr GHC.RdrName -> RefactGhc DeclaredNames
#if __GLASGOW_HASKELL__ <= 710
lexpr (GHC.L l (GHC.HsVar n))
#else
lexpr (GHC.L l (GHC.HsVar (GHC.L _ n)))
#endif
| findNameInRdr nm e n = do
-- logm $ "hsVisibleDsRdr.lexpr.HsVar entity found"
return (DN [rdrName2NamePure nm (GHC.L l n)])
lexpr (GHC.L _ (GHC.HsLet lbinds expr))
| findNameInRdr nm e lbinds || findNameInRdr nm e expr = do
-- logm $ "hsVisibleDsRdr.lexpr.HsLet entity found"
let (_,lds) = hsFreeAndDeclaredRdr nm lbinds
let (_,eds) = hsFreeAndDeclaredRdr nm expr
return $ lds <> eds
lexpr expr
| findNameInRdr nm e expr = do
-- logm $ "hsVisibleDsRdr nm.lexpr.(e,expr):" ++ (showGhc (e,expr))
let (FN efs,eds) = hsFreeAndDeclaredRdr nm expr
let (FN _eefs,DN eeds) = hsFreeAndDeclaredRdr nm e
-- logm $ "hsVisibleDsRdr nm.lexpr (efs,_d,_eefs,eeds) " ++ show (efs,_d,_eefs,eeds)
return (DN (efs \\ eeds) <> eds)
lexpr x = do
-- logm $ "hsVisibleDsRdr.lexpr:miss for:" ++ SYB.showData SYB.Parser 0 x
return (DN [])
-- ---------------------------------
tyclgroups :: [GHC.TyClGroup GHC.RdrName] -> RefactGhc DeclaredNames
tyclgroups tgrps
| findNameInRdr nm e tgrps = do
fds <- mapM (hsVisibleDsRdr nm e) tgrps
return $ mconcat fds
tyclgroups _ = return (DN [])
tyclgroup :: GHC.TyClGroup GHC.RdrName -> RefactGhc DeclaredNames
tyclgroup (GHC.TyClGroup tyclds _roles)
| findNameInRdr nm e tyclds = do
fds <- mapM (hsVisibleDsRdr nm e) tyclds
return $ mconcat fds
tyclgroup _ = return (DN [])
tycldeclss :: [[GHC.LTyClDecl GHC.RdrName]] -> RefactGhc DeclaredNames
tycldeclss tcds
| findNameInRdr nm e tcds = do
fds <- mapM (hsVisibleDsRdr nm e) tcds
return $ mconcat fds
tycldeclss _ = return (DN [])
tycldecls :: [GHC.LTyClDecl GHC.RdrName] -> RefactGhc DeclaredNames
tycldecls tcds
| findNameInRdr nm e tcds = do
fds <- mapM (hsVisibleDsRdr nm e) tcds
return $ mconcat fds
tycldecls _ = return (DN [])
ltycldecl :: GHC.LTyClDecl GHC.RdrName -> RefactGhc DeclaredNames
ltycldecl tcd
| findNameInRdr nm e tcd = do
let (_,ds) = hsFreeAndDeclaredRdr nm tcd
return ds
ltycldecl _ = return (DN [])
tycldecl :: GHC.TyClDecl GHC.RdrName -> RefactGhc DeclaredNames
tycldecl tcd
| findNameInRdr nm e tcd = do
let (_,ds) = hsFreeAndDeclaredRdr nm tcd
return ds
tycldecl _ = return (DN [])
hsdatadefn :: GHC.HsDataDefn GHC.RdrName -> RefactGhc DeclaredNames
hsdatadefn tcd
| findNameInRdr nm e tcd = do
let (_,ds) = hsFreeAndDeclaredRdr nm tcd
return ds
hsdatadefn _ = return (DN [])
condecl :: GHC.ConDecl GHC.RdrName -> RefactGhc DeclaredNames
condecl tcd
| findNameInRdr nm e tcd = do
let (_,ds) = hsFreeAndDeclaredRdr nm tcd
return ds
condecl _ = return (DN [])
-- ---------------------------------
instdecls :: [GHC.LInstDecl GHC.RdrName] -> RefactGhc DeclaredNames
instdecls ds
| findNameInRdr nm e ds = do
fds <- mapM (hsVisibleDsRdr nm e) ds
return $ mconcat fds
instdecls _ = return (DN [])
instdecl :: GHC.LInstDecl GHC.RdrName -> RefactGhc DeclaredNames
instdecl (GHC.L _ (GHC.ClsInstD (GHC.ClsInstDecl polytyp binds sigs tyfaminsts dfaminsts _)))
| findNameInRdr nm e polytyp = hsVisibleDsRdr nm e polytyp
| findNameInRdr nm e binds = hsVisibleDsRdr nm e binds
| findNameInRdr nm e sigs = hsVisibleDsRdr nm e sigs
| findNameInRdr nm e tyfaminsts = hsVisibleDsRdr nm e tyfaminsts
| findNameInRdr nm e dfaminsts = hsVisibleDsRdr nm e dfaminsts
| otherwise = return (DN [])
instdecl (GHC.L _ (GHC.DataFamInstD (GHC.DataFamInstDecl _ln pats defn _)))
| findNameInRdr nm e pats = hsVisibleDsRdr nm e pats
| findNameInRdr nm e defn = hsVisibleDsRdr nm e defn
| otherwise = return (DN [])
instdecl (GHC.L _ (GHC.TyFamInstD (GHC.TyFamInstDecl eqn _)))
| findNameInRdr nm e eqn = hsVisibleDsRdr nm e eqn
| otherwise = return (DN [])
lhstype :: GHC.LHsType GHC.RdrName -> RefactGhc DeclaredNames
#if __GLASGOW_HASKELL__ <= 710
lhstype tv@(GHC.L l (GHC.HsTyVar n))
#else
lhstype tv@(GHC.L l (GHC.HsTyVar (GHC.L _ n)))
#endif
| findNameInRdr nm e tv = return (DN [rdrName2NamePure nm (GHC.L l n)])
| otherwise = return (DN [])
lhstype (GHC.L _ (GHC.HsForAllTy {}))
= return (DN [])
lhstype (GHC.L _ (GHC.HsFunTy{})) = return (DN [])
lhstype ty = do
-- logm $ "lshtype: TypeUtils 1588" ++ SYB.showData SYB.Renamer 0 ty
return (DN [])
-- -----------------------
lsigs :: [GHC.LSig GHC.RdrName] -> RefactGhc DeclaredNames
lsigs ss = do
fds <- mapM (hsVisibleDsRdr nm e) ss
return $ mconcat fds
-- -----------------------
lsig :: GHC.LSig GHC.RdrName -> RefactGhc DeclaredNames
#if __GLASGOW_HASKELL__ <= 710
lsig (GHC.L _ (GHC.TypeSig _ns typ _))
#else
lsig (GHC.L _ (GHC.TypeSig _ns typ))
#endif
| findNameInRdr nm e typ = hsVisibleDsRdr nm e typ
#if __GLASGOW_HASKELL__ <= 710
lsig (GHC.L _ (GHC.GenericSig _n typ))
#else
lsig (GHC.L _ (GHC.ClassOpSig _ _n (GHC.HsIB _ typ)))
#endif
| findNameInRdr nm e typ = hsVisibleDsRdr nm e typ
lsig (GHC.L _ (GHC.IdSig _)) = return (DN [])
lsig (GHC.L _ (GHC.InlineSig _ _)) = return (DN [])
lsig (GHC.L _ (GHC.SpecSig _n typ _))
| findNameInRdr nm e typ = hsVisibleDsRdr nm e typ
lsig (GHC.L _ (GHC.SpecInstSig _ _)) = return (DN [])
lsig _ = return (DN [])
-- -----------------------
lstmts :: [GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)] -> RefactGhc DeclaredNames
lstmts ds
| findNameInRdr nm e ds = do
fds <- mapM (hsVisibleDsRdr nm e) ds
return $ mconcat fds
lstmts _ = return (DN [])
-- -----------------------
lstmt :: GHC.LStmt GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc DeclaredNames
#if __GLASGOW_HASKELL__ <= 710
lstmt (GHC.L _ (GHC.LastStmt ex _)) = hsVisibleDsRdr nm e ex
#else
lstmt (GHC.L _ (GHC.LastStmt ex _ _)) = hsVisibleDsRdr nm e ex
#endif
#if __GLASGOW_HASKELL__ <= 710
lstmt (GHC.L _ (GHC.BindStmt pa ex _ _)) = do
#else
lstmt (GHC.L _ (GHC.BindStmt pa ex _ _ _)) = do
#endif
fdp <- hsVisibleDsRdr nm e pa
fde <- hsVisibleDsRdr nm e ex
return (fdp <> fde)
lstmt (GHC.L _ (GHC.BodyStmt ex _ _ _)) = hsVisibleDsRdr nm e ex
lstmt (GHC.L _ (GHC.LetStmt bs)) = hsVisibleDsRdr nm e bs
#if __GLASGOW_HASKELL__ <= 710
lstmt (GHC.L _ (GHC.ParStmt ps _ _)) = hsVisibleDsRdr nm e ps
#else
lstmt (GHC.L _ (GHC.ParStmt ps _ _ _)) = hsVisibleDsRdr nm e ps
#endif
#if __GLASGOW_HASKELL__ <= 710
lstmt (GHC.L _ (GHC.TransStmt _ stmts _ using mby _ _ _)) = do
#else
lstmt (GHC.L _ (GHC.TransStmt _ stmts _ using mby _ _ _ _)) = do
#endif
fds <- hsVisibleDsRdr nm e stmts
fdu <- hsVisibleDsRdr nm e using
fdb <- case mby of
Nothing -> return (DN [])
Just ex -> hsVisibleDsRdr nm e ex
return $ fds <> fdu <> fdb
#if __GLASGOW_HASKELL__ <= 710
lstmt (GHC.L _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _)) = hsVisibleDsRdr nm e stmts
#else
lstmt (GHC.L _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _ _)) = hsVisibleDsRdr nm e stmts
#endif
#if __GLASGOW_HASKELL__ > 710
lstmt (GHC.L _ (GHC.ApplicativeStmt {})) = return mempty
#endif
-- lstmt _ = return (DN [])
-- -----------------------
lpats :: [GHC.LPat GHC.RdrName] -> RefactGhc DeclaredNames
lpats ps
| findNameInRdr nm e ps = do
fds <- mapM (hsVisibleDsRdr nm e) ps
return $ mconcat fds
lpats _ = return (DN [])
-- -----------------------
lpat :: GHC.LPat GHC.RdrName -> RefactGhc DeclaredNames
lpat (GHC.L _ (GHC.WildPat _)) = return (DN [])
#if __GLASGOW_HASKELL__ <= 710
lpat (GHC.L l (GHC.VarPat n))
#else
lpat (GHC.L l (GHC.VarPat (GHC.L _ n)))
#endif
= return (DN [rdrName2NamePure nm (GHC.L l n)])
lpat (GHC.L _ (GHC.AsPat ln p)) = do
(DN dp) <- lpat p
return (DN (rdrName2NamePure nm ln:dp))
lpat (GHC.L _ (GHC.ParPat p)) = lpat p
lpat (GHC.L _ (GHC.BangPat p)) = lpat p
lpat (GHC.L _ (GHC.ListPat ps _ _)) = do
fds <- mapM lpat ps
return $ mconcat fds
lpat (GHC.L _ (GHC.TuplePat ps _ _)) = do
fds <- mapM lpat ps
return $ mconcat fds
lpat (GHC.L _ (GHC.PArrPat ps _)) = do
fds <- mapM lpat ps
return $ mconcat fds
lpat (GHC.L _ (GHC.ConPatIn n det)) = do
(DN d) <- details det
return $ (DN (rdrName2NamePure nm n:d))
-- lpat (GHC.ConPatOut )
lpat (GHC.L _ (GHC.ViewPat ex p _)) = do
fde <- hsVisibleDsRdr nm e ex
fdp <- lpat p
return $ fde <> fdp
-- lpat (GHC.QuasiQuotePat _)
lpat (GHC.L _ (GHC.LitPat _)) = return (DN [])
#if __GLASGOW_HASKELL__ <= 710
lpat (GHC.L _ (GHC.NPat _ _ _)) = return (DN [])
lpat (GHC.L _ (GHC.NPlusKPat n _ _ _)) = return (DN [rdrName2NamePure nm n])
#else
lpat (GHC.L _ (GHC.NPat _ _ _ _)) = return (DN [])
lpat (GHC.L _ (GHC.NPlusKPat n _ _ _ _ _)) = return (DN [rdrName2NamePure nm n])
#endif
lpat (GHC.L _ _p@(GHC.SigPatIn p b)) = do
dp <- lpat p
db <- hsVisibleDsRdr nm e b
-- error $ "lpat.SigPatIn:(b,fb,db)" ++ showGhc (b,fb,db)
return $ dp <> db
lpat (GHC.L _ (GHC.SigPatOut p _)) = lpat p
lpat (GHC.L l (GHC.CoPat _ p _)) = lpat (GHC.L l p)
lpat (GHC.L _ (GHC.LazyPat p)) = lpat p
lpat (GHC.L _ (GHC.ConPatOut {})) = error $ "hsFreeAndDeclared.lpat:impossible GHC.ConPatOut"
#if __GLASGOW_HASKELL__ <= 710
lpat (GHC.L _ (GHC.QuasiQuotePat _)) = return mempty
lpat (GHC.L _ (GHC.SplicePat (GHC.HsSplice _ expr))) = hsVisibleDsRdr nm e expr
#else
lpat (GHC.L _ (GHC.SplicePat (GHC.HsTypedSplice _ expr))) = hsVisibleDsRdr nm e expr
lpat (GHC.L _ (GHC.SplicePat (GHC.HsUntypedSplice _ expr))) = hsVisibleDsRdr nm e expr
lpat (GHC.L _ (GHC.SplicePat (GHC.HsQuasiQuote {}))) = return mempty
#endif
-- ---------------------------
details :: GHC.HsConPatDetails GHC.RdrName -> RefactGhc DeclaredNames
details (GHC.PrefixCon args) = do
fds <- mapM lpat args
return $ mconcat fds
details (GHC.RecCon recf) =
recfields recf
details (GHC.InfixCon arg1 arg2) = do
fds <- mapM lpat [arg1,arg2]
return $ mconcat fds
-- Note: this one applies to HsRecFields in LPats
recfields :: (GHC.HsRecFields GHC.RdrName (GHC.LPat GHC.RdrName)) -> RefactGhc DeclaredNames
recfields (GHC.HsRecFields fields _) = do
let args = map (\(GHC.L _ (GHC.HsRecField _ arg _)) -> arg) fields
fds <- mapM lpat args
return $ mconcat fds
-- -----------------------
#if __GLASGOW_HASKELL__ > 710
ibndrs :: GHC.LHsSigWcType GHC.RdrName -> RefactGhc DeclaredNames
ibndrs (GHC.HsIB _ (GHC.HsWC _ _ ty)) = hsVisibleDsRdr nm e ty
lsigty :: GHC.LHsSigType GHC.RdrName -> RefactGhc DeclaredNames
lsigty (GHC.HsIB _ ty) = hsVisibleDsRdr nm e ty
#endif
-- -----------------------
lanndecl :: GHC.LAnnDecl GHC.RdrName -> RefactGhc DeclaredNames
lanndecl (GHC.L _ (GHC.HsAnnotation _ _ expr)) = hsVisibleDsRdr nm e expr
-- -----------------------
err = error $ "hsVisibleDsRdr nm:no match for:" ++ (SYB.showData SYB.Parser 0 t)
-- ---------------------------------------------------------------------
-- |`hsFDsFromInsideRdr` is different from `hsFreeAndDeclaredPNs` in
-- that: given an syntax phrase t, `hsFDsFromInsideRdr` returns not only
-- the declared variables that are visible from outside of t, but also
-- those declared variables that are visible to the main expression
-- inside t.
-- NOTE: Expects to be given ParsedSource
hsFDsFromInsideRdr :: (SYB.Data t)
=> NameMap -> t -> (FreeNames,DeclaredNames)
hsFDsFromInsideRdr nm t = hsFDsFromInsideRdr' t
where
hsFDsFromInsideRdr' :: (SYB.Data t) => t -> (FreeNames,DeclaredNames)
hsFDsFromInsideRdr' t1 = (FN $ nub f', DN $ nub d')
where
r1 = applyTU (once_tdTU (failTU `adhocTU` parsed
`adhocTU` decl
`adhocTU` match
`adhocTU` expr
`adhocTU` stmts )) t1
-- let (f',d') = fromMaybe ([],[]) r1
(FN f',DN d') = fromMaybe (FN [],DN []) r1
-- (FN f',DN d') = r1
parsed :: GHC.ParsedSource -> Maybe (FreeNames,DeclaredNames)
parsed p = return $ hsFreeAndDeclaredRdr nm p
-- ----------------------
match :: GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> Maybe (FreeNames,DeclaredNames)
match (GHC.Match _fn pats _type rhs) = do
let (FN pf, DN pd) = hsFreeAndDeclaredRdr nm pats
(FN rf, DN rd) = hsFreeAndDeclaredRdr nm rhs
return (FN $ nub (pf `union` (rf \\ pd)),
DN $ nub (pd `union` rd))
-- ----------------------
decl :: GHC.HsBind GHC.RdrName -> Maybe (FreeNames,DeclaredNames)
#if __GLASGOW_HASKELL__ <= 710
decl (GHC.FunBind (GHC.L _ _) _ (GHC.MG matches _ _ _) _ _ _) = do
#else
decl (GHC.FunBind (GHC.L _ _) (GHC.MG (GHC.L _ matches) _ _ _) _ _ _) = do
#endif
let
fds = map hsFDsFromInsideRdr' matches
-- error (show $ nameToString n)
return (FN $ nub (concat $ map (fn . fst) fds), DN $ nub (concat $ map (dn . snd) fds))
decl ((GHC.PatBind p rhs _ _ _) :: GHC.HsBind GHC.RdrName) = do
let
(FN pf, DN pd) = hsFreeAndDeclaredRdr nm p
(FN rf, DN rd) = hsFreeAndDeclaredRdr nm rhs
return
(FN $ nub (pf `union` (rf \\ pd)),
DN $ nub (pd `union` rd))
decl ((GHC.VarBind p rhs _) :: GHC.HsBind GHC.RdrName) = do
let
(FN pf, DN pd) = hsFreeAndDeclaredRdr nm p
(FN rf, DN rd) = hsFreeAndDeclaredRdr nm rhs
return
(FN $ nub (pf `union` (rf \\ pd)),
DN $ nub (pd `union` rd))
decl _ = mzero
-- ----------------------
expr ((GHC.HsLet decls e) :: GHC.HsExpr GHC.RdrName) = do
let
(FN df,DN dd) = hsFreeAndDeclaredRdr nm decls
(FN ef,_) = hsFreeAndDeclaredRdr nm e
return (FN $ nub (df `union` (ef \\ dd)), DN $ nub dd)
expr ((GHC.HsLam (GHC.MG matches _ _ _)) :: GHC.HsExpr GHC.RdrName) =
return $ hsFreeAndDeclaredRdr nm matches
expr ((GHC.HsCase e (GHC.MG matches _ _ _)) :: GHC.HsExpr GHC.RdrName) = do
let
(FN ef,_) = hsFreeAndDeclaredRdr nm e
(FN df,DN dd) = hsFreeAndDeclaredRdr nm matches
return (FN $ nub (df `union` (ef \\ dd)), DN $ nub dd)
expr _ = return (FN [],DN [])
#if __GLASGOW_HASKELL__ <= 710
stmts ((GHC.BindStmt pat e1 e2 e3) :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do
#else
stmts ((GHC.BindStmt pat e1 e2 e3 _) :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do
#endif
let
(FN pf,DN pd) = hsFreeAndDeclaredRdr nm pat
(FN ef,DN _ed) = hsFreeAndDeclaredRdr nm e1
(FN df,DN dd) = hsFreeAndDeclaredRdr nm [e2,e3]
return
(FN $ nub (pf `union` (((ef \\ dd) `union` df) \\ pd)), DN $ nub (pd `union` dd))
stmts ((GHC.LetStmt binds) :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) =
return $ hsFreeAndDeclaredRdr nm binds
stmts _ = return (FN [],DN [])
-- ---------------------------------------------------------------------
-- | The same as `hsFDsFromInside` except that the returned variables
-- are in the String format
hsFDNamesFromInsideRdr ::(SYB.Data t) => t -> RefactGhc ([String],[String])
hsFDNamesFromInsideRdr t = do
nm <- getRefactNameMap
return (hsFDNamesFromInsideRdrPure nm t)
-- (FN f,DN d) <- hsFDsFromInsideRdr nm t
-- return ((nub.map showGhc) f, (nub.map showGhc) d)
-- | The same as `hsFDsFromInside` except that the returned variables
-- are in the String format
hsFDNamesFromInsideRdrPure :: (SYB.Data t) => NameMap -> t -> ([String],[String])
hsFDNamesFromInsideRdrPure nm t = ((nub.map showGhc) f, (nub.map showGhc) d)
where
(FN f,DN d) = hsFDsFromInsideRdr nm t
-- ---------------------------------------------------------------------
rdrName2Name :: GHC.Located GHC.RdrName -> RefactGhc GHC.Name
rdrName2Name ln = do
nameMap <- getRefactNameMap
return (rdrName2NamePure nameMap ln)
rdrName2NamePure :: NameMap -> GHC.Located GHC.RdrName -> GHC.Name
rdrName2NamePure _nameMap (GHC.L _ (GHC.Exact n)) = n
rdrName2NamePure nameMap (GHC.L lrn _) =
fromMaybe (error $ "rdrName2NamePure: no name found for" ++ showGhc lrn)
-- fromMaybe (error $ "rdrName2NamePure: no name found for (lrn,e,nameMap)=" ++ showGhc (lrn,e,nameMap))
(Map.lookup lrn nameMap)
eqRdrNamePure :: NameMap -> GHC.Located GHC.RdrName -> GHC.Name -> Bool
eqRdrNamePure nameMap rn n
= GHC.nameUnique (rdrName2NamePure nameMap rn) == GHC.nameUnique n
-- ---------------------------------------------------------------------
-- | Returns True if both @GHC.Name@s are in the same @GHC.NameSpace@.
sameNameSpace :: GHC.Name -> GHC.Name -> Bool
sameNameSpace n1 n2
= (GHC.occNameSpace $ GHC.nameOccName n1) == (GHC.occNameSpace $ GHC.nameOccName n2)
-- ---------------------------------------------------------------------
-- |Find the identifier(in GHC.Name format) whose start position is
-- (row,col) in the file specified by the fileName, and returns
-- `Nothing` if such an identifier does not exist.
locToNameRdr :: (SYB.Data t)
=> SimpPos -- ^ The row and column number
-> t -- ^ The syntax phrase, parameterised by RdrName
-> RefactGhc (Maybe GHC.Name) -- ^ The result
locToNameRdr pos t = do
nm <- getRefactNameMap
let mn = locToRdrName pos t
return $ fmap (rdrName2NamePure nm) mn
-- |Find the identifier(in GHC.Name format) whose start position is
-- (row,col) in the file specified by the fileName, and returns
-- `Nothing` if such an identifier does not exist.
locToNameRdrPure :: (SYB.Data t)
=> NameMap
-> SimpPos -- ^ The row and column number
-> t -- ^ The syntax phrase, parameterised by RdrName
-> Maybe GHC.Name -- ^ The result
locToNameRdrPure nm pos t =
let mn = locToRdrName pos t
in fmap (rdrName2NamePure nm) mn
-- |Find the identifier(in GHC.RdrName format) whose start position is
-- (row,col) in the file specified by the fileName, and returns
-- `Nothing` if such an identifier does not exist.
locToRdrName::(SYB.Data t)
=>SimpPos -- ^ The row and column number
->t -- ^ The syntax phrase
-> Maybe (GHC.Located GHC.RdrName) -- ^ The result
locToRdrName (row,col) t = locToName' (row,col) t
-- |Worker for both locToName and locToRdrName.
-- NOTE: provides for FunBind MatchGroups where only the first name is
-- retained in the AST
locToName':: forall a t.(SYB.Data t, SYB.Data a)
=>SimpPos -- ^ The row and column number
->t -- ^ The syntax phrase
-> Maybe (GHC.Located a) -- ^ The result
locToName' (row,col) t = res1
where
res1 :: Maybe (GHC.Located a)
res1 = SYB.something (nameSybQuery checker) t
checker pnt =
-- trace ("locToName':pnt=" ++ show (GHC.getLoc pnt)) $
if inScope pnt
then Just pnt
else Nothing
-- ++AZ++:TODO: Is inScope actually required?
inScope :: GHC.Located e -> Bool
inScope (GHC.L l _) =
case l of
(GHC.UnhelpfulSpan _) -> False
(GHC.RealSrcSpan ss) ->
-- (GHC.srcSpanFile ss == fileName) &&
(GHC.srcSpanStartLine ss <= row) &&
(GHC.srcSpanEndLine ss >= row) &&
(col >= (GHC.srcSpanStartCol ss)) &&
(col <= (GHC.srcSpanEndCol ss))
-- EOF