diff options
Diffstat (limited to 'compiler/typecheck/TcInstDcls.lhs')
| -rw-r--r-- | compiler/typecheck/TcInstDcls.lhs | 170 |
1 files changed, 102 insertions, 68 deletions
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index f701b30db8..2b123ffab6 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -6,7 +6,8 @@ TcInstDecls: Typechecking instance declarations \begin{code} -{-# OPTIONS -fno-warn-tabs #-} +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -fno-warn-tabs #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and -- detab the module (please do the detabbing in a separate patch). See @@ -37,6 +38,7 @@ import TcDeriv import TcEnv import TcHsType import TcUnify +import Coercion ( pprCoAxiom ) import MkCore ( nO_METHOD_BINDING_ERROR_ID ) import Type import TcEvidence @@ -49,8 +51,8 @@ import VarEnv import VarSet import CoreUnfold ( mkDFunUnfolding ) import CoreSyn ( Expr(Var, Type), CoreExpr, mkTyApps, mkVarApps ) -import PrelNames ( tYPEABLE_INTERNAL, typeableClassName, oldTypeableClassNames ) - +import PrelNames ( tYPEABLE_INTERNAL, typeableClassName, + oldTypeableClassNames, genericClassNames ) import Bag import BasicTypes import DynFlags @@ -68,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 @@ -412,13 +415,17 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls -- hand written instances of old Typeable as then unsafe casts could be -- performed. Derived instances are OK. ; dflags <- getDynFlags - ; when (safeLanguageOn dflags) $ - mapM_ (\x -> when (typInstCheck x) - (addErrAt (getSrcSpan $ iSpec x) typInstErr)) - local_infos + ; when (safeLanguageOn dflags) $ forM_ local_infos $ \x -> case x of + _ | typInstCheck x -> addErrAt (getSrcSpan $ iSpec x) (typInstErr x) + _ | genInstCheck x -> addErrAt (getSrcSpan $ iSpec x) (genInstErr x) + _ -> return () + -- As above but for Safe Inference mode. - ; when (safeInferOn dflags) $ - mapM_ (\x -> when (typInstCheck x) recordUnsafeInfer) local_infos + ; when (safeInferOn dflags) $ forM_ local_infos $ \x -> case x of + _ | typInstCheck x -> recordUnsafeInfer + _ | genInstCheck x -> recordUnsafeInfer + _ | overlapCheck x -> recordUnsafeInfer + _ -> return () ; return ( gbl_env , bagToList deriv_inst_info ++ local_infos @@ -439,8 +446,18 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls else (typeableInsts, i:otherInsts) typInstCheck ty = is_cls_nm (iSpec ty) `elem` oldTypeableClassNames - typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe" - ++ " Haskell! Can only derive them" + typInstErr i = hang (ptext (sLit $ "Typeable instances can only be " + ++ "derived in Safe Haskell.") $+$ + ptext (sLit "Replace the following instance:")) + 2 (pprInstanceHdr (iSpec i)) + + overlapCheck ty = overlapMode (is_flag $ iSpec ty) `elem` + [Overlappable, Overlapping, Overlaps] + genInstCheck ty = is_cls_nm (iSpec ty) `elem` genericClassNames + genInstErr i = hang (ptext (sLit $ "Generic instances can only be " + ++ "derived in Safe Haskell.") $+$ + ptext (sLit "Replace the following instance:")) + 2 (pprInstanceHdr (iSpec i)) instMsg i = hang (ptext (sLit $ "Typeable instances can only be derived; replace " ++ "the following instance:")) @@ -504,6 +521,7 @@ tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl })) tcClsInstDecl :: LClsInstDecl Name -> TcM ([InstInfo Name], [FamInst]) tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds , cid_sigs = uprags, cid_tyfam_insts = ats + , cid_overlap_mode = overlap_mode , cid_datafam_insts = adts })) = setSrcSpan loc $ addErrCtxt (instDeclCtxt1 poly_ty) $ @@ -525,44 +543,20 @@ 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 $ \(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' = varSetElems tv_set' - ; rep_tc_name <- newFamInstTyConName (noLoc (tyConName fam_tc)) pat_tys' - ; let axiom = mkSingleCoAxiom rep_tc_name tvs' fam_tc pat_tys' rhs' - ; 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.) ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty) -- Dfun location is that of instance *header* - ; overlap_flag <- getOverlapFlag + ; overlap_flag <- + do defaultOverlapFlag <- getOverlapFlag + return $ setOverlapModeMaybe defaultOverlapFlag overlap_mode ; (subst, tyvars') <- tcInstSkolTyVars tyvars ; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys ispec = mkLocalInstance dfun overlap_flag tyvars' clas (substTys subst inst_tys) @@ -577,6 +571,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 @@ -625,24 +661,22 @@ 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 - ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) - ; checkTc (isSynTyCon fam_tc) (wrongKindOfFamily fam_tc) - ; checkTc (isOpenSynFamilyTyCon fam_tc) - (notOpenFamily fam_tc) + ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc) + ; checkTc (isSynFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc) + ; 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 } @@ -665,7 +699,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 @@ -680,7 +714,7 @@ tcDataFamInstDecl mb_clsinfo ; checkTc (isLiftedTypeKind res_kind) $ tooFewParmsErr (tyConArity fam_tc) ; stupid_theta <- tcHsContext ctxt - ; h98_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons + ; gadt_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons -- Construct representation tycon ; rep_tc_name <- newFamInstTyConName fam_tc_name pats' @@ -703,7 +737,7 @@ tcDataFamInstDecl mb_clsinfo rep_tc = buildAlgTyCon rep_tc_name tvs' roles cType stupid_theta tc_rhs Recursive False -- No promotable to the kind level - h98_syntax parent + gadt_syntax parent -- We always assume that indexed types are recursive. Why? -- (1) Due to their open nature, we can never be sure that a -- further instance might not introduce a new recursive @@ -888,9 +922,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds }) , abs_ev_vars = dfun_ev_vars , abs_exports = [export] , abs_ev_binds = sc_binds - , abs_binds = unitBag (Generated, dict_bind) } + , abs_binds = unitBag dict_bind } - ; return (unitBag (Generated, L loc main_bind) `unionBags` + ; return (unitBag (L loc main_bind) `unionBags` listToBag meth_binds) } where @@ -1169,7 +1203,7 @@ tcInstanceMethods :: DFunId -> Class -> [TcTyVar] -> ([Located TcSpecPrag], PragFun) -> [(Id, DefMeth)] -> InstBindings Name - -> TcM ([Id], [(Origin, LHsBind Id)]) + -> TcM ([Id], [LHsBind Id]) -- The returned inst_meth_ids all have types starting -- forall tvs. theta => ... tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys @@ -1188,7 +1222,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys set_exts es thing = foldr setXOptM thing es ---------------------- - tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, (Origin, LHsBind Id)) + tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, LHsBind Id) tc_item sig_fn (sel_id, dm_info) = case findMethodBind (idName sel_id) binds of Just (user_bind, bndr_loc) @@ -1197,10 +1231,10 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; tc_default sig_fn sel_id dm_info } ---------------------- - tc_body :: HsSigFun -> Id -> Bool -> (Origin, LHsBind Name) - -> SrcSpan -> TcM (TcId, (Origin, LHsBind Id)) + tc_body :: HsSigFun -> Id -> Bool -> LHsBind Name + -> SrcSpan -> TcM (TcId, LHsBind Id) tc_body sig_fn sel_id generated_code rn_bind bndr_loc - = add_meth_ctxt sel_id generated_code (snd rn_bind) $ + = add_meth_ctxt sel_id generated_code rn_bind $ do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id)) ; (meth_id, local_meth_sig) <- setSrcSpan bndr_loc $ mkMethIds sig_fn clas tyvars dfun_ev_vars @@ -1216,12 +1250,12 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys ; return (meth_id1, bind) } ---------------------- - tc_default :: HsSigFun -> Id -> DefMeth -> TcM (TcId, (Origin, LHsBind Id)) + tc_default :: HsSigFun -> Id -> DefMeth -> TcM (TcId, LHsBind Id) tc_default sig_fn sel_id (GenDefMeth dm_name) = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name ; tc_body sig_fn sel_id False {- Not generated code? -} - (Generated, meth_bind) inst_loc } + meth_bind inst_loc } tc_default sig_fn sel_id NoDefMeth -- No default method at all = do { traceTc "tc_def: warn" (ppr sel_id) @@ -1229,8 +1263,8 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys inst_tys sel_id ; dflags <- getDynFlags ; return (meth_id, - (Generated, mkVarBind meth_id $ - mkLHsWrap lam_wrapper (error_rhs dflags))) } + mkVarBind meth_id $ + mkLHsWrap lam_wrapper (error_rhs dflags)) } where error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags) error_fun = L inst_loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID @@ -1272,13 +1306,13 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars , abs_exports = [export] , abs_ev_binds = EvBinds (unitBag self_ev_bind) - , abs_binds = unitBag (Generated, meth_bind) } + , abs_binds = unitBag meth_bind } -- Default methods in an instance declaration can't have their own -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but -- currently they are rejected with -- "INLINE pragma lacks an accompanying binding" - ; return (meth_id1, (Generated, L inst_loc bind)) } + ; return (meth_id1, L inst_loc bind) } ---------------------- mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags @@ -1329,7 +1363,7 @@ mkGenericDefMethBind clas inst_tys sel_id dm_name (vcat [ppr clas <+> ppr inst_tys, nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) - ; return (noLoc $ mkTopFunBind (noLoc (idName sel_id)) + ; return (noLoc $ mkTopFunBind Generated (noLoc (idName sel_id)) [mkSimpleMatch [] rhs]) } where rhs = nlHsVar dm_name |