X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=ebe4b26d46c7140b908c7af464663f10f1b2034e;hb=13878c136b4e6b676dbc859f378809676f4d679c;hp=21ed1d5cbc3c29fbaa09775ff79c88f23df11436;hpb=b27560c4649d7025456fb9936d5a5cdd1e5dc383;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 21ed1d5..ebe4b26 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -12,47 +12,46 @@ module TcInstDcls ( tcInstDecls1, tcIfaceInstDecls1, addInstDFuns, import CmdLineOpts ( DynFlag(..) ) -import HsSyn ( HsDecl(..), InstDecl(..), TyClDecl(..), HsType(..), +import HsSyn ( InstDecl(..), TyClDecl(..), HsType(..), MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), HsTyVarBndr(..), andMonoBindList, collectMonoBinders, isClassDecl, toHsType ) -import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl, +import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedMonoBinds, RenamedTyClDecl, RenamedHsType, extractHsTyVars, maybeGenericMatch ) import TcHsSyn ( TcMonoBinds, mkHsConApp ) import TcBinds ( tcSpecSigs ) -import TcClassDcl ( tcMethodBind, badMethodErr ) +import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr ) import TcMonad -import TcMType ( tcInstSigType, checkValidTheta, checkValidInstHead, instTypeErr, +import TcMType ( tcInstType, checkValidTheta, checkValidInstHead, instTypeErr, UserTypeCtxt(..), SourceTyCtxt(..) ) -import TcType ( mkClassPred, mkTyVarTy, mkTyVarTys, tcSplitForAllTys, +import TcType ( mkClassPred, mkTyVarTy, tcSplitForAllTys, tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, TyVarDetails(..) ) import Inst ( InstOrigin(..), newDicts, instToId, LIE, mkLIE, emptyLIE, plusLIE, plusLIEs ) import TcDeriv ( tcDeriving ) -import TcEnv ( TcEnv, tcExtendGlobalValEnv, isLocalThing, - tcExtendTyVarEnvForMeths, tcLookupId, tcLookupClass, +import TcEnv ( tcExtendGlobalValEnv, tcExtendLocalValEnv2, + tcLookupId, tcLookupClass, tcExtendTyVarEnv2, InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy, newDFunName ) import InstEnv ( InstEnv, extendInstEnv ) import PprType ( pprClassPred ) -import TcMonoType ( tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType ) +import TcMonoType ( tcSigPolyId, tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType ) import TcUnify ( checkSigTyVars ) -import TcSimplify ( tcSimplifyCheck ) -import HscTypes ( HomeSymbolTable, DFunId, +import TcSimplify ( tcSimplifyCheck, tcSimplifyTop ) +import HscTypes ( HomeSymbolTable, DFunId, FixityEnv, PersistentCompilerState(..), PersistentRenamerState, - ModDetails(..), PackageInstEnv + ModDetails(..) ) -import Subst ( substTy, substTheta ) +import Subst ( mkTyVarSubst, substTheta ) import DataCon ( classDataCon ) import Class ( Class, classBigSig ) import Var ( idName, idType ) -import VarSet ( emptyVarSet ) import Id ( setIdLocalExported ) import MkId ( mkDictFunId, unsafeCoerceId, eRROR_ID ) import FunDeps ( checkInstFDs ) @@ -61,19 +60,16 @@ import Module ( Module, foldModuleEnv ) import Name ( getSrcLoc ) import NameSet ( unitNameSet, emptyNameSet, nameSetToList ) import TyCon ( TyCon ) -import Subst ( mkTopTyVarSubst, substTheta ) import TysWiredIn ( genericTyCons ) -import Name ( Name ) import SrcLoc ( SrcLoc ) import Unique ( Uniquable(..) ) import Util ( lengthExceeds, isSingleton ) -import BasicTypes ( NewOrData(..), Fixity ) +import BasicTypes ( NewOrData(..) ) import ErrUtils ( dumpIfSet_dyn ) import ListSetOps ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc, assocElts, extendAssoc_C, equivClassesByUniq, minusList ) import Maybe ( catMaybes ) -import List ( partition ) import Outputable \end{code} @@ -163,7 +159,7 @@ Gather up the instance declarations from their various sources tcInstDecls1 -- Deal with source-code instance decls :: PersistentRenamerState -> InstEnv -- Imported instance envt - -> (Name -> Maybe Fixity) -- for deriving Show and Read + -> FixityEnv -- for deriving Show and Read -> Module -- Module for deriving -> [RenamedTyClDecl] -- For deriving stuff -> [RenamedInstDecl] -- Source code instance decls @@ -515,7 +511,7 @@ First comes the easy case of a non-local instance decl. tcInstDecl2 :: InstInfo -> TcM (LIE, TcMonoBinds) tcInstDecl2 (NewTypeDerived { iDFunId = dfun_id }) - = tcInstSigType InstTv (idType dfun_id) `thenNF_Tc` \ (inst_tyvars', dfun_theta', inst_head') -> + = tcInstType InstTv (idType dfun_id) `thenNF_Tc` \ (inst_tyvars', dfun_theta', inst_head') -> newDicts InstanceDeclOrigin dfun_theta' `thenNF_Tc` \ rep_dicts -> let rep_dict_id = ASSERT( isSingleton rep_dicts ) @@ -537,87 +533,63 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = monobinds, iPrags = uprags } recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $ tcAddSrcLoc (getSrcLoc dfun_id) $ tcAddErrCtxt (instDeclCtxt (toHsType (idType dfun_id))) $ + let + inst_ty = idType dfun_id + (inst_tyvars, _) = tcSplitForAllTys inst_ty + -- The tyvars of the instance decl scope over the 'where' part + -- Those tyvars are inside the dfun_id's type, which is a bit + -- bizarre, but OK so long as you realise it! + in -- Instantiate the instance decl with tc-style type variables - tcInstSigType InstTv (idType dfun_id) `thenNF_Tc` \ (inst_tyvars', dfun_theta', inst_head') -> + tcInstType InstTv inst_ty `thenNF_Tc` \ (inst_tyvars', dfun_theta', inst_head') -> let Just pred = tcSplitPredTy_maybe inst_head' (clas, inst_tys') = getClassPredTys pred (class_tyvars, sc_theta, _, op_items) = classBigSig clas - sel_names = [idName sel_id | (sel_id, _) <- op_items] - -- Instantiate the super-class context with inst_tys - sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys') sc_theta - - -- Find any definitions in monobinds that aren't from the class - bad_bndrs = collectMonoBinders monobinds `minusList` sel_names - (inst_tyvars, _) = tcSplitForAllTys (idType dfun_id) - origin = InstanceDeclOrigin + sc_theta' = substTheta (mkTyVarSubst class_tyvars inst_tys') sc_theta + origin = InstanceDeclOrigin in - -- Check that all the method bindings come from this class - mapTc (addErrTc . badMethodErr clas) bad_bndrs `thenNF_Tc_` - -- Create dictionary Ids from the specified instance contexts. - newDicts origin sc_theta' `thenNF_Tc` \ sc_dicts -> - newDicts origin dfun_theta' `thenNF_Tc` \ dfun_arg_dicts -> - newDicts origin [mkClassPred clas inst_tys'] `thenNF_Tc` \ [this_dict] -> - - tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' ( - -- The type variable from the dict fun actually scope - -- over the bindings. They were gotten from - -- the original instance declaration - + newDicts origin sc_theta' `thenNF_Tc` \ sc_dicts -> + newDicts origin dfun_theta' `thenNF_Tc` \ dfun_arg_dicts -> + newDicts origin [pred] `thenNF_Tc` \ [this_dict] -> -- Default-method Ids may be mentioned in synthesised RHSs, -- but they'll already be in the environment. - mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys' - dfun_theta' - monobinds uprags True) - op_items - ) `thenTc` \ (method_binds_s, insts_needed_s, meth_insts) -> + -- Check that all the method bindings come from this class + mkMethodBinds clas inst_tys' op_items monobinds `thenTc` \ (meth_insts, meth_infos) -> + + let -- These insts are in scope; quite a few, eh? + avail_insts = [this_dict] ++ dfun_arg_dicts ++ + sc_dicts ++ meth_insts + + xtve = inst_tyvars `zip` inst_tyvars' + tc_meth = tcMethodBind xtve inst_tyvars' dfun_theta' avail_insts + in + mapAndUnzipTc tc_meth meth_infos `thenTc` \ (meth_binds_s, meth_lie_s) -> + + -- Figure out bindings for the superclass context + tcSuperClasses inst_tyvars' dfun_arg_dicts sc_dicts + `thenTc` \ (zonked_inst_tyvars, sc_binds_inner, sc_binds_outer) -> -- Deal with SPECIALISE instance pragmas by making them -- look like SPECIALISE pragmas for the dfun let - dfun_prags = [SpecSig (idName dfun_id) ty loc | SpecInstSig ty loc <- uprags] + spec_prags = [ SpecSig (idName dfun_id) ty loc + | SpecInstSig ty loc <- uprags] in + tcExtendGlobalValEnv [dfun_id] ( - tcSpecSigs dfun_prags + tcExtendTyVarEnv2 xtve $ + tcExtendLocalValEnv2 [(idName sel_id, tcSigPolyId sig) + | (sel_id, sig, _) <- meth_infos] $ + -- Map sel_id to the local method name we are using + tcSpecSigs spec_prags ) `thenTc` \ (prag_binds, prag_lie) -> - -- Check the overloading constraints of the methods and superclasses - let - -- These insts are in scope; quite a few, eh? - avail_insts = [this_dict] ++ - dfun_arg_dicts ++ - sc_dicts ++ - meth_insts - - methods_lie = plusLIEs insts_needed_s - in - - -- Simplify the constraints from methods - tcAddErrCtxt methodCtxt ( - tcSimplifyCheck - (ptext SLIT("instance declaration context")) - inst_tyvars' - avail_insts - methods_lie - ) `thenTc` \ (const_lie1, lie_binds1) -> - - -- Figure out bindings for the superclass context - tcAddErrCtxt superClassCtxt ( - tcSimplifyCheck - (ptext SLIT("instance declaration context")) - inst_tyvars' - dfun_arg_dicts -- NB! Don't include this_dict here, else the sc_dicts - -- get bound by just selecting from this_dict!! - (mkLIE sc_dicts) - ) `thenTc` \ (const_lie2, lie_binds2) -> - - checkSigTyVars inst_tyvars' emptyVarSet `thenNF_Tc` \ zonked_inst_tyvars -> - -- Create the result bindings let local_dfun_id = setIdLocalExported dfun_id @@ -660,24 +632,97 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = monobinds, iPrags = uprags } where msg = _PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas)) - dict_bind = VarMonoBind this_dict_id dict_rhs - method_binds = andMonoBindList method_binds_s - - main_bind - = AbsBinds - zonked_inst_tyvars - (map instToId dfun_arg_dicts) - [(inst_tyvars', local_dfun_id, this_dict_id)] - inlines - (lie_binds1 `AndMonoBinds` - lie_binds2 `AndMonoBinds` - method_binds `AndMonoBinds` - dict_bind) + dict_bind = VarMonoBind this_dict_id dict_rhs + meth_binds = andMonoBindList meth_binds_s + all_binds = sc_binds_inner `AndMonoBinds` meth_binds `AndMonoBinds` dict_bind + + main_bind = AbsBinds + zonked_inst_tyvars + (map instToId dfun_arg_dicts) + [(inst_tyvars', local_dfun_id, this_dict_id)] + inlines all_binds in - returnTc (const_lie1 `plusLIE` const_lie2 `plusLIE` prag_lie, - main_bind `AndMonoBinds` prag_binds) + returnTc (plusLIEs meth_lie_s `plusLIE` prag_lie, + main_bind `AndMonoBinds` prag_binds `AndMonoBinds` sc_binds_outer) \end{code} +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 + = tcAddErrCtxt superClassCtxt $ + tcSimplifyCheck doc inst_tyvars' + dfun_arg_dicts + (mkLIE sc_dicts) `thenTc` \ (sc_lie, sc_binds1) -> + + -- It's possible that the superclass stuff might have done unification + checkSigTyVars inst_tyvars' `thenTc` \ zonked_inst_tyvars -> + + -- We must simplify this all the way down + -- lest we build superclass loops + tcSimplifyTop sc_lie `thenTc` \ sc_binds2 -> + + returnTc (zonked_inst_tyvars, sc_binds1, sc_binds2) + + where + doc = ptext SLIT("instance declaration superclass context") +\end{code} + +\begin{code} +mkMethodBinds clas inst_tys' op_items monobinds + = -- Check that all the method bindings come from this class + mapTc (addErrTc . badMethodErr clas) bad_bndrs `thenNF_Tc_` + + -- Make the method bindings + mapAndUnzipTc mk_method_bind op_items + + where + mk_method_bind op_item = mkMethodBind InstanceDeclOrigin clas + inst_tys' monobinds op_item + + -- Find any definitions in monobinds that aren't from the class + sel_names = [idName sel_id | (sel_id, _) <- op_items] + bad_bndrs = collectMonoBinders monobinds `minusList` sel_names +\end{code} + + ------------------------------ Inlining dfuns unconditionally ------------------------------