X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=21c89287bb7fbf470dc410a0bcb919db67e4b332;hp=880a0eee075d212d4b59bb2128886cf164de8c48;hb=5822cb8d13aa3c05d2b46b4510c13d94b902eb21;hpb=e6d057711f4d6d6ff6342c39fa2b9e44d25447f1 diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 880a0ee..21c8928 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -1,7 +1,9 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[TcInstDecls]{Typechecking instance declarations} + +TcInstDecls: Typechecking instance declarations \begin{code} module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where @@ -9,56 +11,44 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where #include "HsVersions.h" import HsSyn -import TcBinds ( mkPragFun, tcPrags, badBootDeclErr ) -import TcTyClsDecls ( tcIdxTyInstDecl ) -import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr, badATErr, - omittedATWarn, tcClassDecl2, getGenericInstances ) +import TcBinds +import TcTyClsDecls +import TcClassDcl import TcRnMonad -import TcMType ( tcSkolSigType, checkValidInstance, - checkValidInstHead ) -import TcType ( TcType, mkClassPred, tcSplitSigmaTy, - tcSplitDFunHead, SkolemInfo(InstSkol), - tcSplitTyConApp, - tcSplitDFunTy, mkFunTy ) -import Inst ( newDictBndr, newDictBndrs, instToId, showLIE, - getOverlapFlag, tcExtendLocalInstEnv ) -import InstEnv ( mkLocalInstance, instanceDFunId ) -import FamInst ( tcExtendLocalFamInstEnv ) -import FamInstEnv ( extractFamInsts ) -import TcDeriv ( tcDeriving ) -import TcEnv ( InstInfo(..), InstBindings(..), - newDFunName, tcExtendIdEnv, tcExtendGlobalEnv - ) -import TcHsType ( kcHsSigType, tcHsKindedType ) -import TcUnify ( checkSigTyVars ) -import TcSimplify ( tcSimplifySuperClasses ) -import Type ( zipOpenTvSubst, substTheta, mkTyConApp, mkTyVarTy, - TyThing(ATyCon), isTyVarTy, tcEqType, - substTys, emptyTvSubst, extendTvSubst ) -import Coercion ( mkSymCoercion ) -import TyCon ( TyCon, tyConName, newTyConCo_maybe, tyConTyVars, - isTyConAssoc, tyConFamInst_maybe, tyConDataCons, - assocTyConArgPoss_maybe ) -import DataCon ( classDataCon, dataConInstArgTys ) -import Class ( Class, classTyCon, classBigSig, classATs ) -import Var ( TyVar, Id, idName, idType, tyVarName ) -import MkId ( mkDictFunId ) -import Name ( Name, getSrcLoc, nameOccName ) -import NameSet ( addListToNameSet, emptyNameSet, minusNameSet, - nameSetToList ) -import Maybe ( fromJust, catMaybes ) -import Monad ( when ) -import List ( find ) -import DynFlags ( DynFlag(Opt_WarnMissingMethods) ) -import SrcLoc ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart, - getLoc) -import ListSetOps ( minusList ) -import Util ( snocView, dropList ) +import TcMType +import TcType +import Inst +import InstEnv +import FamInst +import FamInstEnv +import TcDeriv +import TcEnv +import TcHsType +import TcUnify +import TcSimplify +import Type +import Coercion +import TyCon +import TypeRep +import DataCon +import Class +import Var +import MkId +import Name +import NameSet +import DynFlags +import SrcLoc +import ListSetOps +import Util import Outputable import Bag -import BasicTypes ( Activation( AlwaysActive ), InlineSpec(..) ) -import HscTypes ( implicitTyThings ) +import BasicTypes +import HscTypes import FastString + +import Data.Maybe +import Control.Monad hiding (zipWithM_, mapAndUnzipM) +import Data.List \end{code} Typechecking instance declarations is done in two passes. The first @@ -146,20 +136,20 @@ Gather up the instance declarations from their various sources tcInstDecls1 -- Deal with both source-code and imported instance decls :: [LTyClDecl Name] -- For deriving stuff -> [LInstDecl Name] -- Source code instance decls + -> [LDerivDecl Name] -- Source code stand-alone deriving decls -> TcM (TcGblEnv, -- The full inst env [InstInfo], -- Source-code instance decls to process; -- contains all dfuns for this module HsValBinds Name) -- Supporting bindings for derived instances -tcInstDecls1 tycl_decls inst_decls +tcInstDecls1 tycl_decls inst_decls deriv_decls = checkNoErrs $ do { -- Stop if addInstInfos etc discovers any errors -- (they recover, so that we get more than one error each -- round) - -- (1) Do class instance declarations and instances of indexed - -- types - ; let { idxty_decls = filter (isIdxTyDecl . unLoc) tycl_decls } + -- (1) Do class and family instance declarations + ; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls } ; local_info_tycons <- mappM tcLocalInstDecl1 inst_decls ; idx_tycons <- mappM tcIdxTyInstDeclTL idxty_decls @@ -190,7 +180,10 @@ tcInstDecls1 tycl_decls inst_decls -- (4) Compute instances from "deriving" clauses; -- This stuff computes a context for the derived instance -- decl, so it needs to know about all the instances possible - ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls + -- NB: class instance declarations can contain derivings as + -- part of associated data type declarations + ; (deriv_inst_info, deriv_binds) <- tcDeriving tycl_decls inst_decls + deriv_decls ; addInsts deriv_inst_info $ do { ; gbl_env <- getGblEnv @@ -203,7 +196,7 @@ tcInstDecls1 tycl_decls inst_decls -- !!!TODO: Need to perform this check for the TyThing of type functions, -- too. tcIdxTyInstDeclTL ldecl@(L loc decl) = - do { tything <- tcIdxTyInstDecl ldecl + do { tything <- tcFamInstDecl ldecl ; setSrcSpan loc $ when (isAssocFamily tything) $ addErr $ assocInClassErr (tcdName decl) @@ -226,8 +219,12 @@ addInsts infos thing_inside addFamInsts :: [TyThing] -> TcM a -> TcM a addFamInsts tycons thing_inside - = tcExtendLocalFamInstEnv (extractFamInsts tycons) thing_inside -\end{code} + = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside + where + mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon + mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts" + (ppr tything) +\end{code} \begin{code} tcLocalInstDecl1 :: LInstDecl Name @@ -246,14 +243,10 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags)) badBootDeclErr - -- Typecheck the instance type itself. We can't use - -- tcHsSigType, because it's not a valid user type. - ; kinded_ty <- kcHsSigType poly_ty - ; poly_ty' <- tcHsKindedType kinded_ty - ; let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty' + ; (tyvars, theta, tau) <- tcHsInstHead poly_ty -- Next, process any associated types. - ; idx_tycons <- mappM tcIdxTyInstDecl ats + ; idx_tycons <- mappM tcFamInstDecl ats -- Now, check the validity of the instance. ; (clas, inst_tys) <- checkValidInstHead tau @@ -263,9 +256,11 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) -- Finally, construct the Core representation of the instance. -- (This no longer includes the associated types.) - ; dfun_name <- newDFunName clas inst_tys (srcSpanStart loc) + ; dfun_name <- newDFunName clas inst_tys loc ; overlap_flag <- getOverlapFlag - ; let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys + ; let (eq_theta,dict_theta) = partition isEqPred theta + theta' = eq_theta ++ dict_theta + dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys ispec = mkLocalInstance dfun overlap_flag ; return ([InstInfo { iSpec = ispec, @@ -284,11 +279,11 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats)) checkValidAndMissingATs clas inst_tys ats = do { -- Issue a warning for each class AT that is not defined in this -- instance. - ; let classDefATs = listToNameSet . map tyConName . classATs $ clas - definedATs = listToNameSet . map (tcdName.unLoc.fst) $ ats - omitted = classDefATs `minusNameSet` definedATs + ; let class_ats = map tyConName (classATs clas) + defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats + omitted = filterOut (`elemNameSet` defined_ats) class_ats ; warn <- doptM Opt_WarnMissingMethods - ; mapM_ (warnTc warn . omittedATWarn) (nameSetToList omitted) + ; mapM_ (warnTc warn . omittedATWarn) omitted -- Ensure that all AT indexes that correspond to class parameters -- coincide with the types in the instance head. All remaining @@ -489,7 +484,7 @@ tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id) tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds }) = do { let dfun_id = instanceDFunId ispec - rigid_info = InstSkol dfun_id + rigid_info = InstSkol origin = SigOrigin rigid_info inst_ty = idType dfun_id ; (tvs, theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty @@ -524,7 +519,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds }) make_wrapper inst_loc tvs theta (Just preds) -- Case (a) = ASSERT( null tvs && null theta ) do { dicts <- newDictBndrs inst_loc preds - ; sc_binds <- addErrCtxt superClassCtxt (tcSimplifySuperClasses [] [] dicts) + ; sc_binds <- addErrCtxt superClassCtxt $ + tcSimplifySuperClasses inst_loc [] dicts -- Use tcSimplifySuperClasses to avoid creating loops, for the -- same reason as Note [SUPERCLASS-LOOP 1] in TcSimplify ; return (map instToId dicts, idHsWrapper, sc_binds) } @@ -590,12 +586,13 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = NewTypeDerived mb_preds }) tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) = let dfun_id = instanceDFunId ispec - rigid_info = InstSkol dfun_id + rigid_info = InstSkol inst_ty = idType dfun_id + loc = srcLocSpan (getSrcLoc dfun_id) in -- Prime error recovery recoverM (returnM emptyLHsBinds) $ - setSrcSpan (srcLocSpan (getSrcLoc dfun_id)) $ + setSrcSpan loc $ addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ -- Instantiate the instance decl with skolem constants @@ -609,20 +606,30 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) -- Instantiate the super-class context with inst_tys sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta + (eq_sc_theta',dict_sc_theta') = partition isEqPred sc_theta' origin = SigOrigin rigid_info + (eq_dfun_theta',dict_dfun_theta') = partition isEqPred dfun_theta' in -- Create dictionary Ids from the specified instance contexts. getInstLoc InstScOrigin `thenM` \ sc_loc -> - newDictBndrs sc_loc sc_theta' `thenM` \ sc_dicts -> + newDictBndrs sc_loc dict_sc_theta' `thenM` \ sc_dicts -> getInstLoc origin `thenM` \ inst_loc -> - newDictBndrs inst_loc dfun_theta' `thenM` \ dfun_arg_dicts -> - newDictBndr inst_loc (mkClassPred clas inst_tys') `thenM` \ this_dict -> + mkMetaCoVars eq_sc_theta' `thenM` \ sc_covars -> + mkEqInsts eq_sc_theta' (map mkWantedCo sc_covars) `thenM` \ wanted_sc_eqs -> + mkCoVars eq_dfun_theta' `thenM` \ dfun_covars -> + mkEqInsts eq_dfun_theta' (map mkGivenCo $ mkTyVarTys dfun_covars) `thenM` \ dfun_eqs -> + newDictBndrs inst_loc dict_dfun_theta' `thenM` \ dfun_dicts -> + newDictBndr inst_loc (mkClassPred clas inst_tys') `thenM` \ this_dict -> -- Default-method Ids may be mentioned in synthesised RHSs, -- but they'll already be in the environment. -- Typecheck the methods let -- These insts are in scope; quite a few, eh? - avail_insts = [this_dict] ++ dfun_arg_dicts ++ sc_dicts + dfun_insts = dfun_eqs ++ dfun_dicts + wanted_sc_insts = wanted_sc_eqs ++ sc_dicts + given_sc_eqs = map (updateEqInstCoercion (mkGivenCo . TyVarTy . fromWantedCo "tcInstDecl2") ) wanted_sc_eqs + given_sc_insts = given_sc_eqs ++ sc_dicts + avail_insts = [this_dict] ++ dfun_insts ++ given_sc_insts in tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' avail_insts @@ -630,11 +637,10 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) -- Figure out bindings for the superclass context -- Don't include this_dict in the 'givens', else - -- sc_dicts get bound by just selecting from this_dict!! + -- wanted_sc_insts get bound by just selecting from this_dict!! addErrCtxt superClassCtxt - (tcSimplifySuperClasses inst_tyvars' - dfun_arg_dicts - sc_dicts) `thenM` \ sc_binds -> + (tcSimplifySuperClasses inst_loc + dfun_insts wanted_sc_insts) `thenM` \ sc_binds -> -- It's possible that the superclass stuff might unified one -- of the inst_tyavars' with something in the envt @@ -648,8 +654,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) dict_constr = classDataCon clas scs_and_meths = map instToId sc_dicts ++ meth_ids this_dict_id = instToId this_dict - inline_prag | null dfun_arg_dicts = [] - | otherwise = [InlinePrag (Inline AlwaysActive True)] + inline_prag | null dfun_insts = [] + | otherwise = [L loc (InlinePrag (Inline AlwaysActive True))] -- Always inline the dfun; this is an experimental decision -- because it makes a big performance difference sometimes. -- Often it means we can do the method selection, and then @@ -662,7 +668,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) -- See Note [Inline dfuns] below dict_rhs - = mkHsConApp dict_constr inst_tys' (map HsVar scs_and_meths) + = mkHsConApp dict_constr (inst_tys' ++ mkTyVarTys sc_covars) (map HsVar scs_and_meths) -- We don't produce a binding for the dict_constr; instead we -- rely on the simplifier to unfold this saturated application -- We do this rather than generate an HsCon directly, because @@ -674,15 +680,32 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags }) all_binds = dict_bind `consBag` (sc_binds `unionBags` meth_binds) main_bind = noLoc $ AbsBinds - inst_tyvars' - (map instToId dfun_arg_dicts) - [(inst_tyvars', dfun_id, this_dict_id, - inline_prag ++ prags)] + (inst_tyvars' ++ dfun_covars) + (map instToId dfun_dicts) + [(inst_tyvars' ++ dfun_covars, dfun_id, this_dict_id, inline_prag ++ prags)] all_binds in showLIE (text "instance") `thenM_` returnM (unitBag main_bind) +mkCoVars :: [PredType] -> TcM [TyVar] +mkCoVars [] = return [] +mkCoVars (pred:preds) = + do { uniq <- newUnique + ; let name = mkSysTvName uniq FSLIT("mkCoVars") + ; let tv = mkCoVar name (PredTy pred) + ; tvs <- mkCoVars preds + ; return (tv:tvs) + } + +mkMetaCoVars :: [PredType] -> TcM [TyVar] +mkMetaCoVars [] = return [] +mkMetaCoVars (EqPred ty1 ty2:preds) = + do { tv <- newMetaTyVar TauTv (mkCoKind ty1 ty2) + ; tvs <- mkMetaCoVars preds + ; return (tv:tvs) + } + tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' avail_insts op_items monobinds uprags