Commit 98bf5734 authored by simonpj's avatar simonpj
Browse files

[project @ 2001-08-23 09:54:45 by simonpj]

--------------------------------------------------
	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
parent 321743a1
......@@ -20,7 +20,7 @@ module OccName (
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
mkGenOcc1, mkGenOcc2,
isTvOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,
isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,
occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour,
setOccNameSpace,
......@@ -219,11 +219,14 @@ occNameFlavour (OccName sp _) = nameSpaceString sp
\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
......
......@@ -16,7 +16,7 @@ module RdrName (
-- Destruction
rdrNameModule, rdrNameOcc, setRdrNameOcc,
isRdrDataCon, isRdrTyVar, isQual, isUnqual, isOrig,
isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isUnqual, isOrig,
-- Environment
RdrNameEnv,
......@@ -33,7 +33,7 @@ import OccName ( NameSpace, tcName,
OccName, UserFS, EncodedFS,
mkSysOccFS,
mkOccFS, mkVarOcc,
isDataOcc, isTvOcc, mkWorkerOcc
isDataOcc, isTvOcc, isTcOcc, mkWorkerOcc
)
import Module ( ModuleName,
mkSysModuleNameFS, mkModuleNameFS
......@@ -134,6 +134,7 @@ dummyRdrTcName = RdrName Unqual (mkOccFS tcName SLIT("TC-DUMMY"))
\begin{code}
isRdrDataCon (RdrName _ occ) = isDataOcc occ
isRdrTyVar (RdrName _ occ) = isTvOcc occ
isRdrTc (RdrName _ occ) = isTcOcc occ
isUnqual (RdrName Unqual _) = True
isUnqual other = False
......
......@@ -30,7 +30,7 @@ module HscTypes (
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(..),
......@@ -599,7 +599,13 @@ type IfaceInsts = GatedDecls RdrNameInstDecl
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}
......
......@@ -43,8 +43,8 @@ module RdrHsSyn (
RdrMatch(..),
SigConverter,
extractHsTyRdrNames,
extractHsTyRdrTyVars, extractHsTysRdrTyVars,
extractHsTyRdrNames, extractSomeHsTyRdrNames,
extractHsTysRdrNames, extractSomeHsTysRdrNames,
extractRuleBndrsTyVars,
extractHsCtxtRdrTyVars, extractGenericPatTyVars,
......@@ -126,14 +126,17 @@ type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat
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))
......
......@@ -26,6 +26,7 @@ import RnHsSyn
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 )
......@@ -209,7 +210,7 @@ bindPatSigTyVars :: [RdrNameHsType]
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
......
......@@ -11,8 +11,7 @@ module RnHiFiles (
lookupFixityRn,
getTyClDeclBinders,
removeContext -- removeContext probably belongs somewhere else
getTyClDeclBinders
) where
#include "HsVersions.h"
......@@ -29,11 +28,11 @@ import HscTypes ( ModuleLocation(..),
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
......@@ -45,7 +44,7 @@ import Name ( Name {-instance NamedThing-},
)
import NameEnv
import Module
import RdrName ( rdrNameOcc )
import RdrName ( rdrNameOcc, isRdrTc )
import SrcLoc ( mkSrcLoc )
import Maybes ( maybeToBool, orElse )
import StringBuffer ( hGetStringBuffer )
......@@ -362,23 +361,43 @@ loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _)
-- 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
-----------------------------------------------------
......@@ -401,7 +420,7 @@ loadRule :: Module -> RdrNameRuleDecl -> RnM d (GatedDecl RdrNameRuleDecl)
-- 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))
-----------------------------------------------------
......
......@@ -457,8 +457,9 @@ decl slurped in during an earlier compilation, like this:
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
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -483,6 +484,8 @@ vars of the source program, and extracts from the decl the gate names.
\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
......@@ -658,9 +661,9 @@ selectGated available (decl_bag, n_slurped)
= 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}
......
......@@ -14,9 +14,9 @@ import RnExpr
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
......@@ -552,7 +552,7 @@ rnHsType doc (HsForAllTy Nothing ctxt ty)
-- 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
......@@ -564,7 +564,7 @@ rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau)
-- 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
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment