X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstDcls.lhs;h=1a38a133db4253914953acb490f9848caa094513;hb=d455d8a0f37aba8b7da6250519368a48a9386cca;hp=fd70cffe4fcad247ef4eb2db0a7b1419e0f584ab;hpb=20d1c20c49feae6b862c87504bbd9b8c483044f3;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index fd70cff..1a38a13 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -25,7 +25,7 @@ import TcClassDcl	( tcMethodBind, badMethodErr )
 import TcMonad       
 import TcType		( tcInstType )
 import Inst		( InstOrigin(..),
-			  newDicts, newClassDicts, instToId,
+			  newDicts, instToId,
 			  LIE, mkLIE, emptyLIE, plusLIE, plusLIEs )
 import TcDeriv		( tcDeriving )
 import TcEnv		( TcEnv, tcExtendGlobalValEnv, 
@@ -52,7 +52,7 @@ import FunDeps		( checkInstFDs )
 import Generics		( validGenericInstanceType )
 import Module		( Module, foldModuleEnv )
 import Name		( getSrcLoc )
-import NameSet		( emptyNameSet, nameSetToList )
+import NameSet		( emptyNameSet, mkNameSet, nameSetToList )
 import PrelInfo		( eRROR_ID )
 import PprType		( pprClassPred, pprPred )
 import TyCon		( TyCon, isSynTyCon )
@@ -60,9 +60,9 @@ import Type		( splitDFunTy, isTyVarTy,
 			  splitTyConApp_maybe, splitDictTy,
 			  splitForAllTys,
 			  tyVarsOfTypes, mkClassPred, mkTyVarTy,
-			  getClassTys_maybe
+			  isTyVarClassPred, inheritablePred
 			)
-import Subst		( mkTopTyVarSubst, substClasses )
+import Subst		( mkTopTyVarSubst, substTheta )
 import VarSet		( varSetElems )
 import TysWiredIn	( genericTyCons, isFFIArgumentTy, isFFIImportResultTy )
 import PrelNames	( cCallableClassKey, cReturnableClassKey, hasKey )
@@ -312,6 +312,9 @@ getGenericInstances class_decls
     let
 	gen_inst_info = concat gen_inst_infos
     in
+    if null gen_inst_info then
+	returnTc []
+    else
     getDOptsTc						`thenTc`  \ dflags ->
     ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances" 
 		      (vcat (map pprInstInfo gen_inst_info)))	
@@ -524,7 +527,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id,
 	sel_names = [idName sel_id | (sel_id, _) <- op_items]
 
         -- Instantiate the super-class context with inst_tys
-	sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys') sc_theta
+	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
@@ -538,9 +541,9 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id,
     mapTc (addErrTc . badMethodErr clas) bad_bndrs		`thenNF_Tc_`
 
 	 -- Create dictionary Ids from the specified instance contexts.
-    newClassDicts origin sc_theta'		`thenNF_Tc` \ sc_dicts ->
-    newDicts origin dfun_theta'			`thenNF_Tc` \ dfun_arg_dicts ->
-    newClassDicts origin [(clas,inst_tys')]	`thenNF_Tc` \ [this_dict] ->
+    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' (
  	tcExtendGlobalValEnv dm_ids (
@@ -598,6 +601,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id,
         dict_constr   = classDataCon clas
 	scs_and_meths = map instToId (sc_dicts ++ meth_insts)
 	this_dict_id  = instToId this_dict
+	inlines       = mkNameSet [idName dfun_id | InlineInstSig _ _ <- uprags]
 
 	dict_rhs
 	  | null scs_and_meths
@@ -630,7 +634,7 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id,
 		 zonked_inst_tyvars
 		 (map instToId dfun_arg_dicts)
 		 [(inst_tyvars', dfun_id, this_dict_id)] 
-		 emptyNameSet		-- No inlines (yet)
+		 inlines
 		 (lie_binds1	`AndMonoBinds` 
 		  lie_binds2	`AndMonoBinds`
 		  method_binds	`AndMonoBinds`
@@ -665,15 +669,16 @@ checkInstValidity dflags theta clas inst_tys
 	   [err | pred <- theta, err <- checkInstConstraint dflags pred]
 
 checkInstConstraint dflags pred
-  |  dopt Opt_AllowUndecidableInstances dflags
-  =  []
+	-- Checks whether a predicate is legal in the
+	-- context of an instance declaration
+  | ok 	       = []
+  | otherwise  = [instConstraintErr pred]
+  where
+    ok = inheritablePred pred &&
+	 (isTyVarClassPred pred || arbitrary_preds_ok)
 
-  |  Just (clas,tys) <- getClassTys_maybe pred,
-     all isTyVarTy tys
-  =  []
+    arbitrary_preds_ok = dopt Opt_AllowUndecidableInstances dflags
 
-  |  otherwise
-  =  [instConstraintErr pred]
 
 checkInstHead dflags theta clas inst_taus
   |	-- CCALL CHECK