Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
4102e5ce
Commit
4102e5ce
authored
Oct 25, 2000
by
simonpj
Browse files
[project @ 2000-10-25 07:09:52 by simonpj]
More renamer stuff; still in flight
parent
b55a5d5d
Changes
22
Expand all
Hide whitespace changes
Inline
Side-by-side
ghc/compiler/basicTypes/MkId.lhs
View file @
4102e5ce
...
...
@@ -570,7 +570,7 @@ mkPrimOpId prim_op
`setArityInfo` exactArity arity
`setStrictnessInfo` strict_info
rules = addRule
id
emptyCoreRules (primOpRule prim_op)
rules = addRule emptyCoreRules
id
(primOpRule prim_op)
-- For each ccall we manufacture a separate CCallOpId, giving it
...
...
ghc/compiler/basicTypes/NameSet.lhs
View file @
4102e5ce
...
...
@@ -9,7 +9,11 @@ module NameSet (
NameSet,
emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets,
minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet,
delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet
delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet,
-- Free variables
FreeVars, isEmptyFVs, emptyFVs, plusFVs, plusFV,
mkFVs, addOneFV, unitFV, delFV, delFVs
) where
#include "HsVersions.h"
...
...
@@ -62,3 +66,34 @@ delListFromNameSet set ns = foldl delFromNameSet set ns
\end{code}
%************************************************************************
%* *
\subsection{Free variables}
%* *
%************************************************************************
These synonyms are useful when we are thinking of free variables
\begin{code}
type FreeVars = NameSet
plusFV :: FreeVars -> FreeVars -> FreeVars
addOneFV :: FreeVars -> Name -> FreeVars
unitFV :: Name -> FreeVars
emptyFVs :: FreeVars
plusFVs :: [FreeVars] -> FreeVars
mkFVs :: [Name] -> FreeVars
delFV :: Name -> FreeVars -> FreeVars
delFVs :: [Name] -> FreeVars -> FreeVars
isEmptyFVs = isEmptyNameSet
emptyFVs = emptyNameSet
plusFVs = unionManyNameSets
plusFV = unionNameSets
mkFVs = mkNameSet
addOneFV = addOneToNameSet
unitFV = unitNameSet
delFV n s = delFromNameSet s n
delFVs ns s = delListFromNameSet s ns
\end{code}
ghc/compiler/basicTypes/RdrName.lhs
View file @
4102e5ce
...
...
@@ -22,7 +22,7 @@ module RdrName (
-- Environment
RdrNameEnv,
emptyRdrEnv, lookupRdrEnv, addListToRdrEnv, rdrEnvElts,
extendRdrEnv, rdrEnvToList,
extendRdrEnv, rdrEnvToList,
elemRdrEnv,
-- Printing; instance Outputable RdrName
pprUnqualRdrName
...
...
@@ -185,6 +185,7 @@ addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a
extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a
rdrEnvToList :: RdrNameEnv a -> [(RdrName, a)]
rdrEnvElts :: RdrNameEnv a -> [a]
elemRdrEnv :: RdrName -> RdrNameEnv a -> Bool
emptyRdrEnv = emptyFM
lookupRdrEnv = lookupFM
...
...
@@ -192,4 +193,5 @@ addListToRdrEnv = addListToFM
rdrEnvElts = eltsFM
extendRdrEnv = addToFM
rdrEnvToList = fmToList
elemRdrEnv = elemFM
\end{code}
ghc/compiler/basicTypes/VarSet.lhs
View file @
4102e5ce
...
...
@@ -7,7 +7,7 @@
module VarSet (
VarSet, IdSet, TyVarSet, UVarSet,
emptyVarSet, unitVarSet, mkVarSet,
extendVarSet,
extendVarSet,
extendVarSet_C,
elemVarSet, varSetElems, subVarSet,
unionVarSet, unionVarSets,
intersectVarSet, intersectsVarSet,
...
...
@@ -18,12 +18,10 @@ module VarSet (
#include "HsVersions.h"
import CmdLineOpts ( opt_PprStyle_Debug )
import Var ( Var, Id, TyVar, UVar, setVarUnique )
import Unique ( Unique, Uniquable(..) )
import Var ( Var, Id, TyVar, UVar )
import Unique ( Unique )
import UniqSet
import UniqFM ( delFromUFM_Directly )
import Outputable
import UniqFM ( delFromUFM_Directly, addToUFM_C )
\end{code}
%************************************************************************
...
...
@@ -59,6 +57,7 @@ mapVarSet :: (Var -> Var) -> VarSet -> VarSet
sizeVarSet :: VarSet -> Int
filterVarSet :: (Var -> Bool) -> VarSet -> VarSet
subVarSet :: VarSet -> VarSet -> Bool
extendVarSet_C :: (Var->Var->Var) -> VarSet -> Var -> VarSet
delVarSetByKey :: VarSet -> Unique -> VarSet
...
...
@@ -80,6 +79,7 @@ lookupVarSet = lookupUniqSet
mapVarSet = mapUniqSet
sizeVarSet = sizeUniqSet
filterVarSet = filterUniqSet
extendVarSet_C combine s x = addToUFM_C combine s x x
a `subVarSet` b = isEmptyVarSet (a `minusVarSet` b)
delVarSetByKey = delFromUFM_Directly -- Can't be bothered to add this to UniqSet
\end{code}
...
...
ghc/compiler/hsSyn/HsCore.lhs
View file @
4102e5ce
...
...
@@ -14,11 +14,11 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
module HsCore (
UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
UfBinding(..), UfConAlt(..),
HsIdInfo(..), pprHsIdInfo,
HsIdInfo(..), pprHsIdInfo,
eq_ufExpr, eq_ufBinders, pprUfExpr,
toUfExpr, toUfBndr
toUfExpr, toUfBndr
, ufBinderName
) where
#include "HsVersions.h"
...
...
@@ -47,7 +47,6 @@ import DataCon ( dataConTyCon )
import TyCon ( isTupleTyCon, tupleTyConBoxity )
import Type ( Kind )
import CostCentre
import SrcLoc ( SrcLoc )
import Outputable
\end{code}
...
...
@@ -92,6 +91,10 @@ data UfBinding name
data UfBinder name
= UfValBinder name (HsType name)
| UfTyBinder name Kind
ufBinderName :: UfBinder name -> name
ufBinderName (UfValBinder n _) = n
ufBinderName (UfTyBinder n _) = n
\end{code}
...
...
ghc/compiler/hsSyn/HsDecls.lhs
View file @
4102e5ce
...
...
@@ -16,7 +16,7 @@ module HsDecls (
DeprecDecl(..), DeprecTxt,
hsDeclName, instDeclName, tyClDeclName, tyClDeclNames,
isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule,
mkClassDeclSysNames,
mkClassDeclSysNames,
isIfaceRuleDecl,
getClassDeclSysNames
) where
...
...
@@ -237,7 +237,6 @@ mkClassDeclSysNames (a,b,c,ds) = a:b:c:ds
getClassDeclSysNames (a:b:c:ds) = (a,b,c,ds)
\end{code}
\begin{code}
isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
...
...
@@ -373,7 +372,7 @@ data ConDecl name
name -- Name of the constructor's 'worker Id'
-- Filled in as the ConDecl is built
[HsTyVarBndr name]
-- Existentially quantified type variables
[HsTyVarBndr name] -- Existentially quantified type variables
(HsContext name) -- ...and context
-- If both are empty then there are no existentials
...
...
@@ -632,6 +631,8 @@ data RuleDecl name pat
name -- Head of LHS
CoreRule
isIfaceRuleDecl (HsRule _ _ _ _ _ _) = False
isIfaceRuleDecl other = True
data RuleBndr name
= RuleBndr name
...
...
ghc/compiler/main/HscTypes.lhs
View file @
4102e5ce
...
...
@@ -52,6 +52,7 @@ import OccName ( OccName )
import Module ( Module, ModuleName, ModuleEnv,
lookupModuleEnv, lookupModuleEnvByName
)
import Rules ( RuleBase )
import VarSet ( TyVarSet )
import VarEnv ( emptyVarEnv )
import Id ( Id )
...
...
@@ -149,7 +150,7 @@ data ModDetails
-- The next three fields are created by the typechecker
md_types :: TypeEnv,
md_insts :: [DFunId], -- Dfun-ids for the instances in this module
md_rules ::
RuleBase
-- Domain may include Ids from other modules
md_rules ::
[(Id,CoreRule)]
-- Domain may include Ids from other modules
}
\end{code}
...
...
@@ -158,7 +159,7 @@ emptyModDetails :: ModDetails
emptyModDetails
= ModDetails { md_types = emptyTypeEnv,
md_insts = [],
md_rules =
emptyRuleBase
md_rules =
[]
}
emptyModIface :: Module -> ModIface
...
...
@@ -386,7 +387,7 @@ data PersistentCompilerState
pcs_insts :: PackageInstEnv, -- The total InstEnv accumulated from all
-- the non-home-package modules
pcs_rules :: PackageRule
Env
, -- Ditto RuleEnv
pcs_rules :: PackageRule
Base
, -- Ditto RuleEnv
pcs_PRS :: PersistentRenamerState
}
...
...
ghc/compiler/rename/Rename.lhs
View file @
4102e5ce
This diff is collapsed.
Click to expand it.
ghc/compiler/rename/RnBinds.lhs
View file @
4102e5ce
...
...
@@ -18,7 +18,7 @@ module RnBinds (
#include "HsVersions.h"
import {-# SOURCE #-} RnSource ( rnHsSigType )
import {-# SOURCE #-} RnSource ( rnHsSigType
, rnHsType
)
import HsSyn
import HsBinds ( eqHsSig, sigName, hsSigDoc )
...
...
@@ -483,11 +483,12 @@ renameSigs :: (RenamedSig -> Bool) -- OK-sig predicate
-> [RdrNameSig]
-> RnMS ([RenamedSig], FreeVars)
renameSigs ok_sig [] = returnRn ([], emptyFVs) -- Common shortcut
renameSigs ok_sig []
= returnRn ([], emptyFVs) -- Common shortcut
renameSigs ok_sig sigs
= -- Rename the signatures
map
Fv
Rn renameSig sigs `thenRn` \
(
sigs'
, fvs)
->
mapRn renameSig sigs `thenRn` \ sigs' ->
-- Check for (a) duplicate signatures
-- (b) signatures for things not in this group
...
...
@@ -499,7 +500,7 @@ renameSigs ok_sig sigs
(goods, bads) = partition ok_sig in_scope
in
mapRn_ unknownSigErr bads `thenRn_`
returnRn (goods,
fv
s)
returnRn (goods,
hsSigFVs good
s)
-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
-- because this won't work for:
...
...
@@ -510,39 +511,39 @@ renameSigs ok_sig sigs
-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.)
-- Doesn't seem worth much trouble to sort this.
renameSig :: Sig RdrName -> RnMS (Sig Name
, FreeVars
)
renameSig :: Sig RdrName -> RnMS (Sig Name)
-- ClassOpSig is renamed elsewhere.
renameSig (Sig v ty src_loc)
= pushSrcLocRn src_loc $
lookupSigOccRn v `thenRn` \ new_v ->
rnHsSigType (quotes (ppr v)) ty `thenRn` \
(
new_ty
,fvs)
->
returnRn (Sig new_v new_ty src_loc
, fvs `addOneFV` new_v
)
rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty ->
returnRn (Sig new_v new_ty src_loc)
renameSig (SpecInstSig ty src_loc)
= pushSrcLocRn src_loc $
rnHs
Sig
Type (text "A SPECIALISE instance pragma") ty `thenRn` \
(
new_ty
, fvs)
->
returnRn (SpecInstSig new_ty src_loc
, fvs
)
rnHsType (text "A SPECIALISE instance pragma") ty `thenRn` \ new_ty ->
returnRn (SpecInstSig new_ty src_loc)
renameSig (SpecSig v ty src_loc)
= pushSrcLocRn src_loc $
lookupSigOccRn v `thenRn` \ new_v ->
rnHsSigType (quotes (ppr v)) ty `thenRn` \
(
new_ty
,fvs)
->
returnRn (SpecSig new_v new_ty src_loc
, fvs `addOneFV` new_v
)
rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty ->
returnRn (SpecSig new_v new_ty src_loc)
renameSig (FixSig (FixitySig v fix src_loc))
= pushSrcLocRn src_loc $
lookupSigOccRn v `thenRn` \ new_v ->
returnRn (FixSig (FixitySig new_v fix src_loc)
, unitFV new_v
)
returnRn (FixSig (FixitySig new_v fix src_loc))
renameSig (InlineSig v p src_loc)
= pushSrcLocRn src_loc $
lookupSigOccRn v `thenRn` \ new_v ->
returnRn (InlineSig new_v p src_loc
, unitFV new_v
)
returnRn (InlineSig new_v p src_loc)
renameSig (NoInlineSig v p src_loc)
= pushSrcLocRn src_loc $
lookupSigOccRn v `thenRn` \ new_v ->
returnRn (NoInlineSig new_v p src_loc
, unitFV new_v
)
returnRn (NoInlineSig new_v p src_loc)
\end{code}
\begin{code}
...
...
ghc/compiler/rename/RnEnv.lhs
View file @
4102e5ce
...
...
@@ -670,25 +670,6 @@ pprAvail (Avail n) = ppr n
%************************************************************************
\begin{code}
type FreeVars = NameSet
plusFV :: FreeVars -> FreeVars -> FreeVars
addOneFV :: FreeVars -> Name -> FreeVars
unitFV :: Name -> FreeVars
emptyFVs :: FreeVars
plusFVs :: [FreeVars] -> FreeVars
mkFVs :: [Name] -> FreeVars
isEmptyFVs = isEmptyNameSet
emptyFVs = emptyNameSet
plusFVs = unionManyNameSets
plusFV = unionNameSets
mkFVs = mkNameSet
-- No point in adding implicitly imported names to the free-var set
addOneFV s n = addOneToNameSet s n
unitFV n = unitNameSet n
-- A useful utility
mapFvRn f xs = mapRn f xs `thenRn` \ stuff ->
let
...
...
ghc/compiler/rename/RnExpr.lhs
View file @
4102e5ce
...
...
@@ -18,14 +18,14 @@ module RnExpr (
#include "HsVersions.h"
import {-# SOURCE #-} RnBinds ( rnBinds )
import {-# SOURCE #-} RnSource ( rnHs
Sig
Type
, rnHsType
)
import {-# SOURCE #-} RnSource ( rnHsType
FVs
)
import HsSyn
import RdrHsSyn
import RnHsSyn
import RnMonad
import RnEnv
import Rn
Ifac
es
( lookupFixityRn )
import Rn
HiFil
es ( lookupFixityRn )
import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts )
import Literal ( inIntRange )
import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity )
...
...
@@ -71,7 +71,7 @@ rnPat (SigPatIn pat ty)
if glaExts
then rnPat pat `thenRn` \ (pat', fvs1) ->
rnHsType doc ty `thenRn` \ (ty', fvs2) ->
rnHsType
FVs
doc ty `thenRn` \ (ty', fvs2) ->
returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
else addErrRn (patSigErr ty) `thenRn_`
...
...
@@ -146,7 +146,7 @@ rnPat (RecPatIn con rpats)
rnRpats rpats `thenRn` \ (rpats', fvs) ->
returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
rnPat (TypePatIn name) =
(rnHsType (text "type pattern") name) `thenRn` \ (name', fvs) ->
(rnHsType
FVs
(text "type pattern") name) `thenRn` \ (name', fvs) ->
returnRn (TypePatIn name', fvs)
\end{code}
...
...
@@ -187,7 +187,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss)
doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts ->
(case maybe_rhs_sig of
Nothing -> returnRn (Nothing, emptyFVs)
Just ty | opt_GlasgowExts -> rnHsType doc_sig ty `thenRn` \ (ty', ty_fvs) ->
Just ty | opt_GlasgowExts -> rnHsType
FVs
doc_sig ty `thenRn` \ (ty', ty_fvs) ->
returnRn (Just ty', ty_fvs)
| otherwise -> addErrRn (patSigErr ty) `thenRn_`
returnRn (Nothing, emptyFVs)
...
...
@@ -411,8 +411,8 @@ rnExpr (RecordUpd expr rbinds)
returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
rnExpr (ExprWithTySig expr pty)
= rnExpr expr `thenRn` \ (expr', fvExpr) ->
rnHs
Sig
Type (text "an expression") pty
`thenRn` \ (pty', fvTy) ->
= rnExpr expr
`thenRn` \ (expr', fvExpr) ->
rnHsType
FVs
(text "an expression
type signature
") pty
`thenRn` \ (pty', fvTy) ->
returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
rnExpr (HsIf p b1 b2 src_loc)
...
...
@@ -422,10 +422,11 @@ rnExpr (HsIf p b1 b2 src_loc)
rnExpr b2 `thenRn` \ (b2', fvB2) ->
returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
rnExpr (HsType a) =
(rnHsType doc a) `thenRn` \ (t, fvT) -> returnRn (HsType t, fvT)
where doc = text "renaming a type pattern"
rnExpr (HsType a)
= rnHsTypeFVs doc a `thenRn` \ (t, fvT) ->
returnRn (HsType t, fvT)
where
doc = text "renaming a type pattern"
rnExpr (ArithSeqIn seq)
= lookupOrigName enumClass_RDR `thenRn` \ enum ->
...
...
ghc/compiler/rename/RnHiFiles.lhs
View file @
4102e5ce
...
...
@@ -9,6 +9,8 @@ module RnHiFiles (
tryLoadInterface, loadOrphanModules,
loadExports, loadFixDecls, loadDeprecs,
lookupFixityRn,
getTyClDeclBinders,
removeContext -- removeContext probably belongs somewhere else
) where
...
...
@@ -541,6 +543,39 @@ readIface wanted_mod file_path
\end{code}
%*********************************************************
%* *
\subsection{Looking up fixities}
%* *
%*********************************************************
This has to be in RnIfaces (or RnHiFiles) because it calls loadHomeInterface
\begin{code}
lookupFixityRn :: Name -> RnMS Fixity
lookupFixityRn name
| isLocallyDefined name
= getFixityEnv `thenRn` \ local_fix_env ->
returnRn (lookupLocalFixity local_fix_env name)
| otherwise -- Imported
-- For imported names, we have to get their fixities by doing a loadHomeInterface,
-- and consulting the Ifaces that comes back from that, because the interface
-- file for the Name might not have been loaded yet. Why not? Suppose you import module A,
-- which exports a function 'f', which is defined in module B. Then B isn't loaded
-- right away (after all, it's possible that nothing from B will be used).
-- When we come across a use of 'f', we need to know its fixity, and it's then,
-- and only then, that we load B.hi. That is what's happening here.
= getHomeIfaceTableRn `thenRn` \ hit ->
loadHomeInterface doc name `thenRn` \ ifaces ->
case lookupTable hit (iPIT ifaces) name of
Just iface -> returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity)
Nothing -> returnRn defaultFixity
where
doc = ptext SLIT("Checking fixity for") <+> ppr name
\end{code}
%*********************************************************
%* *
\subsection{Errors}
...
...
ghc/compiler/rename/RnHsSyn.lhs
View file @
4102e5ce
...
...
@@ -9,10 +9,13 @@ module RnHsSyn where
#include "HsVersions.h"
import HsSyn
import HsCore
import Class ( FunDep, DefMeth(..) )
import TysWiredIn ( tupleTyCon, listTyCon, charTyCon )
import Name ( Name, getName, isTyVarName )
import NameSet
import BasicTypes ( Boxity )
import Maybes ( orElse )
import Outputable
\end{code}
...
...
@@ -65,6 +68,9 @@ tupleTyCon_name boxity n = getName (tupleTyCon boxity n)
extractHsTyVars :: RenamedHsType -> NameSet
extractHsTyVars x = filterNameSet isTyVarName (extractHsTyNames x)
extractFunDepNames :: FunDep Name -> NameSet
extractFunDepNames (ns1, ns2) = mkNameSet ns1 `unionNameSets` mkNameSet ns2
extractHsTyNames :: RenamedHsType -> NameSet
extractHsTyNames ty
= get ty
...
...
@@ -102,6 +108,111 @@ extractHsPredTyNames (HsPIParam n ty)
\end{code}
%************************************************************************
%* *
\subsection{Free variables of declarations}
%* *
%************************************************************************
Return the Names that must be in scope if we are to use this declaration.
In all cases this is set up for interface-file declarations:
- for class decls we ignroe the bindings
- for instance decls likewise, plus the pragmas
- for rule decls, we ignore HsRules
\begin{code}
tyClDeclFVs :: RenamedTyClDecl -> NameSet
tyClDeclFVs (IfaceSig name ty id_infos loc)
= extractHsTyNames ty `plusFV`
plusFVs (map hsIdInfoFVs id_infos)
tyClDeclFVs (TyData _ context _ tyvars condecls _ derivings _ _ _)
= delFVs (map hsTyVarName tyvars) $
extractHsCtxtTyNames context `plusFV`
plusFVs (map conDeclFVs condecls) `plusFV`
mkNameSet (derivings `orElse` [])
tyClDeclFVs (TySynonym _ tyvars ty _)
= delFVs (map hsTyVarName tyvars) (extractHsTyNames ty)
tyClDeclFVs (ClassDecl context _ tyvars fds sigs _ _ src_loc)
= delFVs (map hsTyVarName tyvars) $
extractHsCtxtTyNames context `plusFV`
plusFVs (map extractFunDepNames fds) `plusFV`
plusFVs (map hsSigFVs sigs)
----------------
hsSigFVs (Sig v ty _) = extractHsTyNames ty `addOneFV` v
hsSigFVs (SpecInstSig ty _) = extractHsTyNames ty
hsSigFVs (SpecSig v ty _) = extractHsTyNames ty `addOneFV` v
hsSigFVs (FixSig (FixitySig v _ _)) = unitFV v
hsSigFVs (InlineSig v p _) = unitFV v
hsSigFVs (NoInlineSig v p _) = unitFV v
hsSigFVs (ClassOpSig v dm ty _) = dmFVs dm `plusFV` extractHsTyNames ty `addOneFV` v
dmFVs (Just (DefMeth v)) = unitFV v
dmFVs other = emptyFVs
----------------
instDeclFVs (InstDecl inst_ty _ _ maybe_dfun _)
= extractHsTyNames inst_ty `plusFV`
(case maybe_dfun of { Just n -> unitFV n; Nothing -> emptyFVs })
----------------
ruleDeclFVs (HsRule _ _ _ _ _ _) = emptyFVs
ruleDeclFVs (IfaceRule _ vars _ _ rhs _)
= delFVs (map ufBinderName vars) $
ufExprFVs rhs
----------------
conDeclFVs (ConDecl _ _ tyvars context details _)
= delFVs (map hsTyVarName tyvars) $
extractHsCtxtTyNames context `plusFV`
conDetailsFVs details
conDetailsFVs (VanillaCon btys) = plusFVs (map bangTyFVs btys)
conDetailsFVs (InfixCon bty1 bty2) = bangTyFVs bty1 `plusFV` bangTyFVs bty2
conDetailsFVs (RecCon flds) = plusFVs [bangTyFVs bty | (_, bty) <- flds]
bangTyFVs bty = extractHsTyNames (getBangType bty)
----------------
hsIdInfoFVs (HsUnfold _ unf) = ufExprFVs unf
hsIdInfoFVs (HsWorker n) = unitFV n
hsIdInfoFVs other = emptyFVs
----------------
ufExprFVs (UfVar n) = unitFV n
ufExprFVs (UfLit l) = emptyFVs
ufExprFVs (UfLitLit l ty) = extractHsTyNames ty
ufExprFVs (UfCCall cc ty) = extractHsTyNames ty
ufExprFVs (UfType ty) = extractHsTyNames ty
ufExprFVs (UfTuple tc es) = hsTupConFVs tc `plusFV` plusFVs (map ufExprFVs es)
ufExprFVs (UfLam v e) = ufBndrFVs v (ufExprFVs e)
ufExprFVs (UfApp e1 e2) = ufExprFVs e1 `plusFV` ufExprFVs e2
ufExprFVs (UfCase e n as) = ufExprFVs e `plusFV` delFV n (plusFVs (map ufAltFVs as))
ufExprFVs (UfNote n e) = ufNoteFVs n `plusFV` ufExprFVs e
ufExprFVs (UfLet (UfNonRec b r) e) = ufExprFVs r `plusFV` ufBndrFVs b (ufExprFVs e)
ufExprFVs (UfLet (UfRec prs) e) = foldr ufBndrFVs
(foldr (plusFV . ufExprFVs . snd) (ufExprFVs e) prs)
(map fst prs)
ufBndrFVs (UfValBinder n ty) fvs = extractHsTyNames ty `plusFV` delFV n fvs
ufBndrFVs (UfTyBinder n k) fvs = delFV n fvs
ufAltFVs (con, vs, e) = ufConFVs con `plusFV` delFVs vs (ufExprFVs e)
ufConFVs (UfDataAlt n) = unitFV n
ufConFVs (UfTupleAlt t) = hsTupConFVs t
ufConFVs (UfLitLitAlt _ ty) = extractHsTyNames ty
ufConFVs other = emptyFVs
ufNoteFVs (UfCoerce ty) = extractHsTyNames ty
ufNoteFVs note = emptyFVs
hsTupConFVs (HsTupCon n _) = unitFV n
\end{code}
%************************************************************************
%* *
\subsection{A few functions on generic defintions
...
...
ghc/compiler/rename/RnIfaces.lhs
View file @
4102e5ce
...
...
@@ -5,12 +5,12 @@
\begin{code}
module RnIfaces
(
(
getInterfaceExports,
getImportedInstDecls, getImportedRule
s,
lookupFixityRn
,
importDecl, ImportDeclResult(..), recordLocalSlurps,
mkImportInfo, getSlurped,
recordLocalSlurp
s,
mkImportInfo
,
slurpImpDecls,
RecompileRequired, outOfDate, upToDate, recompileRequired
)
...
...
@@ -27,6 +27,7 @@ import RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl, RdrNameInstDecl )
import RnHiFiles ( tryLoadInterface, loadHomeInterface, loadInterface,
loadOrphanModules
)
import RnSource ( rnTyClDecl, rnDecl )
import RnEnv
import RnMonad
import Name ( Name {-instance NamedThing-}, nameOccName,
...
...
@@ -79,39 +80,6 @@ getInterfaceExports mod_name from
\end{code}
%*********************************************************
%* *
\subsection{Instance declarations are handled specially}
%* *
%*********************************************************
This has to be in RnIfaces (or RnHiFiles) because it calls loadHomeInterface
\begin{code}
lookupFixityRn :: Name -> RnMS Fixity
lookupFixityRn name
| isLocallyDefined name
= getFixityEnv `thenRn` \ local_fix_env ->
returnRn (lookupLocalFixity local_fix_env name)
| otherwise -- Imported
-- For imported names, we have to get their fixities by doing a loadHomeInterface,
-- and consulting the Ifaces that comes back from that, because the interface
-- file for the Name might not have been loaded yet. Why not? Suppose you import module A,
-- which exports a function 'f', which is defined in module B. Then B isn't loaded
-- right away (after all, it's possible that nothing from B will be used).
-- When we come across a use of 'f', we need to know its fixity, and it's then,
-- and only then, that we load B.hi. That is what's happening here.
= getHomeIfaceTableRn `thenRn` \ hit ->
loadHomeInterface doc name `thenRn` \ ifaces ->
case lookupTable hit (iPIT ifaces) name of
Just iface -> returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity)
Nothing -> returnRn defaultFixity
where
doc = ptext SLIT("Checking fixity for") <+> ppr name
\end{code}
%*********************************************************
%* *