Commit c0324c09 authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu Committed by Ben Gamari
Browse files

Merge #10817/#10899 (e27b267f)

parent bf210296
......@@ -1729,7 +1729,7 @@ classToIfaceDecl env clas
toIfaceAT :: ClassATItem -> IfaceAT
toIfaceAT (ATI tc def)
= IfaceAT if_decl (fmap (tidyToIfaceType env2) def)
= IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def)
where
(env2, if_decl) = tyConToIfaceDecl env1 tc
......
......@@ -413,7 +413,7 @@ tc_iface_decl _parent ignore_prags
Just def -> forkM (mk_at_doc tc) $
extendIfaceTyVarEnv (tyConTyVars tc) $
do { tc_def <- tcIfaceType def
; return (Just tc_def) }
; return (Just (tc_def, noSrcSpan)) }
-- Must be done lazily in case the RHS of the defaults mention
-- the type constructor being defined here
-- e.g. type AT a; type AT b = AT [b] Trac #8002
......@@ -533,7 +533,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name))
name is_infix
stricts -- Pass the HsImplBangs (i.e. final decisions
-- to buildDataCon; it'll use these to guide
-- to buildDataCon; it'll use these to guide
-- the construction of a worker
lbl_names
tc_tyvars ex_tyvars
......
......@@ -567,7 +567,7 @@ tcATDefault inst_subst defined_ats (ATI fam_tc defs)
-- Example: class C a where { type F a b :: *; type F a b = () }
-- instance C [x]
-- Then we want to generate the decl: type F [x] b = ()
| Just rhs_ty <- defs
| Just (rhs_ty, _loc) <- defs
= do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst
(tyConTyVars fam_tc)
rhs' = substTy subst' rhs_ty
......
......@@ -930,8 +930,8 @@ checkBootTyCon tc1 tc2
(text "The associated type defaults differ")
-- Ignore the location of the defaults
eqATDef Nothing Nothing = True
eqATDef (Just ty1) (Just ty2) = eqTypeX env ty1 ty2
eqATDef Nothing Nothing = True
eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2
eqATDef _ _ = False
eqFD (as1,bs1) (as2,bs2) =
......
......@@ -852,9 +852,9 @@ tcClassATs class_name parent ats at_defs
; return (ATI fam_tc atd) }
-------------------------
tcDefaultAssocDecl :: TyCon -- ^ Family TyCon
-> [LTyFamDefltEqn Name] -- ^ Defaults
-> TcM (Maybe Type) -- ^ Type checked RHS
tcDefaultAssocDecl :: TyCon -- ^ Family TyCon
-> [LTyFamDefltEqn Name] -- ^ Defaults
-> TcM (Maybe (Type, SrcSpan)) -- ^ Type checked RHS
tcDefaultAssocDecl _ []
= return Nothing -- No default declaration
......@@ -879,7 +879,7 @@ tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name
; let fam_tc_tvs = tyConTyVars fam_tc
subst = zipTopTvSubst tvs (mkTyVarTys fam_tc_tvs)
; return ( ASSERT( equalLength fam_tc_tvs tvs )
Just (substTy subst rhs_ty) ) }
Just (substTy subst rhs_ty, loc) ) }
-- We check for well-formedness and validity later, in checkValidClass
-------------------------
......@@ -1667,8 +1667,9 @@ checkValidClass cls
; mapM_ check_at_defs at_stuff }
where
(tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls
cls_arity = count isTypeVar tyvars -- Ignore kind variables
cls_arity = count isTypeVar tyvars -- Ignore kind variables
cls_tv_set = mkVarSet tyvars
mini_env = zipVarEnv tyvars (mkTyVarTys tyvars)
check_op constrained_class_methods (sel_id, dm)
= addErrCtxt (classOpCtxt sel_id tau) $ do
......@@ -1709,9 +1710,14 @@ checkValidClass cls
-- in the context of a for-all must mention at least one quantified
-- type variable. What a mess!
check_at_defs (ATI fam_tc _)
= check_mentions (mkVarSet (tyConTyVars fam_tc))
(ptext (sLit "associated type") <+> quotes (ppr fam_tc))
check_at_defs (ATI fam_tc m_dflt_rhs)
= do { check_mentions (mkVarSet fam_tvs) $
ptext (sLit "associated type") <+> quotes (ppr fam_tc)
; whenIsJust m_dflt_rhs $ \ (rhs, loc) ->
checkValidTyFamEqn (Just (cls, mini_env)) fam_tc
fam_tvs (mkTyVarTys fam_tvs) rhs loc }
where
fam_tvs = tyConTyVars fam_tc
check_mentions :: TyVarSet -> SDoc -> TcM ()
-- Check that the thing (method or associated type) mentions at least
......
......@@ -11,8 +11,8 @@ module TcValidity (
checkValidTheta, checkValidFamPats,
checkValidInstance, validDerivPred,
checkInstTermination, checkValidTyFamInst, checkTyFamFreeness,
checkConsistentFamInst,
arityErr, badATErr
checkValidTyFamEqn, checkConsistentFamInst,
arityErr, badATErr, ClsInfo
) where
#include "HsVersions.h"
......@@ -1071,6 +1071,11 @@ But if the 'b' didn't scope, we would make F's instance too
poly-kinded.
-}
-- | Extra information needed when type-checking associated types. The 'Class' is
-- the enclosing class, and the @VarEnv Type@ maps class variables to their
-- instance types.
type ClsInfo = (Class, VarEnv Type)
checkConsistentFamInst
:: Maybe ( Class
, VarEnv Type ) -- ^ Class of associated type
......@@ -1148,6 +1153,19 @@ checkValidTyFamInst :: Maybe ( Class, VarEnv Type )
checkValidTyFamInst mb_clsinfo fam_tc
(CoAxBranch { cab_tvs = tvs, cab_lhs = typats
, cab_rhs = rhs, cab_loc = loc })
= checkValidTyFamEqn mb_clsinfo fam_tc tvs typats rhs loc
-- | Do validity checks on a type family equation, including consistency
-- with any enclosing class instance head, termination, and lack of
-- polytypes.
checkValidTyFamEqn :: Maybe ClsInfo
-> TyCon -- ^ of the type family
-> [TyVar] -- ^ bound tyvars in the equation
-> [Type] -- ^ type patterns
-> Type -- ^ rhs
-> SrcSpan
-> TcM ()
checkValidTyFamEqn mb_clsinfo fam_tc tvs typats rhs loc
= setSrcSpan loc $
do { checkValidFamPats fam_tc tvs typats
......
......@@ -29,6 +29,7 @@ import Name
import BasicTypes
import Unique
import Util
import SrcLoc
import Outputable
import FastString
import BooleanFormula (BooleanFormula)
......@@ -100,7 +101,8 @@ data DefMeth = NoDefMeth -- No default method
data ClassATItem
= ATI TyCon -- See Note [Associated type tyvar names]
(Maybe Type) -- Default associated type (if any) from this template
(Maybe (Type, SrcSpan))
-- Default associated type (if any) from this template
-- Note [Associated type defaults]
type ClassMinimalDef = BooleanFormula Name -- Required methods
......@@ -147,6 +149,8 @@ Note that
the default Type rhs
The @mkClass@ function fills in the indirect superclasses.
The SrcSpan is for the entire original declaration.
-}
mkClass :: [TyVar]
......
{-# LANGUAGE TypeFamilies #-}
module T10817 where
import Data.Proxy
class C a where
type F a
type F a = F a
instance C Bool
x :: Proxy (F Bool)
x = Proxy
T10817.hs:9:3:
Application is no smaller than the instance head
in the type family application: F a
(Use UndecidableInstances to permit this)
In the class declaration for ‘C’
{-# LANGUAGE TypeFamilies, RankNTypes #-}
module T10899 where
class C a where
type F a
type F a = forall m. m a
T10899.hs:7:3:
Illegal polymorphic or qualified type: forall (m :: * -> *). m a
In the class declaration for ‘C’
......@@ -133,4 +133,5 @@ test('T9662', normal, compile_fail, [''])
test('T7862', normal, compile_fail, [''])
test('T9896', normal, compile_fail, [''])
test('T6088', normal, compile_fail, [''])
test('T10817', normal, compile_fail, [''])
test('T10899', normal, compile_fail, [''])
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-- this is needed because |FamHelper a x| /< |Fam a x|
module ShouldCompile where
class Cls a where
......
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