diff options
Diffstat (limited to 'compiler/typecheck/TcInstDcls.lhs')
| -rw-r--r-- | compiler/typecheck/TcInstDcls.lhs | 93 |
1 files changed, 53 insertions, 40 deletions
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index ed682df1b4..c3ba825cd5 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -38,7 +38,7 @@ import TcDeriv import TcEnv import TcHsType import TcUnify -import Coercion ( pprCoAxiom, pprCoAxBranch ) +import Coercion ( pprCoAxiom ) import MkCore ( nO_METHOD_BINDING_ERROR_ID ) import Type import TcEvidence @@ -70,6 +70,7 @@ import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice ) import Control.Monad import Maybes ( isNothing, isJust, whenIsJust ) +import Data.List ( mapAccumL ) \end{code} Typechecking instance declarations is done in two passes. The first @@ -528,40 +529,11 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds -- Check for missing associated types and build them -- from their defaults (if available) - ; let defined_ats = mkNameSet $ map (tyFamInstDeclName . unLoc) ats - defined_adts = mkNameSet $ map (unLoc . dfid_tycon . unLoc) adts - - mk_deflt_at_instances :: ClassATItem -> TcM [FamInst] - mk_deflt_at_instances (fam_tc, defs) - -- User supplied instances ==> everything is OK - | tyConName fam_tc `elemNameSet` defined_ats - || tyConName fam_tc `elemNameSet` defined_adts - = return [] - - -- No defaults ==> generate a warning - | null defs - = do { warnMissingMethodOrAT "associated type" (tyConName fam_tc) - ; return [] } - - -- No user instance, have defaults ==> instatiate them - -- 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 $ \br@(CoAxBranch { cab_lhs = pat_tys, cab_rhs = rhs }) -> - do { let pat_tys' = substTys mini_subst pat_tys - rhs' = substTy mini_subst rhs - tv_set' = tyVarsOfTypes pat_tys' - tvs' = varSetElemsKvsFirst tv_set' - ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys' - ; let axiom = mkSingleCoAxiom rep_tc_name tvs' fam_tc pat_tys' rhs' - ; traceTc "mk_deflt_at_instance" (vcat [ ppr (tyvars, theta, clas, inst_tys) - , pprCoAxBranch fam_tc br - , pprCoAxiom axiom ]) - ; ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) - newFamInst SynFamilyInst axiom } - - ; tyfam_insts1 <- mapM mk_deflt_at_instances (classATItems clas) + ; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats) + `unionNameSets` + mkNameSet (map (unLoc . dfid_tycon . unLoc) adts) + ; tyfam_insts1 <- mapM (tcATDefault mini_subst defined_ats) + (classATItems clas) -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.) @@ -585,6 +557,48 @@ tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts) } + +tcATDefault :: TvSubst -> NameSet -> ClassATItem -> TcM [FamInst] +-- ^ Construct default instances for any associated types that +-- aren't given a user definition +-- Returns [] or singleton +tcATDefault inst_subst defined_ats (ATI fam_tc defs) + -- User supplied instances ==> everything is OK + | tyConName fam_tc `elemNameSet` defined_ats + = return [] + + -- No user instance, have defaults ==> instatiate them + -- 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 + = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst + (tyConTyVars fam_tc) + rhs' = substTy subst' rhs_ty + tv_set' = tyVarsOfTypes pat_tys' + tvs' = varSetElemsKvsFirst tv_set' + ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys' + ; let axiom = mkSingleCoAxiom rep_tc_name tvs' fam_tc pat_tys' rhs' + ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty + , pprCoAxiom axiom ]) + ; fam_inst <- ASSERT( tyVarsOfType rhs' `subVarSet` tv_set' ) + newFamInst SynFamilyInst axiom + ; return [fam_inst] } + + -- No defaults ==> generate a warning + | otherwise -- defs = Nothing + = do { warnMissingMethodOrAT "associated type" (tyConName fam_tc) + ; return [] } + where + subst_tv subst tc_tv + | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv + = (subst, ty) + | otherwise + = (extendTvSubst subst tc_tv ty', ty') + where + ty' = mkTyVarTy (updateTyVarKind (substTy subst) tc_tv) + + -------------- tcAssocTyDecl :: Class -- Class of associated type -> VarEnv Type -- Instantiation of class TyVars @@ -633,7 +647,7 @@ tcTyFamInstDecl :: Maybe (Class, VarEnv Type) -- the class & mini_env if applica tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) = setSrcSpan loc $ tcAddTyFamInstCtxt decl $ - do { let fam_lname = tfie_tycon (unLoc eqn) + do { let fam_lname = tfe_tycon (unLoc eqn) ; fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_lname -- (0) Check it's an open type family @@ -642,14 +656,13 @@ tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn })) ; checkTc (isOpenSynFamilyTyCon fam_tc) (notOpenFamily fam_tc) -- (1) do the work of verifying the synonym group - ; co_ax_branch <- tcSynFamInstDecl fam_tc decl + ; co_ax_branch <- tcTyFamInstEqn (famTyConShape fam_tc) eqn -- (2) check for validity ; checkValidTyFamInst mb_clsinfo fam_tc co_ax_branch -- (3) construct coercion axiom - ; rep_tc_name <- newFamInstAxiomName loc - (tyFamInstDeclName decl) + ; rep_tc_name <- newFamInstAxiomName loc (unLoc fam_lname) [co_ax_branch] ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch ; newFamInst SynFamilyInst axiom } @@ -672,7 +685,7 @@ tcDataFamInstDecl mb_clsinfo ; checkTc (isAlgTyCon fam_tc) (wrongKindOfFamily fam_tc) -- Kind check type patterns - ; tcFamTyPats (unLoc fam_tc_name) (tyConKind fam_tc) pats + ; tcFamTyPats (famTyConShape fam_tc) pats (kcDataDefn defn) $ \tvs' pats' res_kind -> do |