Commit d2d6bdae authored by Simon Peyton Jones's avatar Simon Peyton Jones

Allow associated types to have fresh parameters

This patch allows

     class C a where
       type T a b :: *
     instance C Int
       type T Int b = b -> b

That is, T has a type index 'b' that is not one of the class
variables.

On the way I did a good deal of refactoring (as usual), especially in
TcInstDcls.tcLocalInstDecl1, which checks for consistent instantiation
of the class instance and the type instance.  Less code, more
expressiveness.  See Note [Checking consistent instantiation]
parent 94ec282a
...@@ -455,13 +455,8 @@ data TyClDecl name ...@@ -455,13 +455,8 @@ data TyClDecl name
tcdLName :: Located name, -- ^ Type constructor tcdLName :: Located name, -- ^ Type constructor
tcdTyVars :: [LHsTyVarBndr name], -- ^ Type variables tcdTyVars :: [LHsTyVarBndr name], -- ^ Type variables
tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns.
tcdTyPats :: Maybe [LHsType name], -- See Note [tcdTyVars and tcdTyPats]
-- ^ Type patterns.
--
-- @Just [t1..tn]@ for @data instance T t1..tn = ...@
-- in this case @tcdTyVars = fv( tcdTyPats )@.
-- @Nothing@ for everything else.
tcdKindSig:: Maybe Kind, tcdKindSig:: Maybe Kind,
-- ^ Optional kind signature. -- ^ Optional kind signature.
...@@ -492,8 +487,7 @@ data TyClDecl name ...@@ -492,8 +487,7 @@ data TyClDecl name
| TySynonym { tcdLName :: Located name, -- ^ type constructor | TySynonym { tcdLName :: Located name, -- ^ type constructor
tcdTyVars :: [LHsTyVarBndr name], -- ^ type variables tcdTyVars :: [LHsTyVarBndr name], -- ^ type variables
tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns
-- See comments for tcdTyPats in TyData -- See Note [tcdTyVars and tcdTyPats]
-- 'Nothing' => vanilla type synonym
tcdSynRhs :: LHsType name -- ^ synonym expansion tcdSynRhs :: LHsType name -- ^ synonym expansion
} }
...@@ -505,9 +499,7 @@ data TyClDecl name ...@@ -505,9 +499,7 @@ data TyClDecl name
tcdSigs :: [LSig name], -- ^ Methods' signatures tcdSigs :: [LSig name], -- ^ Methods' signatures
tcdMeths :: LHsBinds name, -- ^ Default methods tcdMeths :: LHsBinds name, -- ^ Default methods
tcdATs :: [LTyClDecl name], -- ^ Associated types; ie tcdATs :: [LTyClDecl name], -- ^ Associated types; ie
-- only 'TyFamily' and -- only 'TyFamily'
-- 'TySynonym'; the
-- latter for defaults
tcdDocs :: [LDocDecl] -- ^ Haddock docs tcdDocs :: [LDocDecl] -- ^ Haddock docs
} }
deriving (Data, Typeable) deriving (Data, Typeable)
...@@ -523,6 +515,26 @@ data FamilyFlavour ...@@ -523,6 +515,26 @@ data FamilyFlavour
deriving (Data, Typeable) deriving (Data, Typeable)
\end{code} \end{code}
Note [tcdTyVars and tcdTyPats]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We use TyData and TySynonym both for vanilla data/type declarations
type T a = Int
AND for data/type family instance declarations
type instance F [a] = (a,Int)
tcdTyPats = Nothing
This is a vanilla data type or type synonym
tcdTyVars are the quantified type variables
tcdTyPats = Just tys
This is a data/type family instance declaration
tcdTyVars are fv(tys)
Eg instance C (a,b) where
type F a x y = x->y
After the renamer, the tcdTyVars of the F decl are {x,y}
------------------------------
Simple classifiers Simple classifiers
\begin{code} \begin{code}
......
...@@ -22,7 +22,7 @@ module HsTypes ( ...@@ -22,7 +22,7 @@ module HsTypes (
ConDeclField(..), pprConDeclFields, ConDeclField(..), pprConDeclFields,
mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs, mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
hsTyVarName, hsTyVarNames, replaceTyVarName, hsTyVarName, hsTyVarNames, replaceTyVarName, replaceLTyVarName,
hsTyVarKind, hsTyVarNameKind, hsTyVarKind, hsTyVarNameKind,
hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
splitHsInstDeclTy, splitHsFunType, splitHsInstDeclTy, splitHsFunType,
...@@ -285,6 +285,9 @@ hsLTyVarLocNames = map hsLTyVarLocName ...@@ -285,6 +285,9 @@ hsLTyVarLocNames = map hsLTyVarLocName
replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2 replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2
replaceTyVarName (UserTyVar _ k) n' = UserTyVar n' k replaceTyVarName (UserTyVar _ k) n' = UserTyVar n' k
replaceTyVarName (KindedTyVar _ k) n' = KindedTyVar n' k replaceTyVarName (KindedTyVar _ k) n' = KindedTyVar n' k
replaceLTyVarName :: LHsTyVarBndr name1 -> name2 -> LHsTyVarBndr name2
replaceLTyVarName (L loc n1) n2 = L loc (replaceTyVarName n1 n2)
\end{code} \end{code}
......
...@@ -182,7 +182,7 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls ...@@ -182,7 +182,7 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
= do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls) = do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
; let cxt = fromMaybe (noLoc []) mcxt ; let cxt = fromMaybe (noLoc []) mcxt
; (cls, tparams) <- checkTyClHdr tycl_hdr ; (cls, tparams) <- checkTyClHdr tycl_hdr
; tyvars <- checkTyVars tparams -- Only type vars allowed ; tyvars <- checkTyVars tycl_hdr tparams -- Only type vars allowed
; checkKindSigs ats ; checkKindSigs ats
; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars, ; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds, tcdFDs = unLoc fds, tcdSigs = sigs, tcdMeths = binds,
...@@ -201,7 +201,7 @@ mkTyData loc new_or_data is_family (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_d ...@@ -201,7 +201,7 @@ mkTyData loc new_or_data is_family (L _ (mcxt, tycl_hdr)) ksig data_cons maybe_d
; checkDatatypeContext mcxt ; checkDatatypeContext mcxt
; let cxt = fromMaybe (noLoc []) mcxt ; let cxt = fromMaybe (noLoc []) mcxt
; (tyvars, typats) <- checkTParams is_family tparams ; (tyvars, typats) <- checkTParams is_family tycl_hdr tparams
; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc, ; return (L loc (TyData { tcdND = new_or_data, tcdCtxt = cxt, tcdLName = tc,
tcdTyVars = tyvars, tcdTyPats = typats, tcdTyVars = tyvars, tcdTyPats = typats,
tcdCons = data_cons, tcdCons = data_cons,
...@@ -214,7 +214,7 @@ mkTySynonym :: SrcSpan ...@@ -214,7 +214,7 @@ mkTySynonym :: SrcSpan
-> P (LTyClDecl RdrName) -> P (LTyClDecl RdrName)
mkTySynonym loc is_family lhs rhs mkTySynonym loc is_family lhs rhs
= do { (tc, tparams) <- checkTyClHdr lhs = do { (tc, tparams) <- checkTyClHdr lhs
; (tyvars, typats) <- checkTParams is_family tparams ; (tyvars, typats) <- checkTParams is_family lhs tparams
; return (L loc (TySynonym tc tyvars typats rhs)) } ; return (L loc (TySynonym tc tyvars typats rhs)) }
mkTyFamily :: SrcSpan mkTyFamily :: SrcSpan
...@@ -224,7 +224,7 @@ mkTyFamily :: SrcSpan ...@@ -224,7 +224,7 @@ mkTyFamily :: SrcSpan
-> P (LTyClDecl RdrName) -> P (LTyClDecl RdrName)
mkTyFamily loc flavour lhs ksig mkTyFamily loc flavour lhs ksig
= do { (tc, tparams) <- checkTyClHdr lhs = do { (tc, tparams) <- checkTyClHdr lhs
; tyvars <- checkTyVars tparams ; tyvars <- checkTyVars lhs tparams
; return (L loc (TyFamily flavour tc tyvars ksig)) } ; return (L loc (TyFamily flavour tc tyvars ksig)) }
mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
...@@ -484,6 +484,7 @@ checkDictTy (L spn ty) = check ty [] ...@@ -484,6 +484,7 @@ checkDictTy (L spn ty) = check ty []
done tc args = return (L spn (HsPredTy (HsClassP tc args))) done tc args = return (L spn (HsPredTy (HsClassP tc args)))
checkTParams :: Bool -- Type/data family checkTParams :: Bool -- Type/data family
-> LHsType RdrName
-> [LHsType RdrName] -> [LHsType RdrName]
-> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName]) -> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
-- checkTParams checks the type parameters of a data/newtype declaration -- checkTParams checks the type parameters of a data/newtype declaration
...@@ -501,31 +502,32 @@ checkTParams :: Bool -- Type/data family ...@@ -501,31 +502,32 @@ checkTParams :: Bool -- Type/data family
-- If there are kind sigs in the type parameters, they -- If there are kind sigs in the type parameters, they
-- will fix the binder's kind when we kind-check the -- will fix the binder's kind when we kind-check the
-- type parameters -- type parameters
checkTParams is_family tparams checkTParams is_family tycl_hdr tparams
| not is_family -- Vanilla case (a) | not is_family -- Vanilla case (a)
= do { tyvars <- checkTyVars tparams = do { tyvars <- checkTyVars tycl_hdr tparams
; return (tyvars, Nothing) } ; return (tyvars, Nothing) }
| otherwise -- Family case (b) | otherwise -- Family case (b)
= do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams) = do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars tparams)
; return (tyvars, Just tparams) } ; return (tyvars, Just tparams) }
checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName] checkTyVars :: LHsType RdrName -> [LHsType RdrName] -> P [LHsTyVarBndr RdrName]
-- Check whether the given list of type parameters are all type variables -- Check whether the given list of type parameters are all type variables
-- (possibly with a kind signature). If the second argument is `False', -- (possibly with a kind signature). If the second argument is `False',
-- only type variables are allowed and we raise an error on encountering a -- only type variables are allowed and we raise an error on encountering a
-- non-variable; otherwise, we allow non-variable arguments and return the -- non-variable; otherwise, we allow non-variable arguments and return the
-- entire list of parameters. -- entire list of parameters.
checkTyVars tparms = mapM chk tparms checkTyVars tycl_hdr tparms = mapM chk tparms
where where
-- Check that the name space is correct! -- Check that the name space is correct!
chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
| isRdrTyVar tv = return (L l (KindedTyVar tv k)) | isRdrTyVar tv = return (L l (KindedTyVar tv k))
chk (L l (HsTyVar tv)) chk (L l (HsTyVar tv))
| isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind)) | isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind))
chk t@(L l _) = chk t@(L l _)
parseErrorSDoc l (text "Type found:" <+> ppr t = parseErrorSDoc l $
$$ text "where type variable expected, in:" <+> vcat [ sep [ ptext (sLit "Unexpected type") <+> quotes (ppr t)
sep (map (pprParendHsType . unLoc) tparms)) , ptext (sLit "where type variable expected") ]
, ptext (sLit "In the declaration of") <+> quotes (ppr tycl_hdr) ]
checkDatatypeContext :: Maybe (LHsContext RdrName) -> P () checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()
checkDatatypeContext Nothing = return () checkDatatypeContext Nothing = return ()
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
module RnEnv ( module RnEnv (
newTopSrcBinder, newTopSrcBinder,
lookupLocatedTopBndrRn, lookupTopBndrRn, lookupLocatedTopBndrRn, lookupTopBndrRn,
lookupLocatedOccRn, lookupOccRn, lookupLocatedOccRn, lookupOccRn, lookupLocalOccRn_maybe,
lookupGlobalOccRn, lookupGlobalOccRn_maybe, lookupGlobalOccRn, lookupGlobalOccRn_maybe,
lookupLocalDataTcNames, lookupSigOccRn, lookupLocalDataTcNames, lookupSigOccRn,
lookupFixityRn, lookupTyFixityRn, lookupFixityRn, lookupTyFixityRn,
...@@ -424,6 +424,12 @@ getLookupOccRn ...@@ -424,6 +424,12 @@ getLookupOccRn
lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)
lookupLocatedOccRn = wrapLocM lookupOccRn lookupLocatedOccRn = wrapLocM lookupOccRn
lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name)
-- Just look in the local environment
lookupLocalOccRn_maybe rdr_name
= do { local_env <- getLocalRdrEnv
; return (lookupLocalRdrEnv local_env rdr_name) }
-- lookupOccRn looks up an occurrence of a RdrName -- lookupOccRn looks up an occurrence of a RdrName
lookupOccRn :: RdrName -> RnM Name lookupOccRn :: RdrName -> RnM Name
lookupOccRn rdr_name lookupOccRn rdr_name
...@@ -947,9 +953,8 @@ bindTyVarsRn tyvar_names enclosed_scope ...@@ -947,9 +953,8 @@ bindTyVarsRn tyvar_names enclosed_scope
do { kind_sigs_ok <- xoptM Opt_KindSignatures do { kind_sigs_ok <- xoptM Opt_KindSignatures
; unless (null kinded_tyvars || kind_sigs_ok) ; unless (null kinded_tyvars || kind_sigs_ok)
(mapM_ (addErr . kindSigErr) kinded_tyvars) (mapM_ (addErr . kindSigErr) kinded_tyvars)
; enclosed_scope (zipWith replace tyvar_names names) } ; enclosed_scope (zipWith replaceLTyVarName tyvar_names names) }
where where
replace (L loc n1) n2 = L loc (replaceTyVarName n1 n2)
located_tyvars = hsLTyVarLocNames tyvar_names located_tyvars = hsLTyVarLocNames tyvar_names
kinded_tyvars = [n | L _ (KindedTyVar n _) <- tyvar_names] kinded_tyvars = [n | L _ (KindedTyVar n _) <- tyvar_names]
......
...@@ -16,7 +16,7 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl ) ...@@ -16,7 +16,7 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl )
#endif /* GHCI */ #endif /* GHCI */
import HsSyn import HsSyn
import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc ) import RdrName
import RdrHsSyn ( extractHsRhoRdrTyVars ) import RdrHsSyn ( extractHsRhoRdrTyVars )
import RnHsSyn import RnHsSyn
import RnTypes import RnTypes
...@@ -48,7 +48,7 @@ import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices ) ...@@ -48,7 +48,7 @@ import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
import Control.Monad import Control.Monad
import Maybes( orElse ) import Maybes( orElse )
import Data.Maybe import Data.Maybe( isNothing )
\end{code} \end{code}
@rnSourceDecl@ `renames' declarations. @rnSourceDecl@ `renames' declarations.
...@@ -304,11 +304,14 @@ rnSrcWarnDecls bndr_set decls ...@@ -304,11 +304,14 @@ rnSrcWarnDecls bndr_set decls
what = ptext (sLit "deprecation") what = ptext (sLit "deprecation")
-- look for duplicates among the OccNames; warn_rdr_dups = findDupRdrNames (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls)
-- we check that the names are defined above
-- invt: the lists returned by findDupsEq always have at least two elements findDupRdrNames :: [Located RdrName] -> [[Located RdrName]]
warn_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
(map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls)
-- look for duplicates among the OccNames;
-- we check that the names are defined above
-- invt: the lists returned by findDupsEq always have at least two elements
dupWarnDecl :: Located RdrName -> RdrName -> SDoc dupWarnDecl :: Located RdrName -> RdrName -> SDoc
-- Located RdrName -> DeprecDecl RdrName -> SDoc -- Located RdrName -> DeprecDecl RdrName -> SDoc
...@@ -421,28 +424,29 @@ rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars) ...@@ -421,28 +424,29 @@ rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
-- Used for both source and interface file decls -- Used for both source and interface file decls
= do { inst_ty' <- rnHsSigType (text "an instance decl") inst_ty = do { inst_ty' <- rnHsSigType (text "an instance decl") inst_ty
; let (inst_tyvars, _, L _ cls, _) = splitHsInstDeclTy inst_ty'
-- Rename the bindings -- Rename the bindings
-- The typechecker (not the renamer) checks that all -- The typechecker (not the renamer) checks that all
-- the bindings are for the right class -- the bindings are for the right class
; let (inst_tyvars, _, L _ cls, _) = splitHsInstDeclTy inst_ty' -- (Slightly strangely) when scoped type variables are on, the
-- forall-d tyvars scope over the method bindings too
; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds inst_tyvars $ ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds inst_tyvars $
rnMethodBinds cls (\_ -> []) -- No scoped tyvars rnMethodBinds cls (\_ -> []) -- No scoped tyvars
mbinds mbinds
-- (Slightly strangely) the forall-d tyvars
-- scope over the method bindings too
-- Rename the associated types -- Rename the associated types
-- Here the instance variables always scope, regardless of -XScopedTypeVariables
; (ats', at_fvs) <- extendTyVarEnvFVRn (map hsLTyVarName inst_tyvars) $
rnATInsts cls ats
-- Check for duplicate associated types
-- The typechecker (not the renamer) checks that all -- The typechecker (not the renamer) checks that all
-- the declarations are for the right class -- the declarations are for the right class
; let at_names = map (tcdLName . unLoc) ats -- The names of the associated types ; let at_names = map (tcdLName . unLoc) ats
; checkDupRdrNames at_names ; checkDupRdrNames at_names
-- See notes with checkDupRdrNames for methods, above -- See notes with checkDupRdrNames for methods, above
; traceRn (text "rnATInsts" <+> ppr ats)
; (ats', at_fvs) <- rnATInsts cls ats
-- Rename the prags and signatures. -- Rename the prags and signatures.
-- Note that the type variables are not in scope here, -- Note that the type variables are not in scope here,
-- so that instance Eq a => Eq (T a) where -- so that instance Eq a => Eq (T a) where
...@@ -457,7 +461,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) ...@@ -457,7 +461,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
; return (InstDecl inst_ty' mbinds' uprags' ats', ; return (InstDecl inst_ty' mbinds' uprags' ats',
meth_fvs `plusFV` at_fvs meth_fvs `plusFV` at_fvs
`plusFV` hsSigsFVs uprags' `plusFV` hsSigsFVs uprags'
`plusFV` extractHsTyNames inst_ty') } `plusFV` extractHsTyNames inst_ty') }
-- We return the renamed associated data type declarations so -- We return the renamed associated data type declarations so
-- that they can be entered into the list of type declarations -- that they can be entered into the list of type declarations
...@@ -712,11 +716,19 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name}) ...@@ -712,11 +716,19 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name})
; return (ForeignType {tcdLName = name', tcdExtName = ext_name}, ; return (ForeignType {tcdLName = name', tcdExtName = ext_name},
emptyFVs) } emptyFVs) }
-- all flavours of type family declarations ("type family", "newtype family", -- All flavours of type family declarations ("type family", "newtype family",
-- 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 mb_cls tyvars $ \tyvars' ->
do { tycon' <- lookupLocatedTopBndrRn tycon
; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars'
, tcdFlavour = flav, tcdKind = kind }
, emptyFVs) }
-- "data", "newtype", "data instance, and "newtype instance" declarations -- "data", "newtype", "data instance, and "newtype instance" declarations
-- both top level and (for an associated type) in an instance decl
rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
tcdLName = tycon, tcdTyVars = tyvars, tcdLName = tycon, tcdTyVars = tyvars,
tcdTyPats = typats, tcdCons = condecls, tcdTyPats = typats, tcdCons = condecls,
...@@ -724,8 +736,9 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, ...@@ -724,8 +736,9 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
= do { tycon' <- lookupTcdName mb_cls tydecl = do { tycon' <- lookupTcdName mb_cls tydecl
; checkTc (h98_style || null (unLoc context)) ; checkTc (h98_style || null (unLoc context))
(badGadtStupidTheta tycon) (badGadtStupidTheta tycon)
; ((tyvars', context', typats', derivs'), stuff_fvs) ; ((tyvars', context', typats', derivs'), stuff_fvs)
<- bindTyVarsFV tyvars $ \ tyvars' -> do <- bindQTvs mb_cls tyvars $ \ tyvars' -> do
-- Checks for distinct tyvars -- Checks for distinct tyvars
{ context' <- rnContext data_doc context { context' <- rnContext data_doc context
; (typats', fvs1) <- rnTyPats data_doc tycon' typats ; (typats', fvs1) <- rnTyPats data_doc tycon' typats
...@@ -766,7 +779,7 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, ...@@ -766,7 +779,7 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
-- "type" and "type instance" declarations -- "type" and "type instance" declarations
rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdLName = name, rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdLName = name,
tcdTyPats = typats, tcdSynRhs = ty}) tcdTyPats = typats, tcdSynRhs = ty})
= bindTyVarsFV tyvars $ \ tyvars' -> do = bindQTvs mb_cls tyvars $ \ tyvars' -> do
{ -- Checks for distinct tyvars { -- Checks for distinct tyvars
name' <- lookupTcdName mb_cls tydecl name' <- lookupTcdName mb_cls tydecl
; (typats',fvs1) <- rnTyPats syn_doc name' typats ; (typats',fvs1) <- rnTyPats syn_doc name' typats
...@@ -777,22 +790,24 @@ rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdLName = name, ...@@ -777,22 +790,24 @@ rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdLName = name,
where where
syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name) syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = cname, rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls,
tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs}) tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
= do { cname' <- lookupLocatedTopBndrRn cname = do { lcls' <- lookupLocatedTopBndrRn lcls
; let cls' = unLoc lcls'
-- Tyvars scope over superclass context and method signatures -- Tyvars scope over superclass context and method signatures
; ((tyvars', context', fds', ats', sigs'), stuff_fvs) ; ((tyvars', context', fds', ats', sigs'), stuff_fvs)
<- bindTyVarsFV tyvars $ \ tyvars' -> do <- bindTyVarsFV tyvars $ \ tyvars' -> do
-- Checks for distinct tyvars -- Checks for distinct tyvars
{ context' <- rnContext cls_doc context { context' <- rnContext cls_doc context
; fds' <- rnFds cls_doc fds ; fds' <- rnFds cls_doc fds
; (ats', at_fvs) <- rnATs ats ; let rn_at = rnTyClDecl (Just cls')
; (ats', fv_ats) <- mapAndUnzipM (wrapLocFstM rn_at) ats
; sigs' <- renameSigs Nothing okClsDclSig sigs ; sigs' <- renameSigs Nothing okClsDclSig sigs
; let fvs = at_fvs `plusFV` ; let fvs = extractHsCtxtTyNames context' `plusFV`
extractHsCtxtTyNames context' `plusFV` hsSigsFVs sigs' `plusFV`
hsSigsFVs sigs' plusFVs fv_ats
-- The fundeps have no free variables -- The fundeps have no free variables
; return ((tyvars', context', fds', ats', sigs'), fvs) } ; return ((tyvars', context', fds', ats', sigs'), fvs) }
...@@ -821,17 +836,60 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = cname, ...@@ -821,17 +836,60 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = cname,
-- No need to check for duplicate method signatures -- No need to check for duplicate method signatures
-- since that is done by RnNames.extendGlobalRdrEnvRn -- since that is done by RnNames.extendGlobalRdrEnvRn
-- and the methods are already in scope -- and the methods are already in scope
rnMethodBinds (unLoc cname') (mkSigTvFn sigs') mbinds rnMethodBinds cls' (mkSigTvFn sigs') mbinds
-- Haddock docs -- Haddock docs
; docs' <- mapM (wrapLocM rnDocDecl) docs ; docs' <- mapM (wrapLocM rnDocDecl) docs
; return (ClassDecl { tcdCtxt = context', tcdLName = cname', ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs', tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'}, tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
meth_fvs `plusFV` stuff_fvs) } meth_fvs `plusFV` stuff_fvs) }
where where
cls_doc = text "In the declaration for class" <+> ppr cname cls_doc = text "In the declaration for class" <+> ppr lcls
bindQTvs :: Maybe Name -> [LHsTyVarBndr RdrName]
-> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
-- For *associated* type/data family instances (in an instance decl)
-- don't quantify over the already-in-scope type variables
bindQTvs mb_cls tyvars thing_inside
| isNothing mb_cls -- Not associated
= bindTyVarsFV tyvars thing_inside
| otherwise -- Associated
= do { let tv_rdr_names = map hsLTyVarLocName tyvars
-- 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_nbs <- mapM (mk_tv_name rdr_env) tv_rdr_names
; let tv_ns, fresh_ns :: [Name]
tv_ns = map fst tv_nbs
fresh_ns = [n | (n,True) <- tv_nbs]
; (thing, fvs) <- bindLocalNames tv_ns $
thing_inside (zipWith replaceLTyVarName tyvars tv_ns)
; return (thing, delFVs fresh_ns fvs) }
where
mk_tv_name :: LocalRdrEnv -> Located RdrName -> RnM (Name, Bool)
-- False <=> already in scope
-- True <=> fresh
mk_tv_name rdr_env (L l tv_rdr)
= do { case lookupLocalRdrEnv rdr_env tv_rdr of
Just n -> return (n, False)
Nothing -> do { n <- newLocalBndrRn (L l tv_rdr)
; return (n, True) } }
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 :: Located RdrName -> SDoc
badGadtStupidTheta _ badGadtStupidTheta _
...@@ -981,70 +1039,7 @@ rnConDeclDetails doc (RecCon fields) ...@@ -981,70 +1039,7 @@ rnConDeclDetails doc (RecCon fields)
-- since that is done by RnNames.extendGlobalRdrEnvRn -- since that is done by RnNames.extendGlobalRdrEnvRn
; return (RecCon new_fields) } ; return (RecCon new_fields) }
-- Rename family declarations -------------------------------------------------
--
-- * This function is parametrised by the routine handling the index
-- variables. On the toplevel, these are defining occurences, whereas they
-- are usage occurences for associated types.
--
rnFamily :: TyClDecl RdrName
-> ([LHsTyVarBndr RdrName] ->
([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
RnM (TyClDecl Name, FreeVars))
-> RnM (TyClDecl Name, FreeVars)
rnFamily (tydecl@TyFamily {tcdFlavour = flavour,
tcdLName = tycon, tcdTyVars = tyvars})
bindIdxVars =
do { bindIdxVars tyvars $ \tyvars' -> do {
; tycon' <- lookupLocatedTopBndrRn tycon
; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon',
tcdTyVars = tyvars', tcdKind = tcdKind tydecl},
emptyFVs)
} }
rnFamily d _ = pprPanic "rnFamily" (ppr d)
-- Rename associated type declarations (in classes)
--
-- * This can be family declarations and (default) type instances
--
rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
where
rn_at (tydecl@TyFamily {}) = rnFamily tydecl lookupIdxVars
rn_at (tydecl@TySynonym {}) =
do
unless (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
rnTyClDecl Nothing tydecl
rn_at _ = panic "RnSource.rnATs: invalid TyClDecl"
lookupIdxVars tyvars cont =
do { checkForDups tyvars
; tyvars' <- mapM lookupIdxVar tyvars
; cont tyvars'
}
-- Type index variables must be class parameters, which are the only
-- type variables in scope at this point.
lookupIdxVar (L l tyvar) =
do
name' <- lookupOccRn (hsTyVarName tyvar)
return $ L l (replaceTyVarName tyvar name')
-- Type variable may only occur once.
--
checkForDups [] = return ()
checkForDups (L loc tv:ltvs) =
do { setSrcSpan loc $
when (hsTyVarName tv `ltvElem` ltvs) $
addErr (repeatedTyVar tv)
; checkForDups ltvs
}
_ `ltvElem` [] = False
rdrName `ltvElem` (L _ tv:ltvs)
| rdrName == hsTyVarName tv = True
| otherwise = rdrName `ltvElem` ltvs
deprecRecSyntax :: ConDecl RdrName -> SDoc deprecRecSyntax :: ConDecl RdrName -> SDoc
deprecRecSyntax decl deprecRecSyntax decl
= vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl)) = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl))
...@@ -1055,14 +1050,6 @@ deprecRecSyntax decl ...@@ -1055,14 +1050,6 @@ deprecRecSyntax decl
badRecResTy :: SDoc -> SDoc badRecResTy :: SDoc -> SDoc
badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
noPatterns :: SDoc
noPatterns = text "Default definition for an associated synonym cannot have"
<+> text "type pattern"
repeatedTyVar :: HsTyVarBndr RdrName -> SDoc
repeatedTyVar tv = ptext (sLit "Illegal repeated type variable") <+>
quotes (ppr tv)
-- This data decl will parse OK -- This data decl will parse OK
-- data T = a Int -- data T = a Int
-- treating "a" as the constructor. -- treating "a" as the constructor.
......
...@@ -9,7 +9,7 @@ Typechecking class declarations ...@@ -9,7 +9,7 @@ Typechecking class declarations
module TcClassDcl ( tcClassSigs, tcClassDecl2, module TcClassDcl ( tcClassSigs, tcClassDecl2,
findMethodBind, instantiateMethod, tcInstanceMethodBody, findMethodBind, instantiateMethod, tcInstanceMethodBody,
mkGenericDefMethBind, mkGenericDefMethBind,