HaRe-0.8.1.1: 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
, isDeclaredIn,isDeclaredInRdr
, FreeNames(..),DeclaredNames(..)
, hsFreeAndDeclaredPNsOld
, hsFreeAndDeclaredRdr
, hsFreeAndDeclaredNameStrings
, hsFreeAndDeclaredPNs
, hsFreeAndDeclaredGhc
, getDeclaredTypes
, getDeclaredTypesRdr
, getFvs, getFreeVars, getDeclaredVars
, hsVisiblePNs, hsVisiblePNsRdr, hsVisibleNames, hsVisibleNamesRdr
, hsFDsFromInsideRdr, hsFDNamesFromInsideRdr
, hsFDsFromInside, hsFDNamesFromInside
, hsVisibleDs, hsVisibleDsRdr
, rdrName2Name, rdrName2NamePure
, eqRdrNamePure
, rdrName2Name'
-- ** Identifiers, expressions, patterns and declarations
, FindEntity(..)
, sameOccurrence
, definedPNs, definedPNsRdr,definedNamesRdr
, definingDeclsRdrNames,definingDeclsRdrNames',definingSigsRdrNames
, definingDeclsNames, definingDeclsNames', definingSigsNames
, definingTyClDeclsNames
, defines
, definesRdr,definesDeclRdr
, definesTypeSig,definesTypeSigRdr,definesSigDRdr
, definesP
, allNames
, hsPNs, hsNamess, hsNamessRdr
, locToName, locToRdrName
) where
import Control.Monad.State
import Data.List
import Data.Maybe
import Data.Monoid
import Language.Haskell.Refact.Utils.Binds
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.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 NameSet as GHC
import qualified Outputable as GHC
import qualified RdrName as GHC
import qualified UniqSet 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
-- ---------------------------------------------------------------------
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
-- ---------------------------------------------------------------------
{-
-- This is not precise enough, RdrNames are ambiguous
instance FindEntity GHC.RdrName where
findEntity n t = fromMaybe False res
where
res = SYB.something (Nothing `SYB.mkQ` worker) t
worker (name::GHC.RdrName)
| n == name = Just True
worker _ = 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 the identifiers (in PName format) in a given syntax phrase.
hsPNs::(SYB.Data t)=> t -> [PName]
hsPNs t = (nub.ghead "hsPNs") res
where
res = SYB.everythingStaged SYB.Parser (++) [] ([] `SYB.mkQ` inPnt) t
inPnt (pname :: GHC.RdrName) = return [(PN pname)]
-------------------------------------------------------------------------------
-- ++AZ++ see if we can get away with one only..
isDeclaredIn :: (HsValBinds t GHC.Name) => GHC.Name -> t -> Bool
isDeclaredIn name t = nonEmptyList $ definingDeclsNames [name] (hsBinds t) False True
isDeclaredInRdr :: NameMap -> GHC.Name -> [GHC.LHsDecl GHC.RdrName] -> Bool
isDeclaredInRdr nm name decls = nonEmptyList $ definingDeclsRdrNames nm [name] decls False True
-- ---------------------------------------------------------------------
-- | 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 RenamedSource
hsFreeAndDeclaredRdr :: (SYB.Data t) => NameMap -> t -> (FreeNames,DeclaredNames)
hsFreeAndDeclaredRdr nm t = res
where
fd = hsFreeAndDeclaredRdr' nm t
(FN f,DN d) = fromMaybe mempty fd
res = (FN (f \\ d),DN d)
hsFreeAndDeclaredRdr':: (SYB.Data t) => NameMap -> t -> Maybe (FreeNames,DeclaredNames)
hsFreeAndDeclaredRdr' nm t = do
(FN f,DN d) <- hsFreeAndDeclared'
let (f',d') = (nub f, nub d)
return (FN f',DN d')
-- hsFreeAndDeclared'=applyTU (stop_tdTU (failTU `adhocTU` exp
where
hsFreeAndDeclared' :: Maybe (FreeNames,DeclaredNames)
hsFreeAndDeclared' = applyTU (stop_tdTU (failTU
`adhocTU` expr
`adhocTU` pattern
`adhocTU` binds
`adhocTU` bindList
`adhocTU` match
`adhocTU` stmts
`adhocTU` rhs
`adhocTU` ltydecl
)) t
-- expr --
expr (GHC.L l (GHC.HsVar n))
= return (FN [rdrName2NamePure nm (GHC.L l n)],DN [])
expr (GHC.L _ (GHC.OpApp e1 (GHC.L l (GHC.HsVar n)) _ e2)) = do
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 [])
expr (GHC.L _ (GHC.RecordCon ln _ e)) = do
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 --
pattern (GHC.L _ (GHC.AsPat ln pat)) = do
let (f,DN d) = fromMaybe mempty $ hsFreeAndDeclaredRdr' nm pat
return (f,DN (rdrName2NamePure nm ln:d))
pattern (GHC.L l (GHC.VarPat n))
= return (FN [],DN [rdrName2NamePure nm (GHC.L l n)])
-- It seems all the GHC pattern match syntax elements end up
-- with GHC.VarPat
pattern _ = mzero
-- pattern _ = return ([],[])
bindList (ds :: [GHC.LHsBind GHC.RdrName])
=do (FN f,DN d) <- hsFreeAndDeclaredList ds
return (FN (f\\d),DN d)
-- bindList _ = mzero
-- match and patBind, same type--
binds ((GHC.FunBind ln _ (GHC.MG matches _ _ _) _ _fvs _) :: GHC.HsBind GHC.RdrName)
= 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 [])
-- stmts --
stmts ((GHC.BindStmt pat expre _bindOp _failOp) :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) = do
-- TODO ++AZ++ : Not sure it is meaningful to pull
-- anything out of bindOp/failOp
(FN pf,DN pd) <- hsFreeAndDeclaredRdr' nm pat
(FN ef,_ed) <- hsFreeAndDeclaredRdr' nm expre
let sf1 = []
return (FN $ pf `union` ef `union` (sf1\\pd),DN []) -- pd) -- Check this
stmts ((GHC.LetStmt binds') :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) =
hsFreeAndDeclaredRdr' nm binds'
stmts _ = mzero
-- tycldecls -----------------
ltydecl :: GHC.LTyClDecl GHC.RdrName -> Maybe (FreeNames,DeclaredNames)
ltydecl (GHC.L _ (GHC.FamDecl fd)) = hsFreeAndDeclaredRdr' nm fd
ltydecl (GHC.L _ (GHC.SynDecl ln _bndrs _rhs _fvs))
= return (FN [],DN [rdrName2NamePure nm ln])
ltydecl (GHC.L _ (GHC.DataDecl ln _bndrs defn _fvs)) = do
let dds = map (rdrName2NamePure nm) $ concatMap (GHC.con_names . GHC.unLoc) $ GHC.dd_cons defn
return (FN [],DN (rdrName2NamePure nm ln:dds))
ltydecl (GHC.L _ (GHC.ClassDecl _ctx ln _tyvars
_fds _sigs meths ats atds _docs _fvs)) = do
(_,md) <- hsFreeAndDeclaredRdr' nm meths
(_,ad) <- hsFreeAndDeclaredRdr' nm ats
(_,atd) <- hsFreeAndDeclaredRdr' nm atds
return (FN [],DN [rdrName2NamePure nm ln] <> md <> ad <> atd)
------------------------------
addFree :: GHC.Name -> (FreeNames,DeclaredNames)
-> Maybe (FreeNames,DeclaredNames)
addFree free (FN fr,de) = return (FN $ [free] `union` fr, de)
hsFreeAndDeclaredList :: (SYB.Data t) => [t] -> Maybe (FreeNames,DeclaredNames)
hsFreeAndDeclaredList l = do
fds <- mapM (hsFreeAndDeclaredRdr' nm) l
let
unionF (FN a) (FN b) = FN (a `union` b)
unionD (DN a) (DN b) = DN (a `union` b)
return (foldr unionF mempty (map fst fds),
foldr unionD mempty (map snd fds))
-- ---------------------------------------------------------------------
-- | 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 RenamedSource
hsFreeAndDeclaredPNsOld:: (SYB.Data t) => t -> ([GHC.Name],[GHC.Name])
hsFreeAndDeclaredPNsOld t = res
where
fd = hsFreeAndDeclaredPNs' t
(f,d) = fromMaybe ([],[]) fd
res = (f \\ d, d)
hsFreeAndDeclaredPNs':: (SYB.Data t) => t -> Maybe ([GHC.Name],[GHC.Name])
hsFreeAndDeclaredPNs' t = do
(f,d) <- hsFreeAndDeclared'
let (f',d') = (nub f, nub d)
-- return (f' \\ d',d')
return (f',d')
-- hsFreeAndDeclared'=applyTU (stop_tdTU (failTU `adhocTU` exp
where
hsFreeAndDeclared' = applyTU (stop_tdTU (failTU
`adhocTU` expr
`adhocTU` pattern
`adhocTU` binds
`adhocTU` bindList
`adhocTU` match
`adhocTU` stmts
`adhocTU` rhs
)) t
-- expr --
expr (GHC.HsVar n) = return ([n],[])
expr (GHC.OpApp e1 (GHC.L _ (GHC.HsVar n)) _ e2) = do
efed <- hsFreeAndDeclaredPNs' [e1,e2]
fd <- addFree n efed
return fd
expr ((GHC.HsLam (GHC.MG matches _ _ _)) :: GHC.HsExpr GHC.Name) =
hsFreeAndDeclaredPNs' matches
expr ((GHC.HsLet decls e) :: GHC.HsExpr GHC.Name) =
do
(df,dd) <- hsFreeAndDeclaredPNs' decls
(ef,_) <- hsFreeAndDeclaredPNs' e
return ((df `union` (ef \\ dd)),[])
expr (GHC.RecordCon (GHC.L _ n) _ e) = do
fd <- (hsFreeAndDeclaredPNs' e)
addFree n fd --Need Testing
expr (GHC.EAsPat (GHC.L _ n) e) = do
fd <- (hsFreeAndDeclaredPNs' e)
addFree n fd
expr _ = mzero
-- rhs --
rhs ((GHC.GRHSs g ds) :: GHC.GRHSs GHC.Name (GHC.LHsExpr GHC.Name))
= do (df,dd) <- hsFreeAndDeclaredPNs' g
(ef,ed) <- hsFreeAndDeclaredPNs' ds
return (df ++ ef, dd ++ ed)
-- pat --
pattern (GHC.AsPat (GHC.L _ n) pat) = do
(f,d) <- hsFreeAndDeclaredPNs' pat
return (f,n:d)
pattern (GHC.VarPat n) = return ([],[n])
-- It seems all the GHC pattern match syntax elements end up
-- with GHC.VarPat
pattern _ = mzero
-- pattern _ = return ([],[])
bindList (ds :: [GHC.LHsBind GHC.Name])
=do (f,d) <- hsFreeAndDeclaredList ds
return (f\\d,d)
-- bindList _ = mzero
-- match and patBind, same type--
binds ((GHC.FunBind (GHC.L _ n) _ (GHC.MG matches _ _ _) _ _fvs _) :: GHC.HsBind GHC.Name)
= do
(pf,_pd) <- hsFreeAndDeclaredPNs' matches
return (pf \\ [n] ,[n])
-- patBind --
binds (GHC.PatBind pat prhs _ ds _) =
do
(pf,pd) <- hsFreeAndDeclaredPNs' pat
(rf,rd) <- hsFreeAndDeclaredPNs' prhs
return (pf `union` (rf \\pd),pd ++ GHC.uniqSetToList ds ++ rd)
binds _ = mzero
match ((GHC.Match _fn pats _mtype mrhs) :: GHC.Match GHC.Name (GHC.LHsExpr GHC.Name))
= do
(pf,pd) <- hsFreeAndDeclaredPNs' pats
(rf,rd) <- hsFreeAndDeclaredPNs' mrhs
return ((pf `union` (rf \\ (pd `union` rd))),[])
-- stmts --
stmts ((GHC.BindStmt pat expre _bindOp _failOp) :: GHC.Stmt GHC.Name (GHC.LHsExpr GHC.Name)) = do
-- TODO ++AZ++ : Not sure it is meaningful to pull
-- anything out of bindOp/failOp
(pf,pd) <- hsFreeAndDeclaredPNs' pat
(ef,_ed) <- hsFreeAndDeclaredPNs' expre
let sf1 = []
return (pf `union` ef `union` (sf1\\pd),[]) -- pd) -- Check this
stmts ((GHC.LetStmt binds') :: GHC.Stmt GHC.Name (GHC.LHsExpr GHC.Name)) =
hsFreeAndDeclaredPNs' binds'
stmts _ = mzero
addFree :: GHC.Name -> ([GHC.Name],[GHC.Name])
-> Maybe ([GHC.Name],[GHC.Name])
addFree free (fr,de) = return ([free] `union` fr, de)
hsFreeAndDeclaredList l=do fds<-mapM hsFreeAndDeclaredPNs' l
return (foldr union [] (map fst fds),
foldr union [] (map snd fds))
-- |The same as `hsFreeAndDeclaredPNs` except that the returned
-- variables are in the String format.
hsFreeAndDeclaredNameStrings::(SYB.Data t,GHC.Outputable t)
=> t -> RefactGhc ([String],[String])
hsFreeAndDeclaredNameStrings t = do
(f1,d1) <- hsFreeAndDeclaredPNs t
return ((nub.map showGhc) f1, (nub.map showGhc) d1)
hsFreeAndDeclaredPNs :: (SYB.Data t) => t -> RefactGhc ([GHC.Name],[GHC.Name])
hsFreeAndDeclaredPNs t = do
-- logm $ "hsFreeAndDeclaredPNs:t=" ++ (showGhc t)
(FN f,DN d) <- hsFreeAndDeclaredGhc 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.
-- TODO: use GHC.NameSet instead of lists for FreeNames/DeclaredNames
-- NOTE: The GHC fvs fields only carry non-GHC values, as they are
-- used in the renaming process
-- hsFreeAndDeclaredGhc :: (SYB.Data t,GHC.Outputable t)
hsFreeAndDeclaredGhc :: (SYB.Data t)
=> t -> RefactGhc (FreeNames,DeclaredNames)
hsFreeAndDeclaredGhc t = do
-- logm $ "hsFreeAndDeclaredGhc:t=" ++ showGhc t
-- logm $ "hsFreeAndDeclaredGhc:t=" ++ SYB.showData SYB.Renamer 0 t
(FN f,DN d) <- res
let f' = nub f
let d' = nub d
-- logm $ "hsFreeAndDeclaredGhc:res=" ++ showGhc (f',d')
return (FN (f' \\ d'), DN d')
where
res = (const err
`SYB.extQ` renamed
`SYB.extQ` lhsbind
`SYB.extQ` hsbind
`SYB.extQ` lhsbinds
`SYB.extQ` lhsbindslrs
`SYB.extQ` lhsbindslr
`SYB.extQ` hslocalbinds
`SYB.extQ` hsvalbinds
`SYB.extQ` lpats
`SYB.extQ` lpat
`SYB.extQ` bndrs
`SYB.extQ` ltydecls
`SYB.extQ` ltydecl
-- `SYB.extQ` lfaminstdecls
-- `SYB.extQ` lfaminstdecl
`SYB.extQ` lsigs
`SYB.extQ` lsig
`SYB.extQ` lexprs
`SYB.extQ` lexpr
`SYB.extQ` expr
`SYB.extQ` name
`SYB.extQ` lstmts
`SYB.extQ` lstmt
`SYB.extQ` lhstype
`SYB.extQ` hstype
`SYB.extQ` grhs_s
`SYB.extQ` grhs
`SYB.extQ` grhsss
`SYB.extQ` grhss
`SYB.extQ` matchgroup
`SYB.extQ` lmatches
`SYB.extQ` lmatch
`SYB.extQ` hsrecordbinds
`SYB.extQ` hsrecordbind
) t
-- -----------------------
renamed :: GHC.RenamedSource -> RefactGhc (FreeNames,DeclaredNames)
renamed (g,_i,_e,_d) = do
(FN gf,DN gd) <- hsFreeAndDeclaredGhc $ GHC.hs_valds g
let tds = concatMap getDeclaredTypes $ concatMap GHC.group_tyclds (GHC.hs_tyclds g)
logm $ "hsFreeAndDeclaredGhc.renamed:(gf,gd,tds)=" ++ showGhc (gf,gd,tds)
-- return $ gfds <> (FN [],DN tds)
return $ (FN (gf \\ tds), DN (gd++tds))
-- -----------------------
lhsbinds :: [GHC.LHsBind GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)
lhsbinds bs = do
(FN f,DN d) <- recurseList bs
let r = (FN (f \\ d),DN d)
-- logm $ "hsFreeAndDeclaredGhc.hsbinds:r=" ++ (show r)
return r
lhsbind :: GHC.LHsBind GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
lhsbind (GHC.L _ b) = hsFreeAndDeclaredGhc b
-- -----------------------
hsbind :: GHC.HsBind GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
hsbind b@(GHC.FunBind _n _ (GHC.MG matches _ _ _) _ _ _) = do
-- logm $ "hsFreeAndDeclaredGhc.hsbind:b=" ++ (showGhc b)
let d = GHC.collectHsBindBinders b
(fp,_dp) <- hsFreeAndDeclaredGhc matches
-- logm $ "hsFreeAndDeclaredGhc.hsbind:(fp,_dp)=" ++ (show (fp,_dp))
-- logm $ "hsFreeAndDeclaredGhc.hsbind:(d)=" ++ (showGhc (d))
let r = (fp,DN []) <> (FN [],DN d)
-- logm $ "hsFreeAndDeclaredGhc.hsbind:r=" ++ (show (r))
return $ r
hsbind b@(GHC.PatBind pa rhs _ _ _) = do
-- logm $ "hsFreeAndDeclaredGhc.hsbind.PatBind:b=" ++ (showGhc b)
let d = GHC.collectHsBindBinders b
(FN fr,DN _dr) <- hsFreeAndDeclaredGhc rhs
(fp,_) <- lpat pa
-- logm $ "hsFreeAndDeclaredGhc.hsbind.PatBind:f=" ++ (showGhc fr)
return $ (fp,DN []) <> (FN fr,DN d)
hsbind b = do
-- logm $ "hsFreeAndDeclaredGhc.hsbind:b=" ++ (showGhc b)
let d = GHC.collectHsBindBinders b
return (FN [],DN d)
-- -----------------------
lhsbindslrs :: [GHC.LHsBindsLR GHC.Name GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)
lhsbindslrs bs = recurseList bs
-- -----------------------
lhsbindslr :: GHC.LHsBindsLR GHC.Name GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
lhsbindslr bs = do
hsFreeAndDeclaredGhc $ GHC.bagToList bs
hslocalbinds :: GHC.HsLocalBinds GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
hslocalbinds (GHC.HsValBinds binds) = hsFreeAndDeclaredGhc binds
hslocalbinds (GHC.HsIPBinds binds) = hsFreeAndDeclaredGhc binds
hslocalbinds GHC.EmptyLocalBinds = return emptyFD
hsvalbinds :: GHC.HsValBinds GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
hsvalbinds (GHC.ValBindsIn binds sigs) = do
bfds <- hsFreeAndDeclaredGhc binds
sfds <- hsFreeAndDeclaredGhc sigs
return $ bfds <> sfds
hsvalbinds (GHC.ValBindsOut binds sigs) = do
bfds <- hsFreeAndDeclaredGhc $ map snd binds
sfds <- hsFreeAndDeclaredGhc sigs
return $ bfds <> sfds
-- -----------------------
lpats :: [GHC.LPat GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)
lpats xs = recurseList xs
-- -----------------------
lpat :: GHC.LPat GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
lpat lp@(GHC.L _ p) = do
-- logm $ "hsFreeAndDeclaredGhc.lpat:" ++ (showGhc lp)
let
d = GHC.collectPatBinders lp
(FN f,DN _dn) <- pat p
-- logm $ "hsFreeAndDeclaredGhc.lpat:(fn,dn)=" ++ (showGhc (fn,dn))
return (FN f,DN d)
pat :: GHC.Pat GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
pat (GHC.WildPat _) = return emptyFD
pat (GHC.VarPat n) = return (FN [],DN [n])
pat (GHC.LazyPat (GHC.L _ p)) = pat p
pat (GHC.AsPat (GHC.L _ n) (GHC.L _ p)) = do
fd <- pat p
return $ (FN [], DN [n]) <> fd
pat (GHC.ParPat (GHC.L _ p)) = pat p
pat (GHC.BangPat (GHC.L _ p)) = pat p
pat (GHC.ListPat ps _ _) = do
fds <- mapM pat $ map GHC.unLoc ps
return $ mconcat fds
pat (GHC.TuplePat ps _ _) = do
fds <- mapM pat $ map GHC.unLoc ps
return $ mconcat fds
pat (GHC.PArrPat ps _) = do
fds <- mapM pat $ map GHC.unLoc ps
return $ mconcat fds
pat (GHC.ConPatIn (GHC.L _ n) det) = do
-- logm $ "hsFreeAndDeclaredGhc.pat.ConPatIn:details=" ++ (SYB.showData SYB.Renamer 0 det)
(FN f,DN _d) <- details det
return $ (FN [n],DN []) <> (FN [],DN f)
-- pat (GHC.ConPatOut )
pat (GHC.ViewPat e (GHC.L _ p) _) = do
fde <- hsFreeAndDeclaredGhc e
fdp <- pat p
return $ fde <> fdp
-- pat (GHC.QuasiQuotePat _)
pat (GHC.LitPat _) = return emptyFD
pat (GHC.NPat _ _ _) = return emptyFD
pat (GHC.NPlusKPat (GHC.L _ n) _ _ _) = return (FN [],DN [n])
pat _p@(GHC.SigPatIn (GHC.L _ p) b) = do
fdp <- pat p
(FN fb,DN _db) <- hsFreeAndDeclaredGhc b
return $ fdp <> (FN fb,DN [])
pat (GHC.SigPatOut (GHC.L _ p) _) = pat p
pat (GHC.CoPat _ p _) = pat p
pat p = error $ "hsFreeAndDeclaredGhc.pat:unimplemented:" ++ (showGhc p)
details :: GHC.HsConPatDetails GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
details (GHC.PrefixCon args) = do
-- logm $ "hsFreeAndDeclaredGhc.details:args=" ++ (showGhc args)
fds <- mapM pat $ map GHC.unLoc args
return $ mconcat fds
details (GHC.RecCon recf) =
recfields recf
details (GHC.InfixCon arg1 arg2) = do
fds <- mapM pat $ map GHC.unLoc [arg1,arg2]
return $ mconcat fds
-- Note: this one applies to HsRecFields in LPats
recfields :: (GHC.HsRecFields GHC.Name (GHC.LPat GHC.Name)) -> RefactGhc (FreeNames,DeclaredNames)
recfields (GHC.HsRecFields fields _) = do
let args = map (\(GHC.L _ (GHC.HsRecField _ (GHC.L _ arg) _)) -> arg) fields
fds <- mapM pat args
return $ mconcat fds
-- -----------------------
bndrs :: GHC.HsWithBndrs GHC.Name (GHC.LHsType GHC.Name) -> RefactGhc (FreeNames,DeclaredNames)
bndrs (GHC.HsWB (GHC.L _ thing) _ _ _) = do
(_ft,DN dt) <- hsFreeAndDeclaredGhc thing
-- logm $ "hsFreeAndDeclaredGhc.bndrs (_ft,dt)=" ++ show (_ft,DN dt)
return (FN dt,DN [])
-- -----------------------
ltydecls :: [GHC.LTyClDecl GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)
ltydecls ds = do
fds <- mapM hsFreeAndDeclaredGhc ds
return $ mconcat fds
ltydecl :: GHC.LTyClDecl GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
-- ltydecl (GHC.L _ (GHC.ForeignType (GHC.L _ n) _)) = return (FN [],DN [n])
-- ltydecl (GHC.L _ (GHC.TyFamily _ (GHC.L _ n) _bndrs _)) = return (FN [],DN [n])
ltydecl (GHC.L _ (GHC.FamDecl fd)) = hsFreeAndDeclaredGhc fd
ltydecl (GHC.L _ (GHC.SynDecl (GHC.L _ n) _bndrs _rhs fvs))
= return (FN (GHC.nameSetElems fvs),DN [n])
ltydecl (GHC.L _ (GHC.DataDecl (GHC.L _ n) _bndrs defn fvs)) = do
let dds = map GHC.unLoc $ concatMap (GHC.con_names . GHC.unLoc) $ GHC.dd_cons defn
logm $ "hsFreeAndDeclaredGhc.ltydecl:(n,dds)" ++ showGhc (n,dds)
return (FN (GHC.nameSetElems fvs),DN (n:dds))
ltydecl (GHC.L _ (GHC.ClassDecl _ctx (GHC.L _ n) _tyvars
_fds _sigs meths ats atds _docs fvs)) = do
-- logm $ "hsFreeAndDeclaredGhc.ltydecl.ClassDecl.meths"
(_,md) <- hsFreeAndDeclaredGhc meths
-- logm $ "hsFreeAndDeclaredGhc.ltydecl.ClassDecl.ats"
(_,ad) <- hsFreeAndDeclaredGhc ats
-- logm $ "hsFreeAndDeclaredGhc.ltydecl.ClassDecl.atds"
(_,atd) <- hsFreeAndDeclaredGhc atds
-- logm $ "hsFreeAndDeclaredGhc.ltydecl.ClassDecl.done"
return (FN (GHC.nameSetElems fvs),DN [n] <> md <> ad <> atd)
{-
FamDecl -- type/data family T :: *->*
tcdFam :: FamilyDecl name
SynDecl -- type declaration
tcdLName :: Located name
tcdTyVars :: LHsTyVarBndrs name
tcdRhs :: LHsType name
tcdFVs :: PostRn name NameSet
DataDecl
tcdLName :: Located name
tcdTyVars :: LHsTyVarBndrs name
tcdDataDefn :: HsDataDefn name
tcdFVs :: PostRn name NameSet
ClassDecl
tcdCtxt :: LHsContext name
tcdLName :: Located name
tcdTyVars :: LHsTyVarBndrs name
tcdFDs :: [Located (FunDep (Located name))]
tcdSigs :: [LSig name]
tcdMeths :: LHsBinds name
tcdATs :: [LFamilyDecl name]
tcdATDefs :: [LTyFamDefltEqn name]
tcdDocs :: [LDocDecl]
tcdFVs :: PostRn name NameSet
-}
-- ---------------------------------
{-
lfaminstdecls :: [GHC.LFamInstDecl GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)
lfaminstdecls ds = do
fds <- mapM hsFreeAndDeclaredGhc ds
return $ mconcat fds
lfaminstdecl :: GHC.LFamInstDecl GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
lfaminstdecl _f@(GHC.L _ (GHC.FamInstDecl (GHC.L _ n) _pats _defn fvs)) = do
-- logm $ "hsFreeAndDeclaredGhc.lfaminstdecl:" ++ showGhc _f
return (FN (GHC.nameSetElems fvs), DN [n])
-}
-- -----------------------
lsigs :: [GHC.LSig GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)
lsigs ss = do
fds <- mapM hsFreeAndDeclaredGhc ss
return $ mconcat fds
-- -----------------------
lsig :: GHC.LSig GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
lsig (GHC.L _ (GHC.TypeSig ns typ _)) = do
tfds <- hsFreeAndDeclaredGhc typ
return $ (FN [],DN (map GHC.unLoc ns)) <> tfds
lsig (GHC.L _ (GHC.GenericSig n typ)) = do
tfds <- hsFreeAndDeclaredGhc typ
return $ (FN [],DN (map GHC.unLoc n)) <> tfds
lsig (GHC.L _ (GHC.IdSig _)) = return emptyFD
lsig (GHC.L _ (GHC.InlineSig _ _)) = return emptyFD
lsig (GHC.L _ (GHC.SpecSig n typ _)) = do
tfds <- hsFreeAndDeclaredGhc typ
return $ (FN [],DN [GHC.unLoc n]) <> tfds
lsig (GHC.L _ (GHC.SpecInstSig _ _)) = return emptyFD
lsig (GHC.L _ (GHC.FixSig _)) = return emptyFD
lsig (GHC.L _ (GHC.PatSynSig _ _ _ _ _)) = error "lsig: PatSynSig: toImplement"
lsig (GHC.L _ (GHC.MinimalSig _ _)) = error "lsig FixSig: toImplement"
-- -----------------------
lexprs :: [GHC.LHsExpr GHC.Name] -> RefactGhc (FreeNames,DeclaredNames)
lexprs es = recurseList es
-- -----------------------
lexpr :: GHC.LHsExpr GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
lexpr (GHC.L _ e) = hsFreeAndDeclaredGhc e
-- -----------------------
expr :: GHC.HsExpr GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
expr ((GHC.HsVar n)) = return (FN [n],DN [])
expr ((GHC.HsIPVar _)) = return emptyFD
expr ((GHC.HsOverLit _)) = return emptyFD
expr ((GHC.HsLit _)) = return emptyFD
expr ((GHC.HsLam mg)) = hsFreeAndDeclaredGhc mg
expr ((GHC.HsLamCase _ mg)) = hsFreeAndDeclaredGhc mg
expr ((GHC.HsApp e1 e2)) = do
fde1 <- hsFreeAndDeclaredGhc e1
fde2 <- hsFreeAndDeclaredGhc e2
return $ fde1 <> fde2
expr ((GHC.OpApp e1 eop _fix e2)) = do
fde1 <- hsFreeAndDeclaredGhc e1
fdeop <- hsFreeAndDeclaredGhc eop
fde2 <- hsFreeAndDeclaredGhc e2
return $ fde1 <> fdeop <> fde2
expr ((GHC.NegApp e _)) = hsFreeAndDeclaredGhc e
expr ((GHC.HsPar e)) = hsFreeAndDeclaredGhc e
expr ((GHC.SectionL e1 e2)) = do
fde1 <- hsFreeAndDeclaredGhc e1
fde2 <- hsFreeAndDeclaredGhc e2
return $ fde1 <> fde2
expr ((GHC.SectionR e1 e2)) = do
fde1 <- hsFreeAndDeclaredGhc e1
fde2 <- hsFreeAndDeclaredGhc e2
return $ fde1 <> fde2
expr ((GHC.ExplicitTuple args _boxity)) = do
let argse = concatMap bb args
bb (GHC.L _ (GHC.Missing _)) = []
bb (GHC.L _ (GHC.Present a)) = [a]
fds <- mapM hsFreeAndDeclaredGhc argse
return $ mconcat fds
expr ((GHC.HsCase e body)) = do
fdes <- hsFreeAndDeclaredGhc e
fdbs <- hsFreeAndDeclaredGhc body
return $ fdes <> fdbs
expr ((GHC.HsIf _ms e1 e2 e3)) = do
fde1 <- hsFreeAndDeclaredGhc e1
fde2 <- hsFreeAndDeclaredGhc e2
fde3 <- hsFreeAndDeclaredGhc e3
return $ fde1 <> fde2 <> fde3
expr ((GHC.HsMultiIf _typ rhs))
= hsFreeAndDeclaredGhc rhs
expr ((GHC.HsLet binds e)) = do
fdb <- hsFreeAndDeclaredGhc binds
fde <- hsFreeAndDeclaredGhc e
return $ fdb <> fde
expr ((GHC.HsDo _ctx stmts _typ))
= hsFreeAndDeclaredGhc stmts
expr ((GHC.ExplicitList _ _ es))
= hsFreeAndDeclaredGhc es
expr ((GHC.ExplicitPArr _typ es))
= hsFreeAndDeclaredGhc es
expr ((GHC.RecordCon (GHC.L _ n) _typ binds)) = do
fdb <- hsFreeAndDeclaredGhc binds
return $ (FN [],DN [n]) <> fdb
expr ((GHC.RecordUpd e1 binds _cons _typ1 _typ2)) = do
fde <- hsFreeAndDeclaredGhc e1
fdb <- hsFreeAndDeclaredGhc binds
return $ fde <> fdb
expr ((GHC.ExprWithTySig e _typ _))
= hsFreeAndDeclaredGhc e
expr ((GHC.ExprWithTySigOut e _typ))
= hsFreeAndDeclaredGhc e
expr ((GHC.ArithSeq _ _typ as)) = do
fds <- case as of
GHC.From e -> hsFreeAndDeclaredGhc e
GHC.FromThen e1 e2 -> recurseList [e1,e2]
GHC.FromTo e1 e2 -> recurseList [e1,e2]
GHC.FromThenTo e1 e2 e3 -> recurseList [e1,e2,e3]
return fds
expr ((GHC.PArrSeq _typ as))
= hsFreeAndDeclaredGhc as
expr ((GHC.HsSCC _ _ e))
= hsFreeAndDeclaredGhc e
expr ((GHC.HsCoreAnn _ _ e))
= hsFreeAndDeclaredGhc e
expr ((GHC.HsBracket (GHC.ExpBr b)))
= hsFreeAndDeclaredGhc b
expr ((GHC.HsBracket (GHC.PatBr b)))
= hsFreeAndDeclaredGhc b
expr ((GHC.HsBracket (GHC.DecBrL b)))
= hsFreeAndDeclaredGhc b
expr ((GHC.HsBracket (GHC.DecBrG b)))
= hsFreeAndDeclaredGhc b
expr ((GHC.HsBracket (GHC.TypBr b)))
= hsFreeAndDeclaredGhc b
expr ((GHC.HsBracket (GHC.VarBr _ n)))
= return (FN [],DN [n])
expr ((GHC.HsBracket (GHC.TExpBr _)))
= error "expr: GHC.HsBracket (GHC.TExpBr), to implement"
expr ((GHC.HsRnBracketOut b _ps))
= hsFreeAndDeclaredGhc b
expr ((GHC.HsTcBracketOut b _ps))
= hsFreeAndDeclaredGhc b
expr ((GHC.HsSpliceE _ (GHC.HsSplice _ e)))
= hsFreeAndDeclaredGhc e
expr ((GHC.HsQuasiQuoteE _q))
= return emptyFD
expr ((GHC.HsProc pa cmd)) = do
fdp <- hsFreeAndDeclaredGhc pa
fdc <- hsFreeAndDeclaredGhc cmd
return $ fdp <> fdc
expr ((GHC.HsStatic e)) = hsFreeAndDeclaredGhc e
expr ((GHC.HsArrApp e1 e2 _typ _atyp _)) = do
fd1 <- hsFreeAndDeclaredGhc e1
fd2 <- hsFreeAndDeclaredGhc e2
return $ fd1 <> fd2
expr ((GHC.HsArrForm e1 _fix cmds)) = do
fd1 <- hsFreeAndDeclaredGhc e1
fdc <- hsFreeAndDeclaredGhc cmds
return $ fd1 <> fdc
expr ((GHC.HsTick _ e))
= hsFreeAndDeclaredGhc e
expr ((GHC.HsBinTick _ _ e))
= hsFreeAndDeclaredGhc e
expr ((GHC.HsTickPragma _ _ e))
= hsFreeAndDeclaredGhc e
expr ((GHC.EWildPat)) = return emptyFD
expr ((GHC.EAsPat (GHC.L _ n) e)) = do
fde <- hsFreeAndDeclaredGhc e
return $ (FN [],DN [n]) <> fde
expr ((GHC.EViewPat e1 e2)) = do
fd1 <- hsFreeAndDeclaredGhc e1
fd2 <- hsFreeAndDeclaredGhc e2
return $ fd1 <> fd2
expr ((GHC.ELazyPat e))
= hsFreeAndDeclaredGhc e
expr ((GHC.HsType typ))
= hsFreeAndDeclaredGhc typ
expr ((GHC.HsWrap _wrap e))
= hsFreeAndDeclaredGhc e
expr ((GHC.HsUnboundVar _)) = return emptyFD
-- -----------------------
name :: GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
name n = return (FN [],DN [n])
-- -----------------------
lstmts :: [GHC.LStmt GHC.Name (GHC.LHsExpr GHC.Name)] -> RefactGhc (FreeNames,DeclaredNames)
lstmts ss = recurseList ss
lstmt :: GHC.LStmt GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc (FreeNames,DeclaredNames)
lstmt (GHC.L _ (GHC.LastStmt e _)) = hsFreeAndDeclaredGhc e
lstmt (GHC.L _ (GHC.BindStmt pa e _ _)) = do
fdp <- hsFreeAndDeclaredGhc pa
fde <- hsFreeAndDeclaredGhc e
return (fdp <> fde)
lstmt (GHC.L _ (GHC.BodyStmt e _ _ _)) = hsFreeAndDeclaredGhc e
-- lstmt (GHC.L _ (GHC.ExprStmt e _ _ _)) = hsFreeAndDeclaredGhc e
lstmt (GHC.L _ (GHC.LetStmt bs)) = hsFreeAndDeclaredGhc bs
lstmt (GHC.L _ (GHC.ParStmt ps _ _)) = hsFreeAndDeclaredGhc ps
lstmt (GHC.L _ (GHC.TransStmt _ stmts _ using mby _ _ _)) = do
fds <- hsFreeAndDeclaredGhc stmts
fdu <- hsFreeAndDeclaredGhc using
fdb <- case mby of
Nothing -> return emptyFD
Just e -> hsFreeAndDeclaredGhc e
return $ fds <> fdu <> fdb
lstmt (GHC.L _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _)) = hsFreeAndDeclaredGhc stmts
-- -----------------------
lhstype :: GHC.LHsType GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
lhstype (GHC.L _ typ) = hstype typ
-- -----------------------
hstype :: GHC.HsType GHC.Name -> RefactGhc (FreeNames,DeclaredNames)
hstype (GHC.HsForAllTy _ _ _ _ typ) = hsFreeAndDeclaredGhc typ
hstype (GHC.HsTyVar n) = return (FN [],DN [n])
hstype (GHC.HsAppTy t1 t2) = recurseList [t1,t2]
hstype (GHC.HsFunTy t1 t2) = recurseList [t1,t2]
hstype (GHC.HsListTy typ) = hsFreeAndDeclaredGhc typ
hstype (GHC.HsPArrTy typ) = hsFreeAndDeclaredGhc typ
hstype (GHC.HsTupleTy _ typs) = recurseList typs
hstype (GHC.HsOpTy t1 _ t2) = recurseList [t1,t2]
hstype (GHC.HsParTy typ) = hsFreeAndDeclaredGhc typ
hstype (GHC.HsIParamTy _ typ) = hsFreeAndDeclaredGhc typ
hstype (GHC.HsEqTy t1 t2) = recurseList [t1,t2]
hstype (GHC.HsKindSig t1 t2) = recurseList [t1,t2]
hstype (GHC.HsQuasiQuoteTy _) = return emptyFD
hstype (GHC.HsSpliceTy _ _) = return (FN [],DN [])
hstype (GHC.HsDocTy _ typ) = hsFreeAndDeclaredGhc typ
hstype (GHC.HsBangTy _ typ) = hsFreeAndDeclaredGhc typ
hstype (GHC.HsRecTy cons) = recurseList cons
hstype (GHC.HsCoreTy _) = return emptyFD
hstype (GHC.HsExplicitListTy _ typs) = recurseList typs
hstype (GHC.HsExplicitTupleTy _ typs) = recurseList typs
hstype (GHC.HsTyLit _) = return emptyFD
hstype (GHC.HsWrapTy _ typ) = hsFreeAndDeclaredGhc typ
hstype (GHC.HsWildcardTy) = error "To implement: hstype, HsWildcardTy"
hstype (GHC.HsNamedWildcardTy _) = error "To implement: HsNamedWildcardTy"
-- -----------------------
grhs_s :: [GHC.LGRHS GHC.Name (GHC.LHsExpr GHC.Name)] -> RefactGhc (FreeNames,DeclaredNames)
grhs_s gs = recurseList gs
-- -----------------------
grhs :: GHC.LGRHS GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc (FreeNames,DeclaredNames)
grhs (GHC.L _ (GHC.GRHS stmts e)) = do
fds <- hsFreeAndDeclaredGhc stmts
fde <- hsFreeAndDeclaredGhc e
return $ fds <> fde
-- -----------------------
grhsss :: [GHC.GRHSs GHC.Name (GHC.LHsExpr GHC.Name)] -> RefactGhc (FreeNames,DeclaredNames)
grhsss gs = recurseList gs
-- -----------------------
grhss :: GHC.GRHSs GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc (FreeNames,DeclaredNames)
grhss (GHC.GRHSs g binds) = do
(fg,_dg) <- hsFreeAndDeclaredGhc g
fdb <- hsFreeAndDeclaredGhc binds
return $ (fg,DN[]) <> fdb
-- -----------------------
matchgroup :: GHC.MatchGroup GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc (FreeNames,DeclaredNames)
matchgroup (GHC.MG matches _ _ _) = recurseList matches
-- -----------------------
lmatches :: [GHC.LMatch GHC.Name (GHC.LHsExpr GHC.Name)] -> RefactGhc (FreeNames,DeclaredNames)
lmatches ms = recurseList ms
-- -----------------------
lmatch :: GHC.LMatch GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc (FreeNames,DeclaredNames)
lmatch (GHC.L _ _m@(GHC.Match _fn pats _ rhs)) = do
(fp,DN dp) <- recurseList pats
(FN fr,DN dr) <- hsFreeAndDeclaredGhc rhs
let r = (fp,DN []) <> (FN (fr \\ (dr ++ dp)), DN [])
return $ r
-- -----------------------
hsrecordbinds :: (GHC.HsRecordBinds GHC.Name) -> RefactGhc (FreeNames,DeclaredNames)
hsrecordbinds (GHC.HsRecFields fields _) = recurseList fields
hsrecordbind :: (GHC.HsRecField GHC.Name (GHC.LHsExpr GHC.Name)) -> RefactGhc (FreeNames,DeclaredNames)
hsrecordbind (GHC.HsRecField (GHC.L _ n) arg _) = do
fda <- hsFreeAndDeclaredGhc arg
return $ (FN [n],DN []) <> fda
-- -----------------------
err = do
logm $ "hsFreeAndDeclaredGhc:not matched:"
++ show (annGetConstr t) ++ ":"
++ (SYB.showData SYB.Renamer 0 t)
return emptyFD
-- ---------------------------------
recurseList xs = do
fds <- mapM hsFreeAndDeclaredGhc xs
return $ mconcat fds
-- ---------------------------------------------------------------------
-- |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
(GHC.FamDecl (GHC.FamilyDecl _ ln _ _)) -> return [rdrName2NamePure nm ln]
(GHC.SynDecl ln _ _ _) -> return [rdrName2NamePure nm ln]
(GHC.DataDecl ln _ defn _) -> do
let dds = concatMap (GHC.con_names . GHC.unLoc) $ GHC.dd_cons defn
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]
getLSig (GHC.L _ (GHC.TypeSig ns _ _)) = map (rdrName2NamePure nm) ns
getLSig (GHC.L _ (GHC.GenericSig ns _)) = map (rdrName2NamePure nm) ns
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 _)) = []
getLSig (GHC.L _ (GHC.PatSynSig _ _ _ _ _)) = error "To implement: getLSig PatSynSig"
getLSig (GHC.L _ (GHC.MinimalSig _ _)) = error "To implement: getLSig PatSynSig"
ssn = concatMap getLSig sigs
-- msn = getDeclaredVars $ hsBinds meths
getDeclaredTypesRdr _ = return []
-- |Get the names of all types declared in the given declaration
getDeclaredTypes :: GHC.LTyClDecl GHC.Name -> [GHC.Name]
getDeclaredTypes (GHC.L _ (GHC.FamDecl (GHC.FamilyDecl _ (GHC.L _ n) _ _))) = [n]
getDeclaredTypes (GHC.L _ (GHC.SynDecl (GHC.L _ n) _ _ _)) = [n]
getDeclaredTypes (GHC.L _ (GHC.DataDecl (GHC.L _ n) _ defn _)) = n:dds
where dds = map GHC.unLoc $ concatMap (GHC.con_names . GHC.unLoc) $ GHC.dd_cons defn
getDeclaredTypes (GHC.L _ (GHC.ClassDecl _ (GHC.L _ n) _vars _fds sigs meths _ats _atdefs _ _fvs))
= nub $ [n] ++ ssn ++ msn -- ++ asn
where
getLSig :: GHC.LSig GHC.Name -> [GHC.Name]
getLSig (GHC.L _ (GHC.TypeSig ns _ _)) = map GHC.unLoc ns
getLSig (GHC.L _ (GHC.GenericSig ns _)) = map GHC.unLoc ns
getLSig (GHC.L _ (GHC.IdSig _n)) = []
getLSig (GHC.L _ (GHC.InlineSig (GHC.L _ n2) _)) = [n2]
getLSig (GHC.L _ (GHC.SpecSig (GHC.L _ n2) _ _)) = [n2]
getLSig (GHC.L _ (GHC.SpecInstSig _ _)) = []
getLSig (GHC.L _ (GHC.FixSig _)) = []
getLSig (GHC.L _ (GHC.PatSynSig _ _ _ _ _)) = error "To implement: getLSig PatSynSig"
getLSig (GHC.L _ (GHC.MinimalSig _ _)) = error "To implement: getLSig PatSynSig"
ssn = concatMap getLSig sigs
msn = getDeclaredVars $ hsBinds meths
-- ---------------------------------------------------------------------
-- | Return the list of identifiers (in PName format) defined by a
-- function\/pattern binding.
definedPNs :: GHC.LHsBind GHC.Name -> [GHC.Name]
definedPNs (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _)) = [pname]
definedPNs (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _)) = (hsNamess p)
definedPNs (GHC.L _ (GHC.VarBind pname _rhs _)) = [pname]
-- AbsBinds and ValBinds will never occur in ParsedSource
definedPNs _ = []
definedPNsRdr :: GHC.LHsDecl GHC.RdrName -> [GHC.Located GHC.RdrName]
definedPNsRdr (GHC.L _ (GHC.ValD (GHC.FunBind pname _ _ _ _ _))) = [pname]
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
-- ++AZ++:TODO: now we are processing decls again, reinstate incTypeSig function
where
defining decl
= if recursive
then SYB.everythingStaged SYB.Parser (++) [] ([] `SYB.mkQ` definesDecl `SYB.extQ` definesBind) decl
else definesDecl decl
where
definesDecl :: (GHC.LHsDecl GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName]
definesDecl decl'@(GHC.L _ (GHC.ValD (GHC.FunBind _ _ _ _ _ _)))
| 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 _ = []
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' _ = []
definesBind :: (GHC.LHsBind GHC.RdrName) -> [GHC.LHsDecl GHC.RdrName]
definesBind (GHC.L l b) = defines' (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.
definingDeclsNames::
[GHC.Name] -- ^ The specified identifiers.
->[GHC.LHsBind GHC.Name] -- ^ A collection of declarations.
->Bool -- ^ True means to include the type signature.
->Bool -- ^ True means to look at the local declarations as well.
->[GHC.LHsBind GHC.Name] -- ^ The result.
definingDeclsNames pns ds _incTypeSig recursive = concatMap defining ds
where
defining decl
= if recursive
then SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` defines') decl
else defines' decl
where
defines' :: (GHC.LHsBind GHC.Name) -> [GHC.LHsBind GHC.Name]
defines' decl'@(GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _))
|isJust (find (==(pname)) pns) = [decl']
defines' decl'@(GHC.L _l (GHC.PatBind p _rhs _ty _fvs _))
|(hsNamess p) `intersect` pns /= [] = [decl']
defines' _ = []
-- |Find those declarations(function\/pattern binding) which define
-- the specified GHC.Names. incTypeSig indicates whether the
-- corresponding type signature will be included.
definingDeclsNames':: (SYB.Data t)
=> [GHC.Name] -- ^ The specified identifiers.
-> t -- ^ A collection of declarations.
->[GHC.LHsBind GHC.Name] -- ^ The result.
definingDeclsNames' pns t = defining t
where
defining decl
= SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` defines') decl
where
defines' :: (GHC.LHsBind GHC.Name) -> [GHC.LHsBind GHC.Name]
defines' decl'@(GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _))
|isJust (find (==(pname)) pns) = [decl']
defines' decl'@(GHC.L _l (GHC.PatBind p _rhs _ty _fvs _))
|(hsNamess p) `intersect` pns /= [] = [decl']
defines' _ = []
-- ---------------------------------------------------------------------
-- |Find those type signatures for the specified GHC.Names.
definingSigsNames :: (SYB.Data t) =>
[GHC.Name] -- ^ The specified identifiers.
->t -- ^ A collection of declarations.
->[GHC.LSig GHC.Name] -- ^ The result.
definingSigsNames pns ds = def ds
where
def decl
= SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` inSig) decl
where
inSig :: (GHC.LSig GHC.Name) -> [GHC.LSig GHC.Name]
inSig (GHC.L l (GHC.TypeSig ns t p))
| defines' ns /= [] = [(GHC.L l (GHC.TypeSig (defines' ns) t p))]
inSig _ = []
defines' (p::[GHC.Located GHC.Name])
= filter (\(GHC.L _ n) -> n `elem` pns) p
-- ---------------------------------------------------------------------
-- |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]
inSig (GHC.L l (GHC.TypeSig ns t p))
| defines' ns /= [] = [(GHC.L l (GHC.TypeSig (defines' ns) t p))]
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)
=> [GHC.Name] -- ^ The specified identifiers.
-> t -- ^ A collection of declarations.
->[GHC.LTyClDecl GHC.Name] -- ^ The result.
definingTyClDeclsNames pns t = defining t
where
defining decl
= SYB.everythingStaged SYB.Renamer (++) []
([] `SYB.mkQ` defines') decl
where
defines' :: (GHC.LTyClDecl GHC.Name) -> [GHC.LTyClDecl GHC.Name]
defines' decl'@(GHC.L _ (GHC.FamDecl (GHC.FamilyDecl _ (GHC.L _ pname) _ _)))
|isJust (find (==(pname)) pns) = [decl']
| otherwise = []
defines' decl'@(GHC.L _ (GHC.SynDecl (GHC.L _ pname) _ _ _))
|isJust (find (==(pname)) pns) = [decl']
| otherwise = []
defines' decl'@(GHC.L _ (GHC.DataDecl (GHC.L _ pname) _ _ _))
|isJust (find (==(pname)) pns) = [decl']
| otherwise = []
defines' decl'@(GHC.L _ (GHC.ClassDecl _ (GHC.L _ pname) _ _ _ _ _ _ _ _))
|isJust (find (==(pname)) pns) = [decl']
| otherwise = []
-- ---------------------------------------------------------------------
-- | Return True if the function\/pattern binding defines the
-- specified identifier.
defines:: GHC.Name -> GHC.LHsBind GHC.Name -> Bool
defines n (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _ _))
= GHC.nameUnique pname == GHC.nameUnique n
defines n (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _))
= elem (GHC.nameUnique n) (map GHC.nameUnique $ hsNamess p)
defines _ _= False
-- | Return True if the function\/pattern binding defines the
-- specified identifier.
definesRdr :: NameMap -> GHC.Name -> GHC.LHsBind GHC.RdrName -> Bool
definesRdr nameMap nin (GHC.L _ (GHC.FunBind (GHC.L ln _pname) _ _ _ _ _)) =
case Map.lookup ln nameMap of
Nothing -> False
Just n -> GHC.nameUnique n == GHC.nameUnique nin
definesRdr nameMap n (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _)) =
elem n (map (rdrName2NamePure nameMap) (hsNamessRdr p))
definesRdr _ _ _= False
-- |Unwraps a LHsDecl and calls definesRdr on the result if a HsBind
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 _ _ _ = False
definesP::PName -> HsDeclP ->Bool
definesP pn (GHC.L _ (GHC.ValD (GHC.FunBind (GHC.L _ pname) _ _ _ _ _)))
= PN pname == pn
definesP pn (GHC.L _ (GHC.ValD (GHC.PatBind p _rhs _ty _fvs _)))
= elem pn (hsPNs p)
definesP _ _= False
-- ---------------------------------------------------------------------
-- | Return True if the declaration defines the type signature of the
-- specified identifier.
definesTypeSig :: GHC.Name -> GHC.LSig GHC.Name -> Bool
definesTypeSig pn (GHC.L _ (GHC.TypeSig names _typ _)) = elem (GHC.nameUnique pn) $ map (\(GHC.L _ n)->GHC.nameUnique n) names
definesTypeSig _ _ = False
-- | Return True if the declaration defines the type signature of the
-- specified identifier.
definesTypeSigRdr :: NameMap -> GHC.Name -> GHC.Sig GHC.RdrName -> Bool
definesTypeSigRdr nameMap pn (GHC.TypeSig names _typ _)
= 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
-- ---------------------------------------------------------------------
-- |Find all Located Names in the given Syntax phrase.
allNames::(SYB.Data t)
=>t -- ^ The syntax phrase
->[GHC.Located GHC.Name] -- ^ The result
allNames t
= res
where
res = SYB.everythingStaged SYB.Parser (++) []
([] `SYB.mkQ` worker `SYB.extQ` workerBind `SYB.extQ` workerExpr) t
worker (pnt :: (GHC.Located GHC.Name))
= [pnt]
-- worker _ = []
workerBind (GHC.L l (GHC.VarPat name) :: (GHC.Located (GHC.Pat GHC.Name)))
= [(GHC.L l name)]
workerBind _ = []
workerExpr ((GHC.L l (GHC.HsVar name)) :: (GHC.Located (GHC.HsExpr GHC.Name)))
= [(GHC.L l name)]
workerExpr _ = []
-- ---------------------------------------------------------------------
-- |Get all the names in the given syntax element
hsNamess :: (SYB.Data t) => t -> [GHC.Name]
hsNamess t = nub $ concat res
where
res = SYB.everythingStaged SYB.Renamer (++) [] ([] `SYB.mkQ` inName) t
inName (pname :: GHC.Name) = return [pname]
-- |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
-- ---------------------------------------------------------------------
getDeclaredVarsRdr :: NameMap -> [GHC.LHsDecl GHC.RdrName] -> [GHC.Name]
getDeclaredVarsRdr nm bs = concatMap vars bs
where
vars :: (GHC.LHsDecl GHC.RdrName) -> [GHC.Name]
vars (GHC.L _ (GHC.ValD (GHC.FunBind ln _ _ _ _fvs _))) = [rdrName2NamePure nm ln]
vars (GHC.L _ (GHC.ValD (GHC.PatBind p _rhs _ty _fvs _))) = (hsNamess p)
vars _ = []
getDeclaredVars :: [GHC.LHsBind GHC.Name] -> [GHC.Name]
getDeclaredVars bs = concatMap vars bs
where
vars :: (GHC.LHsBind GHC.Name) -> [GHC.Name]
vars (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ _fvs _)) = [pname]
vars (GHC.L _ (GHC.PatBind p _rhs _ty _fvs _)) = (hsNamess p)
vars _ = []
-- ---------------------------------------------------------------------
-- |Experiment with GHC fvs stuff
getFvs :: [GHC.LHsBind GHC.Name] -> [([GHC.Name], GHC.NameSet)]
getFvs bs = concatMap binds bs
where
binds :: (GHC.LHsBind GHC.Name) -> [([GHC.Name],GHC.NameSet)]
binds (GHC.L _ (GHC.FunBind (GHC.L _ pname) _ _ _ fvs _)) = [([pname], fvs)]
binds (GHC.L _ (GHC.PatBind p _rhs _ty fvs _)) = [((hsNamess p),fvs)]
binds _ = []
getFreeVars :: [GHC.LHsBind GHC.Name] -> [GHC.Name]
getFreeVars bs = concatMap binds bs
where
binds :: (GHC.LHsBind GHC.Name) -> [GHC.Name]
binds (GHC.L _ (GHC.FunBind (GHC.L _ _pname) _ _ _ fvs _)) = (GHC.nameSetElems fvs)
binds (GHC.L _ (GHC.PatBind _p _rhs _ty fvs _)) = (GHC.nameSetElems fvs)
binds _ = []
------------------------------------------------------------------------
-- | Given syntax phrases e and t, if e occurs in t, then return those
-- variables which are declared in t and accessible to e, otherwise
-- return [].
hsVisiblePNs :: (FindEntity e,HsValBinds t GHC.Name,GHC.Outputable e)
=> e -> t -> RefactGhc [GHC.Name]
hsVisiblePNs e t = do
(DN d) <- hsVisibleDs e t
return d
--------------------------------------------------------------------------------
-- | Same as `hsVisiblePNs' except that the returned identifiers are
-- in String format.
hsVisibleNames:: (FindEntity t1,HsValBinds t2 GHC.Name,GHC.Outputable t1)
=> t1 -> t2 -> RefactGhc [String]
hsVisibleNames e t = do
d <- hsVisiblePNs e t
return ((nub . map showGhc) d)
--------------------------------------------------------------------------------
-- | Same as `hsVisiblePNs' except that the returned identifiers are
-- in String format.
hsVisibleNamesRdr:: (FindEntity t1,SYB.Data t2,GHC.Outputable t1)
=> t1 -> t2 -> RefactGhc [String]
hsVisibleNamesRdr e t = do
nm <- getRefactNameMap
d <- hsVisiblePNsRdr nm e t
return ((nub . map showGhc) d)
------------------------------------------------------------------------
-- | Given syntax phrases e and t, if e occurs in t, then return those
-- variables which are declared in t and accessible to e, otherwise
-- return [].
hsVisiblePNsRdr :: (FindEntity e,SYB.Data t,GHC.Outputable e)
=> NameMap -> e -> t -> RefactGhc [GHC.Name]
hsVisiblePNsRdr nm e t = do
(DN d) <- hsVisibleDsRdr nm e t
return d
------------------------------------------------------------------------
-- | Given syntax phrases e and t, if e occurs in t, then return those
-- variables which are declared in t and accessible to e, otherwise
-- return [].
hsVisibleDsRdr :: (FindEntity e, GHC.Outputable e,SYB.Data t)
=> NameMap -> e -> t -> RefactGhc DeclaredNames
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.
res = (const err -- (DN [])
`SYB.extQ` parsed
`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` grhss
`SYB.extQ` lgrhs
`SYB.extQ` lexpr
`SYB.extQ` tyclgroups
`SYB.extQ` tyclgroup
`SYB.extQ` tycldeclss
`SYB.extQ` tycldecls
`SYB.extQ` tycldecl
`SYB.extQ` instdecls
`SYB.extQ` instdecl
`SYB.extQ` lhstype
`SYB.extQ` lsigs
`SYB.extQ` lsig
) t
-- err2 = error $ "hsVisibleDsRdr:err2:no match for:" ++ (SYB.showData SYB.Renamer 0 t)
parsed :: GHC.ParsedSource -> RefactGhc DeclaredNames
parsed p
| findEntity 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 [])
valbinds :: (GHC.HsValBindsLR GHC.RdrName GHC.RdrName) -> RefactGhc DeclaredNames
valbinds vb@(GHC.ValBindsIn bindsBag sigs)
| findEntity e vb = do
fdsb <- mapM (hsVisibleDsRdr nm e) $ hsBinds bindsBag
fdss <- mapM (hsVisibleDsRdr nm e) sigs
return $ mconcat fdss <> mconcat fdsb
valbinds vb@(GHC.ValBindsOut _binds _sigs)
| findEntity 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
| findEntity 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.LHsBindsLR GHC.RdrName 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
| findEntity e ds = do
fds <- mapM (hsVisibleDsRdr nm e) ds
return $ mconcat fds
hsbinds _ = return (DN [])
hsbind :: (GHC.LHsBind GHC.RdrName) -> RefactGhc DeclaredNames
hsbind ((GHC.L _ (GHC.FunBind _n _ (GHC.MG matches _ _ _) _ _ _)))
| findEntity e matches = do
fds <- mapM (hsVisibleDsRdr nm e) matches
logm $ "hsVisibleDsRdr.hsbind:fds=" ++ show fds
return $ mconcat fds
hsbind _ = do
logm $ "hsVisibleDsRdr.hsbind:miss"
return (DN [])
hslocalbinds :: (GHC.HsLocalBinds GHC.RdrName) -> RefactGhc DeclaredNames
hslocalbinds (GHC.HsValBinds binds)
| findEntity e binds = hsVisibleDsRdr nm e binds
hslocalbinds (GHC.HsIPBinds binds)
| findEntity 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 _ (GHC.Match _fn pats _mtyp rhs))
| findEntity e pats = do
logm $ "hsVisibleDsRdr nm.lmatch:in pats="
return (DN []) -- TODO: extend this
| findEntity e rhs = 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
return (pd <> rd)
lmatch _ =return (DN [])
grhss :: (GHC.GRHSs GHC.RdrName (GHC.LHsExpr GHC.RdrName)) -> RefactGhc DeclaredNames
grhss (GHC.GRHSs guardedRhss lstmts)
| findEntity e guardedRhss = do
logm "hsVisibleDsRdr nm.grhss:about to do grhss"
fds <- mapM (hsVisibleDsRdr nm e) guardedRhss
logm "hsVisibleDsRdr nm.grhss:grhss done"
return $ mconcat fds
| findEntity e lstmts = do
logm "hsVisibleDsRdr nm.grhss:about to do lstmts"
hsVisibleDsRdr nm e lstmts
grhss _ = return (DN [])
lgrhs :: GHC.LGRHS GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc DeclaredNames
lgrhs (GHC.L _ (GHC.GRHS guards ex))
| findEntity e guards = logm "hsVisibleDsRdr nm.lgrhs.guards" >> hsVisibleDsRdr nm e guards
| findEntity e ex = logm "hsVisibleDsRdr nm.lgrhs.ex" >> hsVisibleDsRdr nm e ex
lgrhs _ = return (DN [])
lexpr :: GHC.LHsExpr GHC.RdrName -> RefactGhc DeclaredNames
lexpr (GHC.L l (GHC.HsVar n))
| findEntity e n = do
logm $ "hsVisibleDsRdr.lexpr.HsVar entity found"
return (DN [rdrName2NamePure nm (GHC.L l n)])
lexpr (GHC.L _ (GHC.HsLet lbinds expr))
| findEntity e lbinds || findEntity e expr = do
logm $ "hsVisibleDsRdr.lexpr.HsLet entity found"
let (_,lds) = hsFreeAndDeclaredRdr nm lbinds
let (_,eds) = hsFreeAndDeclaredRdr nm expr
return $ lds <> eds
lexpr expr
| findEntity e expr = do
logm $ "hsVisibleDsRdr nm.lexpr.(e,expr):" ++ (showGhc (e,expr))
let (FN efs,_) = hsFreeAndDeclaredRdr nm expr
let (FN _eefs,DN eeds) = hsFreeAndDeclaredRdr nm e
logm $ "hsVisibleDsRdr nm.lexpr done"
-- return (DN e1fs <> DN eofs <> DN e2fs)
return (DN (efs \\ eeds))
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
| findEntity 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)
| findEntity e tyclds = do
fds <- mapM (hsVisibleDsRdr nm e) tyclds
return $ mconcat fds
tyclgroup _ = return (DN [])
tycldeclss :: [[GHC.LTyClDecl GHC.RdrName]] -> RefactGhc DeclaredNames
tycldeclss tcds
| findEntity e tcds = do
fds <- mapM (hsVisibleDsRdr nm e) tcds
return $ mconcat fds
tycldeclss _ = return (DN [])
tycldecls :: [GHC.LTyClDecl GHC.RdrName] -> RefactGhc DeclaredNames
tycldecls tcds
| findEntity e tcds = do
logm $ "hsVisibleDsRdr.tycldecls"
fds <- mapM (hsVisibleDsRdr nm e) tcds
logm $ "hsVisibleDsRdr.tycldecls done"
return $ mconcat fds
tycldecls _ = return (DN [])
tycldecl :: GHC.LTyClDecl GHC.RdrName -> RefactGhc DeclaredNames
tycldecl tcd
| findEntity e tcd = do
logm $ "hsVisibleDsRdr.tycldecl"
let (_,ds) = hsFreeAndDeclaredRdr nm tcd
logm $ "hsVisibleDsRdr.tycldecl done"
return ds
tycldecl _ = return (DN [])
-- ---------------------------------
instdecls :: [GHC.LInstDecl GHC.RdrName] -> RefactGhc DeclaredNames
instdecls ds
| findEntity 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 _)))
| findEntity e polytyp = hsVisibleDsRdr nm e polytyp
| findEntity e binds = hsVisibleDsRdr nm e binds
| findEntity e sigs = hsVisibleDsRdr nm e sigs
| findEntity e tyfaminsts = hsVisibleDsRdr nm e tyfaminsts
| findEntity e dfaminsts = hsVisibleDsRdr nm e dfaminsts
| otherwise = return (DN [])
instdecl (GHC.L _ (GHC.DataFamInstD (GHC.DataFamInstDecl _ln pats defn _)))
| findEntity e pats = hsVisibleDsRdr nm e pats
| findEntity e defn = hsVisibleDsRdr nm e defn
| otherwise = return (DN [])
instdecl (GHC.L _ (GHC.TyFamInstD (GHC.TyFamInstDecl eqn _)))
| findEntity e eqn = hsVisibleDsRdr nm e eqn
| otherwise = return (DN [])
lhstype :: GHC.LHsType GHC.RdrName -> RefactGhc DeclaredNames
lhstype tv@(GHC.L l (GHC.HsTyVar n))
| findEntity e tv = return (DN [rdrName2NamePure nm (GHC.L l n)])
| otherwise = return (DN [])
lhstype (GHC.L _ (GHC.HsForAllTy _ _ _bndrs _ctxt _typ))
= 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
lsig (GHC.L _ (GHC.TypeSig _ns typ _))
| findEntity e typ = hsVisibleDsRdr nm e typ
lsig (GHC.L _ (GHC.GenericSig _n typ))
| findEntity 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 _))
| findEntity e typ = hsVisibleDsRdr nm e typ
lsig (GHC.L _ (GHC.SpecInstSig _ _)) = return (DN [])
lsig _ = return (DN [])
-- -----------------------
err = error $ "hsVisibleDsRdr nm:no match for:" ++ (SYB.showData SYB.Renamer 0 t)
------------------------------------------------------------------------
-- | Given syntax phrases e and t, if e occurs in t, then return those
-- variables which are declared in t and accessible to e, otherwise
-- return [].
hsVisibleDs :: (FindEntity e, GHC.Outputable e
,SYB.Data t,HsValBinds t GHC.Name)
=> e -> t -> RefactGhc DeclaredNames
hsVisibleDs e t = do
-- logm $ "hsVisibleDs:(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.
res = (const err -- (DN [])
`SYB.extQ` renamed
`SYB.extQ` valbinds
`SYB.extQ` lhsbindslr
`SYB.extQ` hsbinds
`SYB.extQ` hsbind
`SYB.extQ` hslocalbinds
`SYB.extQ` lmatch
`SYB.extQ` grhss
`SYB.extQ` lgrhs
`SYB.extQ` lexpr
`SYB.extQ` tyclgroups
`SYB.extQ` tyclgroup
`SYB.extQ` tycldeclss
`SYB.extQ` tycldecls
`SYB.extQ` tycldecl
`SYB.extQ` instdecls
`SYB.extQ` instdecl
`SYB.extQ` lhstype
`SYB.extQ` lsigs
`SYB.extQ` lsig
) t
renamed :: GHC.RenamedSource -> RefactGhc DeclaredNames
renamed (g,_i,_ex,_d)
| findEntity e g = do
dfds <- hsVisibleDs e $ GHC.hs_valds g
-- logm $ "hsVisibleDs.renamedSource:valds done"
tfds <- hsVisibleDs e $ GHC.hs_tyclds g
-- logm $ "hsVisibleDs.renamedSource:tyclds done"
ifds <- hsVisibleDs e $ GHC.hs_instds g
-- logm $ "hsVisibleDs.renamedSource:instds done"
return $ dfds <> tfds <> ifds
renamed _ = return (DN [])
valbinds :: (GHC.HsValBindsLR GHC.Name GHC.Name) -> RefactGhc DeclaredNames
valbinds vb@(GHC.ValBindsIn bindsBag sigs)
| findEntity e vb = do
fdsb <- mapM (hsVisibleDs e) $ hsBinds bindsBag
fdss <- mapM (hsVisibleDs e) sigs
return $ mconcat fdss <> mconcat fdsb
valbinds vb@(GHC.ValBindsOut binds sigs)
| findEntity e vb = do
-- logm $ "hsVisibleDs.valbinds:ValBindsOut"
fdsb <- mapM (hsVisibleDs e) $ map snd binds
fdss <- mapM (hsVisibleDs e) sigs
return $ mconcat fdss <> mconcat fdsb
valbinds _ = do
-- logm $ "hsVisibleDs.valbinds:not matched"
return (DN [])
lhsbindslr :: GHC.LHsBindsLR GHC.Name GHC.Name -> RefactGhc DeclaredNames
lhsbindslr bs = do
fds <- mapM (hsVisibleDs e) $ GHC.bagToList bs
return $ mconcat fds
hsbinds :: [GHC.LHsBind GHC.Name] -> RefactGhc DeclaredNames
hsbinds ds
| findEntity e ds = do
fds <- mapM (hsVisibleDs e) ds
return $ mconcat fds
hsbinds _ = return (DN [])
hsbind :: (GHC.LHsBind GHC.Name) -> RefactGhc DeclaredNames
hsbind ((GHC.L _ (GHC.FunBind _n _ (GHC.MG matches _ _ _) _ _ _)))
| findEntity e matches = do
fds <- mapM (hsVisibleDs e) matches
-- logm $ "hsVisibleDs.hsbind:fds=" ++ show fds
return $ mconcat fds
hsbind _ = return (DN [])
hslocalbinds :: (GHC.HsLocalBinds GHC.Name) -> RefactGhc DeclaredNames
hslocalbinds (GHC.HsValBinds binds)
| findEntity e binds = hsVisibleDs e binds
hslocalbinds (GHC.HsIPBinds binds)
| findEntity e binds = hsVisibleDs e binds
hslocalbinds (GHC.EmptyLocalBinds) = return (DN [])
hslocalbinds _ = return (DN [])
lmatch :: (GHC.LMatch GHC.Name (GHC.LHsExpr GHC.Name)) -> RefactGhc DeclaredNames
lmatch (GHC.L _ (GHC.Match _fn pats _mtyp rhs))
| findEntity e pats = do
-- logm $ "hsVisibleDs.lmatch:in pats="
return (DN []) -- TODO: extend this
| findEntity e rhs = do
-- logm $ "hsVisibleDs.lmatch:doing rhs"
(_pf,pd) <- hsFreeAndDeclaredGhc pats
-- logm $ "hsVisibleDs.lmatch:(pf,pd)=" ++ (show (pf,pd))
( rd) <- hsVisibleDs e rhs
return (pd <> rd)
lmatch _ =return (DN [])
grhss :: (GHC.GRHSs GHC.Name (GHC.LHsExpr GHC.Name)) -> RefactGhc DeclaredNames
grhss (GHC.GRHSs guardedRhss lstmts)
| findEntity e guardedRhss = do
-- logm "hsVisibleDs.grhss:about to do grhss"
fds <- mapM (hsVisibleDs e) guardedRhss
-- logm "hsVisibleDs.grhss:grhss done"
return $ mconcat fds
| findEntity e lstmts = do
-- logm "hsVisibleDs.grhss:about to do lstmts"
hsVisibleDs e lstmts
grhss _ = return (DN [])
lgrhs :: GHC.LGRHS GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc DeclaredNames
lgrhs (GHC.L _ (GHC.GRHS guards ex))
| findEntity e guards = hsVisibleDs e guards
| findEntity e ex = hsVisibleDs e ex
lgrhs _ = return (DN [])
lexpr :: GHC.LHsExpr GHC.Name -> RefactGhc DeclaredNames
lexpr (GHC.L _ (GHC.HsVar n))
| findEntity e n = return (DN [n])
lexpr (GHC.L _ (GHC.HsLet lbinds expr))
| findEntity e lbinds || findEntity e expr = do
(_,lds) <- hsFreeAndDeclaredGhc lbinds
(_,eds) <- hsFreeAndDeclaredGhc expr
return $ lds <> eds
lexpr expr
| findEntity e expr = do
-- logm $ "hsVisibleDs.lexpr.(e,expr):" ++ (showGhc (e,expr))
(FN efs,_) <- hsFreeAndDeclaredGhc expr
(FN _eefs,DN eeds) <- hsFreeAndDeclaredGhc e
-- logm $ "hsVisibleDs.lexpr done"
-- return (DN e1fs <> DN eofs <> DN e2fs)
return (DN (efs \\ eeds))
lexpr _ = return (DN [])
-- ---------------------------------
tyclgroups :: [GHC.TyClGroup GHC.Name] -> RefactGhc DeclaredNames
tyclgroups tgrps
| findEntity e tgrps = do
fds <- mapM (hsVisibleDs e) tgrps
return $ mconcat fds
tyclgroups _ = return (DN [])
tyclgroup :: GHC.TyClGroup GHC.Name -> RefactGhc DeclaredNames
tyclgroup (GHC.TyClGroup tyclds _roles)
| findEntity e tyclds = do
fds <- mapM (hsVisibleDs e) tyclds
return $ mconcat fds
tyclgroup _ = return (DN [])
tycldeclss :: [[GHC.LTyClDecl GHC.Name]] -> RefactGhc DeclaredNames
tycldeclss tcds
| findEntity e tcds = do
fds <- mapM (hsVisibleDs e) tcds
return $ mconcat fds
tycldeclss _ = return (DN [])
tycldecls :: [GHC.LTyClDecl GHC.Name] -> RefactGhc DeclaredNames
tycldecls tcds
| findEntity e tcds = do
-- logm $ "hsVisibleDs.tycldecls"
fds <- mapM (hsVisibleDs e) tcds
return $ mconcat fds
tycldecls _ = return (DN [])
tycldecl :: GHC.LTyClDecl GHC.Name -> RefactGhc DeclaredNames
tycldecl tcd
| findEntity e tcd = do
-- logm $ "hsVisibleDs.tycldecl"
(_,ds) <- hsFreeAndDeclaredGhc tcd
return ds
tycldecl _ = return (DN [])
-- ---------------------------------
instdecls :: [GHC.LInstDecl GHC.Name] -> RefactGhc DeclaredNames
instdecls ds
| findEntity e ds = do
fds <- mapM (hsVisibleDs e) ds
return $ mconcat fds
instdecls _ = return (DN [])
instdecl :: GHC.LInstDecl GHC.Name -> RefactGhc DeclaredNames
instdecl (GHC.L _ (GHC.ClsInstD (GHC.ClsInstDecl polytyp binds sigs tyfaminsts dfaminsts _)))
| findEntity e polytyp = hsVisibleDs e polytyp
| findEntity e binds = hsVisibleDs e binds
| findEntity e sigs = hsVisibleDs e sigs
| findEntity e tyfaminsts = hsVisibleDs e tyfaminsts
| findEntity e dfaminsts = hsVisibleDs e dfaminsts
| otherwise = return (DN [])
instdecl (GHC.L _ (GHC.DataFamInstD (GHC.DataFamInstDecl _ln pats defn _)))
| findEntity e pats = hsVisibleDs e pats
| findEntity e defn = hsVisibleDs e defn
| otherwise = return (DN [])
instdecl (GHC.L _ (GHC.TyFamInstD (GHC.TyFamInstDecl eqn _)))
| findEntity e eqn = hsVisibleDs e eqn
| otherwise = return (DN [])
lhstype :: GHC.LHsType GHC.Name -> RefactGhc DeclaredNames
lhstype tv@(GHC.L _ (GHC.HsTyVar n))
| findEntity e tv = return (DN [n])
| otherwise = return (DN [])
lhstype (GHC.L _ (GHC.HsForAllTy _ _ _bndrs _ctxt _typ))
= 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.Name] -> RefactGhc DeclaredNames
lsigs ss = do
fds <- mapM (hsVisibleDs e) ss
return $ mconcat fds
-- -----------------------
lsig :: GHC.LSig GHC.Name -> RefactGhc DeclaredNames
lsig (GHC.L _ (GHC.TypeSig _ns typ _))
| findEntity e typ = hsVisibleDs e typ
lsig (GHC.L _ (GHC.GenericSig _n typ))
| findEntity e typ = hsVisibleDs e typ
lsig (GHC.L _ (GHC.IdSig _)) = return (DN [])
lsig (GHC.L _ (GHC.InlineSig _ _)) = return (DN [])
lsig (GHC.L _ (GHC.SpecSig _n typ _))
| findEntity e typ = hsVisibleDs e typ
lsig (GHC.L _ (GHC.SpecInstSig _ _)) = return (DN [])
lsig _ = return (DN [])
-- -----------------------
err = error $ "hsVisibleDs:no match for:" ++ (SYB.showData SYB.Renamer 0 t)
-- ---------------------------------------------------------------------
-- |`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 RenamedSource
hsFDsFromInsideRdr:: (SYB.Data t)
=> NameMap -> t -> RefactGhc (FreeNames,DeclaredNames)
hsFDsFromInsideRdr nm t = do
r <- hsFDsFromInsideRdr' t
return r
where
hsFDsFromInsideRdr' :: (SYB.Data t) => t -> RefactGhc (FreeNames,DeclaredNames)
hsFDsFromInsideRdr' t1 = do
r1 <- applyTU (once_tdTU (failTU `adhocTU` parsed
`adhocTU` decl
`adhocTU` match
`adhocTU` expr
`adhocTU` stmts )) t1
-- let (f',d') = fromMaybe ([],[]) r1
let (FN f',DN d') = r1
return (FN $ nub f', DN $ nub d')
parsed :: GHC.ParsedSource -> RefactGhc (FreeNames,DeclaredNames)
parsed p
= return $ hsFreeAndDeclaredRdr nm p
match :: GHC.Match GHC.RdrName (GHC.LHsExpr GHC.RdrName) -> RefactGhc (FreeNames,DeclaredNames)
match (GHC.Match _fn pats _type rhs) = do
let (FN pf, DN pd) = hsFreeAndDeclaredRdr nm pats
let (FN rf, DN rd) = hsFreeAndDeclaredRdr nm rhs
return (FN $ nub (pf `union` (rf \\ pd)),
DN $ nub (pd `union` rd))
-- ----------------------
decl :: GHC.HsBind GHC.RdrName -> RefactGhc (FreeNames,DeclaredNames)
decl (GHC.FunBind (GHC.L _ _) _ (GHC.MG matches _ _ _) _ _ _) =
do
fds <- mapM 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
let (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
let (FN rf, DN rd) = hsFreeAndDeclaredRdr nm rhs
return
(FN $ nub (pf `union` (rf \\ pd)),
DN $ nub (pd `union` rd))
decl _ = return (FN [],DN [])
-- ----------------------
expr ((GHC.HsLet decls e) :: GHC.HsExpr GHC.RdrName) =
do
let (FN df,DN dd) = hsFreeAndDeclaredRdr nm decls
let (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
let (FN df,DN dd) = hsFreeAndDeclaredRdr nm matches
return (FN $ nub (df `union` (ef \\ dd)), DN $ nub dd)
expr _ = mzero
stmts ((GHC.BindStmt pat e1 e2 e3) :: GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) =
do
let (FN pf,DN pd) = hsFreeAndDeclaredRdr nm pat
let (FN ef,DN _ed) = hsFreeAndDeclaredRdr nm e1
let (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 _ = mzero
-- ---------------------------------------------------------------------
-- |`hsFDsFromInside` is different from `hsFreeAndDeclaredPNs` in
-- that: given an syntax phrase t, `hsFDsFromInside` 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 RenamedSource
hsFDsFromInside:: (SYB.Data t) => t-> RefactGhc ([GHC.Name],[GHC.Name])
hsFDsFromInside t = do
r <- hsFDsFromInside' t
return r
where
hsFDsFromInside' :: (SYB.Data t) => t -> RefactGhc ([GHC.Name],[GHC.Name])
hsFDsFromInside' t1 = do
r1 <- applyTU (once_tdTU (failTU `adhocTU` renamed
`adhocTU` decl
`adhocTU` match
`adhocTU` expr
`adhocTU` stmts )) t1
let (f',d') = r1
return (nub f', nub d')
renamed :: GHC.RenamedSource -> RefactGhc ([GHC.Name],[GHC.Name])
renamed ((grp,_,_,_)::GHC.RenamedSource)
= hsFreeAndDeclaredPNs $ GHC.hs_valds grp
match :: GHC.Match GHC.Name (GHC.LHsExpr GHC.Name) -> RefactGhc ([GHC.Name],[GHC.Name])
match ((GHC.Match _fn pats _type rhs):: GHC.Match GHC.Name (GHC.LHsExpr GHC.Name)) = do
(pf, pd) <- hsFreeAndDeclaredPNs pats
(rf, rd) <- hsFreeAndDeclaredPNs rhs
return (nub (pf `union` (rf \\ pd)),
nub (pd `union` rd))
-- ----------------------
decl :: GHC.HsBind GHC.Name -> RefactGhc ([GHC.Name],[GHC.Name])
decl ((GHC.FunBind (GHC.L _ _) _ (GHC.MG matches _ _ _) _ _ _) :: GHC.HsBind GHC.Name) =
do
fds <- mapM hsFDsFromInside' matches
-- error (show $ nameToString n)
return (nub (concatMap fst fds), nub (concatMap snd fds))
decl ((GHC.PatBind p rhs _ _ _) :: GHC.HsBind GHC.Name) =
do
(pf, pd) <- hsFreeAndDeclaredPNs p
(rf, rd) <- hsFreeAndDeclaredPNs rhs
return
(nub (pf `union` (rf \\ pd)),
nub (pd `union` rd))
decl ((GHC.VarBind p rhs _) :: GHC.HsBind GHC.Name) =
do
(pf, pd) <- hsFreeAndDeclaredPNs p
(rf, rd) <- hsFreeAndDeclaredPNs rhs
return
(nub (pf `union` (rf \\ pd)),
nub (pd `union` rd))
decl _ = return ([],[])
-- ----------------------
expr ((GHC.HsLet decls e) :: GHC.HsExpr GHC.Name) =
do
(df,dd) <- hsFreeAndDeclaredPNs decls
(ef,_) <- hsFreeAndDeclaredPNs e
return (nub (df `union` (ef \\ dd)), nub dd)
expr ((GHC.HsLam (GHC.MG matches _ _ _)) :: GHC.HsExpr GHC.Name) =
hsFreeAndDeclaredPNs matches
expr ((GHC.HsCase e (GHC.MG matches _ _ _)) :: GHC.HsExpr GHC.Name) =
do
(ef,_) <- hsFreeAndDeclaredPNs e
(df,dd) <- hsFreeAndDeclaredPNs matches
return (nub (df `union` (ef \\ dd)), nub dd)
expr _ = mzero
stmts ((GHC.BindStmt pat e1 e2 e3) :: GHC.Stmt GHC.Name (GHC.LHsExpr GHC.Name)) =
do
(pf,pd) <- hsFreeAndDeclaredPNs pat
(ef,_ed) <- hsFreeAndDeclaredPNs e1
(df,dd) <- hsFreeAndDeclaredPNs [e2,e3]
return
(nub (pf `union` (((ef \\ dd) `union` df) \\ pd)), nub (pd `union` dd))
stmts ((GHC.LetStmt binds) :: GHC.Stmt GHC.Name (GHC.LHsExpr GHC.Name)) =
hsFreeAndDeclaredPNs binds
stmts _ = mzero
-- | The same as `hsFDsFromInside` except that the returned variables
-- are in the String format
hsFDNamesFromInside::(SYB.Data t) => t -> RefactGhc ([String],[String])
hsFDNamesFromInside t = do
(f,d) <- hsFDsFromInside t
return
((nub.map showGhc) f, (nub.map showGhc) d)
-- | 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
(FN f,DN d) <- hsFDsFromInsideRdr nm t
return
((nub.map showGhc) f, (nub.map showGhc) d)
-- ---------------------------------------------------------------------
rdrName2Name' :: GHC.Located GHC.RdrName -> RefactGhc GHC.Name
rdrName2Name' (GHC.L l rdr) = do
renamed <- getRefactRenamed
let mn = locToName (getGhcLoc l) renamed
return (GHC.unLoc $ gfromJust ("rdrName2Name':failed for:" ++ showGhc (GHC.L l rdr)) mn)
-- ---------------------------------------------------------------------
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
-- ---------------------------------------------------------------------
-- |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.
locToName::(SYB.Data t)
=>SimpPos -- ^ The row and column number
->t -- ^ The syntax phrase
-> Maybe (GHC.Located GHC.Name) -- ^ The result
locToName (row,col) t = locToName' (row,col) t
-- |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, Eq 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 =
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