Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

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 authored
76  compiler/typecheck/TcInstDcls.lhs
@@ -42,7 +42,7 @@ import DataCon
42 42
 import Class
43 43
 import Var
44 44
 import VarEnv
45  
-import VarSet     ( mkVarSet, varSetElems )
  45
+import VarSet     ( mkVarSet, subVarSet, varSetElems )
46 46
 import Pair
47 47
 import CoreUnfold ( mkDFunUnfolding )
48 48
 import CoreSyn    ( Expr(Var), CoreExpr, varToCoreExpr )
@@ -61,7 +61,6 @@ import SrcLoc
61 61
 import Util
62 62
 
63 63
 import Control.Monad
64  
-import Data.Maybe
65 64
 import Maybes     ( orElse )
66 65
 \end{code}
67 66
 
@@ -453,8 +452,9 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
453 452
                   badBootDeclErr
454 453
 
455 454
         ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead InstDeclCtxt poly_ty
456  
-        ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys)
457  
-
  455
+        ; let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)
  456
+              mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
  457
+                           
458 458
         -- Next, process any associated types.
459 459
         ; traceTc "tcLocalInstDecl" (ppr poly_ty)
460 460
         ; idx_tycons0 <- tcExtendTyVarEnv tyvars $
@@ -463,30 +463,37 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
463 463
         -- Check for missing associated types and build them
464 464
         -- from their defaults (if available)
465 465
         ; let defined_ats = mkNameSet $ map (tcdName . unLoc) ats
466  
-              check_at_instance (fam_tc, defs)
  466
+
  467
+              mk_deflt_at_instances :: ClassATItem -> TcM [TyCon]
  468
+              mk_deflt_at_instances (fam_tc, defs)
467 469
                  -- User supplied instances ==> everything is OK
468  
-                | tyConName fam_tc `elemNameSet` defined_ats = return (Nothing, [])
  470
+                | tyConName fam_tc `elemNameSet` defined_ats 
  471
+                = return []
  472
+
469 473
                  -- No defaults ==> generate a warning
470  
-                | null defs                                  = return (Just (tyConName fam_tc), [])
  474
+                | null defs
  475
+                = do { warnMissingMethodOrAT "associated type" (tyConName fam_tc)
  476
+                     ; return [] }
  477
+
471 478
                  -- No user instance, have defaults ==> instatiate them
472  
-                | otherwise = do
473  
-                    defs' <- forM defs $ \(ATD tvs pat_tys rhs _loc) -> do
474  
-                      let mini_env_subst = mkTvSubst (mkInScopeSet (mkVarSet tvs)) mini_env
475  
-                          tvs' = varSetElems (tyVarsOfType rhs')
476  
-                          pat_tys' = substTys mini_env_subst pat_tys
477  
-                          rhs' = substTy mini_env_subst rhs
478  
-                      rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys'
479  
-                      buildSynTyCon rep_tc_name tvs'
480  
-                                    (SynonymTyCon rhs')
481  
-                                    (mkArrowKinds (map tyVarKind tvs') (typeKind rhs'))
482  
-                                    NoParentTyCon (Just (fam_tc, pat_tys'))
483  
-                    return (Nothing, defs')
484  
-        ; missing_at_stuff <- mapM check_at_instance (classATItems clas)
  479
+                 -- Example:   class C a where { type F a b :: *; type F a b = () }
  480
+                 --            instance C [x]
  481
+                 -- Then we want to generate the decl:   type F [x] b = ()
  482
+                | otherwise 
  483
+                = forM defs $ \(ATD _tvs pat_tys rhs _loc) ->
  484
+                  do { let pat_tys' = substTys mini_subst pat_tys
  485
+                           rhs'     = substTy  mini_subst rhs
  486
+                           tv_set'  = tyVarsOfTypes pat_tys'
  487
+                           tvs'     = varSetElems tv_set'
  488
+                     ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys'
  489
+                     ; ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) 
  490
+                       buildSynTyCon rep_tc_name tvs'
  491
+                                     (SynonymTyCon rhs')
  492
+                                     (typeKind rhs')
  493
+                                     NoParentTyCon (Just (fam_tc, pat_tys')) }
  494
+
  495
+        ; idx_tycons1 <- mapM mk_deflt_at_instances (classATItems clas)
485 496
         
486  
-        ; let (omitted, idx_tycons1) = unzip missing_at_stuff
487  
-        ; warn <- woptM Opt_WarnMissingMethods
488  
-        ; mapM_ (warnTc warn . omittedATWarn) (catMaybes omitted)
489  
-
490 497
         -- Finally, construct the Core representation of the instance.
491 498
         -- (This no longer includes the associated types.)
492 499
         ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
@@ -1007,7 +1014,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
1007 1014
 
1008 1015
     tc_default sel_id NoDefMeth     -- No default method at all
1009 1016
       = do { traceTc "tc_def: warn" (ppr sel_id)
1010  
-           ; warnMissingMethod sel_id
  1017
+           ; warnMissingMethodOrAT "method" (idName sel_id)
1011 1018
            ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
1012 1019
                                          inst_tys sel_id
1013 1020
            ; return (meth_id, mkVarBind meth_id $
@@ -1194,18 +1201,15 @@ derivBindCtxt sel_id clas tys _bind
1194 1201
                     <+> quotes (pprClassPred clas tys) <> colon)
1195 1202
           , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
1196 1203
 
1197  
--- Too voluminous
1198  
---        , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
1199  
-
1200  
-warnMissingMethod :: Id -> TcM ()
1201  
-warnMissingMethod sel_id
  1204
+warnMissingMethodOrAT :: String -> Name -> TcM ()
  1205
+warnMissingMethodOrAT what name
1202 1206
   = do { warn <- woptM Opt_WarnMissingMethods
1203  
-       ; traceTc "warn" (ppr sel_id <+> ppr warn <+> ppr (not (startsWithUnderscore (getOccName sel_id))))
  1207
+       ; traceTc "warn" (ppr name <+> ppr warn <+> ppr (not (startsWithUnderscore (getOccName name))))
1204 1208
        ; warnTc (warn  -- Warn only if -fwarn-missing-methods
1205  
-                 && not (startsWithUnderscore (getOccName sel_id)))
  1209
+                 && not (startsWithUnderscore (getOccName name)))
1206 1210
                                         -- Don't warn about _foo methods
1207  
-                (ptext (sLit "No explicit method nor default method for")
1208  
-                 <+> quotes (ppr sel_id)) }
  1211
+                (ptext (sLit "No explicit") <+> text what <+> ptext (sLit "or default declaration for")
  1212
+                 <+> quotes (ppr name)) }
1209 1213
 \end{code}
1210 1214
 
1211 1215
 Note [Export helper functions]
@@ -1331,10 +1335,6 @@ instDeclCtxt2 dfun_ty
1331 1335
 inst_decl_ctxt :: SDoc -> SDoc
1332 1336
 inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
1333 1337
 
1334  
-omittedATWarn :: Name -> SDoc
1335  
-omittedATWarn at
1336  
-  = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
1337  
-
1338 1338
 badBootFamInstDeclErr :: SDoc
1339 1339
 badBootFamInstDeclErr
1340 1340
   = ptext (sLit "Illegal family instance in hs-boot file")
2  compiler/types/Class.lhs
@@ -105,7 +105,7 @@ type ClassATItem = (TyCon, [ATDefault])
105 105
 
106 106
 -- Each associated type default template is a triple of:
107 107
 data ATDefault = ATD { -- TyVars of the RHS and family arguments 
108  
-                       -- (including the class TVs)
  108
+                       -- (including, but perhaps more than, the class TVs)
109 109
                        atDefaultTys     :: [TyVar],
110 110
                        -- The instantiated family arguments
111 111
                        atDefaultPats    :: [Type],

0 notes on commit 8785726

Please sign in to comment.
Something went wrong with that request. Please try again.