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
tcdLName :: Located name, -- ^ Type constructor
tcdTyVars :: [LHsTyVarBndr name], -- ^ Type variables
tcdTyPats :: Maybe [LHsType name],
-- ^ Type patterns.
--
-- @Just [t1..tn]@ for @data instance T t1..tn = ...@
-- in this case @tcdTyVars = fv( tcdTyPats )@.
-- @Nothing@ for everything else.
tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns.
-- See Note [tcdTyVars and tcdTyPats]
tcdKindSig:: Maybe Kind,
-- ^ Optional kind signature.
......@@ -492,8 +487,7 @@ data TyClDecl name
| TySynonym { tcdLName :: Located name, -- ^ type constructor
tcdTyVars :: [LHsTyVarBndr name], -- ^ type variables
tcdTyPats :: Maybe [LHsType name], -- ^ Type patterns
-- See comments for tcdTyPats in TyData
-- 'Nothing' => vanilla type synonym
-- See Note [tcdTyVars and tcdTyPats]
tcdSynRhs :: LHsType name -- ^ synonym expansion
}
......@@ -505,9 +499,7 @@ data TyClDecl name
tcdSigs :: [LSig name], -- ^ Methods' signatures
tcdMeths :: LHsBinds name, -- ^ Default methods
tcdATs :: [LTyClDecl name], -- ^ Associated types; ie
-- only 'TyFamily' and
-- 'TySynonym'; the
-- latter for defaults
-- only 'TyFamily'
tcdDocs :: [LDocDecl] -- ^ Haddock docs
}
deriving (Data, Typeable)
......@@ -523,6 +515,26 @@ data FamilyFlavour
deriving (Data, Typeable)
\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
\begin{code}
......
......@@ -22,7 +22,7 @@ module HsTypes (
ConDeclField(..), pprConDeclFields,
mkExplicitHsForAllTy, mkImplicitHsForAllTy, hsExplicitTvs,
hsTyVarName, hsTyVarNames, replaceTyVarName,
hsTyVarName, hsTyVarNames, replaceTyVarName, replaceLTyVarName,
hsTyVarKind, hsTyVarNameKind,
hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
splitHsInstDeclTy, splitHsFunType,
......@@ -285,6 +285,9 @@ hsLTyVarLocNames = map hsLTyVarLocName
replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2
replaceTyVarName (UserTyVar _ k) n' = UserTyVar 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}
......
......@@ -182,7 +182,7 @@ mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls
= do { let (binds, sigs, ats, docs) = cvBindsAndSigs (unLoc where_cls)
; let cxt = fromMaybe (noLoc []) mcxt
; (cls, tparams) <- checkTyClHdr tycl_hdr
; tyvars <- checkTyVars tparams -- Only type vars allowed
; tyvars <- checkTyVars tycl_hdr tparams -- Only type vars allowed
; checkKindSigs ats
; return (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tyvars,
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
; checkDatatypeContext 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,
tcdTyVars = tyvars, tcdTyPats = typats,
tcdCons = data_cons,
......@@ -214,7 +214,7 @@ mkTySynonym :: SrcSpan
-> P (LTyClDecl RdrName)
mkTySynonym loc is_family lhs rhs
= 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)) }
mkTyFamily :: SrcSpan
......@@ -224,7 +224,7 @@ mkTyFamily :: SrcSpan
-> P (LTyClDecl RdrName)
mkTyFamily loc flavour lhs ksig
= do { (tc, tparams) <- checkTyClHdr lhs
; tyvars <- checkTyVars tparams
; tyvars <- checkTyVars lhs tparams
; return (L loc (TyFamily flavour tc tyvars ksig)) }
mkTopSpliceDecl :: LHsExpr RdrName -> HsDecl RdrName
......@@ -484,6 +484,7 @@ checkDictTy (L spn ty) = check ty []
done tc args = return (L spn (HsPredTy (HsClassP tc args)))
checkTParams :: Bool -- Type/data family
-> LHsType RdrName
-> [LHsType RdrName]
-> P ([LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
-- checkTParams checks the type parameters of a data/newtype declaration
......@@ -501,31 +502,32 @@ checkTParams :: Bool -- Type/data family
-- If there are kind sigs in the type parameters, they
-- will fix the binder's kind when we kind-check the
-- type parameters
checkTParams is_family tparams
checkTParams is_family tycl_hdr tparams
| not is_family -- Vanilla case (a)
= do { tyvars <- checkTyVars tparams
= do { tyvars <- checkTyVars tycl_hdr tparams
; return (tyvars, Nothing) }
| otherwise -- Family case (b)
= do { let tyvars = userHsTyVarBndrs (extractHsTysRdrTyVars 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
-- (possibly with a kind signature). If the second argument is `False',
-- only type variables are allowed and we raise an error on encountering a
-- non-variable; otherwise, we allow non-variable arguments and return the
-- entire list of parameters.
checkTyVars tparms = mapM chk tparms
checkTyVars tycl_hdr tparms = mapM chk tparms
where
-- Check that the name space is correct!
chk (L l (HsKindSig (L _ (HsTyVar tv)) k))
| isRdrTyVar tv = return (L l (KindedTyVar tv k))
chk (L l (HsTyVar tv))
| isRdrTyVar tv = return (L l (UserTyVar tv placeHolderKind))
chk t@(L l _) =
parseErrorSDoc l (text "Type found:" <+> ppr t
$$ text "where type variable expected, in:" <+>
sep (map (pprParendHsType . unLoc) tparms))
chk t@(L l _)
= parseErrorSDoc l $
vcat [ sep [ ptext (sLit "Unexpected type") <+> quotes (ppr t)
, ptext (sLit "where type variable expected") ]
, ptext (sLit "In the declaration of") <+> quotes (ppr tycl_hdr) ]
checkDatatypeContext :: Maybe (LHsContext RdrName) -> P ()
checkDatatypeContext Nothing = return ()
......
......@@ -7,7 +7,7 @@
module RnEnv (
newTopSrcBinder,
lookupLocatedTopBndrRn, lookupTopBndrRn,
lookupLocatedOccRn, lookupOccRn,
lookupLocatedOccRn, lookupOccRn, lookupLocalOccRn_maybe,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
lookupLocalDataTcNames, lookupSigOccRn,
lookupFixityRn, lookupTyFixityRn,
......@@ -424,6 +424,12 @@ getLookupOccRn
lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)
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 :: RdrName -> RnM Name
lookupOccRn rdr_name
......@@ -947,9 +953,8 @@ bindTyVarsRn tyvar_names enclosed_scope
do { kind_sigs_ok <- xoptM Opt_KindSignatures
; unless (null kinded_tyvars || kind_sigs_ok)
(mapM_ (addErr . kindSigErr) kinded_tyvars)
; enclosed_scope (zipWith replace tyvar_names names) }
; enclosed_scope (zipWith replaceLTyVarName tyvar_names names) }
where
replace (L loc n1) n2 = L loc (replaceTyVarName n1 n2)
located_tyvars = hsLTyVarLocNames tyvar_names
kinded_tyvars = [n | L _ (KindedTyVar n _) <- tyvar_names]
......
......@@ -16,7 +16,7 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl )
#endif /* GHCI */
import HsSyn
import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
import RdrName
import RdrHsSyn ( extractHsRhoRdrTyVars )
import RnHsSyn
import RnTypes
......@@ -48,7 +48,7 @@ import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
import Control.Monad
import Maybes( orElse )
import Data.Maybe
import Data.Maybe( isNothing )
\end{code}
@rnSourceDecl@ `renames' declarations.
......@@ -304,11 +304,14 @@ rnSrcWarnDecls bndr_set decls
what = ptext (sLit "deprecation")
-- 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
warn_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
(map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls)
warn_rdr_dups = findDupRdrNames (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls)
findDupRdrNames :: [Located RdrName] -> [[Located RdrName]]
findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
-- 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
-- Located RdrName -> DeprecDecl RdrName -> SDoc
......@@ -421,28 +424,29 @@ rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
-- Used for both source and interface file decls
= do { inst_ty' <- rnHsSigType (text "an instance decl") inst_ty
; let (inst_tyvars, _, L _ cls, _) = splitHsInstDeclTy inst_ty'
-- Rename the bindings
-- The typechecker (not the renamer) checks that all
-- 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 $
rnMethodBinds cls (\_ -> []) -- No scoped tyvars
mbinds
-- (Slightly strangely) the forall-d tyvars
-- scope over the method bindings too
-- 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 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
-- See notes with checkDupRdrNames for methods, above
; traceRn (text "rnATInsts" <+> ppr ats)
; (ats', at_fvs) <- rnATInsts cls ats
-- Rename the prags and signatures.
-- Note that the type variables are not in scope here,
-- so that instance Eq a => Eq (T a) where
......@@ -712,11 +716,19 @@ rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name})
; return (ForeignType {tcdLName = name', tcdExtName = ext_name},
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
-- both top level and (for an associated type) in an instance decl
rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
tcdLName = tycon, tcdTyVars = tyvars,
tcdTyPats = typats, tcdCons = condecls,
......@@ -724,8 +736,9 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
= do { tycon' <- lookupTcdName mb_cls tydecl
; checkTc (h98_style || null (unLoc context))
(badGadtStupidTheta tycon)
; ((tyvars', context', typats', derivs'), stuff_fvs)
<- bindTyVarsFV tyvars $ \ tyvars' -> do
<- bindQTvs mb_cls tyvars $ \ tyvars' -> do
-- Checks for distinct tyvars
{ context' <- rnContext data_doc context
; (typats', fvs1) <- rnTyPats data_doc tycon' typats
......@@ -766,7 +779,7 @@ rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
-- "type" and "type instance" declarations
rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdLName = name,
tcdTyPats = typats, tcdSynRhs = ty})
= bindTyVarsFV tyvars $ \ tyvars' -> do
= bindQTvs mb_cls tyvars $ \ tyvars' -> do
{ -- Checks for distinct tyvars
name' <- lookupTcdName mb_cls tydecl
; (typats',fvs1) <- rnTyPats syn_doc name' typats
......@@ -777,10 +790,11 @@ rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdLName = name,
where
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,
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', context', fds', ats', sigs'), stuff_fvs)
......@@ -788,11 +802,12 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = cname,
-- Checks for distinct tyvars
{ context' <- rnContext cls_doc context
; 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
; let fvs = at_fvs `plusFV`
extractHsCtxtTyNames context' `plusFV`
hsSigsFVs sigs'
; let fvs = extractHsCtxtTyNames context' `plusFV`
hsSigsFVs sigs' `plusFV`
plusFVs fv_ats
-- The fundeps have no free variables
; return ((tyvars', context', fds', ats', sigs'), fvs) }
......@@ -821,17 +836,60 @@ rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = cname,
-- No need to check for duplicate method signatures
-- since that is done by RnNames.extendGlobalRdrEnvRn
-- and the methods are already in scope
rnMethodBinds (unLoc cname') (mkSigTvFn sigs') mbinds
rnMethodBinds cls' (mkSigTvFn sigs') mbinds
-- Haddock docs
; docs' <- mapM (wrapLocM rnDocDecl) docs
; return (ClassDecl { tcdCtxt = context', tcdLName = cname',
; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
meth_fvs `plusFV` stuff_fvs) }
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 _
......@@ -981,70 +1039,7 @@ rnConDeclDetails doc (RecCon fields)
-- since that is done by RnNames.extendGlobalRdrEnvRn
; 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 decl
= vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl))
......@@ -1055,14 +1050,6 @@ deprecRecSyntax decl
badRecResTy :: SDoc -> SDoc
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
-- data T = a Int
-- treating "a" as the constructor.
......
......@@ -9,7 +9,7 @@ Typechecking class declarations
module TcClassDcl ( tcClassSigs, tcClassDecl2,
findMethodBind, instantiateMethod, tcInstanceMethodBody,
mkGenericDefMethBind,
tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
tcAddDeclCtxt, badMethodErr
) where
#include "HsVersions.h"
......@@ -400,14 +400,6 @@ badGenericMethod clas op
= hsep [ptext (sLit "Class"), quotes (ppr clas),
ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)]
badATErr :: Class -> Name -> SDoc
badATErr clas at
= hsep [ptext (sLit "Class"), quotes (ppr clas),
ptext (sLit "does not have an associated type"), quotes (ppr at)]
omittedATWarn :: Name -> SDoc
omittedATWarn at
= ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
{-
badGenericInstanceType :: LHsBinds Name -> SDoc
badGenericInstanceType binds
......
This diff is collapsed.
......@@ -8,7 +8,7 @@ TcTyClsDecls: Typecheck type and class declarations
\begin{code}
module TcTyClsDecls (
tcTyAndClassDecls, kcDataDecl, tcConDecls, mkRecSelBinds,
checkValidTyCon, dataDeclChecks, badFamInstDecl
checkValidTyCon, dataDeclChecks
) where
#include "HsVersions.h"
......@@ -435,11 +435,7 @@ tcTyClDecl1 parent _calc_isrec
tcdKind = Just kind}) -- NB: kind at latest added during kind checking
= tcTyVarBndrs tvs $ \ tvs' -> do
{ traceTc "type family:" (ppr tc_name)
-- Check that we don't use families without -XTypeFamilies
; idx_tys <- xoptM Opt_TypeFamilies
; checkTc idx_tys $ badFamInstDecl tc_name
; checkFamFlag tc_name
; tycon <- buildSynTyCon tc_name tvs' SynFamilyTyCon kind parent Nothing
; return [ATyCon tycon]
}
......@@ -450,21 +446,16 @@ tcTyClDecl1 parent _calc_isrec
tcdLName = L _ tc_name, tcdTyVars = tvs, tcdKind = mb_kind})
= tcTyVarBndrs tvs $ \ tvs' -> do
{ traceTc "data family:" (ppr tc_name)
; checkFamFlag tc_name
; extra_tvs <- tcDataKindSig mb_kind
; let final_tvs = tvs' ++ extra_tvs -- we may not need these
-- Check that we don't use families without -XTypeFamilies
; idx_tys <- xoptM Opt_TypeFamilies
; checkTc idx_tys $ badFamInstDecl tc_name
; tycon <- buildAlgTyCon tc_name final_tvs []
DataFamilyTyCon Recursive True
parent Nothing
; return [ATyCon tycon]
}
-- "type"
-- "type" synonym declaration
tcTyClDecl1 _parent _calc_isrec
(TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty})
= ASSERT( isNoParent _parent )
......@@ -1022,6 +1013,17 @@ checkValidClass cls
-- forall has an (Eq a) constraint. Whereas in general, each constraint
-- in the context of a for-all must mention at least one quantified
-- type variable. What a mess!
checkFamFlag :: Name -> TcM ()
-- Check that we don't use families without -XTypeFamilies
-- The parser won't even parse them, but I suppose a GHC API
-- client might have a go!
checkFamFlag tc_name
= do { idx_tys <- xoptM Opt_TypeFamilies
; checkTc idx_tys err_msg }
where
err_msg = hang (ptext (sLit "Illegal family declaraion for") <+> quotes (ppr tc_name))
2 (ptext (sLit "Use -XTypeFamilies to allow indexed type families"))
\end{code}
......@@ -1350,12 +1352,6 @@ badSigTyDecl tc_name
quotes (ppr tc_name)
, nest 2 (parens $ ptext (sLit "Use -XKindSignatures to allow kind signatures")) ]
badFamInstDecl :: Outputable a => a -> SDoc
badFamInstDecl tc_name
= vcat [ ptext (sLit "Illegal family instance for") <+>
quotes (ppr tc_name)
, nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ]
emptyConDeclsErr :: Name -> SDoc
emptyConDeclsErr tycon
= sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"),
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment