summaryrefslogtreecommitdiff
path: root/compiler/rename
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/rename')
-rw-r--r--compiler/rename/RnBinds.lhs42
-rw-r--r--compiler/rename/RnEnv.lhs127
-rw-r--r--compiler/rename/RnExpr.lhs9
-rw-r--r--compiler/rename/RnHsSyn.lhs159
-rw-r--r--compiler/rename/RnNames.lhs80
-rw-r--r--compiler/rename/RnPat.lhs21
-rw-r--r--compiler/rename/RnSource.lhs355
-rw-r--r--compiler/rename/RnTypes.lhs465
8 files changed, 592 insertions, 666 deletions
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 969a517629..6a7bfbea9a 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -33,10 +33,9 @@ module RnBinds (
import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
import HsSyn
-import RnHsSyn
import TcRnMonad
import TcEvidence ( emptyTcEvBinds )
-import RnTypes ( rnIPName, rnHsSigType, rnLHsType, checkPrecMatch )
+import RnTypes ( bindSigTyVarsFV, rnIPName, rnHsSigType, rnLHsType, checkPrecMatch )
import RnPat
import RnEnv
import DynFlags
@@ -184,8 +183,8 @@ rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
-- Return a single HsBindGroup with empty binds and renamed signatures
rnTopBindsBoot (ValBindsIn mbinds sigs)
= do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
- ; sigs' <- renameSigs HsBootCtxt sigs
- ; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) }
+ ; (sigs', fvs) <- renameSigs HsBootCtxt sigs
+ ; return (ValBindsOut [] sigs', usesOnly fvs) }
rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b)
\end{code}
@@ -291,13 +290,13 @@ rnValBindsRHS :: HsSigCtxt
-> RnM (HsValBinds Name, DefUses)
rnValBindsRHS ctxt (ValBindsIn mbinds sigs)
- = do { sigs' <- renameSigs ctxt sigs
+ = do { (sigs', sig_fvs) <- renameSigs ctxt sigs
; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs')) mbinds
; case depAnalBinds binds_w_dus of
(anal_binds, anal_dus) -> return (valbind', valbind'_dus)
where
valbind' = ValBindsOut anal_binds sigs'
- valbind'_dus = anal_dus `plusDU` usesOnly (hsSigsFVs sigs')
+ valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs
-- Put the sig uses *after* the bindings
-- so that the binders are removed from
-- the uses in the sigs
@@ -649,7 +648,7 @@ signatures. We'd only need this if we wanted to report unused tyvars.
\begin{code}
renameSigs :: HsSigCtxt
-> [LSig RdrName]
- -> RnM [LSig Name]
+ -> RnM ([LSig Name], FreeVars)
-- Renames the signatures and performs error checks
renameSigs ctxt sigs
= do { mapM_ dupSigDeclErr (findDupsEq overlapHsSig sigs) -- Duplicate
@@ -662,12 +661,12 @@ renameSigs ctxt sigs
-- op :: a -> a
-- default op :: Eq a => a -> a
- ; sigs' <- mapM (wrapLocM (renameSig ctxt)) sigs
+ ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs
; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'
; mapM_ misplacedSigErr bad_sigs -- Misplaced
- ; return good_sigs }
+ ; return (good_sigs, sig_fvs) }
----------------------
-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
@@ -679,26 +678,26 @@ renameSigs ctxt sigs
-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.)
-- Doesn't seem worth much trouble to sort this.
-renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name)
+renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name, FreeVars)
-- FixitySig is renamed elsewhere.
renameSig _ (IdSig x)
- = return (IdSig x) -- Actually this never occurs
+ = return (IdSig x, emptyFVs) -- Actually this never occurs
renameSig ctxt sig@(TypeSig vs ty)
= do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs
- ; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty
- ; return (TypeSig new_vs new_ty) }
+ ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty
+ ; return (TypeSig new_vs new_ty, fvs) }
renameSig ctxt sig@(GenericSig vs ty)
= do { defaultSigs_on <- xoptM Opt_DefaultSignatures
; unless defaultSigs_on (addErr (defaultSigErr sig))
; new_v <- mapM (lookupSigOccRn ctxt sig) vs
- ; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty
- ; return (GenericSig new_v new_ty) }
+ ; (new_ty, fvs) <- rnHsSigType (ppr_sig_bndrs vs) ty
+ ; return (GenericSig new_v new_ty, fvs) }
renameSig _ (SpecInstSig ty)
- = do { new_ty <- rnLHsType SpecInstSigCtx ty
- ; return (SpecInstSig new_ty) }
+ = do { (new_ty, fvs) <- rnLHsType SpecInstSigCtx ty
+ ; return (SpecInstSig new_ty,fvs) }
-- {-# SPECIALISE #-} pragmas can refer to imported Ids
-- so, in the top-level case (when mb_names is Nothing)
@@ -708,16 +707,16 @@ renameSig ctxt sig@(SpecSig v ty inl)
= do { new_v <- case ctxt of
TopSigCtxt -> lookupLocatedOccRn v
_ -> lookupSigOccRn ctxt sig v
- ; new_ty <- rnHsSigType (quotes (ppr v)) ty
- ; return (SpecSig new_v new_ty inl) }
+ ; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty
+ ; return (SpecSig new_v new_ty inl, fvs) }
renameSig ctxt sig@(InlineSig v s)
= do { new_v <- lookupSigOccRn ctxt sig v
- ; return (InlineSig new_v s) }
+ ; return (InlineSig new_v s, emptyFVs) }
renameSig ctxt sig@(FixSig (FixitySig v f))
= do { new_v <- lookupSigOccRn ctxt sig v
- ; return (FixSig (FixitySig new_v f)) }
+ ; return (FixSig (FixitySig new_v f), emptyFVs) }
ppr_sig_bndrs :: [Located RdrName] -> SDoc
ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)
@@ -778,7 +777,6 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
{ (grhss', grhss_fvs) <- rnGRHSs ctxt grhss
; return (Match pats' Nothing grhss', grhss_fvs) }}
- -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
resSigErr :: HsMatchContext Name -> Match RdrName -> HsType RdrName -> SDoc
resSigErr ctxt match ty
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index ecd2cd3147..f1adba6bd3 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -14,13 +14,16 @@
module RnEnv (
newTopSrcBinder,
lookupLocatedTopBndrRn, lookupTopBndrRn,
- lookupLocatedOccRn, lookupOccRn, lookupLocalOccRn_maybe, lookupPromotedOccRn,
+ lookupLocatedOccRn, lookupOccRn,
+ lookupLocalOccRn_maybe,
+ lookupTypeOccRn, lookupKindOccRn,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
HsSigCtxt(..), lookupLocalDataTcNames, lookupSigOccRn,
lookupFixityRn, lookupTyFixityRn,
- lookupInstDeclBndr, lookupSubBndrOcc, greRdrName,
+ lookupInstDeclBndr, lookupSubBndrOcc, lookupTcdName,
+ greRdrName,
lookupSubBndrGREs, lookupConstructorFields,
lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse,
lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe,
@@ -31,7 +34,6 @@ module RnEnv (
MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv,
addLocalFixities,
bindLocatedLocalsFV, bindLocatedLocalsRn,
- bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV,
extendTyVarEnvFVRn,
checkDupRdrNames, checkDupAndShadowedRdrNames,
@@ -40,7 +42,6 @@ module RnEnv (
warnUnusedMatches,
warnUnusedTopBinds, warnUnusedLocalBinds,
dataTcOccs, unknownNameErr, kindSigErr, dataKindsErr, perhapsForallMsg,
-
HsDocContext(..), docOfHsDocContext
) where
@@ -49,7 +50,6 @@ module RnEnv (
import LoadIface ( loadInterfaceForName, loadSrcInterface )
import IfaceEnv
import HsSyn
-import RdrHsSyn ( extractHsTyRdrTyVars )
import RdrName
import HscTypes
import TcEnv ( tcLookupDataCon, tcLookupField, isBrackStage )
@@ -72,7 +72,6 @@ import ListSetOps ( removeDups )
import DynFlags
import FastString
import Control.Monad
-import Data.List
import qualified Data.Set as Set
\end{code}
@@ -271,6 +270,25 @@ lookupInstDeclBndr cls what rdr
where
doc = what <+> ptext (sLit "of class") <+> quotes (ppr cls)
+
+-----------------------------------------------
+lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name)
+-- Used for TyData and TySynonym only,
+-- both ordinary ones and family instances
+-- See Note [Family instance binders]
+lookupTcdName mb_cls tc_decl
+ | not (isFamInstDecl tc_decl) -- The normal case
+ = ASSERT2( isNothing mb_cls, ppr tc_rdr ) -- Parser prevents this
+ lookupLocatedTopBndrRn tc_rdr
+
+ | Just cls <- mb_cls -- Associated type; c.f RnBinds.rnMethodBind
+ = wrapLocM (lookupInstDeclBndr cls (ptext (sLit "associated type"))) tc_rdr
+
+ | otherwise -- Family instance; tc_rdr is an *occurrence*
+ = lookupLocatedOccRn tc_rdr
+ where
+ tc_rdr = tcdLName tc_decl
+
-----------------------------------------------
lookupConstructorFields :: Name -> RnM [Name]
-- Look up the fields of a given constructor
@@ -374,6 +392,40 @@ lookupSubBndrGREs env parent rdr_name
parent_is _ _ = False
\end{code}
+Note [Family instance binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+ data family F a
+ data instance F T = X1 | X2
+
+The 'data instance' decl has an *occurrence* of F (and T), and *binds*
+X1 and X2. (This is unlike a normal data type declaration which would
+bind F too.) So we want an AvailTC F [X1,X2].
+
+Now consider a similar pair:
+ class C a where
+ data G a
+ instance C S where
+ data G S = Y1 | Y2
+
+The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G.
+
+But there is a small complication: in an instance decl, we don't use
+qualified names on the LHS; instead we use the class to disambiguate.
+Thus:
+ module M where
+ import Blib( G )
+ class C a where
+ data G a
+ instance C S where
+ data G S = Y1 | Y2
+Even though there are two G's in scope (M.G and Blib.G), the occurence
+of 'G' in the 'instance C S' decl is unambiguous, becuase C has only
+one associated type called G. This is exactly what happens for methods,
+and it is only consistent to do the same thing for types. That's the
+role of the function lookupTcdName; the (Maybe Name) give the class of
+the encloseing instance decl, if any.
+
Note [Looking up Exact RdrNames]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Exact RdrNames are generated by Template Haskell. See Note [Binders
@@ -452,10 +504,18 @@ lookupOccRn rdr_name = do
opt_name <- lookupOccRn_maybe rdr_name
maybe (unboundName WL_Any rdr_name) return opt_name
+lookupKindOccRn :: RdrName -> RnM Name
+-- Looking up a name occurring in a kind
+lookupKindOccRn rdr_name
+ = do { mb_name <- lookupOccRn_maybe rdr_name
+ ; case mb_name of
+ Just name -> return name
+ Nothing -> unboundName WL_Any rdr_name }
+
-- lookupPromotedOccRn looks up an optionally promoted RdrName.
-lookupPromotedOccRn :: RdrName -> RnM Name
+lookupTypeOccRn :: RdrName -> RnM Name
-- see Note [Demotion]
-lookupPromotedOccRn rdr_name
+lookupTypeOccRn rdr_name
= do { mb_name <- lookupOccRn_maybe rdr_name
; case mb_name of {
Just name -> return name ;
@@ -1018,42 +1078,6 @@ bindLocatedLocalsFV rdr_names enclosed_scope
return (thing, delFVs names fvs)
-------------------------------------
-bindPatSigTyVars :: [LHsType RdrName] -> ([Name] -> RnM a) -> RnM a
- -- Find the type variables in the pattern type
- -- signatures that must be brought into scope
-bindPatSigTyVars tys thing_inside
- = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
- ; if not scoped_tyvars then
- thing_inside []
- else
- do { name_env <- getLocalRdrEnv
- ; let locd_tvs = [ tv | ty <- tys
- , tv <- extractHsTyRdrTyVars ty
- , not (unLoc tv `elemLocalRdrEnv` name_env) ]
- nubbed_tvs = nubBy eqLocated locd_tvs
- -- The 'nub' is important. For example:
- -- f (x :: t) (y :: t) = ....
- -- We don't want to complain about binding t twice!
-
- ; bindLocatedLocalsRn nubbed_tvs thing_inside }}
-
-bindPatSigTyVarsFV :: [LHsType RdrName]
- -> RnM (a, FreeVars)
- -> RnM (a, FreeVars)
-bindPatSigTyVarsFV tys thing_inside
- = bindPatSigTyVars tys $ \ tvs ->
- thing_inside `thenM` \ (result,fvs) ->
- return (result, fvs `delListFromNameSet` tvs)
-
-bindSigTyVarsFV :: [Name]
- -> RnM (a, FreeVars)
- -> RnM (a, FreeVars)
-bindSigTyVarsFV tvs thing_inside
- = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
- ; if not scoped_tyvars then
- thing_inside
- else
- bindLocalNamesFV tvs thing_inside }
extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
-- This function is used only in rnSourceDecl on InstDecl
@@ -1148,24 +1172,19 @@ unboundName wl rdr = unboundNameX wl rdr empty
unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name
unboundNameX where_look rdr_name extra
= do { show_helpful_errors <- doptM Opt_HelpfulErrors
- ; let err = unknownNameErr rdr_name $$ extra
+ ; let what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
+ err = unknownNameErr what rdr_name $$ extra
; if not show_helpful_errors
then addErr err
else do { suggestions <- unknownNameSuggestErr where_look rdr_name
; addErr (err $$ suggestions) }
- ; env <- getGlobalRdrEnv;
- ; traceRn (vcat [unknownNameErr rdr_name,
- ptext (sLit "Global envt is:"),
- nest 3 (pprGlobalRdrEnv env)])
-
; return (mkUnboundName rdr_name) }
-unknownNameErr :: RdrName -> SDoc
-unknownNameErr rdr_name
+unknownNameErr :: SDoc -> RdrName -> SDoc
+unknownNameErr what rdr_name
= vcat [ hang (ptext (sLit "Not in scope:"))
- 2 (pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
- <+> quotes (ppr rdr_name))
+ 2 (what <+> quotes (ppr rdr_name))
, extra ]
where
extra | rdr_name == forall_tv_RDR = perhapsForallMsg
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 7caae61027..b884d4abde 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -34,8 +34,7 @@ import HsSyn
import TcRnMonad
import TcEnv ( thRnBrack )
import RnEnv
-import RnTypes ( rnHsTypeFVs, rnSplice, rnIPName, checkTH,
- mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
+import RnTypes
import RnPat
import DynFlags
import BasicTypes ( FixityDirection(..) )
@@ -270,7 +269,7 @@ rnExpr (RecordUpd expr rbinds _ _ _)
fvExpr `plusFV` fvRbinds) }
rnExpr (ExprWithTySig expr pty)
- = do { (pty', fvTy) <- rnHsTypeFVs ExprWithTySigCtx pty
+ = do { (pty', fvTy) <- rnLHsType ExprWithTySigCtx pty
; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
rnLExpr expr
; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
@@ -283,7 +282,7 @@ rnExpr (HsIf _ p b1 b2)
; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
rnExpr (HsType a)
- = rnHsTypeFVs HsTypeCtx a `thenM` \ (t, fvT) ->
+ = rnLHsType HsTypeCtx a `thenM` \ (t, fvT) ->
return (HsType t, fvT)
rnExpr (ArithSeq _ seq)
@@ -607,7 +606,7 @@ rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
-rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs TypBrCtx t
+rnBracket (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t
; return (TypBr t', fvs) }
rnBracket (DecBrL decls)
diff --git a/compiler/rename/RnHsSyn.lhs b/compiler/rename/RnHsSyn.lhs
deleted file mode 100644
index e2369bb776..0000000000
--- a/compiler/rename/RnHsSyn.lhs
+++ /dev/null
@@ -1,159 +0,0 @@
-%
-% (c) The AQUA Project, Glasgow University, 1996-1998
-%
-\section[RnHsSyn]{Specialisations of the @HsSyn@ syntax for the renamer}
-
-\begin{code}
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
-module RnHsSyn(
- -- Names
- charTyCon_name, listTyCon_name, parrTyCon_name, tupleTyCon_name,
- extractHsTyVars, extractHsTyNames, extractHsTyNames_s,
- extractFunDepNames, extractHsCtxtTyNames,
- extractHsTyVarBndrNames, extractHsTyVarBndrNames_s,
-
- -- Free variables
- hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs
- ) where
-
-#include "HsVersions.h"
-
-import HsSyn
-import Class ( FunDep )
-import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon )
-import Name ( Name, getName, isTyVarName )
-import NameSet
-import BasicTypes ( TupleSort )
-import SrcLoc
-import Panic ( panic )
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Free variables}
-%* *
-%************************************************************************
-
-These free-variable finders returns tycons and classes too.
-
-\begin{code}
-charTyCon_name, listTyCon_name, parrTyCon_name :: Name
-charTyCon_name = getName charTyCon
-listTyCon_name = getName listTyCon
-parrTyCon_name = getName parrTyCon
-
-tupleTyCon_name :: TupleSort -> Int -> Name
-tupleTyCon_name sort n = getName (tupleTyCon sort n)
-
-extractHsTyVars :: LHsType Name -> NameSet
-extractHsTyVars x = filterNameSet isTyVarName (extractHsTyNames x)
-
-extractFunDepNames :: FunDep Name -> NameSet
-extractFunDepNames (ns1, ns2) = mkNameSet ns1 `unionNameSets` mkNameSet ns2
-
-extractHsTyNames :: LHsType Name -> NameSet
--- Also extract names in kinds.
-extractHsTyNames ty
- = getl ty
- where
- getl (L _ ty) = get ty
-
- get (HsAppTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2
- get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` getl ty
- get (HsPArrTy ty) = unitNameSet parrTyCon_name `unionNameSets` getl ty
- get (HsTupleTy _ tys) = extractHsTyNames_s tys
- get (HsFunTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2
- get (HsIParamTy _ ty) = getl ty
- get (HsEqTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2
- get (HsOpTy ty1 (_, op) ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op)
- get (HsParTy ty) = getl ty
- get (HsBangTy _ ty) = getl ty
- get (HsRecTy flds) = extractHsTyNames_s (map cd_fld_type flds)
- get (HsTyVar tv) = unitNameSet tv
- get (HsSpliceTy _ fvs _) = fvs
- get (HsQuasiQuoteTy {}) = emptyNameSet
- get (HsKindSig ty ki) = getl ty `unionNameSets` getl ki
- get (HsForAllTy _ tvs
- ctxt ty) = extractHsTyVarBndrNames_s tvs
- (extractHsCtxtTyNames ctxt
- `unionNameSets` getl ty)
- get (HsDocTy ty _) = getl ty
- get (HsCoreTy {}) = emptyNameSet -- This probably isn't quite right
- -- but I don't think it matters
- get (HsExplicitListTy _ tys) = extractHsTyNames_s tys
- get (HsExplicitTupleTy _ tys) = extractHsTyNames_s tys
- get (HsWrapTy {}) = panic "extractHsTyNames"
-
-extractHsTyNames_s :: [LHsType Name] -> NameSet
-extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys
-
-extractHsCtxtTyNames :: LHsContext Name -> NameSet
-extractHsCtxtTyNames (L _ ctxt)
- = foldr (unionNameSets . extractHsTyNames) emptyNameSet ctxt
-
-extractHsTyVarBndrNames :: LHsTyVarBndr Name -> NameSet
-extractHsTyVarBndrNames (L _ (UserTyVar _ _)) = emptyNameSet
-extractHsTyVarBndrNames (L _ (KindedTyVar _ ki _)) = extractHsTyNames ki
-
-extractHsTyVarBndrNames_s :: [LHsTyVarBndr Name] -> NameSet -> NameSet
--- Update the name set 'body' by adding the names in the binders
--- kinds and handling scoping.
-extractHsTyVarBndrNames_s [] body = body
-extractHsTyVarBndrNames_s (b:bs) body =
- (extractHsTyVarBndrNames_s bs body `delFromNameSet` hsTyVarName (unLoc b))
- `unionNameSets` extractHsTyVarBndrNames b
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Free variables of declarations}
-%* *
-%************************************************************************
-
-Return the Names that must be in scope if we are to use this declaration.
-In all cases this is set up for interface-file declarations:
- - for class decls we ignore the bindings
- - for instance decls likewise, plus the pragmas
- - for rule decls, we ignore HsRules
- - for data decls, we ignore derivings
-
- *** See "THE NAMING STORY" in HsDecls ****
-
-\begin{code}
-----------------
-hsSigsFVs :: [LSig Name] -> FreeVars
-hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs)
-
-hsSigFVs :: Sig Name -> FreeVars
-hsSigFVs (TypeSig _ ty) = extractHsTyNames ty
-hsSigFVs (GenericSig _ ty) = extractHsTyNames ty
-hsSigFVs (SpecInstSig ty) = extractHsTyNames ty
-hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty
-hsSigFVs _ = emptyFVs
-
-----------------
-conDeclFVs :: LConDecl Name -> FreeVars
-conDeclFVs (L _ (ConDecl { con_qvars = tyvars, con_cxt = context,
- con_details = details, con_res = res_ty}))
- = extractHsTyVarBndrNames_s tyvars $
- extractHsCtxtTyNames context `plusFV`
- conDetailsFVs details `plusFV`
- conResTyFVs res_ty
-
-conResTyFVs :: ResType Name -> FreeVars
-conResTyFVs ResTyH98 = emptyFVs
-conResTyFVs (ResTyGADT ty) = extractHsTyNames ty
-
-conDetailsFVs :: HsConDeclDetails Name -> FreeVars
-conDetailsFVs details = plusFVs (map bangTyFVs (hsConDeclArgTys details))
-
-bangTyFVs :: LHsType Name -> FreeVars
-bangTyFVs bty = extractHsTyNames (getBangType bty)
-\end{code}
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index b1a61db2a2..553c3ef81a 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -7,7 +7,7 @@
module RnNames (
rnImports, getLocalNonValBinders,
rnExports, extendGlobalRdrEnvRn,
- gresFromAvails, lookupTcdName,
+ gresFromAvails,
reportUnusedNames, finishWarnings,
) where
@@ -528,6 +528,18 @@ getLocalNonValBinders fixity_env
; names@(main_name : _) <- mapM newTopSrcBinder bndrs
; return (AvailTC main_name names) }
+ new_assoc :: LInstDecl RdrName -> RnM [AvailInfo]
+ new_assoc (L _ (FamInstDecl d))
+ = do { avail <- new_ti Nothing d
+ ; return [avail] }
+ new_assoc (L _ (ClsInstDecl inst_ty _ _ ats))
+ | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty
+ = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr
+ ; mapM (new_ti (Just cls_nm) . unLoc) ats }
+ | otherwise
+ = return [] -- Do not crash on ill-formed instances
+ -- Eg instance !Show Int Trac #3811c
+
new_ti :: Maybe Name -> FamInstDecl RdrName -> RnM AvailInfo
new_ti mb_cls ti_decl -- ONLY for type/data instances
= ASSERT( isFamInstDecl ti_decl )
@@ -535,37 +547,6 @@ getLocalNonValBinders fixity_env
; sub_names <- mapM newTopSrcBinder (hsTyClDeclBinders ti_decl)
; return (AvailTC (unLoc main_name) sub_names) }
-- main_name is not bound here!
-
- new_assoc :: LInstDecl RdrName -> RnM [AvailInfo]
- new_assoc (L _ (FamInstDecl d))
- = do { avail <- new_ti Nothing d
- ; return [avail] }
- new_assoc (L _ (ClsInstDecl inst_ty _ _ ats))
- = do { mb_cls_nm <- get_cls_parent inst_ty
- ; mapM (new_ti mb_cls_nm . unLoc) ats }
- where
- get_cls_parent inst_ty
- | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty
- = setSrcSpan loc $ do { nm <- lookupGlobalOccRn cls_rdr; return (Just nm) }
- | otherwise
- = return Nothing
-
-lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name)
--- Used for TyData and TySynonym only,
--- both ordinary ones and family instances
--- See Note [Family instance binders]
-lookupTcdName mb_cls tc_decl
- | not (isFamInstDecl tc_decl) -- The normal case
- = ASSERT2( isNothing mb_cls, ppr tc_rdr ) -- Parser prevents this
- lookupLocatedTopBndrRn tc_rdr
-
- | Just cls <- mb_cls -- Associated type; c.f RnBinds.rnMethodBind
- = wrapLocM (lookupInstDeclBndr cls (ptext (sLit "associated type"))) tc_rdr
-
- | otherwise -- Family instance; tc_rdr is an *occurrence*
- = lookupLocatedOccRn tc_rdr
- where
- tc_rdr = tcdLName tc_decl
\end{code}
Note [Looking up family names in family instances]
@@ -586,41 +567,6 @@ Solution is simple: process the type family declarations first, extend
the environment, and then process the type instances.
-Note [Family instance binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- data family F a
- data instance F T = X1 | X2
-
-The 'data instance' decl has an *occurrence* of F (and T), and *binds*
-X1 and X2. (This is unlike a normal data type declaration which would
-bind F too.) So we want an AvailTC F [X1,X2].
-
-Now consider a similar pair:
- class C a where
- data G a
- instance C S where
- data G S = Y1 | Y2
-
-The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G.
-
-But there is a small complication: in an instance decl, we don't use
-qualified names on the LHS; instead we use the class to disambiguate.
-Thus:
- module M where
- import Blib( G )
- class C a where
- data G a
- instance C S where
- data G S = Y1 | Y2
-Even though there are two G's in scope (M.G and Blib.G), the occurence
-of 'G' in the 'instance C S' decl is unambiguous, becuase C has only
-one associated type called G. This is exactly what happens for methods,
-and it is only consistent to do the same thing for types. That's the
-role of the function lookupTcdName; the (Maybe Name) give the class of
-the encloseing instance decl, if any.
-
-
%************************************************************************
%* *
\subsection{Filtering imports}
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index 7dd76bd4e6..162ce22775 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -162,6 +162,10 @@ matchNameMaker ctxt = LamMk report_unused
StmtCtxt GhciStmt -> False
_ -> True
+rnHsSigCps :: HsBndrSig (LHsType RdrName) -> CpsRn (HsBndrSig (LHsType Name))
+rnHsSigCps sig
+ = CpsRn (rnHsBndrSig True PatCtx sig)
+
newPatName :: NameMaker -> Located RdrName -> CpsRn Name
newPatName (LamMk report_unused) rdr_name
= CpsRn (\ thing_inside ->
@@ -232,11 +236,9 @@ rnPats :: HsMatchContext Name -- for error messages
rnPats ctxt pats thing_inside
= do { envs_before <- getRdrEnvs
- -- (0) bring into scope all of the type variables bound by the patterns
-- (1) rename the patterns, bringing into scope all of the term variables
-- (2) then do the thing inside.
- ; bindPatSigTyVarsFV (collectSigTysFromPats pats) $
- unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do
+ ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do
{ -- Check for duplicated and shadowed names
-- Must do this *after* renaming the patterns
-- See Note [Collect binders only after renaming] in HsUtils
@@ -310,15 +312,10 @@ rnPatAndThen mk (VarPat rdr) = do { loc <- liftCps getSrcSpanM
-- we need to bind pattern variables for view pattern expressions
-- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
-rnPatAndThen mk (SigPatIn pat ty)
- = do { patsigs <- liftCps (xoptM Opt_ScopedTypeVariables)
- ; if patsigs
- then do { pat' <- rnLPatAndThen mk pat
- ; ty' <- liftCpsFV (rnHsTypeFVs PatCtx ty)
- ; return (SigPatIn pat' ty') }
- else do { liftCps (addErr (patSigErr ty))
- ; rnPatAndThen mk (unLoc pat) } }
-
+rnPatAndThen mk (SigPatIn pat sig)
+ = do { pat' <- rnLPatAndThen mk pat
+ ; sig' <- rnHsSigCps sig
+ ; return (SigPatIn pat' sig') }
rnPatAndThen mk (LitPat lit)
| HsString s <- lit
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 1969229321..a4a734cca1 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -25,7 +25,6 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl )
import HsSyn
import RdrName
import RdrHsSyn ( extractHsRhoRdrTyVars )
-import RnHsSyn
import RnTypes
import RnBinds
import RnEnv
@@ -43,6 +42,7 @@ import NameEnv
import Avail
import Outputable
import Bag
+import BasicTypes ( RuleName )
import FastString
import Util ( filterOut )
import SrcLoc
@@ -54,7 +54,6 @@ import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
import Control.Monad
import Data.List( partition )
import Maybes( orElse )
-import Data.Maybe( isNothing )
\end{code}
@rnSourceDecl@ `renames' declarations.
@@ -356,7 +355,7 @@ rnAnnProvenance provenance = do
\begin{code}
rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars)
rnDefaultDecl (DefaultDecl tys)
- = do { (tys', fvs) <- mapFvRn (rnHsTypeFVs doc_str) tys
+ = do { (tys', fvs) <- rnLHsTypes doc_str tys
; return (DefaultDecl tys', fvs) }
where
doc_str = DefaultDeclCtx
@@ -373,7 +372,7 @@ rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
rnHsForeignDecl (ForeignImport name ty _ spec)
= do { topEnv :: HscEnv <- getTopEnv
; name' <- lookupLocatedTopBndrRn name
- ; (ty', fvs) <- rnHsTypeFVs (ForeignDeclCtx name) ty
+ ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty
-- Mark any PackageTarget style imports as coming from the current package
; let packageId = thisPackage $ hsc_dflags topEnv
@@ -383,7 +382,7 @@ rnHsForeignDecl (ForeignImport name ty _ spec)
rnHsForeignDecl (ForeignExport name ty _ spec)
= do { name' <- lookupLocatedOccRn name
- ; (ty', fvs) <- rnHsTypeFVs (ForeignDeclCtx name) ty
+ ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty
; return (ForeignExport name' ty' noForeignExportCoercionYet spec, fvs `addOneFV` unLoc name') }
-- NB: a foreign export is an *occurrence site* for name, so
-- we add it to the free-variable list. It might, for example,
@@ -430,18 +429,19 @@ rnSrcInstDecl (FamInstDecl ty_decl)
rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats)
-- Used for both source and interface file decls
- = do { inst_ty' <- rnLHsInstType (text "In an instance declaration") inst_ty
+ = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty
; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty'
(spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags
+ tv_names = hsLTyVarNames inst_tyvars
-- Rename the associated types, and type signatures
-- Both need to have the instance type variables in scope
; ((ats', other_sigs'), more_fvs)
- <- extendTyVarEnvFVRn (map hsLTyVarName inst_tyvars) $
- do { (ats', at_fvs) <- rnATInsts cls ats
- ; other_sigs' <- renameSigs (InstDeclCtxt cls) other_sigs
+ <- extendTyVarEnvFVRn tv_names $
+ do { (ats', at_fvs) <- rnATDecls cls tv_names ats
+ ; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs
; return ( (ats', other_sigs')
- , at_fvs `plusFV` hsSigsFVs other_sigs') }
+ , at_fvs `plusFV` sig_fvs) }
-- Rename the bindings
-- The typechecker (not the renamer) checks that all
@@ -458,16 +458,14 @@ rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats)
-- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
-- works OK. That's why we did the partition game above
--
- -- But the (unqualified) method names are in scope
--- ; let binders = collectHsBindsBinders mbinds'
- ; spec_inst_prags' <- -- bindLocalNames binders $
- renameSigs (InstDeclCtxt cls) spec_inst_prags
+ ; (spec_inst_prags', spec_inst_fvs)
+ <- renameSigs (InstDeclCtxt cls) spec_inst_prags
; let uprags' = spec_inst_prags' ++ other_sigs'
; return (ClsInstDecl inst_ty' mbinds' uprags' ats',
meth_fvs `plusFV` more_fvs
- `plusFV` hsSigsFVs spec_inst_prags'
- `plusFV` extractHsTyNames inst_ty') }
+ `plusFV` spec_inst_fvs
+ `plusFV` inst_fvs) }
-- We return the renamed associated data type declarations so
-- that they can be entered into the list of type declarations
-- for the binding group, but we also keep a copy in the instance.
@@ -483,15 +481,18 @@ rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats)
Renaming of the associated types in instances.
\begin{code}
-rnATInsts :: Name -> [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
- -- NB: We allow duplicate associated-type decls;
- -- See Note [Associated type instances] in TcInstDcls
-rnATInsts cls atDecls = rnList rnATInst atDecls
- where
- rnATInst tydecl@TyData {} = rnTyClDecl (Just cls) tydecl
- rnATInst tydecl@TySynonym {} = rnTyClDecl (Just cls) tydecl
- rnATInst tydecl = pprPanic "RnSource.rnATInsts: invalid AT instance"
- (ppr (tcdName tydecl))
+rnATDecls :: Name -- Class
+ -> [Name] -- Type variable binders (but NOT kind variables)
+ -- See Note [Renaming associated types] in RnTypes
+ -> [LTyClDecl RdrName]
+ -> RnM ([LTyClDecl Name], FreeVars)
+-- Used for the family declarations and defaults in a class decl
+-- and the family instance declarations in an instance
+--
+-- NB: We allow duplicate associated-type decls;
+-- See Note [Associated type instances] in TcInstDcls
+rnATDecls cls tvs atDecls
+ = rnList (rnTyClDecl (Just (cls, tvs))) atDecls
\end{code}
For the method bindings in class and instance decls, we extend the
@@ -520,8 +521,7 @@ rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
rnSrcDerivDecl (DerivDecl ty)
= do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving
; unless standalone_deriv_ok (addErr standaloneDerivErr)
- ; ty' <- rnLHsInstType (text "In a deriving declaration") ty
- ; let fvs = extractHsTyNames ty'
+ ; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty
; return (DerivDecl ty', fvs) }
standaloneDerivErr :: SDoc
@@ -539,36 +539,39 @@ standaloneDerivErr
\begin{code}
rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
- = bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $
- bindLocatedLocalsFV (map get_var vars) $ \ ids ->
- do { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids)
- -- NB: The binders in a rule are always Ids
- -- We don't (yet) support type variables
-
- ; (lhs', fv_lhs') <- rnLExpr lhs
- ; (rhs', fv_rhs') <- rnLExpr rhs
-
- ; checkValidRule rule_name ids lhs' fv_lhs'
-
- ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
- fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') }
+ = do { let rdr_names_w_loc = map get_var vars
+ ; checkDupAndShadowedRdrNames rdr_names_w_loc
+ ; names <- newLocalBndrsRn rdr_names_w_loc
+ ; bindHsRuleVars rule_name vars names $ \ vars' ->
+ do { (lhs', fv_lhs') <- rnLExpr lhs
+ ; (rhs', fv_rhs') <- rnLExpr rhs
+ ; checkValidRule rule_name names lhs' fv_lhs'
+ ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
+ fv_lhs' `plusFV` fv_rhs') } }
where
- doc = RuleCtx rule_name
-
- get_var (RuleBndr v) = v
get_var (RuleBndrSig v _) = v
+ get_var (RuleBndr v) = v
+
+bindHsRuleVars :: RuleName -> [RuleBndr RdrName] -> [Name]
+ -> ([RuleBndr Name] -> RnM (a, FreeVars))
+ -> RnM (a, FreeVars)
+bindHsRuleVars rule_name vars names thing_inside
+ = go vars names $ \ vars' ->
+ bindLocalNamesFV names (thing_inside vars')
+ where
+ doc = RuleCtx rule_name
- rn_var (RuleBndr (L loc _), id)
- = return (RuleBndr (L loc id), emptyFVs)
- rn_var (RuleBndrSig (L loc _) t, id)
- = do { (t', fvs) <- rnHsTypeFVs doc t
- ; return (RuleBndrSig (L loc id) t', fvs) }
+ go (RuleBndr (L loc _) : vars) (n : ns) thing_inside
+ = go vars ns $ \ vars' ->
+ thing_inside (RuleBndr (L loc n) : vars')
-badRuleVar :: FastString -> Name -> SDoc
-badRuleVar name var
- = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
- ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+>
- ptext (sLit "does not appear on left hand side")]
+ go (RuleBndrSig (L loc _) bsig : vars) (n : ns) thing_inside
+ = rnHsBndrSig True doc bsig $ \ bsig' ->
+ go vars ns $ \ vars' ->
+ thing_inside (RuleBndrSig (L loc n) bsig' : vars')
+
+ go [] [] thing_inside = thing_inside []
+ go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
\end{code}
Note [Rule LHS validity checking]
@@ -628,6 +631,12 @@ validRuleLhs foralls lhs
checkl_es es = foldr (mplus . checkl_e) Nothing es
-}
+badRuleVar :: FastString -> Name -> SDoc
+badRuleVar name var
+ = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
+ ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+>
+ ptext (sLit "does not appear on left hand side")]
+
badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
badRuleLhsErr name lhs bad_e
= sep [ptext (sLit "Rule") <+> ftext name <> colon,
@@ -685,8 +694,8 @@ rnHsVectDecl (HsVectClassIn cls)
rnHsVectDecl (HsVectClassOut _)
= panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
rnHsVectDecl (HsVectInstIn instTy)
- = do { instTy' <- rnLHsInstType (text "In a VECTORISE pragma") instTy
- ; return (HsVectInstIn instTy', extractHsTyNames instTy')
+ = do { (instTy', fvs) <- rnLHsInstType (text "In a VECTORISE pragma") instTy
+ ; return (HsVectInstIn instTy', fvs)
}
rnHsVectDecl (HsVectInstOut _)
= panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
@@ -772,9 +781,10 @@ rnTyClDecls extra_deps tycl_ds
; return (map flattenSCC sccs, all_fvs) }
-rnTyClDecl :: Maybe Name -- Just cls => this TyClDecl is nested
- -- inside an *instance decl* for cls
- -- used for associated types
+rnTyClDecl :: Maybe (Name, [Name])
+ -- Just (cls,tvs) => this TyClDecl is nested
+ -- inside an *instance decl* for cls
+ -- used for associated types
-> TyClDecl RdrName
-> RnM (TyClDecl Name, FreeVars)
rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name})
@@ -786,16 +796,15 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name})
-- and "data family"), both top level and (for an associated type)
-- in a class decl
rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars
- , tcdFlavour = flav, tcdKind = kind })
- = bindQTvs fmly_doc mb_cls tyvars $ \tyvars' ->
+ , tcdFlavour = flav, tcdKindSig = kind })
+ = bindTyClTyVars fmly_doc mb_cls tyvars $ \tyvars' ->
do { tycon' <- lookupLocatedTopBndrRn tycon
- ; kind' <- rnLHsMaybeKind fmly_doc kind
- ; let fv_kind = maybe emptyFVs extractHsTyNames kind'
- fvs = extractHsTyVarBndrNames_s tyvars' fv_kind
+ ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind
; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars'
- , tcdFlavour = flav, tcdKind = kind' }
- , fvs) }
- where fmly_doc = TyFamilyCtx tycon
+ , tcdFlavour = flav, tcdKindSig = kind' }
+ , fv_kind) }
+ where
+ fmly_doc = TyFamilyCtx tycon
-- "data", "newtype", "data instance, and "newtype instance" declarations
-- both top level and (for an associated type) in an instance decl
@@ -804,40 +813,35 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCType = cType,
tcdLName = tycon, tcdTyVars = tyvars,
tcdTyPats = typats, tcdCons = condecls,
tcdKindSig = sig, tcdDerivs = derivs}
- = do { tycon' <- lookupTcdName mb_cls tydecl
- ; sig' <- rnLHsMaybeKind data_doc sig
+ = bindTyClTyVars data_doc mb_cls tyvars $ \ tyvars' ->
+ -- Checks for distinct tyvars
+ do { tycon' <- lookupTcdName (fmap fst mb_cls) tydecl
; checkTc (h98_style || null (unLoc context))
(badGadtStupidTheta tycon)
- ; ((tyvars', context', typats', derivs'), stuff_fvs)
- <- bindQTvs data_doc mb_cls tyvars $ \ tyvars' -> do
- -- Checks for distinct tyvars
- { 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'
- `plusFV` maybe emptyFVs extractHsTyNames sig'
- ; 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 $
+ ; (sig', sig_fvs) <- rnLHsMaybeKind data_doc sig
+ ; (context', fvs1) <- rnContext data_doc context
+ ; (typats', fvs2) <- rnTyPats data_doc tycon' typats
+ ; (derivs', fvs3) <- rn_derivs derivs
+
+ -- For the constructor declarations, drop the LocalRdrEnv
+ -- in the GADT case, where the type variables in the declaration
+ -- do not scope over the constructor signatures
+ -- data T a where { T1 :: forall b. b-> b }
+ ; let { zap_lcl_env | h98_style = \ thing -> thing
+ | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
+ ; (condecls', con_fvs) <- zap_lcl_env $
rnConDecls condecls
- -- No need to check for duplicate constructor decls
- -- since that is done by RnNames.extendGlobalRdrEnvRn
-
- ; return (TyData {tcdND = new_or_data, tcdCType = cType,
- tcdCtxt = context',
- tcdLName = tycon', tcdTyVars = tyvars',
- tcdTyPats = typats', tcdKindSig = sig',
- tcdCons = condecls', tcdDerivs = derivs'},
- con_fvs `plusFV` stuff_fvs)
+ -- No need to check for duplicate constructor decls
+ -- since that is done by RnNames.extendGlobalRdrEnvRn
+
+ ; return ( TyData { tcdND = new_or_data, tcdCType = cType
+ , tcdCtxt = context'
+ , tcdLName = tycon', tcdTyVars = tyvars'
+ , tcdTyPats = typats', tcdKindSig = sig'
+ , tcdCons = condecls', tcdDerivs = derivs'}
+ , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV`
+ con_fvs `plusFV` sig_fvs )
}
where
h98_style = case condecls of -- Note [Stupid theta]
@@ -847,22 +851,23 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCType = cType,
data_doc = TyDataCtx tycon
rn_derivs Nothing = return (Nothing, emptyFVs)
- rn_derivs (Just ds) = do { ds' <- rnLHsTypes data_doc ds
- ; return (Just ds', extractHsTyNames_s ds') }
+ rn_derivs (Just ds) = do { (ds', fvs) <- rnLHsTypes data_doc ds
+ ; return (Just ds', fvs) }
-- "type" and "type instance" declarations
-rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars,
- tcdLName = name,
- tcdTyPats = typats, tcdSynRhs = ty})
- = bindQTvs syn_doc mb_cls tyvars $ \ tyvars' -> do
- { -- Checks for distinct tyvars
- name' <- lookupTcdName mb_cls tydecl
- ; (typats',fvs1) <- rnTyPats syn_doc name' typats
- ; (ty', fvs2) <- rnHsTypeFVs syn_doc ty
- ; return (TySynonym { tcdLName = name'
- , tcdTyVars = tyvars'
- , tcdTyPats = typats', tcdSynRhs = ty'}
- , extractHsTyVarBndrNames_s tyvars' (fvs1 `plusFV` fvs2)) }
+rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars
+ , tcdLName = name
+ , tcdTyPats = typats, tcdSynRhs = ty})
+ = do { name' <- lookupTcdName (fmap fst mb_cls) tydecl
+ ; ((tyvars', typats', ty'), fvs)
+ <- bindTyClTyVars syn_doc mb_cls tyvars $ \ tyvars' -> do
+ do { (typats',fvs1) <- rnTyPats syn_doc name' typats
+ ; (ty', fvs2) <- rnLHsType syn_doc ty
+ ; return ((tyvars', typats', ty'), fvs1 `plusFV` fvs2) }
+ ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars'
+ , tcdTyPats = typats', tcdSynRhs = ty'
+ , tcdFVs = fvs }
+ , fvs) }
where
syn_doc = TySynCtx name
@@ -875,19 +880,19 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls,
-- Tyvars scope over superclass context and method signatures
; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs)
- <- bindTyVarsFV cls_doc tyvars $ \ tyvars' -> do
+ <- bindHsTyVars cls_doc tyvars $ \ tyvars' -> do
-- Checks for distinct tyvars
- { context' <- rnContext cls_doc context
+ { (context', cxt_fvs) <- rnContext cls_doc context
; fds' <- rnFds (docOfHsDocContext cls_doc) fds
- ; let rn_at = rnTyClDecl (Just cls')
- ; (ats', fv_ats) <- mapAndUnzipM (wrapLocFstM rn_at) ats
- ; sigs' <- renameSigs (ClsDeclCtxt cls') sigs
- ; (at_defs', fv_at_defs) <- mapAndUnzipM (wrapLocFstM rn_at) at_defs
- ; let fvs = extractHsCtxtTyNames context' `plusFV`
- hsSigsFVs sigs' `plusFV`
- plusFVs fv_ats `plusFV`
- plusFVs fv_at_defs
-- The fundeps have no free variables
+ ; let tv_ns = hsLTyVarNames tyvars'
+ ; (ats', fv_ats) <- rnATDecls cls' tv_ns ats
+ ; (at_defs', fv_at_defs) <- rnATDecls cls' tv_ns at_defs
+ ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs
+ ; let fvs = cxt_fvs `plusFV`
+ sig_fvs `plusFV`
+ fv_ats `plusFV`
+ fv_at_defs
; return ((tyvars', context', fds', ats', at_defs', sigs'), fvs) }
-- No need to check for duplicate associated type decls
@@ -924,64 +929,11 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls,
tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
tcdDocs = docs'},
- extractHsTyVarBndrNames_s tyvars' (meth_fvs `plusFV` stuff_fvs)) }
+ meth_fvs `plusFV` stuff_fvs) }
where
cls_doc = ClassDeclCtx lcls
-bindQTvs :: HsDocContext -> Maybe Name -> [LHsTyVarBndr RdrName]
- -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
- -> RnM (a, FreeVars)
-bindQTvs doc mb_cls tyvars thing_inside
- | isNothing mb_cls -- Not associated
- = bindTyVarsFV doc tyvars thing_inside
- | otherwise -- Associated
- = do { let tv_rdr_names = map hsLTyVarLocName tyvars
- -- *All* the free vars of the family patterns
-
- -- Check for duplicated bindings
- -- This test is irrelevant for data/type *instances*, where the tyvars
- -- are the free tyvars of the patterns, and hence have no duplicates
- -- But it's needed for data/type *family* decls
- ; mapM_ dupBoundTyVar (findDupRdrNames tv_rdr_names)
-
- ; rdr_env <- getLocalRdrEnv
-
- ; tv_ns <- mapM (mk_tv_name rdr_env) tv_rdr_names
- ; tyvars' <- zipWithM (\old new -> replaceLTyVarName old new (rnLHsKind doc)) tyvars tv_ns
- ; (thing, fvs) <- bindLocalNamesFV tv_ns $ thing_inside tyvars'
-
- -- Check that the RHS of the decl mentions only type variables
- -- bound on the LHS. For example, this is not ok
- -- class C a b where
- -- type F a x :: *
- -- instance C (p,q) r where
- -- type F (p,q) x = (x, r) -- BAD: mentions 'r'
- -- c.f. Trac #5515
- ; let bad_tvs = filterNameSet (isTvOcc . nameOccName) fvs
- ; unless (isEmptyNameSet bad_tvs) (badAssocRhs (nameSetToList bad_tvs))
-
- ; return (thing, fvs) }
- where
- mk_tv_name :: LocalRdrEnv -> Located RdrName -> RnM Name
- mk_tv_name rdr_env (L l tv_rdr)
- = case lookupLocalRdrEnv rdr_env tv_rdr of
- Just n -> return n
- Nothing -> newLocalBndrRn (L l tv_rdr)
-
-badAssocRhs :: [Name] -> RnM ()
-badAssocRhs ns
- = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable")
- <> plural ns
- <+> pprWithCommas (quotes . ppr) ns)
- 2 (ptext (sLit "All such variables must be bound on the LHS")))
-
-dupBoundTyVar :: [Located RdrName] -> RnM ()
-dupBoundTyVar (L loc tv : _)
- = setSrcSpan loc $
- addErr (ptext (sLit "Illegal repeated type variable") <+> quotes (ppr tv))
-dupBoundTyVar [] = panic "dupBoundTyVar"
-
badGadtStupidTheta :: Located RdrName -> SDoc
badGadtStupidTheta _
= vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
@@ -1049,24 +1001,22 @@ is jolly confusing. See Trac #4875
%*********************************************************
\begin{code}
-rnTyPats :: HsDocContext -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars)
+rnTyPats :: HsDocContext -> 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, emptyFVs)
rnTyPats doc tc (Just typats)
- = do { typats' <- rnLHsTypes doc typats
- ; let fvs = addOneFV (extractHsTyNames_s typats') (unLoc tc)
+ = do { (typats', fvs) <- rnLHsTypes doc typats
+ ; return (Just typats', addOneFV fvs (unLoc tc)) }
-- type instance => use, hence addOneFV
- ; return (Just typats', fvs) }
rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
-rnConDecls condecls
- = do { condecls' <- mapM (wrapLocM rnConDecl) condecls
- ; return (condecls', plusFVs (map conDeclFVs condecls')) }
+rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
-rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
+rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)
rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
, con_cxt = cxt, con_details = details
, con_res = res_ty, con_doc = mb_doc
@@ -1094,24 +1044,25 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
; mb_doc' <- rnMbLHsDoc mb_doc
- ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do
- { new_context <- rnContext doc cxt
- ; new_details <- rnConDeclDetails doc details
- ; (new_details', new_res_ty) <- rnConResult doc (unLoc new_name) new_details res_ty
+ ; bindHsTyVars doc new_tvs $ \new_tyvars -> do
+ { (new_context, fvs1) <- rnContext doc cxt
+ ; (new_details, fvs2) <- rnConDeclDetails doc details
+ ; (new_details', new_res_ty, fvs3) <- rnConResult doc (unLoc new_name) new_details res_ty
; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context
- , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }}
+ , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' },
+ fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
where
doc = ConDeclCtx name
get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy HsBoxedTuple tys))
rnConResult :: HsDocContext -> Name
-> HsConDetails (LHsType Name) [ConDeclField Name]
- -> ResType RdrName
+ -> ResType (LHsType RdrName)
-> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
- ResType Name)
-rnConResult _ _ details ResTyH98 = return (details, ResTyH98)
+ ResType (LHsType Name), FreeVars)
+rnConResult _ _ details ResTyH98 = return (details, ResTyH98, emptyFVs)
rnConResult doc con details (ResTyGADT ty)
- = do { ty' <- rnLHsType doc ty
+ = do { (ty', fvs) <- rnLHsType doc ty
; let (arg_tys, res_ty) = splitHsFunType ty'
-- We can finally split it up,
-- now the renamer has dealt with fixities
@@ -1123,7 +1074,7 @@ rnConResult doc con details (ResTyGADT ty)
RecCon {} -> do { unless (null arg_tys)
(addErr (badRecResTy (docOfHsDocContext doc)))
- ; return (details, ResTyGADT res_ty) }
+ ; return (details, ResTyGADT res_ty, fvs) }
PrefixCon {} | isSymOcc (getOccName con) -- See Note [Infix GADT cons]
, [ty1,ty2] <- arg_tys
@@ -1131,27 +1082,27 @@ rnConResult doc con details (ResTyGADT ty)
; return (if con `elemNameEnv` fix_env
then InfixCon ty1 ty2
else PrefixCon arg_tys
- , ResTyGADT res_ty) }
+ , ResTyGADT res_ty, fvs) }
| otherwise
- -> return (PrefixCon arg_tys, ResTyGADT res_ty) }
+ -> return (PrefixCon arg_tys, ResTyGADT res_ty, fvs) }
rnConDeclDetails :: HsDocContext
-> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
- -> RnM (HsConDetails (LHsType Name) [ConDeclField Name])
+ -> RnM (HsConDetails (LHsType Name) [ConDeclField Name], FreeVars)
rnConDeclDetails doc (PrefixCon tys)
- = do { new_tys <- mapM (rnLHsType doc) tys
- ; return (PrefixCon new_tys) }
+ = do { (new_tys, fvs) <- rnLHsTypes doc tys
+ ; return (PrefixCon new_tys, fvs) }
rnConDeclDetails doc (InfixCon ty1 ty2)
- = do { new_ty1 <- rnLHsType doc ty1
- ; new_ty2 <- rnLHsType doc ty2
- ; return (InfixCon new_ty1 new_ty2) }
+ = do { (new_ty1, fvs1) <- rnLHsType doc ty1
+ ; (new_ty2, fvs2) <- rnLHsType doc ty2
+ ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
rnConDeclDetails doc (RecCon fields)
- = do { new_fields <- rnConDeclFields doc fields
+ = do { (new_fields, fvs) <- rnConDeclFields doc fields
-- No need to check for duplicate fields
-- since that is done by RnNames.extendGlobalRdrEnvRn
- ; return (RecCon new_fields) }
+ ; return (RecCon new_fields, fvs) }
-------------------------------------------------
deprecRecSyntax :: ConDecl RdrName -> SDoc
diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 3b86d0b38c..15e5501fe0 100644
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -15,7 +15,7 @@ module RnTypes (
-- Type related stuff
rnHsType, rnLHsType, rnLHsTypes, rnContext,
rnHsKind, rnLHsKind, rnLHsMaybeKind,
- rnHsSigType, rnLHsInstType, rnHsTypeFVs, rnConDeclFields,
+ rnHsSigType, rnLHsInstType, rnConDeclFields,
rnIPName,
-- Precence related stuff
@@ -26,7 +26,7 @@ module RnTypes (
rnSplice, checkTH,
-- Binding related stuff
- bindTyVarsRn, bindTyVarsFV
+ bindSigTyVarsFV, bindHsTyVars, bindTyClTyVars, rnHsBndrSig
) where
import {-# SOURCE #-} RnExpr( rnLExpr )
@@ -36,8 +36,7 @@ import {-# SOURCE #-} TcSplice( runQuasiQuoteType )
import DynFlags
import HsSyn
-import RdrHsSyn ( extractHsRhoRdrTyVars )
-import RnHsSyn ( extractHsTyNames, extractHsTyVarBndrNames_s )
+import RdrHsSyn ( extractHsRhoRdrTyVars, extractHsTyRdrTyVars )
import RnHsDoc ( rnLHsDoc, rnMbLHsDoc )
import RnEnv
import TcRnMonad
@@ -54,7 +53,7 @@ import BasicTypes ( IPName(..), ipNameName, compareFixity, funTyFixity, negateFi
Fixity(..), FixityDirection(..) )
import Outputable
import FastString
-import Control.Monad ( unless, zipWithM )
+import Control.Monad ( unless )
#include "HsVersions.h"
\end{code}
@@ -69,23 +68,17 @@ to break several loop.
%*********************************************************
\begin{code}
-rnHsTypeFVs :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
-rnHsTypeFVs doc_str ty = do
- ty' <- rnLHsType doc_str ty
- return (ty', extractHsTyNames ty')
-
-rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
+rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
-- rnHsSigType is used for source-language type signatures,
-- which use *implicit* universal quantification.
-rnHsSigType doc_str ty
- = rnLHsType (TypeSigCtx doc_str) ty
+rnHsSigType doc_str ty = rnLHsType (TypeSigCtx doc_str) ty
-rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name)
+rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
-- Rename the type in an instance or standalone deriving decl
rnLHsInstType doc_str ty
- = do { ty' <- rnLHsType (TypeSigCtx doc_str) ty
+ = do { (ty', fvs) <- rnLHsType (TypeSigCtx doc_str) ty
; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty))
- ; return ty' }
+ ; return (ty', fvs) }
where
good_inst_ty
| Just (_, _, L _ cls, _) <- splitLHsInstDeclTy_maybe ty
@@ -101,27 +94,34 @@ want a gratuitous knot.
\begin{code}
rnLHsTyKi :: Bool -- True <=> renaming a type, False <=> a kind
- -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name)
-rnLHsTyKi isType doc = wrapLocM (rnHsTyKi isType doc)
+ -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
+rnLHsTyKi isType doc (L loc ty)
+ = setSrcSpan loc $
+ do { (ty', fvs) <- rnHsTyKi isType doc ty
+ ; return (L loc ty', fvs) }
-rnLHsType :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name)
+rnLHsType :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
rnLHsType = rnLHsTyKi True
-rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name)
+
+rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars)
rnLHsKind = rnLHsTyKi False
-rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName) -> RnM (Maybe (LHsKind Name))
-rnLHsMaybeKind _ Nothing = return Nothing
-rnLHsMaybeKind doc (Just k) = do
- k' <- rnLHsKind doc k
- return (Just k')
-rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name)
+rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName)
+ -> RnM (Maybe (LHsKind Name), FreeVars)
+rnLHsMaybeKind _ Nothing = return (Nothing, emptyFVs)
+rnLHsMaybeKind doc (Just k)
+ = do { (k', fvs) <- rnLHsKind doc k
+ ; return (Just k', fvs) }
+
+rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
rnHsType = rnHsTyKi True
-rnHsKind :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name)
+rnHsKind :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars)
rnHsKind = rnHsTyKi False
-rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name)
+rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
-rnHsTyKi isType doc (HsForAllTy Implicit _ ctxt ty) = ASSERT ( isType ) do
+rnHsTyKi isType doc (HsForAllTy Implicit _ ctxt ty)
+ = ASSERT ( isType ) do
-- Implicit quantifiction in source code (no kinds on tyvars)
-- Given the signature C => T we universally quantify
-- over FV(T) \ {in-scope-tyvars}
@@ -146,14 +146,11 @@ rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars ctxt tau)
in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty)
; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned
- ; -- rnForAll does the rest
- rnForAll doc Explicit forall_tyvars ctxt tau }
+ ; rnForAll doc Explicit forall_tyvars ctxt tau }
-rnHsTyKi isType _ (HsTyVar rdr_name) = do
- -- We use lookupOccRn in kinds because all the names are in
- -- TcClsName, and we don't want to look in DataName.
- name <- (if isType then lookupPromotedOccRn else lookupOccRn) rdr_name
- return (HsTyVar name)
+rnHsTyKi isType _ (HsTyVar rdr_name)
+ = do { name <- rnTyVar isType rdr_name
+ ; return (HsTyVar name, unitFV name) }
-- If we see (forall a . ty), without foralls on, the forall will give
-- a sensible error message, but we don't want to complain about the dot too
@@ -162,118 +159,144 @@ rnHsTyKi isType doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2)
= ASSERT ( isType ) setSrcSpan loc $
do { ops_ok <- xoptM Opt_TypeOperators
; op' <- if ops_ok
- then lookupPromotedOccRn op
+ then rnTyVar isType op
else do { addErr (opTyErr op ty)
; return (mkUnboundName op) } -- Avoid double complaint
; let l_op' = L loc op'
; fix <- lookupTyFixityRn l_op'
- ; ty1' <- rnLHsType doc ty1
- ; ty2' <- rnLHsType doc ty2
- ; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) op' fix ty1' ty2' }
+ ; (ty1', fvs1) <- rnLHsType doc ty1
+ ; (ty2', fvs2) <- rnLHsType doc ty2
+ ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2)
+ op' fix ty1' ty2'
+ ; return (res_ty, (fvs1 `plusFV` fvs2) `addOneFV` op') }
-rnHsTyKi isType doc (HsParTy ty) = do
- ty' <- rnLHsTyKi isType doc ty
- return (HsParTy ty')
+rnHsTyKi isType doc (HsParTy ty)
+ = do { (ty', fvs) <- rnLHsTyKi isType doc ty
+ ; return (HsParTy ty', fvs) }
rnHsTyKi isType doc (HsBangTy b ty)
- = ASSERT ( isType ) do { ty' <- rnLHsType doc ty
- ; return (HsBangTy b ty') }
+ = ASSERT ( isType )
+ do { (ty', fvs) <- rnLHsType doc ty
+ ; return (HsBangTy b ty', fvs) }
rnHsTyKi isType doc (HsRecTy flds)
- = ASSERT ( isType ) do { flds' <- rnConDeclFields doc flds
- ; return (HsRecTy flds') }
+ = ASSERT ( isType )
+ do { (flds', fvs) <- rnConDeclFields doc flds
+ ; return (HsRecTy flds', fvs) }
-rnHsTyKi isType doc (HsFunTy ty1 ty2) = do
- ty1' <- rnLHsTyKi isType doc ty1
+rnHsTyKi isType doc (HsFunTy ty1 ty2)
+ = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1
-- Might find a for-all as the arg of a function type
- ty2' <- rnLHsTyKi isType doc ty2
+ ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2
-- Or as the result. This happens when reading Prelude.hi
-- when we find return :: forall m. Monad m -> forall a. a -> m a
-- Check for fixity rearrangements
- if isType
- then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
- else return (HsFunTy ty1' ty2')
+ ; res_ty <- if isType
+ then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
+ else return (HsFunTy ty1' ty2')
+ ; return (res_ty, fvs1 `plusFV` fvs2) }
-rnHsTyKi isType doc listTy@(HsListTy ty) = do
- data_kinds <- xoptM Opt_DataKinds
- unless (data_kinds || isType) (addErr (dataKindsErr listTy))
- ty' <- rnLHsTyKi isType doc ty
- return (HsListTy ty')
+rnHsTyKi isType doc listTy@(HsListTy ty)
+ = do { data_kinds <- xoptM Opt_DataKinds
+ ; unless (data_kinds || isType) (addErr (dataKindsErr listTy))
+ ; (ty', fvs) <- rnLHsTyKi isType doc ty
+ ; return (HsListTy ty', fvs) }
rnHsTyKi isType doc (HsKindSig ty k)
- = ASSERT ( isType ) do {
- ; kind_sigs_ok <- xoptM Opt_KindSignatures
- ; unless kind_sigs_ok (addErr (kindSigErr ty))
- ; ty' <- rnLHsType doc ty
- ; k' <- rnLHsKind doc k
- ; return (HsKindSig ty' k') }
+ = ASSERT ( isType )
+ do { kind_sigs_ok <- xoptM Opt_KindSignatures
+ ; unless kind_sigs_ok (badSigErr False doc ty)
+ ; (ty', fvs1) <- rnLHsType doc ty
+ ; (k', fvs2) <- rnLHsKind doc k
+ ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) }
-rnHsTyKi isType doc (HsPArrTy ty) = ASSERT ( isType ) do
- ty' <- rnLHsType doc ty
- return (HsPArrTy ty')
+rnHsTyKi isType doc (HsPArrTy ty)
+ = ASSERT ( isType )
+ do { (ty', fvs) <- rnLHsType doc ty
+ ; return (HsPArrTy ty', fvs) }
-- Unboxed tuples are allowed to have poly-typed arguments. These
-- sometimes crop up as a result of CPR worker-wrappering dictionaries.
-rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys) = do
- data_kinds <- xoptM Opt_DataKinds
- unless (data_kinds || isType) (addErr (dataKindsErr tupleTy))
- tys' <- mapM (rnLHsTyKi isType doc) tys
- return (HsTupleTy tup_con tys')
-
-rnHsTyKi isType doc (HsAppTy ty1 ty2) = do
- ty1' <- rnLHsTyKi isType doc ty1
- ty2' <- rnLHsTyKi isType doc ty2
- return (HsAppTy ty1' ty2')
-
-rnHsTyKi isType doc (HsIParamTy n ty) = ASSERT( isType ) do
- ty' <- rnLHsType doc ty
- n' <- rnIPName n
- return (HsIParamTy n' ty')
-
-rnHsTyKi isType doc (HsEqTy ty1 ty2) = ASSERT( isType ) do
- ty1' <- rnLHsType doc ty1
- ty2' <- rnLHsType doc ty2
- return (HsEqTy ty1' ty2')
+rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys)
+ = do { data_kinds <- xoptM Opt_DataKinds
+ ; unless (data_kinds || isType) (addErr (dataKindsErr tupleTy))
+ ; (tys', fvs) <- mapFvRn (rnLHsTyKi isType doc) tys
+ ; return (HsTupleTy tup_con tys', fvs) }
+
+rnHsTyKi isType doc (HsAppTy ty1 ty2)
+ = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1
+ ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2
+ ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) }
+
+rnHsTyKi isType doc (HsIParamTy n ty)
+ = ASSERT( isType )
+ do { (ty', fvs) <- rnLHsType doc ty
+ ; n' <- rnIPName n
+ ; return (HsIParamTy n' ty', fvs) }
+
+rnHsTyKi isType doc (HsEqTy ty1 ty2)
+ = ASSERT( isType )
+ do { (ty1', fvs1) <- rnLHsType doc ty1
+ ; (ty2', fvs2) <- rnLHsType doc ty2
+ ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) }
rnHsTyKi isType _ (HsSpliceTy sp _ k)
- = ASSERT ( isType ) do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs
- ; return (HsSpliceTy sp' fvs k) }
+ = ASSERT ( isType )
+ do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs
+ ; return (HsSpliceTy sp' fvs k, fvs) }
-rnHsTyKi isType doc (HsDocTy ty haddock_doc) = ASSERT ( isType ) do
- ty' <- rnLHsType doc ty
- haddock_doc' <- rnLHsDoc haddock_doc
- return (HsDocTy ty' haddock_doc')
+rnHsTyKi isType doc (HsDocTy ty haddock_doc)
+ = ASSERT ( isType )
+ do { (ty', fvs) <- rnLHsType doc ty
+ ; haddock_doc' <- rnLHsDoc haddock_doc
+ ; return (HsDocTy ty' haddock_doc', fvs) }
#ifndef GHCI
rnHsTyKi _ _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty)
#else
-rnHsTyKi isType doc (HsQuasiQuoteTy qq) = ASSERT ( isType ) do { ty <- runQuasiQuoteType qq
- ; rnHsType doc (unLoc ty) }
+rnHsTyKi isType doc (HsQuasiQuoteTy qq)
+ = ASSERT ( isType )
+ do { ty <- runQuasiQuoteType qq
+ ; rnHsType doc (unLoc ty) }
#endif
-rnHsTyKi isType _ (HsCoreTy ty) = ASSERT ( isType ) return (HsCoreTy ty)
-rnHsTyKi _ _ (HsWrapTy {}) = panic "rnHsTyKi"
-rnHsTyKi isType doc (HsExplicitListTy k tys) =
- ASSERT( isType )
- do tys' <- mapM (rnLHsType doc) tys
- return (HsExplicitListTy k tys')
+rnHsTyKi isType _ (HsCoreTy ty)
+ = ASSERT ( isType )
+ return (HsCoreTy ty, emptyFVs)
+ -- The emptyFVs probably isn't quite right
+ -- but I don't think it matters
+
+rnHsTyKi _ _ (HsWrapTy {})
+ = panic "rnHsTyKi"
+
+rnHsTyKi isType doc (HsExplicitListTy k tys)
+ = ASSERT( isType )
+ do { (tys', fvs) <- rnLHsTypes doc tys
+ ; return (HsExplicitListTy k tys', fvs) }
+
+rnHsTyKi isType doc (HsExplicitTupleTy kis tys)
+ = ASSERT( isType )
+ do { (tys', fvs) <- rnLHsTypes doc tys
+ ; return (HsExplicitTupleTy kis tys', fvs) }
-rnHsTyKi isType doc (HsExplicitTupleTy kis tys) =
- ASSERT( isType )
- do tys' <- mapM (rnLHsType doc) tys
- return (HsExplicitTupleTy kis tys')
+--------------
+rnTyVar :: Bool -> RdrName -> RnM Name
+rnTyVar is_type rdr_name
+ | is_type = lookupTypeOccRn rdr_name
+ | otherwise = lookupKindOccRn rdr_name
--------------
rnLHsTypes :: HsDocContext -> [LHsType RdrName]
- -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name]
-rnLHsTypes doc tys = mapM (rnLHsType doc) tys
+ -> RnM ([LHsType Name], FreeVars)
+rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
\end{code}
\begin{code}
rnForAll :: HsDocContext -> HsExplicitFlag -> [LHsTyVarBndr RdrName]
- -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name)
+ -> LHsContext RdrName -> LHsType RdrName
+ -> RnM (HsType Name, FreeVars)
rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
-- One reason for this case is that a type like Int#
@@ -285,48 +308,190 @@ rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty
-- of kind *.
rnForAll doc exp forall_tyvars ctxt ty
- = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> do
- new_ctxt <- rnContext doc ctxt
- new_ty <- rnLHsType doc ty
- return (HsForAllTy exp new_tyvars new_ctxt new_ty)
+ = bindHsTyVars doc forall_tyvars $ \ new_tyvars ->
+ do { (new_ctxt, fvs1) <- rnContext doc ctxt
+ ; (new_ty, fvs2) <- rnLHsType doc ty
+ ; return (HsForAllTy exp new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) }
-- Retain the same implicit/explicit flag as before
-- so that we can later print it correctly
-bindTyVarsFV :: HsDocContext -> [LHsTyVarBndr RdrName]
+---------------
+bindSigTyVarsFV :: [Name]
+ -> RnM (a, FreeVars)
+ -> RnM (a, FreeVars)
+-- Used just before renaming the defn of a function
+-- with a separate type signature, to bring its tyvars into scope
+-- With no -XScopedTypeVariables, this is a no-op
+bindSigTyVarsFV tvs thing_inside
+ = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
+ ; if not scoped_tyvars then
+ thing_inside
+ else
+ bindLocalNamesFV tvs thing_inside }
+
+---------------
+bindTyClTyVars
+ :: HsDocContext
+ -> Maybe (Name, [Name]) -- Parent class and its tyvars
+ -- (but not kind vars)
+ -> [LHsTyVarBndr RdrName]
+ -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
+ -> RnM (a, FreeVars)
+-- Used for tyvar binders in type/class declarations
+-- Just like bindHsTyVars, but deals with the case of associated
+-- types, where the type variables may be already in scope
+bindTyClTyVars doc mb_cls tyvars thing_inside
+ | Just (_, cls_tvs) <- mb_cls -- Associated type family or type instance
+ = do { let tv_rdr_names = map hsLTyVarLocName tyvars
+ -- *All* the free vars of the family patterns
+
+ -- Check for duplicated bindings
+ -- This test is irrelevant for data/type *instances*, where the tyvars
+ -- are the free tyvars of the patterns, and hence have no duplicates
+ -- But it's needed for data/type *family* decls
+ ; checkDupRdrNames tv_rdr_names
+
+ -- Make the Names for the tyvars
+ ; rdr_env <- getLocalRdrEnv
+ ; let mk_tv_name :: Located RdrName -> RnM Name
+ -- Use the same Name as the parent class decl
+ mk_tv_name (L l tv_rdr)
+ = case lookupLocalRdrEnv rdr_env tv_rdr of
+ Just n -> return n
+ Nothing -> newLocalBndrRn (L l tv_rdr)
+ ; tv_ns <- mapM mk_tv_name tv_rdr_names
+
+ ; (thing, fvs) <- bindTyVarsRn doc tyvars tv_ns thing_inside
+
+ -- See Note [Renaming associated types]
+ ; let bad_tvs = fvs `intersectNameSet` mkNameSet cls_tvs
+ ; unless (isEmptyNameSet bad_tvs) (badAssocRhs (nameSetToList bad_tvs))
+
+ ; return (thing, fvs) }
+
+ | otherwise -- Not associated, just fall through to bindHsTyVars
+ = bindHsTyVars doc tyvars thing_inside
+
+badAssocRhs :: [Name] -> RnM ()
+badAssocRhs ns
+ = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable")
+ <> plural ns
+ <+> pprWithCommas (quotes . ppr) ns)
+ 2 (ptext (sLit "All such variables must be bound on the LHS")))
+
+---------------
+bindHsTyVars :: HsDocContext -> [LHsTyVarBndr RdrName]
-> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
-bindTyVarsFV doc tyvars thing_inside
- = bindTyVarsRn doc tyvars $ \ tyvars' ->
- do { (res, fvs) <- thing_inside tyvars'
- ; return (res, extractHsTyVarBndrNames_s tyvars' fvs) }
-
-bindTyVarsRn :: HsDocContext -> [LHsTyVarBndr RdrName]
- -> ([LHsTyVarBndr Name] -> RnM a)
- -> RnM a
--- Haskell-98 binding of type variables; e.g. within a data type decl
-bindTyVarsRn doc tyvar_names enclosed_scope
- = bindLocatedLocalsRn located_tyvars $ \ names ->
- do { kind_sigs_ok <- xoptM Opt_KindSignatures
- ; unless (null kinded_tyvars || kind_sigs_ok)
- (mapM_ (addErr . kindSigErr) kinded_tyvars)
- ; tyvar_names' <- zipWithM replace tyvar_names names
- ; enclosed_scope tyvar_names' }
+bindHsTyVars doc tv_bndrs thing_inside
+ = do { checkDupAndShadowedRdrNames rdr_names_w_loc
+ ; names <- newLocalBndrsRn rdr_names_w_loc
+ ; bindTyVarsRn doc tv_bndrs names thing_inside }
where
- replace (L loc n1) n2 = replaceTyVarName n1 n2 (rnLHsKind doc) >>= return . L loc
- located_tyvars = hsLTyVarLocNames tyvar_names
- kinded_tyvars = [n | L _ (KindedTyVar n _ _) <- tyvar_names]
+ rdr_names_w_loc = hsLTyVarLocNames tv_bndrs
-rnConDeclFields :: HsDocContext -> [ConDeclField RdrName] -> RnM [ConDeclField Name]
-rnConDeclFields doc fields = mapM (rnField doc) fields
-
-rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name)
-rnField doc (ConDeclField name ty haddock_doc)
- = do { new_name <- lookupLocatedTopBndrRn name
- ; new_ty <- rnLHsType doc ty
- ; new_haddock_doc <- rnMbLHsDoc haddock_doc
- ; return (ConDeclField new_name new_ty new_haddock_doc) }
+---------------
+bindTyVarsRn :: HsDocContext -> [LHsTyVarBndr RdrName] -> [Name]
+ -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
+ -> RnM (a, FreeVars)
+-- Rename the HsTyVarBndrs, giving them the specified names
+-- *and* bringing into scope the kind variables bound in
+-- any kind signatures
+
+bindTyVarsRn doc tv_bndrs names thing_inside
+ = go tv_bndrs names $ \ tv_bndrs' ->
+ bindLocalNamesFV names (thing_inside tv_bndrs')
+ where
+ go [] [] thing_inside = thing_inside []
+
+ go (L loc (UserTyVar _ tck) : tvs) (n : ns) thing_inside
+ = go tvs ns $ \ tvs' ->
+ thing_inside (L loc (UserTyVar n tck) : tvs')
+
+ go (L loc (KindedTyVar _ bsig tck) : tvs) (n : ns) thing_inside
+ = rnHsBndrSig False doc bsig $ \ bsig' ->
+ go tvs ns $ \ tvs' ->
+ thing_inside (L loc (KindedTyVar n bsig' tck) : tvs')
+
+ -- Lists of unequal length
+ go tvs names _ = pprPanic "bindTyVarsRn" (ppr tvs $$ ppr names)
+
+--------------------------------
+rnHsBndrSig :: Bool -- True <=> type sig, False <=> kind sig
+ -> HsDocContext
+ -> HsBndrSig (LHsType RdrName)
+ -> (HsBndrSig (LHsType Name) -> RnM (a, FreeVars))
+ -> RnM (a, FreeVars)
+rnHsBndrSig is_type doc (HsBSig ty _) thing_inside
+ = do { name_env <- getLocalRdrEnv
+ ; let tv_bndrs = [ tv | tv <- extractHsTyRdrTyVars ty
+ , not (unLoc tv `elemLocalRdrEnv` name_env) ]
+
+ ; checkHsBndrFlags is_type doc ty tv_bndrs
+ ; bindLocatedLocalsFV tv_bndrs $ \ tv_names -> do
+ { (ty', fvs1) <- rnLHsTyKi is_type doc ty
+ ; (res, fvs2) <- thing_inside (HsBSig ty' tv_names)
+ ; return (res, fvs1 `plusFV` fvs2) } }
+
+checkHsBndrFlags :: Bool -> HsDocContext
+ -> LHsType RdrName -> [Located RdrName] -> RnM ()
+checkHsBndrFlags is_type doc ty tv_bndrs
+ | is_type -- Type
+ = do { sig_ok <- xoptM Opt_ScopedTypeVariables
+ ; unless sig_ok (badSigErr True doc ty) }
+ | otherwise -- Kind
+ = do { sig_ok <- xoptM Opt_KindSignatures
+ ; unless sig_ok (badSigErr False doc ty)
+ ; poly_kind <- xoptM Opt_PolyKinds
+ ; unless (poly_kind || null tv_bndrs)
+ (addErr (badKindBndrs doc ty tv_bndrs)) }
+
+badKindBndrs :: HsDocContext -> LHsKind RdrName -> [Located RdrName] -> SDoc
+badKindBndrs doc _kind kvs
+ = vcat [ hang (ptext (sLit "Kind signature mentions kind variable") <> plural kvs
+ <+> pprQuotedList kvs)
+ 2 (ptext (sLit "Perhaps you intended to use -XPolyKinds"))
+ , docOfHsDocContext doc ]
+
+badSigErr :: Bool -> HsDocContext -> LHsType RdrName -> TcM ()
+badSigErr is_type doc (L loc ty)
+ = setSrcSpan loc $ addErr $
+ vcat [ hang (ptext (sLit "Illegal") <+> what
+ <+> ptext (sLit "signature:") <+> quotes (ppr ty))
+ 2 (ptext (sLit "Perhaps you intended to use") <+> flag)
+ , docOfHsDocContext doc ]
+ where
+ what | is_type = ptext (sLit "type")
+ | otherwise = ptext (sLit "kind")
+ flag | is_type = ptext (sLit "-XScopedTypeVariable")
+ | otherwise = ptext (sLit "-XKindSignatures")
\end{code}
+Note [Renaming associated types]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Check that the RHS of the decl mentions only type variables
+bound on the LHS. For example, this is not ok
+ class C a b where
+ type F a x :: *
+ instance C (p,q) r where
+ type F (p,q) x = (x, r) -- BAD: mentions 'r'
+c.f. Trac #5515
+
+What makes it tricky is that the *kind* variable from the class *are*
+in scope (Trac #5862):
+ class Category (x :: k -> k -> *) where
+ type Ob x :: k -> Constraint
+ id :: Ob x a => x a a
+ (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c
+Here 'k' is in scope in the kind signature even though it's not
+explicitly mentioned on the LHS of the type Ob declaration.
+
+We could force you to mention k explicitly, thus
+ class Category (x :: k -> k -> *) where
+ type Ob (x :: k -> k -> *) :: k -> Constraint
+but it seems tiresome to do so.
+
+
%*********************************************************
%* *
\subsection{Contexts and predicates}
@@ -334,11 +499,21 @@ rnField doc (ConDeclField name ty haddock_doc)
%*********************************************************
\begin{code}
-rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name)
-rnContext doc = wrapLocM (rnContext' doc)
+rnConDeclFields :: HsDocContext -> [ConDeclField RdrName]
+ -> RnM ([ConDeclField Name], FreeVars)
+rnConDeclFields doc fields = mapFvRn (rnField doc) fields
+
+rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name, FreeVars)
+rnField doc (ConDeclField name ty haddock_doc)
+ = do { new_name <- lookupLocatedTopBndrRn name
+ ; (new_ty, fvs) <- rnLHsType doc ty
+ ; new_haddock_doc <- rnMbLHsDoc haddock_doc
+ ; return (ConDeclField new_name new_ty new_haddock_doc, fvs) }
-rnContext' :: HsDocContext -> HsContext RdrName -> RnM (HsContext Name)
-rnContext' doc ctxt = mapM (rnLHsType doc) ctxt
+rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
+rnContext doc (L loc cxt)
+ = do { (cxt', fvs) <- rnLHsTypes doc cxt
+ ; return (L loc cxt', fvs) }
rnIPName :: IPName RdrName -> RnM (IPName Name)
rnIPName n = newIPName (occNameFS (rdrNameOcc (ipNameName n)))
View Lorry Controller Status