X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcInstDcls.lhs;h=fe7b1d8b24254915b5335c724569cf62a4f874e7;hp=0b4f8b028520291f6638a36698bc094a12ab0a88;hb=84923cc7de2a93c22a2f72daf9ac863959efae13;hpb=2a8cdc3aee5997374273e27365f92c161aca8453

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 0b4f8b0..fe7b1d8 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,43 @@ 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	( mkLocalFamInst )
-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 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
@@ -232,7 +221,7 @@ addFamInsts tycons thing_inside
     mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
     mkLocalFamInstTyThing tything	 = pprPanic "TcInstDcls.addFamInsts"
 						    (ppr tything)
-\end{code} 
+\end{code}
 
 \begin{code}
 tcLocalInstDecl1 :: LInstDecl Name 
@@ -251,11 +240,7 @@ 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
@@ -494,7 +479,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
@@ -529,7 +514,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) }
@@ -595,7 +581,7 @@ 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
     in
 	 -- Prime error recovery
@@ -621,7 +607,7 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
     newDictBndrs sc_loc 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 ->
+    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.
 
@@ -637,9 +623,8 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = VanillaInst monobinds uprags })
 	-- 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 ->
+	(tcSimplifySuperClasses inst_loc
+			 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