X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=6fdc327be604081be7b164261f03bae470840722;hb=dd313897eb9a14bcc7b81f97e4f2292c30039efd;hp=ff97a4bd6e07216d2b6ff39a182f5679857b610f;hpb=04612d54b51bebf809717d1cf0242efb6294ee59;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index ff97a4b..6fdc327 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -18,7 +18,9 @@ import TcMType ( tcSkolSigType, checkValidTheta, checkValidInstHead, instTypeEr import TcType ( mkClassPred, tyVarsOfType, tcSplitSigmaTy, tcSplitDFunHead, mkTyVarTys, SkolemInfo(InstSkol), tcSplitDFunTy, pprClassPred ) -import Inst ( tcInstClassOp, newDicts, instToId, showLIE, tcExtendLocalInstEnv ) +import Inst ( tcInstClassOp, newDicts, instToId, showLIE, + getOverlapFlag, tcExtendLocalInstEnv ) +import InstEnv ( mkLocalInstance, instanceDFunId ) import TcDeriv ( tcDeriving ) import TcEnv ( tcExtendGlobalValEnv, tcExtendTyVarEnv, InstInfo(..), InstBindings(..), @@ -26,7 +28,7 @@ import TcEnv ( tcExtendGlobalValEnv, tcExtendTyVarEnv, ) import TcHsType ( kcHsSigType, tcHsKindedType ) import TcUnify ( checkSigTyVars ) -import TcSimplify ( tcSimplifyCheck, tcSimplifyTop ) +import TcSimplify ( tcSimplifyCheck, tcSimplifySuperClasses ) import Type ( zipOpenTvSubst, substTheta, substTys ) import DataCon ( classDataCon ) import Class ( classBigSig ) @@ -148,7 +150,7 @@ tcInstDecls1 tycl_decls inst_decls clas_decls = filter (isClassDecl.unLoc) tycl_decls in -- (2) Instances from generic class declarations - getGenericInstances clas_decls `thenM` \ generic_inst_info -> + getGenericInstances clas_decls `thenM` \ generic_inst_info -> -- Next, construct the instance environment so far, consisting of -- a) local instance decls @@ -169,7 +171,7 @@ tcInstDecls1 tycl_decls inst_decls addInsts :: [InstInfo] -> TcM a -> TcM a addInsts infos thing_inside - = tcExtendLocalInstEnv (map iDFunId infos) thing_inside + = tcExtendLocalInstEnv (map iSpec infos) thing_inside \end{code} \begin{code} @@ -202,8 +204,11 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags)) checkTc (checkInstFDs theta clas inst_tys) (instTypeErr (pprClassPred clas inst_tys) msg) `thenM_` newDFunName clas inst_tys (srcSpanStart loc) `thenM` \ dfun_name -> - returnM (Just (InstInfo { iDFunId = mkDictFunId dfun_name tyvars theta clas inst_tys, - iBinds = VanillaInst binds uprags })) + getOverlapFlag `thenM` \ overlap_flag -> + let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys + ispec = mkLocalInstance dfun overlap_flag + in + returnM (Just (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags })) where msg = parens (ptext SLIT("the instance types do not agree with the functional dependencies of the class")) \end{code} @@ -308,17 +313,18 @@ First comes the easy case of a non-local instance decl. \begin{code} tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id) -tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) - = -- Prime error recovery +tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds }) + = let + dfun_id = instanceDFunId ispec + rigid_info = InstSkol dfun_id + inst_ty = idType dfun_id + in + -- Prime error recovery recoverM (returnM emptyLHsBinds) $ setSrcSpan (srcLocSpan (getSrcLoc dfun_id)) $ addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ -- Instantiate the instance decl with skolem constants - let - rigid_info = InstSkol dfun_id - inst_ty = idType dfun_id - in tcSkolSigType rigid_info inst_ty `thenM` \ (inst_tyvars', dfun_theta', inst_head') -> -- These inst_tyvars' scope over the 'where' part -- Those tyvars are inside the dfun_id's type, which is a bit @@ -338,7 +344,6 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) -- 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 @@ -348,10 +353,15 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) op_items binds `thenM` \ (meth_ids, meth_binds) -> -- Figure out bindings for the superclass context - tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts - `thenM` \ (sc_binds_inner, sc_binds_outer) -> - - -- It's possible that the superclass stuff might have done unification + -- Don't include this_dict in the 'givens', else + -- sc_dicts get bound by just selecting from this_dict!! + addErrCtxt superClassCtxt + (tcSimplifySuperClasses inst_tyvars' + dfun_arg_dicts + sc_dicts) `thenM` \ sc_binds -> + + -- It's possible that the superclass stuff might unified one + -- of the inst_tyavars' with something in the envt checkSigTyVars inst_tyvars' `thenM_` -- Deal with 'SPECIALISE instance' pragmas by making them @@ -411,7 +421,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) msg = "Compiler error: bad dictionary " ++ showSDoc (ppr clas) dict_bind = noLoc (VarBind this_dict_id dict_rhs) - all_binds = dict_bind `consBag` (sc_binds_inner `unionBags` meth_binds) + all_binds = dict_bind `consBag` (sc_binds `unionBags` meth_binds) main_bind = noLoc $ AbsBinds inst_tyvars' @@ -421,8 +431,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) in showLIE (text "instance") `thenM_` returnM (unitBag main_bind `unionBags` - prag_binds `unionBags` - sc_binds_outer) + prag_binds ) tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' @@ -515,65 +524,6 @@ tcMethods origin clas inst_tyvars' dfun_theta' inst_tys' subst = zipOpenTvSubst inst_tyvars' (mkTyVarTys inst_tyvars') \end{code} -Note: [Superclass loops] -~~~~~~~~~~~~~~~~~~~~~~~~~ -We have to be very, very careful when generating superclasses, lest we -accidentally build a loop. Here's an example: - - class S a - - class S a => C a where { opc :: a -> a } - class S b => D b where { opd :: b -> b } - - instance C Int where - opc = opd - - instance D Int where - opd = opc - -From (instance C Int) we get the constraint set {ds1:S Int, dd:D Int} -Simplifying, we may well get: - $dfCInt = :C ds1 (opd dd) - dd = $dfDInt - ds1 = $p1 dd -Notice that we spot that we can extract ds1 from dd. - -Alas! Alack! We can do the same for (instance D Int): - - $dfDInt = :D ds2 (opc dc) - dc = $dfCInt - ds2 = $p1 dc - -And now we've defined the superclass in terms of itself. - - -Solution: treat the superclass context separately, and simplify it -all the way down to nothing on its own. Don't toss any 'free' parts -out to be simplified together with other bits of context. -Hence the tcSimplifyTop below. - -At a more basic level, don't include this_dict in the context wrt -which we simplify sc_dicts, else sc_dicts get bound by just selecting -from this_dict!! - -\begin{code} -tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts - = addErrCtxt superClassCtxt $ - getLIE (tcSimplifyCheck doc inst_tyvars' - dfun_arg_dicts - sc_dicts) `thenM` \ (sc_binds1, sc_lie) -> - - -- We must simplify this all the way down - -- lest we build superclass loops - -- See Note [Superclass loops] above - tcSimplifyTop sc_lie `thenM` \ sc_binds2 -> - - returnM (sc_binds1, sc_binds2) - - where - doc = ptext SLIT("instance declaration superclass context") -\end{code} - ------------------------------ [Inline dfuns] Inlining dfuns unconditionally