Merge branch 'master' of darcs.haskell.org:/home/darcs/ghc
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 25 Jan 2013 13:20:56 +0000 (13:20 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 25 Jan 2013 13:20:56 +0000 (13:20 +0000)
1  2 
compiler/typecheck/TcTyClsDecls.lhs

@@@ -603,33 -617,28 +603,33 @@@ tcTyClDecl1 _parent rec_inf
                        -- hold of the name of the class TyCon, which we
                        -- need to look up its recursiveness
                    tycon_name = tyConName (classTyCon clas)
-                   tc_isrec = calc_isrec tycon_name
+                   tc_isrec = rti_is_rec rec_info tycon_name
  
 -            ; at_stuff <- tcClassATs class_name (AssocFamilyTyCon clas) ats at_defs
 -
 -            ; buildClass False {- Must include unfoldings for selectors -}
 -                       class_name tvs' ctxt' fds' at_stuff
 -                       sig_stuff tc_isrec }
 -
 -  ; let gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty)
 -                     | (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas
 -                     , let gen_dm_tau = expectJust "tcTyClDecl1" $
 -                                        lookupNameEnv gen_dm_env (idName sel_id)
 -                   , let gen_dm_ty = mkSigmaTy tvs' 
 -                                                 [mkClassPred clas (mkTyVarTys tvs')] 
 -                                                 gen_dm_tau
 -                     ]
 -        class_ats = map ATyCon (classATs clas)
 -
 -  ; return (ATyCon (classTyCon clas) : gen_dm_ids ++ class_ats )
 -      -- NB: Order is important due to the call to `mkGlobalThings' when
 -      --     tying the the type and class declaration type checking knot.
 -  }
 +               ; ctxt' <- tcHsContext ctxt
 +               ; ctxt' <- zonkTcTypeToTypes emptyZonkEnv ctxt'  
 +                       -- Squeeze out any kind unification variables
 +               ; fds'  <- mapM (addLocM tc_fundep) fundeps
 +               ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths
 +               ; at_stuff <- tcClassATs class_name (AssocFamilyTyCon clas) ats at_defs
 +               ; clas <- buildClass False {- Must include unfoldings for selectors -}
 +                          class_name tvs' ctxt' fds' at_stuff
 +                          sig_stuff tc_isrec 
 +               ; traceTc "tcClassDecl" (ppr fundeps $$ ppr tvs' $$ ppr fds')
 +               ; return (clas, tvs', gen_dm_env) }
 +
 +       ; let { gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty)
 +                            | (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas
 +                          , let gen_dm_tau = expectJust "tcTyClDecl1" $
 +                                             lookupNameEnv gen_dm_env (idName sel_id)
 +                          , let gen_dm_ty = mkSigmaTy tvs' 
 +                                                    [mkClassPred clas (mkTyVarTys tvs')] 
 +                                                    gen_dm_tau
 +                          ]
 +             ; class_ats = map ATyCon (classATs clas) }
 +
 +       ; return (ATyCon (classTyCon clas) : gen_dm_ids ++ class_ats ) }
 +         -- NB: Order is important due to the call to `mkGlobalThings' when
 +         --     tying the the type and class declaration type checking knot.
    where
      tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM tc_fd_tyvar tvs1 ;
                                ; tvs2' <- mapM tc_fd_tyvar tvs2 ;