Commit 4102e5ce authored by simonpj's avatar simonpj
Browse files

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

More renamer stuff; still in flight
parent b55a5d5d
...@@ -570,7 +570,7 @@ mkPrimOpId prim_op ...@@ -570,7 +570,7 @@ mkPrimOpId prim_op
`setArityInfo` exactArity arity `setArityInfo` exactArity arity
`setStrictnessInfo` strict_info `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 -- For each ccall we manufacture a separate CCallOpId, giving it
......
...@@ -9,7 +9,11 @@ module NameSet ( ...@@ -9,7 +9,11 @@ module NameSet (
NameSet, NameSet,
emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets, emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets,
minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet, 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 ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -62,3 +66,34 @@ delListFromNameSet set ns = foldl delFromNameSet set ns ...@@ -62,3 +66,34 @@ delListFromNameSet set ns = foldl delFromNameSet set ns
\end{code} \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 ( ...@@ -22,7 +22,7 @@ module RdrName (
-- Environment -- Environment
RdrNameEnv, RdrNameEnv,
emptyRdrEnv, lookupRdrEnv, addListToRdrEnv, rdrEnvElts, emptyRdrEnv, lookupRdrEnv, addListToRdrEnv, rdrEnvElts,
extendRdrEnv, rdrEnvToList, extendRdrEnv, rdrEnvToList, elemRdrEnv,
-- Printing; instance Outputable RdrName -- Printing; instance Outputable RdrName
pprUnqualRdrName pprUnqualRdrName
...@@ -185,6 +185,7 @@ addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a ...@@ -185,6 +185,7 @@ addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a
extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a
rdrEnvToList :: RdrNameEnv a -> [(RdrName, a)] rdrEnvToList :: RdrNameEnv a -> [(RdrName, a)]
rdrEnvElts :: RdrNameEnv a -> [a] rdrEnvElts :: RdrNameEnv a -> [a]
elemRdrEnv :: RdrName -> RdrNameEnv a -> Bool
emptyRdrEnv = emptyFM emptyRdrEnv = emptyFM
lookupRdrEnv = lookupFM lookupRdrEnv = lookupFM
...@@ -192,4 +193,5 @@ addListToRdrEnv = addListToFM ...@@ -192,4 +193,5 @@ addListToRdrEnv = addListToFM
rdrEnvElts = eltsFM rdrEnvElts = eltsFM
extendRdrEnv = addToFM extendRdrEnv = addToFM
rdrEnvToList = fmToList rdrEnvToList = fmToList
elemRdrEnv = elemFM
\end{code} \end{code}
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
module VarSet ( module VarSet (
VarSet, IdSet, TyVarSet, UVarSet, VarSet, IdSet, TyVarSet, UVarSet,
emptyVarSet, unitVarSet, mkVarSet, emptyVarSet, unitVarSet, mkVarSet,
extendVarSet, extendVarSet, extendVarSet_C,
elemVarSet, varSetElems, subVarSet, elemVarSet, varSetElems, subVarSet,
unionVarSet, unionVarSets, unionVarSet, unionVarSets,
intersectVarSet, intersectsVarSet, intersectVarSet, intersectsVarSet,
...@@ -18,12 +18,10 @@ module VarSet ( ...@@ -18,12 +18,10 @@ module VarSet (
#include "HsVersions.h" #include "HsVersions.h"
import CmdLineOpts ( opt_PprStyle_Debug ) import Var ( Var, Id, TyVar, UVar )
import Var ( Var, Id, TyVar, UVar, setVarUnique ) import Unique ( Unique )
import Unique ( Unique, Uniquable(..) )
import UniqSet import UniqSet
import UniqFM ( delFromUFM_Directly ) import UniqFM ( delFromUFM_Directly, addToUFM_C )
import Outputable
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -59,6 +57,7 @@ mapVarSet :: (Var -> Var) -> VarSet -> VarSet ...@@ -59,6 +57,7 @@ mapVarSet :: (Var -> Var) -> VarSet -> VarSet
sizeVarSet :: VarSet -> Int sizeVarSet :: VarSet -> Int
filterVarSet :: (Var -> Bool) -> VarSet -> VarSet filterVarSet :: (Var -> Bool) -> VarSet -> VarSet
subVarSet :: VarSet -> VarSet -> Bool subVarSet :: VarSet -> VarSet -> Bool
extendVarSet_C :: (Var->Var->Var) -> VarSet -> Var -> VarSet
delVarSetByKey :: VarSet -> Unique -> VarSet delVarSetByKey :: VarSet -> Unique -> VarSet
...@@ -80,6 +79,7 @@ lookupVarSet = lookupUniqSet ...@@ -80,6 +79,7 @@ lookupVarSet = lookupUniqSet
mapVarSet = mapUniqSet mapVarSet = mapUniqSet
sizeVarSet = sizeUniqSet sizeVarSet = sizeUniqSet
filterVarSet = filterUniqSet filterVarSet = filterUniqSet
extendVarSet_C combine s x = addToUFM_C combine s x x
a `subVarSet` b = isEmptyVarSet (a `minusVarSet` b) a `subVarSet` b = isEmptyVarSet (a `minusVarSet` b)
delVarSetByKey = delFromUFM_Directly -- Can't be bothered to add this to UniqSet delVarSetByKey = delFromUFM_Directly -- Can't be bothered to add this to UniqSet
\end{code} \end{code}
......
...@@ -14,11 +14,11 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and ...@@ -14,11 +14,11 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
module HsCore ( module HsCore (
UfExpr(..), UfAlt, UfBinder(..), UfNote(..), UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
UfBinding(..), UfConAlt(..), UfBinding(..), UfConAlt(..),
HsIdInfo(..), pprHsIdInfo, HsIdInfo(..), pprHsIdInfo,
eq_ufExpr, eq_ufBinders, pprUfExpr, eq_ufExpr, eq_ufBinders, pprUfExpr,
toUfExpr, toUfBndr toUfExpr, toUfBndr, ufBinderName
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -47,7 +47,6 @@ import DataCon ( dataConTyCon ) ...@@ -47,7 +47,6 @@ import DataCon ( dataConTyCon )
import TyCon ( isTupleTyCon, tupleTyConBoxity ) import TyCon ( isTupleTyCon, tupleTyConBoxity )
import Type ( Kind ) import Type ( Kind )
import CostCentre import CostCentre
import SrcLoc ( SrcLoc )
import Outputable import Outputable
\end{code} \end{code}
...@@ -92,6 +91,10 @@ data UfBinding name ...@@ -92,6 +91,10 @@ data UfBinding name
data UfBinder name data UfBinder name
= UfValBinder name (HsType name) = UfValBinder name (HsType name)
| UfTyBinder name Kind | UfTyBinder name Kind
ufBinderName :: UfBinder name -> name
ufBinderName (UfValBinder n _) = n
ufBinderName (UfTyBinder n _) = n
\end{code} \end{code}
......
...@@ -16,7 +16,7 @@ module HsDecls ( ...@@ -16,7 +16,7 @@ module HsDecls (
DeprecDecl(..), DeprecTxt, DeprecDecl(..), DeprecTxt,
hsDeclName, instDeclName, tyClDeclName, tyClDeclNames, hsDeclName, instDeclName, tyClDeclName, tyClDeclNames,
isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule, isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule,
mkClassDeclSysNames, mkClassDeclSysNames, isIfaceRuleDecl,
getClassDeclSysNames getClassDeclSysNames
) where ) where
...@@ -237,7 +237,6 @@ mkClassDeclSysNames (a,b,c,ds) = a:b:c:ds ...@@ -237,7 +237,6 @@ mkClassDeclSysNames (a,b,c,ds) = a:b:c:ds
getClassDeclSysNames (a:b:c:ds) = (a,b,c,ds) getClassDeclSysNames (a:b:c:ds) = (a,b,c,ds)
\end{code} \end{code}
\begin{code} \begin{code}
isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
...@@ -373,7 +372,7 @@ data ConDecl name ...@@ -373,7 +372,7 @@ data ConDecl name
name -- Name of the constructor's 'worker Id' name -- Name of the constructor's 'worker Id'
-- Filled in as the ConDecl is built -- Filled in as the ConDecl is built
[HsTyVarBndr name] -- Existentially quantified type variables [HsTyVarBndr name] -- Existentially quantified type variables
(HsContext name) -- ...and context (HsContext name) -- ...and context
-- If both are empty then there are no existentials -- If both are empty then there are no existentials
...@@ -632,6 +631,8 @@ data RuleDecl name pat ...@@ -632,6 +631,8 @@ data RuleDecl name pat
name -- Head of LHS name -- Head of LHS
CoreRule CoreRule
isIfaceRuleDecl (HsRule _ _ _ _ _ _) = False
isIfaceRuleDecl other = True
data RuleBndr name data RuleBndr name
= RuleBndr name = RuleBndr name
......
...@@ -52,6 +52,7 @@ import OccName ( OccName ) ...@@ -52,6 +52,7 @@ import OccName ( OccName )
import Module ( Module, ModuleName, ModuleEnv, import Module ( Module, ModuleName, ModuleEnv,
lookupModuleEnv, lookupModuleEnvByName lookupModuleEnv, lookupModuleEnvByName
) )
import Rules ( RuleBase )
import VarSet ( TyVarSet ) import VarSet ( TyVarSet )
import VarEnv ( emptyVarEnv ) import VarEnv ( emptyVarEnv )
import Id ( Id ) import Id ( Id )
...@@ -149,7 +150,7 @@ data ModDetails ...@@ -149,7 +150,7 @@ data ModDetails
-- The next three fields are created by the typechecker -- The next three fields are created by the typechecker
md_types :: TypeEnv, md_types :: TypeEnv,
md_insts :: [DFunId], -- Dfun-ids for the instances in this module 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} \end{code}
...@@ -158,7 +159,7 @@ emptyModDetails :: ModDetails ...@@ -158,7 +159,7 @@ emptyModDetails :: ModDetails
emptyModDetails emptyModDetails
= ModDetails { md_types = emptyTypeEnv, = ModDetails { md_types = emptyTypeEnv,
md_insts = [], md_insts = [],
md_rules = emptyRuleBase md_rules = []
} }
emptyModIface :: Module -> ModIface emptyModIface :: Module -> ModIface
...@@ -386,7 +387,7 @@ data PersistentCompilerState ...@@ -386,7 +387,7 @@ data PersistentCompilerState
pcs_insts :: PackageInstEnv, -- The total InstEnv accumulated from all pcs_insts :: PackageInstEnv, -- The total InstEnv accumulated from all
-- the non-home-package modules -- the non-home-package modules
pcs_rules :: PackageRuleEnv, -- Ditto RuleEnv pcs_rules :: PackageRuleBase, -- Ditto RuleEnv
pcs_PRS :: PersistentRenamerState pcs_PRS :: PersistentRenamerState
} }
......
This diff is collapsed.
...@@ -18,7 +18,7 @@ module RnBinds ( ...@@ -18,7 +18,7 @@ module RnBinds (
#include "HsVersions.h" #include "HsVersions.h"
import {-# SOURCE #-} RnSource ( rnHsSigType ) import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType )
import HsSyn import HsSyn
import HsBinds ( eqHsSig, sigName, hsSigDoc ) import HsBinds ( eqHsSig, sigName, hsSigDoc )
...@@ -483,11 +483,12 @@ renameSigs :: (RenamedSig -> Bool) -- OK-sig predicate ...@@ -483,11 +483,12 @@ renameSigs :: (RenamedSig -> Bool) -- OK-sig predicate
-> [RdrNameSig] -> [RdrNameSig]
-> RnMS ([RenamedSig], FreeVars) -> RnMS ([RenamedSig], FreeVars)
renameSigs ok_sig [] = returnRn ([], emptyFVs) -- Common shortcut renameSigs ok_sig []
= returnRn ([], emptyFVs) -- Common shortcut
renameSigs ok_sig sigs renameSigs ok_sig sigs
= -- Rename the signatures = -- Rename the signatures
mapFvRn renameSig sigs `thenRn` \ (sigs', fvs) -> mapRn renameSig sigs `thenRn` \ sigs' ->
-- Check for (a) duplicate signatures -- Check for (a) duplicate signatures
-- (b) signatures for things not in this group -- (b) signatures for things not in this group
...@@ -499,7 +500,7 @@ renameSigs ok_sig sigs ...@@ -499,7 +500,7 @@ renameSigs ok_sig sigs
(goods, bads) = partition ok_sig in_scope (goods, bads) = partition ok_sig in_scope
in in
mapRn_ unknownSigErr bads `thenRn_` mapRn_ unknownSigErr bads `thenRn_`
returnRn (goods, fvs) returnRn (goods, hsSigFVs goods)
-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
-- because this won't work for: -- because this won't work for:
...@@ -510,39 +511,39 @@ renameSigs ok_sig sigs ...@@ -510,39 +511,39 @@ renameSigs ok_sig sigs
-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) -- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.)
-- Doesn't seem worth much trouble to sort this. -- 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. -- ClassOpSig is renamed elsewhere.
renameSig (Sig v ty src_loc) renameSig (Sig v ty src_loc)
= pushSrcLocRn src_loc $ = pushSrcLocRn src_loc $
lookupSigOccRn v `thenRn` \ new_v -> lookupSigOccRn v `thenRn` \ new_v ->
rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) -> rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty ->
returnRn (Sig new_v new_ty src_loc, fvs `addOneFV` new_v) returnRn (Sig new_v new_ty src_loc)
renameSig (SpecInstSig ty src_loc) renameSig (SpecInstSig ty src_loc)
= pushSrcLocRn src_loc $ = pushSrcLocRn src_loc $
rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ (new_ty, fvs) -> rnHsType (text "A SPECIALISE instance pragma") ty `thenRn` \ new_ty ->
returnRn (SpecInstSig new_ty src_loc, fvs) returnRn (SpecInstSig new_ty src_loc)
renameSig (SpecSig v ty src_loc) renameSig (SpecSig v ty src_loc)
= pushSrcLocRn src_loc $ = pushSrcLocRn src_loc $
lookupSigOccRn v `thenRn` \ new_v -> lookupSigOccRn v `thenRn` \ new_v ->
rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) -> rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty ->
returnRn (SpecSig new_v new_ty src_loc, fvs `addOneFV` new_v) returnRn (SpecSig new_v new_ty src_loc)
renameSig (FixSig (FixitySig v fix src_loc)) renameSig (FixSig (FixitySig v fix src_loc))
= pushSrcLocRn src_loc $ = pushSrcLocRn src_loc $
lookupSigOccRn v `thenRn` \ new_v -> 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) renameSig (InlineSig v p src_loc)
= pushSrcLocRn src_loc $ = pushSrcLocRn src_loc $
lookupSigOccRn v `thenRn` \ new_v -> 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) renameSig (NoInlineSig v p src_loc)
= pushSrcLocRn src_loc $ = pushSrcLocRn src_loc $
lookupSigOccRn v `thenRn` \ new_v -> lookupSigOccRn v `thenRn` \ new_v ->
returnRn (NoInlineSig new_v p src_loc, unitFV new_v) returnRn (NoInlineSig new_v p src_loc)
\end{code} \end{code}
\begin{code} \begin{code}
......
...@@ -670,25 +670,6 @@ pprAvail (Avail n) = ppr n ...@@ -670,25 +670,6 @@ pprAvail (Avail n) = ppr n
%************************************************************************ %************************************************************************
\begin{code} \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 -- A useful utility
mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> mapFvRn f xs = mapRn f xs `thenRn` \ stuff ->
let let
......
...@@ -18,14 +18,14 @@ module RnExpr ( ...@@ -18,14 +18,14 @@ module RnExpr (
#include "HsVersions.h" #include "HsVersions.h"
import {-# SOURCE #-} RnBinds ( rnBinds ) import {-# SOURCE #-} RnBinds ( rnBinds )
import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType ) import {-# SOURCE #-} RnSource ( rnHsTypeFVs )
import HsSyn import HsSyn
import RdrHsSyn import RdrHsSyn
import RnHsSyn import RnHsSyn
import RnMonad import RnMonad
import RnEnv import RnEnv
import RnIfaces ( lookupFixityRn ) import RnHiFiles ( lookupFixityRn )
import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts ) import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts )
import Literal ( inIntRange ) import Literal ( inIntRange )
import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity ) import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity )
...@@ -71,7 +71,7 @@ rnPat (SigPatIn pat ty) ...@@ -71,7 +71,7 @@ rnPat (SigPatIn pat ty)
if glaExts if glaExts
then rnPat pat `thenRn` \ (pat', fvs1) -> 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) returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
else addErrRn (patSigErr ty) `thenRn_` else addErrRn (patSigErr ty) `thenRn_`
...@@ -146,7 +146,7 @@ rnPat (RecPatIn con rpats) ...@@ -146,7 +146,7 @@ rnPat (RecPatIn con rpats)
rnRpats rpats `thenRn` \ (rpats', fvs) -> rnRpats rpats `thenRn` \ (rpats', fvs) ->
returnRn (RecPatIn con' rpats', fvs `addOneFV` con') returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
rnPat (TypePatIn name) = rnPat (TypePatIn name) =
(rnHsType (text "type pattern") name) `thenRn` \ (name', fvs) -> (rnHsTypeFVs (text "type pattern") name) `thenRn` \ (name', fvs) ->
returnRn (TypePatIn name', fvs) returnRn (TypePatIn name', fvs)
\end{code} \end{code}
...@@ -187,7 +187,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) ...@@ -187,7 +187,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss)
doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts -> doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts ->
(case maybe_rhs_sig of (case maybe_rhs_sig of
Nothing -> returnRn (Nothing, emptyFVs) 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) returnRn (Just ty', ty_fvs)
| otherwise -> addErrRn (patSigErr ty) `thenRn_` | otherwise -> addErrRn (patSigErr ty) `thenRn_`
returnRn (Nothing, emptyFVs) returnRn (Nothing, emptyFVs)
...@@ -411,8 +411,8 @@ rnExpr (RecordUpd expr rbinds) ...@@ -411,8 +411,8 @@ rnExpr (RecordUpd expr rbinds)
returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds) returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
rnExpr (ExprWithTySig expr pty) rnExpr (ExprWithTySig expr pty)
= rnExpr expr `thenRn` \ (expr', fvExpr) -> = rnExpr expr `thenRn` \ (expr', fvExpr) ->
rnHsSigType (text "an expression") pty `thenRn` \ (pty', fvTy) -> rnHsTypeFVs (text "an expression type signature") pty `thenRn` \ (pty', fvTy) ->
returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
rnExpr (HsIf p b1 b2 src_loc) rnExpr (HsIf p b1 b2 src_loc)
...@@ -422,10 +422,11 @@ rnExpr (HsIf p b1 b2 src_loc) ...@@ -422,10 +422,11 @@ rnExpr (HsIf p b1 b2 src_loc)
rnExpr b2 `thenRn` \ (b2', fvB2) -> rnExpr b2 `thenRn` \ (b2', fvB2) ->
returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2]) returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
rnExpr (HsType a) = rnExpr (HsType a)
(rnHsType doc a) `thenRn` \ (t, fvT) -> returnRn (HsType t, fvT) = rnHsTypeFVs doc a `thenRn` \ (t, fvT) ->
where doc = text "renaming a type pattern" returnRn (HsType t, fvT)
where
doc = text "renaming a type pattern"
rnExpr (ArithSeqIn seq) rnExpr (ArithSeqIn seq)
= lookupOrigName enumClass_RDR `thenRn` \ enum -> = lookupOrigName enumClass_RDR `thenRn` \ enum ->
......
...@@ -9,6 +9,8 @@ module RnHiFiles ( ...@@ -9,6 +9,8 @@ module RnHiFiles (
tryLoadInterface, loadOrphanModules, tryLoadInterface, loadOrphanModules,
loadExports, loadFixDecls, loadDeprecs, loadExports, loadFixDecls, loadDeprecs,
lookupFixityRn,
getTyClDeclBinders, getTyClDeclBinders,
removeContext -- removeContext probably belongs somewhere else removeContext -- removeContext probably belongs somewhere else
) where ) where
...@@ -541,6 +543,39 @@ readIface wanted_mod file_path ...@@ -541,6 +543,39 @@ readIface wanted_mod file_path
\end{code} \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} \subsection{Errors}
......
...@@ -9,10 +9,13 @@ module RnHsSyn where ...@@ -9,10 +9,13 @@ module RnHsSyn where
#include "HsVersions.h" #include "HsVersions.h"
import HsSyn import HsSyn