From b87e22d21055cd2bee40f0cc6873f1dcbe60fd01 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Fri, 9 Apr 2010 16:37:10 +0000 Subject: [PATCH] Fix Trac #3955: renamer and type variables The renamer wasn't computing the free variables of a type declaration properly. This patch refactors a bit, and makes it more robust, fixing #3955 and several other closely-related bugs. (We were omitting some free variables and that could just possibly lead to a usage-version tracking error. --- compiler/rename/RnEnv.lhs | 14 ++++++-- compiler/rename/RnSource.lhs | 81 ++++++++++++++++++++---------------------- 2 files changed, 49 insertions(+), 46 deletions(-) diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 6927280..1a05139 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -23,7 +23,7 @@ module RnEnv ( addLocalFixities, bindLocatedLocalsFV, bindLocatedLocalsRn, bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV, - bindTyVarsRn, extendTyVarEnvFVRn, + bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn, checkDupRdrNames, checkDupAndShadowedRdrNames, checkDupNames, checkDupAndShadowedNames, @@ -836,7 +836,7 @@ bindLocalName name enclosed_scope bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) bindLocalNamesFV names enclosed_scope = do { (result, fvs) <- bindLocalNames names enclosed_scope - ; return (result, delListFromNameSet fvs names) } + ; return (result, delFVs names fvs) } ------------------------------------- @@ -847,9 +847,17 @@ bindLocatedLocalsFV :: [Located RdrName] bindLocatedLocalsFV rdr_names enclosed_scope = bindLocatedLocalsRn rdr_names $ \ names -> enclosed_scope names `thenM` \ (thing, fvs) -> - return (thing, delListFromNameSet fvs names) + return (thing, delFVs names fvs) ------------------------------------- +bindTyVarsFV :: [LHsTyVarBndr RdrName] + -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars)) + -> RnM (a, FreeVars) +bindTyVarsFV tyvars thing_inside + = bindTyVarsRn tyvars $ \ tyvars' -> + do { (res, fvs) <- thing_inside tyvars' + ; return (res, delFVs (map hsLTyVarName tyvars') fvs) } + bindTyVarsRn :: [LHsTyVarBndr RdrName] -> ([LHsTyVarBndr Name] -> RnM a) -> RnM a diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index f2683e8..6dce034 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -26,7 +26,7 @@ import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn, lookupTopBndrRn, lookupLocatedTopBndrRn, lookupOccRn, newLocalBndrsRn, bindLocalNamesFV, bindLocatedLocalsFV, bindPatSigTyVarsFV, - bindTyVarsRn, extendTyVarEnvFVRn, + bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn, bindLocalNames, checkDupRdrNames, mapFvRn ) import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn ) @@ -685,32 +685,33 @@ rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name}) -- all flavours of type family declarations ("type family", "newtype fanily", -- and "data family") -rnTyClDecl (tydecl@TyFamily {}) = - rnFamily tydecl bindTyVarsRn +rnTyClDecl tydecl@TyFamily {} = rnFamily tydecl bindTyVarsFV -- "data", "newtype", "data instance, and "newtype instance" declarations rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, tcdTyVars = tyvars, - tcdTyPats = typatsMaybe, tcdCons = condecls, + tcdTyPats = typats, tcdCons = condecls, tcdKindSig = sig, tcdDerivs = derivs} = do { tycon' <- if isFamInstDecl tydecl then lookupLocatedOccRn tycon -- may be imported family else lookupLocatedTopBndrRn tycon ; checkTc (h98_style || null (unLoc context)) (badGadtStupidTheta tycon) - ; (tyvars', context', typats', derivs', deriv_fvs) - <- bindTyVarsRn tyvars $ \ tyvars' -> do + ; ((tyvars', context', typats', derivs'), stuff_fvs) + <- bindTyVarsFV tyvars $ \ tyvars' -> do -- Checks for distinct tyvars - { typats' <- rnTyPats data_doc typatsMaybe - ; context' <- rnContext data_doc context - ; (derivs', deriv_fvs) <- rn_derivs derivs - ; return (tyvars', context', typats', derivs', deriv_fvs) } - -- For GADTs, the type variables in the declaration - -- do not scope over the constructor signatures - -- data T a where { T1 :: forall b. b-> b } + { context' <- rnContext data_doc context + ; (typats', fvs1) <- rnTyPats data_doc tycon' typats + ; (derivs', fvs2) <- rn_derivs derivs + ; let fvs = fvs1 `plusFV` fvs2 `plusFV` + extractHsCtxtTyNames context' + ; return ((tyvars', context', typats', derivs'), fvs) } -- For the constructor declarations, bring into scope the tyvars -- bound by the header, but *only* in the H98 case + -- Reason: for GADTs, the type variables in the declaration + -- do not scope over the constructor signatures + -- data T a where { T1 :: forall b. b-> b } ; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars' | otherwise = [] ; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $ @@ -722,11 +723,7 @@ rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon', tcdTyVars = tyvars', tcdTyPats = typats', tcdKindSig = sig, tcdCons = condecls', tcdDerivs = derivs'}, - con_fvs `plusFV` - deriv_fvs `plusFV` - (if isFamInstDecl tydecl - then unitFV (unLoc tycon') -- type instance => use - else emptyFVs)) + con_fvs `plusFV` stuff_fvs) } where h98_style = case condecls of -- Note [Stupid theta] @@ -741,22 +738,17 @@ rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, -- "type" and "type instance" declarations rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, - tcdTyPats = typatsMaybe, tcdSynRhs = ty}) - = bindTyVarsRn tyvars $ \ tyvars' -> do + tcdTyPats = typats, tcdSynRhs = ty}) + = bindTyVarsFV tyvars $ \ tyvars' -> do { -- Checks for distinct tyvars name' <- if isFamInstDecl tydecl then lookupLocatedOccRn name -- may be imported family else lookupLocatedTopBndrRn name - ; typats' <- rnTyPats syn_doc typatsMaybe - ; (ty', fvs) <- rnHsTypeFVs syn_doc ty + ; (typats',fvs1) <- rnTyPats syn_doc name' typats + ; (ty', fvs2) <- rnHsTypeFVs syn_doc ty ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars' , tcdTyPats = typats', tcdSynRhs = ty'}, - delFVs (map hsLTyVarName tyvars') $ - fvs `plusFV` - (if isFamInstDecl tydecl - then unitFV (unLoc name') -- type instance => use - else emptyFVs)) - } + fvs1 `plusFV` fvs2) } where syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name) @@ -766,14 +758,18 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, = do { cname' <- lookupLocatedTopBndrRn cname -- Tyvars scope over superclass context and method signatures - ; (tyvars', context', fds', ats', ats_fvs, sigs') - <- bindTyVarsRn tyvars $ \ tyvars' -> do + ; ((tyvars', context', fds', ats', sigs'), stuff_fvs) + <- bindTyVarsFV tyvars $ \ tyvars' -> do -- Checks for distinct tyvars { context' <- rnContext cls_doc context ; fds' <- rnFds cls_doc fds - ; (ats', ats_fvs) <- rnATs ats + ; (ats', at_fvs) <- rnATs ats ; sigs' <- renameSigs Nothing okClsDclSig sigs - ; return (tyvars', context', fds', ats', ats_fvs, sigs') } + ; let fvs = at_fvs `plusFV` + extractHsCtxtTyNames context' `plusFV` + hsSigsFVs sigs' + -- The fundeps have no free variables + ; return ((tyvars', context', fds', ats', sigs'), fvs) } -- No need to check for duplicate associated type decls -- since that is done by RnNames.extendGlobalRdrEnvRn @@ -812,13 +808,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, ; return (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'}, - - delFVs (map hsLTyVarName tyvars') $ - extractHsCtxtTyNames context' `plusFV` - plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV` - hsSigsFVs sigs' `plusFV` - meth_fvs `plusFV` - ats_fvs) } + meth_fvs `plusFV` stuff_fvs) } where cls_doc = text "In the declaration for class" <+> ppr cname @@ -845,12 +835,17 @@ are no data constructors we allow h98_style = True %********************************************************* \begin{code} -rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name]) +rnTyPats :: SDoc -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars) -- Although, we are processing type patterns here, all type variables will -- already be in scope (they are the same as in the 'tcdTyVars' field of the -- type declaration to which these patterns belong) -rnTyPats _ Nothing = return Nothing -rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats +rnTyPats _ _ Nothing + = return (Nothing, emptyFVs) +rnTyPats doc tc (Just typats) + = do { typats' <- rnLHsTypes doc typats + ; let fvs = addOneFV (extractHsTyNames_s typats') (unLoc tc) + -- type instance => use, hence addOneFV + ; return (Just typats', fvs) } rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars) rnConDecls condecls @@ -970,7 +965,7 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats rn_at _ = panic "RnSource.rnATs: invalid TyClDecl" lookupIdxVars tyvars cont = - do { checkForDups tyvars; + do { checkForDups tyvars ; tyvars' <- mapM lookupIdxVar tyvars ; cont tyvars' } -- 1.7.10.4