X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=d4d8d2fbc543e6133eee500eb3955fdcca77a9e6;hp=9ac0a6fc752c50be8521ef473dcdd8dadfcac494;hb=792449f555bb4dfa8e718079f6d42dc9babe938a;hpb=d872133bb986dbd15959cbb14504bf9a863e3e4a diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 9ac0a6f..d4d8d2f 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -372,13 +372,12 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls ; let { (local_info, at_tycons_s) = unzip local_info_tycons ; at_idx_tycons = concat at_tycons_s ++ idx_tycons - ; implicit_things = concatMap implicitTyThings at_idx_tycons - ; aux_binds = mkRecSelBinds at_idx_tycons - } + ; implicit_things = concatMap implicitTyConThings at_idx_tycons + ; aux_binds = mkRecSelBinds at_idx_tycons } -- (2) Add the tycons of indexed types and their implicit -- tythings to the global environment - ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do { + ; tcExtendGlobalEnv (map ATyCon at_idx_tycons ++ implicit_things) $ do { -- Next, construct the instance environment so far, consisting @@ -401,9 +400,11 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- Extend the global environment also with the generated datatypes for -- the generic representation - ; gbl_env <- addFamInsts (map ATyCon deriv_ty_insts) $ - tcExtendGlobalEnv (map ATyCon (deriv_tys ++ deriv_ty_insts)) $ - addInsts deriv_inst_info getGblEnv + ; let all_tycons = map ATyCon (deriv_tys ++ deriv_ty_insts) + ; gbl_env <- tcExtendGlobalEnv all_tycons $ + tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $ + addFamInsts deriv_ty_insts $ + addInsts deriv_inst_info getGblEnv ; return ( addTcgDUs gbl_env deriv_dus, deriv_inst_info ++ local_info, aux_binds `plusHsValBinds` deriv_binds) @@ -413,18 +414,14 @@ addInsts :: [InstInfo Name] -> TcM a -> TcM a addInsts infos thing_inside = tcExtendLocalInstEnv (map iSpec infos) thing_inside -addFamInsts :: [TyThing] -> TcM a -> TcM a +addFamInsts :: [TyCon] -> TcM a -> TcM a addFamInsts tycons thing_inside - = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside - where - mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon - mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts" - (ppr tything) + = tcExtendLocalFamInstEnv (map mkLocalFamInst tycons) thing_inside \end{code} \begin{code} tcLocalInstDecl1 :: LInstDecl Name - -> TcM (InstInfo Name, [TyThing]) + -> TcM (InstInfo Name, [TyCon]) -- A source-file instance declaration -- Type-check all the stuff before the "where" -- @@ -468,7 +465,7 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) checkValidAndMissingATs :: Class -> ([TyVar], [TcType]) -- instance types -> [(LTyClDecl Name, -- source form of AT - TyThing)] -- Core 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 @@ -486,12 +483,11 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ; mapM_ (checkIndexes clas inst_tys) ats } - checkIndexes clas inst_tys (hsAT, ATyCon tycon) + 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 _ _ _ = panic "checkIndexes" checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys) = let atName = tcdName . unLoc $ hsAT @@ -581,7 +577,7 @@ lot of kinding and type checking code with ordinary algebraic data types (and GADTs). \begin{code} -tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing +tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyCon tcFamInstDecl top_lvl (L loc decl) = -- Prime error recovery, set source location setSrcSpan loc $ @@ -602,7 +598,7 @@ tcFamInstDecl top_lvl (L loc decl) ; when (isTopLevel top_lvl && isAssocFamily tc) (addErr $ assocInClassErr (tcdName decl)) - ; return (ATyCon tc) } + ; return tc } isAssocFamily :: TyCon -> Bool -- Is an assocaited type isAssocFamily tycon @@ -669,7 +665,6 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, -- (2) type check indexed data type declaration ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars - ; unbox_strict <- doptM Opt_UnboxStrictFields -- kind check the type indexes and the context ; t_typats <- mapM tcHsKindedType k_typats @@ -688,7 +683,7 @@ tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, ; let ex_ok = True -- Existentials ok for type families! ; fixM (\ rep_tycon -> do { let orig_res_ty = mkTyConApp fam_tycon t_typats - ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon + ; data_cons <- tcConDecls ex_ok rep_tycon (t_tvs, orig_res_ty) k_cons ; tc_rhs <- case new_or_data of @@ -799,6 +794,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ do { -- Instantiate the instance decl with skolem constants ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id) + -- We instantiate the dfun_id with superSkolems. + -- See Note [Subtle interaction of recursion and overlap] + -- and Note [Binding when looking up instances] ; let (clas, inst_tys) = tcSplitDFunHead inst_head (class_tyvars, sc_theta, _, op_items) = classBigSig clas sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta @@ -877,7 +875,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) listToBag meth_binds) } where - skol_info = InstSkol -- See Note [Subtle interaction of recursion and overlap] + skol_info = InstSkol dfun_ty = idType dfun_id dfun_id = instanceDFunId ispec loc = getSrcSpan dfun_id