--------------------------------------------------
Be a bit more liberal when slurping instance decls
--------------------------------------------------
Functional dependencies have (as usual) made things more complicated
Suppose an interface file contains
interface A where
class C a b | a->b where op :: a->b
instance C Foo Baz where ...
Now we are compiling
module B where
import A
t = op (v::Foo)
Should we slurp the instance decl, even though Baz is nowhere mentioned
in module B? YES! Because of the fundep, the (C Foo ?) part is enough to
select this instance decl, and the Baz part follows.
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.
Changes:
HscTypes:
generalise the types of GatedDecl a bit
RnHiFiles.loadInstDecl, RnHiFiles.loadRule, RnIfaces.selectGated:
the meat of the solution
RdrName, OccName etc:
some consequential wibbles
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
mkGenOcc1, mkGenOcc2,
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
mkGenOcc1, mkGenOcc2,
- isTvOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,
+ isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,
occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour,
setOccNameSpace,
occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour,
setOccNameSpace,
-isTvOcc, isDataSymOcc, isSymOcc :: OccName -> Bool
+isTvOcc, isDataSymOcc, isSymOcc, isTcOcc :: OccName -> Bool
isTvOcc (OccName TvName _) = True
isTvOcc other = False
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
isValOcc (OccName VarName _) = True
isValOcc (OccName DataName _) = True
isValOcc other = False
-- Destruction
rdrNameModule, rdrNameOcc, setRdrNameOcc,
-- Destruction
rdrNameModule, rdrNameOcc, setRdrNameOcc,
- isRdrDataCon, isRdrTyVar, isQual, isUnqual, isOrig,
+ isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isUnqual, isOrig,
-- Environment
RdrNameEnv,
-- Environment
RdrNameEnv,
OccName, UserFS, EncodedFS,
mkSysOccFS,
mkOccFS, mkVarOcc,
OccName, UserFS, EncodedFS,
mkSysOccFS,
mkOccFS, mkVarOcc,
- isDataOcc, isTvOcc, mkWorkerOcc
+ isDataOcc, isTvOcc, isTcOcc, mkWorkerOcc
)
import Module ( ModuleName,
mkSysModuleNameFS, mkModuleNameFS
)
import Module ( ModuleName,
mkSysModuleNameFS, mkModuleNameFS
\begin{code}
isRdrDataCon (RdrName _ occ) = isDataOcc occ
isRdrTyVar (RdrName _ occ) = isTvOcc occ
\begin{code}
isRdrDataCon (RdrName _ occ) = isDataOcc occ
isRdrTyVar (RdrName _ occ) = isTvOcc occ
+isRdrTc (RdrName _ occ) = isTcOcc occ
isUnqual (RdrName Unqual _) = True
isUnqual other = False
isUnqual (RdrName Unqual _) = True
isUnqual other = False
ImportedModuleInfo, WhetherHasOrphans, ImportVersion, WhatsImported(..),
PersistentRenamerState(..), IsBootInterface, DeclsMap,
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(..),
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 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.
RdrMatch(..),
SigConverter,
RdrMatch(..),
SigConverter,
- extractHsTyRdrNames,
- extractHsTyRdrTyVars, extractHsTysRdrTyVars,
+ extractHsTyRdrNames, extractSomeHsTyRdrNames,
+ extractHsTysRdrNames, extractSomeHsTysRdrNames,
extractRuleBndrsTyVars,
extractHsCtxtRdrTyVars, extractGenericPatTyVars,
extractRuleBndrsTyVars,
extractHsCtxtRdrTyVars, extractGenericPatTyVars,
It's used when making the for-alls explicit.
\begin{code}
It's used when making the for-alls explicit.
\begin{code}
-extractHsTyRdrNames :: HsType RdrName -> [RdrName]
+extractHsTyRdrNames :: RdrNameHsType -> [RdrName]
extractHsTyRdrNames ty = nub (extract_ty ty [])
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))
extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
import RnMonad
import RnEnv
import RnHiFiles ( lookupFixityRn )
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 )
import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts )
import Literal ( inIntRange, inCharRange )
import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity )
bindPatSigTyVars tys thing_inside
= getLocalNameEnv `thenRn` \ name_env ->
let
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
forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs
doc_sig = text "In a pattern type-signature"
in
- getTyClDeclBinders,
- removeContext -- removeContext probably belongs somewhere else
) where
#include "HsVersions.h"
) where
#include "HsVersions.h"
AvailInfo, GenAvailInfo(..), Avails, Deprecations(..)
)
import HsSyn ( TyClDecl(..), InstDecl(..),
AvailInfo, GenAvailInfo(..), Avails, Deprecations(..)
)
import HsSyn ( TyClDecl(..), InstDecl(..),
- HsType(..), FixitySig(..), RuleDecl(..),
+ HsType(..), HsPred(..), FixitySig(..), RuleDecl(..),
tyClDeclNames, tyClDeclSysNames
)
import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl,
tyClDeclNames, tyClDeclSysNames
)
import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl,
+ extractSomeHsTysRdrNames
)
import BasicTypes ( Version, defaultFixity )
import RnEnv
)
import BasicTypes ( Version, defaultFixity )
import RnEnv
)
import NameEnv
import Module
)
import NameEnv
import Module
-import RdrName ( rdrNameOcc )
+import RdrName ( rdrNameOcc, isRdrTc )
import SrcLoc ( mkSrcLoc )
import Maybes ( maybeToBool, orElse )
import StringBuffer ( hGetStringBuffer )
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.
-- 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.
- 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
- 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)
-- 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 ->
-- 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
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
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consructors and class operations
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
getGates :: FreeVars -- Things mentioned in the source program
\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
-> RenamedTyClDecl
-> FreeVars
= case foldrBag select ([], emptyBag) decl_bag of
(decls, new_bag) -> (decls, (new_bag, n_slurped + length decls))
where
= 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)
import HsSyn
import HscTypes ( GlobalRdrEnv )
import HsTypes ( hsTyVarNames, pprHsContext )
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,
import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, RdrNameTyClDecl,
- extractRuleBndrsTyVars, extractHsTyRdrTyVars,
+ extractRuleBndrsTyVars, extractSomeHsTyRdrNames,
extractHsCtxtRdrTyVars, extractGenericPatTyVars
)
import RnHsSyn
extractHsCtxtRdrTyVars, extractGenericPatTyVars
)
import RnHsSyn
-- over FV(T) \ {in-scope-tyvars}
= getLocalNameEnv `thenRn` \ name_env ->
let
-- 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
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
-- 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
mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt
mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt)
forall_tyvar_names = hsTyVarNames forall_tyvars