X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcClassDcl.lhs;h=2e7603b87c8b41ccddd0b555c0d26416d442030a;hb=19b44dcc5e5b9f92735fa99aa45dfaa94777177c;hp=f43a4d7e7ae44c1369c916e1db90c8719ccb6bfc;hpb=e3dd39bf230380f02d73efc287226117bb2eb47f;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index f43a4d7..2e7603b 100644
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -6,6 +6,13 @@
 Typechecking class declarations
 
 \begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 module TcClassDcl ( tcClassSigs, tcClassDecl2, 
 		    getGenericInstances, 
 		    MethodSpec, tcMethodBind, mkMethodBind, 
@@ -53,6 +60,8 @@ import List
 import BasicTypes
 import Bag
 import FastString
+
+import Control.Monad
 \end{code}
 
 
@@ -425,7 +434,7 @@ mkMethId origin clas sel_id inst_tys
 	rho_ty	     = ASSERT( length tyvars == length inst_tys )
 		       substTyWith tyvars inst_tys rho
 	(preds,tau)  = tcSplitPhiTy rho_ty
-        first_pred   = head preds
+        first_pred   = ASSERT( not (null preds)) head preds
     in
 	-- The first predicate should be of form (C a b)
 	-- where C is the class in question
@@ -452,8 +461,7 @@ mkMethId origin clas sel_id inst_tys
 	getSrcSpanM			`thenM` \ loc ->
 	let 
 	    real_tau = mkPhiTy (tail preds) tau
-	    meth_id  = mkUserLocal (getOccName sel_id) uniq real_tau 
-			(srcSpanStart loc) --TODO
+	    meth_id  = mkUserLocal (getOccName sel_id) uniq real_tau loc
 	in
 	returnM (Nothing, meth_id)
 
@@ -529,7 +537,7 @@ mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
 	  -- case we require that the instance decl is for a single-parameter
 	  -- type class with type variable arguments:
 	  --	instance (...) => C (T a b)
-    clas_tyvar    = head (classTyVars clas)
+    clas_tyvar    = ASSERT (not (null (classTyVars clas))) head (classTyVars clas)
     Just tycon	  = maybe_tycon
     maybe_tycon   = case inst_tys of 
 			[ty] -> case tcSplitTyConApp_maybe ty of
@@ -546,7 +554,7 @@ isInstDecl (SigOrigin (ClsSkol _)) = False
 -- The renamer just puts the selector ID as the binder in the method binding
 -- but we must use the method name; so we substitute it here.  Crude but simple.
 find_bind sel_name meth_name binds
-  = foldlBag seqMaybe Nothing (mapBag f binds)
+  = foldlBag mplus Nothing (mapBag f binds)
   where 
 	f (L loc1 bind@(FunBind { fun_id = L loc2 op_name })) | op_name == sel_name
 		 = Just (L loc1 (bind { fun_id = L loc2 meth_name }))
@@ -707,7 +715,7 @@ mkGenericInstance clas (hs_ty, binds)
 	-- Make the dictionary function.
     getSrcSpanM						`thenM` \ span -> 
     getOverlapFlag					`thenM` \ overlap_flag -> 
-    newDFunName clas [inst_ty] (srcSpanStart span)	`thenM` \ dfun_name ->
+    newDFunName clas [inst_ty] span             	`thenM` \ dfun_name ->
     let
 	inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
 	dfun_id    = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
@@ -734,7 +742,7 @@ tcAddDeclCtxt decl thing_inside
 				 else "data type" ++ maybeInst
 	   | isFamilyDecl decl = "family"
 
-     maybeInst | isFamInstDecl decl = " family"
+     maybeInst | isFamInstDecl decl = " instance"
 	       | otherwise          = ""
 
      ctxt = hsep [ptext SLIT("In the"), text thing, 
@@ -767,7 +775,7 @@ badGenericInstance sel_id because
 notSimple inst_tys
   = vcat [ptext SLIT("because the instance type(s)"), 
 	  nest 2 (ppr inst_tys),
-	  ptext SLIT("is not a simple type of form (T a b c)")]
+	  ptext SLIT("is not a simple type of form (T a1 ... an)")]
 
 notGeneric tycon
   = vcat [ptext SLIT("because the instance type constructor") <+> quotes (ppr tycon) <+>