Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Fix an outright bug in the implementation of default decls

for associated types (fixes Trac #5719)

The bug was that we ended up quantifying the new AT instance
over the wrong set of type variables, and that led to confusing
chaos.
  • Loading branch information...
commit 8785726b57ccd44c5451385de61913a79fe02eb7 1 parent ddeb70b
@simonpj simonpj authored
Showing with 39 additions and 39 deletions.
  1. +38 −38 compiler/typecheck/TcInstDcls.lhs
  2. +1 −1  compiler/types/Class.lhs
View
76 compiler/typecheck/TcInstDcls.lhs
@@ -42,7 +42,7 @@ import DataCon
import Class
import Var
import VarEnv
-import VarSet ( mkVarSet, varSetElems )
+import VarSet ( mkVarSet, subVarSet, varSetElems )
import Pair
import CoreUnfold ( mkDFunUnfolding )
import CoreSyn ( Expr(Var), CoreExpr, varToCoreExpr )
@@ -61,7 +61,6 @@ import SrcLoc
import Util
import Control.Monad
-import Data.Maybe
import Maybes ( orElse )
\end{code}
@@ -453,8 +452,9 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
badBootDeclErr
; (tyvars, theta, clas, inst_tys) <- tcHsInstHead InstDeclCtxt poly_ty
- ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys)
-
+ ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys)
+ mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
+
-- Next, process any associated types.
; traceTc "tcLocalInstDecl" (ppr poly_ty)
; idx_tycons0 <- tcExtendTyVarEnv tyvars $
@@ -463,30 +463,37 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
-- Check for missing associated types and build them
-- from their defaults (if available)
; let defined_ats = mkNameSet $ map (tcdName . unLoc) ats
- check_at_instance (fam_tc, defs)
+
+ mk_deflt_at_instances :: ClassATItem -> TcM [TyCon]
+ mk_deflt_at_instances (fam_tc, defs)
-- User supplied instances ==> everything is OK
- | tyConName fam_tc `elemNameSet` defined_ats = return (Nothing, [])
+ | tyConName fam_tc `elemNameSet` defined_ats
+ = return []
+
-- No defaults ==> generate a warning
- | null defs = return (Just (tyConName fam_tc), [])
+ | null defs
+ = do { warnMissingMethodOrAT "associated type" (tyConName fam_tc)
+ ; return [] }
+
-- No user instance, have defaults ==> instatiate them
- | otherwise = do
- defs' <- forM defs $ \(ATD tvs pat_tys rhs _loc) -> do
- let mini_env_subst = mkTvSubst (mkInScopeSet (mkVarSet tvs)) mini_env
- tvs' = varSetElems (tyVarsOfType rhs')
- pat_tys' = substTys mini_env_subst pat_tys
- rhs' = substTy mini_env_subst rhs
- rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys'
- buildSynTyCon rep_tc_name tvs'
- (SynonymTyCon rhs')
- (mkArrowKinds (map tyVarKind tvs') (typeKind rhs'))
- NoParentTyCon (Just (fam_tc, pat_tys'))
- return (Nothing, defs')
- ; missing_at_stuff <- mapM check_at_instance (classATItems clas)
+ -- 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 = ()
+ | otherwise
+ = forM defs $ \(ATD _tvs pat_tys rhs _loc) ->
+ do { let pat_tys' = substTys mini_subst pat_tys
+ rhs' = substTy mini_subst rhs
+ tv_set' = tyVarsOfTypes pat_tys'
+ tvs' = varSetElems tv_set'
+ ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys'
+ ; ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' )
+ buildSynTyCon rep_tc_name tvs'
+ (SynonymTyCon rhs')
+ (typeKind rhs')
+ NoParentTyCon (Just (fam_tc, pat_tys')) }
+
+ ; idx_tycons1 <- mapM mk_deflt_at_instances (classATItems clas)
- ; let (omitted, idx_tycons1) = unzip missing_at_stuff
- ; warn <- woptM Opt_WarnMissingMethods
- ; mapM_ (warnTc warn . omittedATWarn) (catMaybes 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)
@@ -1007,7 +1014,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
tc_default sel_id NoDefMeth -- No default method at all
= do { traceTc "tc_def: warn" (ppr sel_id)
- ; warnMissingMethod sel_id
+ ; warnMissingMethodOrAT "method" (idName sel_id)
; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
inst_tys sel_id
; return (meth_id, mkVarBind meth_id $
@@ -1194,18 +1201,15 @@ derivBindCtxt sel_id clas tys _bind
<+> quotes (pprClassPred clas tys) <> colon)
, nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
--- Too voluminous
--- , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
-
-warnMissingMethod :: Id -> TcM ()
-warnMissingMethod sel_id
+warnMissingMethodOrAT :: String -> Name -> TcM ()
+warnMissingMethodOrAT what name
= do { warn <- woptM Opt_WarnMissingMethods
- ; traceTc "warn" (ppr sel_id <+> ppr warn <+> ppr (not (startsWithUnderscore (getOccName sel_id))))
+ ; traceTc "warn" (ppr name <+> ppr warn <+> ppr (not (startsWithUnderscore (getOccName name))))
; warnTc (warn -- Warn only if -fwarn-missing-methods
- && not (startsWithUnderscore (getOccName sel_id)))
+ && not (startsWithUnderscore (getOccName name)))
-- Don't warn about _foo methods
- (ptext (sLit "No explicit method nor default method for")
- <+> quotes (ppr sel_id)) }
+ (ptext (sLit "No explicit") <+> text what <+> ptext (sLit "or default declaration for")
+ <+> quotes (ppr name)) }
\end{code}
Note [Export helper functions]
@@ -1331,10 +1335,6 @@ instDeclCtxt2 dfun_ty
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
-omittedATWarn :: Name -> SDoc
-omittedATWarn at
- = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
-
badBootFamInstDeclErr :: SDoc
badBootFamInstDeclErr
= ptext (sLit "Illegal family instance in hs-boot file")
View
2  compiler/types/Class.lhs
@@ -105,7 +105,7 @@ type ClassATItem = (TyCon, [ATDefault])
-- Each associated type default template is a triple of:
data ATDefault = ATD { -- TyVars of the RHS and family arguments
- -- (including the class TVs)
+ -- (including, but perhaps more than, the class TVs)
atDefaultTys :: [TyVar],
-- The instantiated family arguments
atDefaultPats :: [Type],
Please sign in to comment.
Something went wrong with that request. Please try again.