Commit 4102e5ce authored by simonpj's avatar simonpj

[project @ 2000-10-25 07:09:52 by simonpj]

More renamer stuff; still in flight
parent b55a5d5d
......@@ -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
......
......@@ -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}
......@@ -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}
......@@ -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}
......
......@@ -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}
......
......@@ -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
......
......@@ -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 :: PackageRuleEnv, -- Ditto RuleEnv
pcs_rules :: PackageRuleBase, -- Ditto RuleEnv
pcs_PRS :: PersistentRenamerState
}
......
This diff is collapsed.
......@@ -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
mapFvRn 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, fvs)
returnRn (goods, hsSigFVs goods)
-- 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 $
rnHsSigType (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}
......
......@@ -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
......
......@@ -18,14 +18,14 @@ module RnExpr (
#include "HsVersions.h"
import {-# SOURCE #-} RnBinds ( rnBinds )
import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType )
import {-# SOURCE #-} RnSource ( rnHsTypeFVs )
import HsSyn
import RdrHsSyn
import RnHsSyn
import RnMonad
import RnEnv
import RnIfaces ( lookupFixityRn )
import RnHiFiles ( 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) ->
rnHsTypeFVs 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) ->
(rnHsTypeFVs (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 -> rnHsTypeFVs 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) ->
rnHsSigType (text "an expression") pty `thenRn` \ (pty', fvTy) ->
= rnExpr expr `thenRn` \ (expr', fvExpr) ->
rnHsTypeFVs (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 ->
......
......@@ -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}
......
......@@ -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
......
......@@ -5,12 +5,12 @@
\begin{code}
module RnIfaces
(
(
getInterfaceExports,
getImportedInstDecls, getImportedRules,
lookupFixityRn,
importDecl, ImportDeclResult(..), recordLocalSlurps,
mkImportInfo, getSlurped,
recordLocalSlurps,
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