X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=0d9ffac081698abd08500ee3ae517239bc2ce7bf;hb=6c872fff42025a842e8500ddbb13fdcca60eaf75;hp=5bd347192edb8157439caa2421d107210c1ff2a3;hpb=e1a4f2a5be6e4cd06d96b601fefd519c2569ba99;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 5bd3471..0d9ffac 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -14,7 +14,7 @@ import HsSyn ( HsDecl(..), InstDecl(..), andMonoBindList ) import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl ) -import TcHsSyn ( TcMonoBinds, +import TcHsSyn ( TcMonoBinds, mkHsConApp, maybeBoxedPrimType ) @@ -23,7 +23,8 @@ import TcClassDcl ( tcMethodBind, checkFromThisClass ) import TcMonad import RnMonad ( RnNameSupply, Fixities ) import Inst ( Inst, InstOrigin(..), - newDicts, LIE, emptyLIE, plusLIE, plusLIEs ) + newDicts, newClassDicts, + LIE, emptyLIE, plusLIE, plusLIEs ) import TcDeriv ( tcDeriving ) import TcEnv ( ValueEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths, tcAddImportedIdInfo, tcInstId @@ -39,7 +40,7 @@ import Bag ( emptyBag, unitBag, unionBags, unionManyBags, import CmdLineOpts ( opt_GlasgowExts, opt_AllowUndecidableInstances ) import Class ( classBigSig, Class ) import Var ( idName, idType, Id, TyVar ) -import DataCon ( isNullaryDataCon, splitProductType_maybe, dataConId ) +import DataCon ( isNullaryDataCon, splitProductType_maybe ) import Maybes ( maybeToBool, catMaybes, expectJust ) import MkId ( mkDictFunId ) import Module ( ModuleName ) @@ -48,14 +49,15 @@ import NameSet ( emptyNameSet ) import PrelInfo ( eRROR_ID ) import PprType ( pprConstraint ) import SrcLoc ( SrcLoc ) -import TyCon ( isSynTyCon, isDataTyCon, tyConDerivings ) +import TyCon ( isSynTyCon, tyConDerivings ) import Type ( Type, isUnLiftedType, mkTyVarTys, splitSigmaTy, isTyVarTy, - splitTyConApp_maybe, splitDictTy_maybe, unUsgTy, - splitAlgTyConApp_maybe, - tyVarsOfTypes + splitTyConApp_maybe, splitDictTy_maybe, + getClassTys_maybe, splitAlgTyConApp_maybe, + classesToPreds, classesOfPreds, + unUsgTy, tyVarsOfTypes ) -import Subst ( mkTopTyVarSubst, substTheta ) +import Subst ( mkTopTyVarSubst, substClasses ) import VarSet ( mkVarSet, varSetElems ) import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon ) import TysWiredIn ( stringTy ) @@ -175,9 +177,10 @@ tcInstDecl1 unf_env (InstDecl poly_ty binds uprags dfun_name src_loc) tcHsTopType poly_ty `thenTc` \ poly_ty' -> let (tyvars, theta, dict_ty) = splitSigmaTy poly_ty' - (clas, inst_tys) = case splitDictTy_maybe dict_ty of - Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty) - Just pair -> pair + constr = classesOfPreds theta + (clas, inst_tys) = case splitDictTy_maybe dict_ty of + Just ct -> ct + Nothing -> pprPanic "tcInstDecl1" (ppr poly_ty) in -- Check for respectable instance type, and context @@ -187,19 +190,19 @@ tcInstDecl1 unf_env (InstDecl poly_ty binds uprags dfun_name src_loc) -- instance CCallable [Char] (if isLocallyDefined dfun_name then scrutiniseInstanceHead clas inst_tys `thenNF_Tc_` - mapNF_Tc scrutiniseInstanceConstraint theta + mapNF_Tc scrutiniseInstanceConstraint constr else returnNF_Tc [] ) `thenNF_Tc_` -- Make the dfun id let - dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta + dfun_id = mkDictFunId dfun_name clas tyvars inst_tys constr -- Add info from interface file final_dfun_id = tcAddImportedIdInfo unf_env dfun_id in - returnTc (unitBag (InstInfo clas tyvars inst_tys theta + returnTc (unitBag (InstInfo clas tyvars inst_tys constr final_dfun_id binds src_loc uprags)) \end{code} @@ -324,22 +327,22 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys origin = InstanceDeclOrigin - (class_tyvars, sc_theta, sc_sel_ids, op_items) = classBigSig clas + (class_tyvars, sc_theta, _, op_items) = classBigSig clas dm_ids = [dm_id | (_, dm_id, _) <- op_items] -- Instantiate the theta found in the original instance decl - inst_decl_theta' = substTheta (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars')) - inst_decl_theta + inst_decl_theta' = substClasses (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars')) + inst_decl_theta -- Instantiate the super-class context with inst_tys - sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys') sc_theta + sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys') sc_theta in -- Create dictionary Ids from the specified instance contexts. - newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) -> + newClassDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) -> newDicts origin dfun_theta' `thenNF_Tc` \ (dfun_arg_dicts, dfun_arg_dicts_ids) -> - newDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) -> - newDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> + newClassDicts origin inst_decl_theta' `thenNF_Tc` \ (inst_decl_dicts, _) -> + newClassDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> -- Check that all the method bindings come from this class checkFromThisClass clas op_items monobinds `thenNF_Tc_` @@ -348,8 +351,9 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys tcExtendGlobalValEnv dm_ids ( -- Default-method Ids may be mentioned in synthesised RHSs - mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys' inst_decl_theta' - monobinds uprags True) + mapAndUnzip3Tc (tcMethodBind clas origin inst_tyvars' inst_tys' + (classesToPreds inst_decl_theta') + monobinds uprags True) op_items )) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) -> @@ -435,13 +439,12 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys (HsLitOut (HsString msg) stringTy) | otherwise -- The common case - = foldl HsApp (TyApp (HsVar (dataConId dict_constr)) inst_tys') - (map HsVar (sc_dict_ids ++ meth_ids)) + = mkHsConApp dict_constr inst_tys' (map HsVar (sc_dict_ids ++ meth_ids)) -- 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 -- it means that the special cases (e.g. dictionary with only one - -- member) are dealt with by the common MkId.mkDataConId code rather + -- member) are dealt with by the common MkId.mkDataConWrapId code rather -- than needing to be repeated here. where @@ -585,7 +588,7 @@ creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) || \begin{code} instConstraintErr clas tys - = hang (ptext SLIT("Illegal constaint") <+> + = hang (ptext SLIT("Illegal constraint") <+> quotes (pprConstraint clas tys) <+> ptext SLIT("in instance context")) 4 (ptext SLIT("(Instance contexts must constrain only type variables)"))