From: simonpj Date: Thu, 23 Aug 2001 09:54:46 +0000 (+0000) Subject: [project @ 2001-08-23 09:54:45 by simonpj] X-Git-Tag: Approximately_9120_patches~1111 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=98bf57340b8945ea786dc18f2d1ecbe1baed0a4d;p=ghc-hetmet.git [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 --- diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index c10e1c4..c2d4533 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -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 diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs index 7ad104e..aa54142 100644 --- a/ghc/compiler/basicTypes/RdrName.lhs +++ b/ghc/compiler/basicTypes/RdrName.lhs @@ -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 diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 2c8757f..3c76b60 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -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} diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 9bc63ea..6334d33 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -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)) diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index b895dcb..62e228f 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -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 diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 3ea0fc4..b0d6d18 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -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)) ----------------------------------------------------- diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index b5a3ebb..3880909 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -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} diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 28e5447..93010de 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -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