mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
mkGenOcc1, mkGenOcc2,
- isTvOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,
+ isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,
occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour,
setOccNameSpace,
\end{code}
\begin{code}
-isTvOcc, isDataSymOcc, isSymOcc :: OccName -> Bool
+isTvOcc, isDataSymOcc, isSymOcc, isTcOcc :: OccName -> Bool
isTvOcc (OccName TvName _) = True
isTvOcc other = False
+isTcOcc (OccName TcClsName _) = True
+isTcOcc other = False
+
isValOcc (OccName VarName _) = True
isValOcc (OccName DataName _) = True
isValOcc other = False
-- Destruction
rdrNameModule, rdrNameOcc, setRdrNameOcc,
- isRdrDataCon, isRdrTyVar, isQual, isUnqual, isOrig,
+ isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isUnqual, isOrig,
-- Environment
RdrNameEnv,
OccName, UserFS, EncodedFS,
mkSysOccFS,
mkOccFS, mkVarOcc,
- isDataOcc, isTvOcc, mkWorkerOcc
+ isDataOcc, isTvOcc, isTcOcc, mkWorkerOcc
)
import Module ( ModuleName,
mkSysModuleNameFS, mkModuleNameFS
\begin{code}
isRdrDataCon (RdrName _ occ) = isDataOcc occ
isRdrTyVar (RdrName _ occ) = isTvOcc occ
+isRdrTc (RdrName _ occ) = isTcOcc occ
isUnqual (RdrName Unqual _) = True
isUnqual other = False
ImportedModuleInfo, WhetherHasOrphans, ImportVersion, WhatsImported(..),
PersistentRenamerState(..), IsBootInterface, DeclsMap,
- IfaceInsts, IfaceRules, GatedDecl, GatedDecls, IsExported,
+ IfaceInsts, IfaceRules, GatedDecl, GatedDecls, GateFn, IsExported,
NameSupply(..), OrigNameCache, OrigIParamCache,
Avails, AvailEnv, GenAvailInfo(..), AvailInfo, RdrAvailInfo,
PersistentCompilerState(..),
type IfaceRules = GatedDecls RdrNameRuleDecl
type GatedDecls d = (Bag (GatedDecl d), Int) -- The Int says how many have been sucked in
-type GatedDecl d = ([Name], (Module, d))
+type GatedDecl d = (GateFn, (Module, d))
+type GateFn = (Name -> Bool) -> Bool -- Returns True <=> gate is open
+ -- The (Name -> Bool) fn returns True for visible Names
+ -- For example, suppose this is in an interface file
+ -- instance C T where ...
+ -- We want to slurp this decl if both C and T are "visible" in
+ -- the importing module. See "The gating story" in RnIfaces for details.
\end{code}
RdrMatch(..),
SigConverter,
- extractHsTyRdrNames,
- extractHsTyRdrTyVars, extractHsTysRdrTyVars,
+ extractHsTyRdrNames, extractSomeHsTyRdrNames,
+ extractHsTysRdrNames, extractSomeHsTysRdrNames,
extractRuleBndrsTyVars,
extractHsCtxtRdrTyVars, extractGenericPatTyVars,
It's used when making the for-alls explicit.
\begin{code}
-extractHsTyRdrNames :: HsType RdrName -> [RdrName]
+extractHsTyRdrNames :: RdrNameHsType -> [RdrName]
extractHsTyRdrNames ty = nub (extract_ty ty [])
-extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
-extractHsTyRdrTyVars ty = filter isRdrTyVar (extractHsTyRdrNames ty)
+extractHsTysRdrNames :: [RdrNameHsType] -> [RdrName]
+extractHsTysRdrNames tys = nub (extract_tys tys)
-extractHsTysRdrTyVars :: [RdrNameHsType] -> [RdrName]
-extractHsTysRdrTyVars tys = filter isRdrTyVar (nub (extract_tys tys))
+extractSomeHsTyRdrNames :: (RdrName -> Bool) -> RdrNameHsType -> [RdrName]
+extractSomeHsTyRdrNames ok ty = nub (filter ok (extract_ty ty []))
+
+extractSomeHsTysRdrNames :: (RdrName -> Bool) -> [RdrNameHsType] -> [RdrName]
+extractSomeHsTysRdrNames ok tys = nub (filter ok (extract_tys tys))
extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
import RnMonad
import RnEnv
import RnHiFiles ( lookupFixityRn )
+import RdrName ( isRdrTyVar )
import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts )
import Literal ( inIntRange, inCharRange )
import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity )
bindPatSigTyVars tys thing_inside
= getLocalNameEnv `thenRn` \ name_env ->
let
- tyvars_in_sigs = extractHsTysRdrTyVars tys
+ tyvars_in_sigs = extractSomeHsTysRdrNames isRdrTyVar tys
forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs
doc_sig = text "In a pattern type-signature"
in
lookupFixityRn,
- getTyClDeclBinders,
- removeContext -- removeContext probably belongs somewhere else
+ getTyClDeclBinders
) where
#include "HsVersions.h"
AvailInfo, GenAvailInfo(..), Avails, Deprecations(..)
)
import HsSyn ( TyClDecl(..), InstDecl(..),
- HsType(..), FixitySig(..), RuleDecl(..),
+ HsType(..), HsPred(..), FixitySig(..), RuleDecl(..),
tyClDeclNames, tyClDeclSysNames
)
import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl,
- extractHsTyRdrNames
+ extractSomeHsTysRdrNames
)
import BasicTypes ( Version, defaultFixity )
import RnEnv
)
import NameEnv
import Module
-import RdrName ( rdrNameOcc )
+import RdrName ( rdrNameOcc, isRdrTc )
import SrcLoc ( mkSrcLoc )
import Maybes ( maybeToBool, orElse )
import StringBuffer ( hGetStringBuffer )
-- instance Foo a => Baz (T a) where ...
--
-- Here the gates are Baz and T, but *not* Foo.
+ --
+ -- HOWEVER: functional dependencies make things more complicated
+ -- class C a b | a->b where ...
+ -- instance C Foo Baz where ...
+ -- Here, the gates are really only C and Foo, *not* Baz.
+ -- That is, if C and Foo are visible, even if Baz isn't, we must
+ -- slurp the decl.
+ --
+ -- Rather than take fundeps into account "properly", we just slurp
+ -- if C is visible and *any one* of the Names in the types
+ -- This is a slightly brutal approximation, but most instance decls
+ -- are regular H98 ones and it's perfect for them.
let
- munged_inst_ty = removeContext inst_ty
- free_names = extractHsTyRdrNames munged_inst_ty
+ (cls_name,tys) = get_head inst_ty
+ free_ty_names = extractSomeHsTysRdrNames isRdrTc tys
in
- mapRn lookupIfaceName free_names `thenRn` \ gate_names ->
- returnRn ((gate_names, (mod, decl)) `consBag` insts)
+ lookupIfaceName cls_name `thenRn` \ cls_name' ->
+ mapRn lookupIfaceName free_ty_names `thenRn` \ free_ty_names' ->
+ let
+ gate_fn vis_fn = vis_fn cls_name' && any vis_fn free_ty_names'
+ -- Here is the implementation of HOWEVER above
+ in
+ returnRn ((gate_fn, (mod, decl)) `consBag` insts)
-- In interface files, the instance decls now look like
-- forall a. Foo a -> Baz (T a)
-- so we have to strip off function argument types as well
-- as the bit before the '=>' (which is always empty in interface files)
-removeContext (HsForAllTy tvs cxt ty) = HsForAllTy tvs [] (removeFuns ty)
-removeContext ty = removeFuns ty
+--
+-- The parser ensures the type will have the right shape.
+-- (e.g. see ParseUtil.checkInstType)
+
+get_head (HsForAllTy tvs cxt ty) = get_head ty
+get_head (HsFunTy _ ty) = get_head ty
+get_head (HsPredTy (HsClassP cls tys)) = (cls,tys)
-removeFuns (HsFunTy _ ty) = removeFuns ty
-removeFuns ty = ty
-----------------------------------------------------
-- needed. We can refine this later.
loadRule mod decl@(IfaceRule _ _ var _ _ src_loc)
= lookupIfaceName var `thenRn` \ var_name ->
- returnRn ([var_name], (mod, decl))
+ returnRn (\vis_fn -> vis_fn var_name, (mod, decl))
-----------------------------------------------------
In the module being compiled we might need (Baz (Maybe T)), where T
is defined in this module, and hence we need (Foo T). So @Foo@ becomes
-a gate. But there's no way to 'see' that, so we simply treat all
-previously-loaded classes as gates.
+a gate. But there's no way to 'see' that, so
+
+ we simply treat all previously-loaded classes as gates.
Consructors and class operations
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
getGates :: FreeVars -- Things mentioned in the source program
+ -- Used for the cunning "constructors and
+ -- class ops" story described 10 lines above.
-> RenamedTyClDecl
-> FreeVars
= case foldrBag select ([], emptyBag) decl_bag of
(decls, new_bag) -> (decls, (new_bag, n_slurped + length decls))
where
- select (reqd, decl) (yes, no)
- | all available reqd = (decl:yes, no)
- | otherwise = (yes, (reqd,decl) `consBag` no)
+ select (gate_fn, decl) (yes, no)
+ | gate_fn available = (decl:yes, no)
+ | otherwise = (yes, (gate_fn,decl) `consBag` no)
\end{code}
import HsSyn
import HscTypes ( GlobalRdrEnv )
import HsTypes ( hsTyVarNames, pprHsContext )
-import RdrName ( RdrName, isRdrDataCon, elemRdrEnv )
+import RdrName ( RdrName, isRdrDataCon, isRdrTyVar, elemRdrEnv )
import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, RdrNameTyClDecl,
- extractRuleBndrsTyVars, extractHsTyRdrTyVars,
+ extractRuleBndrsTyVars, extractSomeHsTyRdrNames,
extractHsCtxtRdrTyVars, extractGenericPatTyVars
)
import RnHsSyn
-- over FV(T) \ {in-scope-tyvars}
= getLocalNameEnv `thenRn` \ name_env ->
let
- mentioned_in_tau = extractHsTyRdrTyVars ty
+ mentioned_in_tau = extractSomeHsTyRdrNames isRdrTyVar ty
mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt)
forall_tyvars = filter (not . (`elemRdrEnv` name_env)) mentioned
-- Check that the forall'd tyvars are actually
-- mentioned in the type, and produce a warning if not
= let
- mentioned_in_tau = extractHsTyRdrTyVars tau
+ mentioned_in_tau = extractSomeHsTyRdrNames isRdrTyVar tau
mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt)
forall_tyvar_names = hsTyVarNames forall_tyvars
projects / ghc-hetmet.git / commitdiff