diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 5461500443884a0176678524c5e9facb346bc536..82f113c096115978427ffc211395b0d807dc2600 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -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} diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs index 7c8cdce7acbbc100f804a4cac7fea2c2665e1f70..f8b7be47af2f9412f127598b032cf14aaf9aa418 100644 --- a/compiler/hsSyn/HsTypes.lhs +++ b/compiler/hsSyn/HsTypes.lhs @@ -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} diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 10274e1823ece99ba952ad10efc484d881636c8a..468c4d589813b0021cb73a568e8220c0312bade6 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -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 () diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 7d4c2b65275cdd8e53b03aac81f7e0706e16517e..cf37499590526367aac57d69bce3796dd1982196 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -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] diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index dc076cf95c906f794e7f4031bdcea60af7c7886d..b5aec610d59595d73925e9bc49fed94ed0e9fcd6 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -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 + rnMethodBinds cls (\_ -> []) -- No scoped tyvars + mbinds - -- 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 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 @@ -457,7 +461,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) ; return (InstDecl inst_ty' mbinds' uprags' ats', meth_fvs `plusFV` at_fvs - `plusFV` hsSigsFVs uprags' + `plusFV` hsSigsFVs uprags' `plusFV` extractHsTyNames inst_ty') } -- We return the renamed associated data type declarations so -- that they can be entered into the list of type declarations @@ -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", --- and "data family") -rnTyClDecl _ tydecl@TyFamily {} = rnFamily tydecl bindTyVarsFV +-- 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,22 +790,24 @@ 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) <- bindTyVarsFV tyvars $ \ tyvars' -> do -- Checks for distinct tyvars { context' <- rnContext cls_doc context - ; fds' <- rnFds cls_doc fds - ; (ats', at_fvs) <- rnATs ats + ; fds' <- rnFds cls_doc fds + ; 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. diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs index 0dca86808478fe34f6cc42150a4b4bbfc8e70a5d..1d12c33c8a7728a4e1af53f35647213e5005a83f 100644 --- a/compiler/typecheck/TcClassDcl.lhs +++ b/compiler/typecheck/TcClassDcl.lhs @@ -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 diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 3070ee9cb4d81770e40ed5b02cb15de7592adf9e..fed1864595c22d97cea7290ba138a6c83f77a9ab 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -35,7 +35,7 @@ import TyCon import DataCon import Class import Var -import VarEnv ( mkInScopeSet ) +import VarEnv import VarSet ( mkVarSet ) import Pair import CoreUtils ( mkPiTypes ) @@ -57,7 +57,6 @@ import SrcLoc import Util import Control.Monad -import Data.List import Data.Maybe import Maybes ( orElse ) \end{code} @@ -369,7 +368,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- round) -- (1) Do class and family instance declarations - ; idx_tycons <- mapAndRecoverM (tcFamInstDecl TopLevel) $ + ; idx_tycons <- mapAndRecoverM tcTopFamInstDecl $ filter (isFamInstDecl . unLoc) tycl_decls ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls @@ -453,134 +452,75 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead poly_ty ; checkValidInstance poly_ty tyvars theta clas inst_tys + ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys) -- Next, process any associated types. - ; idx_tycons <- recoverM (return []) $ - do { idx_tycons <- checkNoErrs $ - mapAndRecoverM (tcFamInstDecl NotTopLevel) ats - ; checkValidAndMissingATs clas (tyvars, inst_tys) - (zip ats idx_tycons) - ; return idx_tycons } + ; idx_tycons <- tcExtendTyVarEnv tyvars $ + mapAndRecoverM (tcAssocDecl clas mini_env) ats + + -- Check for misssing associated types + ; let class_ats = map tyConName (classATs clas) + defined_ats = mkNameSet $ map (tcdName . unLoc) ats + omitted = filterOut (`elemNameSet` defined_ats) class_ats + ; warn <- woptM Opt_WarnMissingMethods + ; mapM_ (warnTc warn . omittedATWarn) omitted -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.) ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty) -- Dfun location is that of instance *header* + ; overlap_flag <- getOverlapFlag - ; let (eq_theta,dict_theta) = partition isEqPred theta - theta' = eq_theta ++ dict_theta - dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys - ispec = mkLocalInstance dfun overlap_flag - - ; return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False }, - idx_tycons) - } + ; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys + ispec = mkLocalInstance dfun overlap_flag + inst_info = InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False } + + ; return (inst_info, idx_tycons) } + +tcAssocDecl :: Class -> VarEnv Type -> LTyClDecl Name -> TcM TyCon +tcAssocDecl clas mini_env (L loc decl) + = setSrcSpan loc $ + tcAddDeclCtxt decl $ + do { at_tc <- tcFamInstDecl NotTopLevel decl + ; let Just (fam_tc, at_tys) = tyConFamInst_maybe at_tc + + -- Check that the associated type comes from this class + ; checkTc (Just clas == tyConAssoc_maybe fam_tc) + (badATErr clas at_tc) + + -- See Note [Checking consistent instantiation] + ; zipWithM_ check_arg (tyConTyVars fam_tc) at_tys + + ; return at_tc } where - -- We pass in the source form and the type checked form of the ATs. We - -- really need the source form only to be able to produce more informative - -- error messages. - checkValidAndMissingATs :: Class - -> ([TyVar], [TcType]) -- instance types - -> [(LTyClDecl Name, -- source form of AT - TyCon)] -- Core form of AT - -> TcM () - checkValidAndMissingATs clas inst_tys ats - = do { -- Issue a warning for each class AT that is not defined in this - -- instance. - ; let class_ats = map tyConName (classATs clas) - defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats - omitted = filterOut (`elemNameSet` defined_ats) class_ats - ; warn <- woptM Opt_WarnMissingMethods - ; mapM_ (warnTc warn . omittedATWarn) omitted - - -- Ensure that all AT indexes that correspond to class parameters - -- coincide with the types in the instance head. All remaining - -- AT arguments must be variables. Also raise an error for any - -- type instances that are not associated with this class. - ; mapM_ (checkIndexes clas inst_tys) ats - } - - checkIndexes clas inst_tys (hsAT, tycon) --- !!!TODO: check that this does the Right Thing for indexed synonyms, too! - = checkIndexes' clas inst_tys hsAT - (tyConTyVars tycon, - snd . fromJust . tyConFamInst_maybe $ tycon) - - checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys) - = let atName = tcdName . unLoc $ hsAT - in - setSrcSpan (getLoc hsAT) $ - addErrCtxt (atInstCtxt atName) $ - case find ((atName ==) . tyConName) (classATs clas) of - Nothing -> addErrTc $ badATErr clas atName -- not in this class - Just atycon -> - -- The following is tricky! We need to deal with three - -- complications: (1) The AT possibly only uses a subset of - -- the class parameters as indexes and those it uses may be in - -- a different order; (2) the AT may have extra arguments, - -- which must be type variables; and (3) variables in AT and - -- instance head will be different `Name's even if their - -- source lexemes are identical. - -- - -- e.g. class C a b c where - -- data D b a :: * -> * -- NB (1) b a, omits c - -- instance C [x] Bool Char where - -- data D Bool [x] v = MkD x [v] -- NB (2) v - -- -- NB (3) the x in 'instance C...' have differnt - -- -- Names to x's in 'data D...' - -- - -- Re (1), `poss' contains a permutation vector to extract the - -- class parameters in the right order. - -- - -- Re (2), we wrap the (permuted) class parameters in a Maybe - -- type and use Nothing for any extra AT arguments. (First - -- equation of `checkIndex' below.) - -- - -- Re (3), we replace any type variable in the AT parameters - -- that has the same source lexeme as some variable in the - -- instance types with the instance type variable sharing its - -- source lexeme. - -- - let poss :: [Int] - -- For *associated* type families, gives the position - -- of that 'TyVar' in the class argument list (0-indexed) - -- e.g. class C a b c where { type F c a :: *->* } - -- Then we get Just [2,0] - poss = catMaybes [ tv `elemIndex` classTyVars clas - | tv <- tyConTyVars atycon] - -- We will get Nothings for the "extra" type - -- variables in an associated data type - -- e.g. class C a where { data D a :: *->* } - -- here D gets arity 2 and has two tyvars - - relevantInstTys = map (instTys !!) poss - instArgs = map Just relevantInstTys ++ - repeat Nothing -- extra arguments - renaming = substSameTyVar atTvs instTvs - in - zipWithM_ checkIndex (substTys renaming atTys) instArgs - - checkIndex ty Nothing - | isTyVarTy ty = return () - | otherwise = addErrTc $ mustBeVarArgErr ty - checkIndex ty (Just instTy) - | ty `eqType` instTy = return () - | otherwise = addErrTc $ wrongATArgErr ty instTy - - listToNameSet = addListToNameSet emptyNameSet - - substSameTyVar [] _ = emptyTvSubst - substSameTyVar (tv:tvs) replacingTvs = - let replacement = case find (tv `sameLexeme`) replacingTvs of - Nothing -> mkTyVarTy tv - Just rtv -> mkTyVarTy rtv - -- - tv1 `sameLexeme` tv2 = - nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2) - in - TcType.extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement + check_arg fam_tc_tv at_ty + | Just inst_ty <- lookupVarEnv mini_env fam_tc_tv + = checkTc (inst_ty `eqType` at_ty) + (wrongATArgErr at_ty inst_ty) + | otherwise + = checkTc (isTyVarTy at_ty) + (mustBeVarArgErr at_ty) \end{code} +Note [Checking consistent instantiation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + class C a b where + type T a x b + + instance C [p] Int + type T [p] y Int = (p,y,y) -- Induces the family instance TyCon + -- type TR p y = (p,y,y) + +So we + * Form the mini-envt from the class type variables a,b + to the instance decl types [p],Int: [a->[p], b->Int] + + * Look at the tyvars a,x,b of the type family constructor T + (it shares tyvars with the class C) + + * Apply the mini-evnt to them, and check that the result is + consistent with the instance types [p] y Int + %************************************************************************ %* * @@ -594,50 +534,46 @@ lot of kinding and type checking code with ordinary algebraic data types (and GADTs). \begin{code} -tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyCon -tcFamInstDecl top_lvl (L loc decl) - = -- Prime error recovery, set source location - setSrcSpan loc $ - tcAddDeclCtxt decl $ - do { -- type family instances require -XTypeFamilies +tcTopFamInstDecl :: LTyClDecl Name -> TcM TyCon +tcTopFamInstDecl (L loc decl) + = setSrcSpan loc $ + tcAddDeclCtxt decl $ + tcFamInstDecl TopLevel decl + +tcFamInstDecl :: TopLevelFlag -> TyClDecl Name -> TcM TyCon +-- TopLevel => top-level +-- NotTopLevel => in an instance decl +tcFamInstDecl top_lvl decl + = do { -- type family instances require -XTypeFamilies -- and can't (currently) be in an hs-boot file + ; let fam_tc_lname = tcdLName decl ; type_families <- xoptM Opt_TypeFamilies - ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? - ; checkTc type_families $ badFamInstDecl (tcdLName decl) + ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + ; checkTc type_families $ badFamInstDecl fam_tc_lname ; checkTc (not is_boot) $ badBootFamInstDeclErr - -- Perform kind and type checking - ; tc <- tcFamInstDecl1 decl + -- Look up the family TyCon and check for validity including + -- check that toplevel type instances are not for associated types. + ; fam_tc <- tcLookupLocatedTyCon fam_tc_lname + ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) + ; when (isTopLevel top_lvl && isTyConAssoc fam_tc) + (addErr $ assocInClassErr fam_tc_lname) + + -- Now check the type/data instance itself + -- This is where type and data decls are treated separately + ; tc <- tcFamInstDecl1 fam_tc decl ; checkValidTyCon tc -- Remember to check validity; -- no recursion to worry about here - -- Check that toplevel type instances are not for associated types. - ; when (isTopLevel top_lvl && isAssocFamily tc) - (addErr $ assocInClassErr (tcdName decl)) - ; return tc } -isAssocFamily :: TyCon -> Bool -- Is an assocaited type -isAssocFamily tycon - = case tyConFamInst_maybe tycon of - Nothing -> panic "isAssocFamily: no family?!?" - Just (fam, _) -> isTyConAssoc fam - -assocInClassErr :: Name -> SDoc -assocInClassErr name - = ptext (sLit "Associated type") <+> quotes (ppr name) <+> - ptext (sLit "must be inside a class instance") - - - -tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon +tcFamInstDecl1 :: TyCon -> TyClDecl Name -> TcM TyCon -- "type instance" -tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) - = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> +tcFamInstDecl1 fam_tc (decl@TySynonym {tcdLName = L loc tc_name}) + = kcIdxTyPats fam_tc decl $ \k_tvs k_typats resKind -> do { -- check that the family declaration is for a synonym - checkTc (isFamilyTyCon family) (notFamily family) - ; checkTc (isSynTyCon family) (wrongKindOfFamily family) + checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc) ; -- (1) kind check the right-hand side of the type equation ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk) @@ -645,13 +581,13 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) -- we need the exact same number of type parameters as the family -- declaration - ; let famArity = tyConArity family + ; let famArity = tyConArity fam_tc ; checkTc (length k_typats == famArity) $ - wrongNumberOfParmsErr famArity + wrongNumberOfParmsErr famArity -- (2) type check type equation - ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars - ; t_typats <- mapM tcHsKindedType k_typats + ; tcTyVarBndrs k_tvs $ \t_tvs -> do -- turn kinded into proper tyvars + { t_typats <- mapM tcHsKindedType k_typats ; t_rhs <- tcHsKindedType k_rhs -- (3) check the well-formedness of the instance @@ -659,18 +595,20 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) -- (4) construct representation tycon ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc - ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) + ; buildSynTyCon rep_tc_name t_tvs + (SynonymTyCon t_rhs) (typeKind t_rhs) - NoParentTyCon (Just (family, t_typats)) + NoParentTyCon (Just (fam_tc, t_typats)) }} -- "newtype instance" and "data instance" -tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, - tcdCons = cons}) - = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon -> +tcFamInstDecl1 fam_tc (decl@TyData { tcdND = new_or_data + , tcdLName = L loc tc_name + , tcdCons = cons}) + = kcIdxTyPats fam_tc decl $ \k_tvs k_typats resKind -> do { -- check that the family declaration is for the right kind - checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon) - ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon) + checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) + ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc) ; -- (1) kind check the data declaration as usual ; k_decl <- kcDataDecl decl k_tvs @@ -678,13 +616,13 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, k_cons = tcdCons k_decl -- result kind must be '*' (otherwise, we have too few patterns) - ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon) + ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tc) -- (2) type check indexed data type declaration - ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars + ; tcTyVarBndrs k_tvs $ \t_tvs -> do -- turn kinded into proper tyvars -- kind check the type indexes and the context - ; t_typats <- mapM tcHsKindedType k_typats + { t_typats <- mapM tcHsKindedType k_typats ; stupid_theta <- tcHsKindedContext k_ctxt -- (3) Check that @@ -699,7 +637,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc ; let ex_ok = True -- Existentials ok for type families! ; fixM (\ rep_tycon -> do - { let orig_res_ty = mkTyConApp fam_tycon t_typats + { let orig_res_ty = mkTyConApp fam_tc t_typats ; data_cons <- tcConDecls ex_ok rep_tycon (t_tvs, orig_res_ty) k_cons ; tc_rhs <- @@ -708,7 +646,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, NewType -> ASSERT( not (null data_cons) ) mkNewTyConRhs rep_tc_name rep_tycon (head data_cons) ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive - h98_syntax NoParentTyCon (Just (fam_tycon, t_typats)) + h98_syntax NoParentTyCon (Just (fam_tc, t_typats)) -- We always assume that indexed types are recursive. Why? -- (1) Due to their open nature, we can never be sure that a -- further instance might not introduce a new recursive @@ -721,7 +659,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False _ -> True -tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d) +tcFamInstDecl1 _ d = pprPanic "tcFamInstDecl1" (ppr d) -- Kind checking of indexed types -- - @@ -732,27 +670,26 @@ tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d) -- not check whether there is a pattern for each type index; the latter -- check is only required for type synonym instances. -kcIdxTyPats :: TyClDecl Name - -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a) +kcIdxTyPats :: TyCon + -> TyClDecl Name + -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TcM a) -- ^^kinded tvs ^^kinded ty pats ^^res kind -> TcM a -kcIdxTyPats decl thing_inside +kcIdxTyPats fam_tc decl thing_inside = kcHsTyVars (tcdTyVars decl) $ \tvs -> - do { let tc_name = tcdLName decl - ; fam_tycon <- tcLookupLocatedTyCon tc_name - ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon) + do { let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tc) ; hs_typats = fromJust $ tcdTyPats decl } - -- we may not have more parameters than the kind indicates + -- We may not have more parameters than the kind indicates ; checkTc (length kinds >= length hs_typats) $ - tooManyParmsErr (tcdLName decl) + tooManyParmsErr (tcdLName decl) - -- type functions can have a higher-kinded result + -- Type functions can have a higher-kinded result ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind ; typats <- zipWithM kcCheckLHsType hs_typats - [ EK kind (EkArg (ppr tc_name) n) + [ EK kind (EkArg (ppr fam_tc) n) | (kind,n) <- kinds `zip` [1..]] - ; thing_inside tvs typats resultKind fam_tycon + ; thing_inside tvs typats resultKind } \end{code} @@ -1405,9 +1342,11 @@ instDeclCtxt2 dfun_ty inst_decl_ctxt :: SDoc -> SDoc inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc +{- atInstCtxt :: Name -> SDoc atInstCtxt name = ptext (sLit "In the associated type instance for") <+> quotes (ppr name) +-} mustBeVarArgErr :: Type -> SDoc mustBeVarArgErr ty = @@ -1455,4 +1394,24 @@ wrongKindOfFamily family kindOfFamily | isSynTyCon family = ptext (sLit "type synonym") | isAlgTyCon family = ptext (sLit "data type") | otherwise = pprPanic "wrongKindOfFamily" (ppr family) + +assocInClassErr :: Located Name -> SDoc +assocInClassErr name + = ptext (sLit "Associated type") <+> quotes (ppr name) <+> + ptext (sLit "must be inside a class instance") + +badFamInstDecl :: Located Name -> 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")) ] + +badATErr :: Class -> TyCon -> 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) \end{code} diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index b7dc8477ea230f42ff18a7aa9162ca69753d99cf..eb950f118726463b73c39ee3ff15f8477e1f0d7d 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -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"),