Small fixes to the generics branch to get rid of warnings,

plus a false ASSERT failure

9 files changed, 33 insertions, 58 deletions

diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index 238c091b97..2e462a21a2 100644
--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -53,7 +53,7 @@ module OccName (
         mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
   	mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, 
  	mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
- 	mkGenD, mkGenC, mkGenS, mkGenR0, mkGenR0Co,
+ 	mkGenD, mkGenR0, mkGenR0Co, mkGenC, mkGenS,
 	mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
 	mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc,
 	mkInstTyCoOcc, mkEqPredCoOcc,
@@ -581,7 +581,11 @@ mkGenOcc2           = mk_simple_deriv varName  "$gto"
 
 -- Generic deriving mechanism (new)
 mkGenD         = mk_simple_deriv tcName "D1"
+
+mkGenC :: OccName -> Int -> OccName
 mkGenC occ m   = mk_deriv tcName ("C1_" ++ show m) (occNameString occ)
+
+mkGenS :: OccName -> Int -> Int -> OccName
 mkGenS occ m n = mk_deriv tcName ("S1_" ++ show m ++ "_" ++ show n)
                    (occNameString occ)
 
diff --git a/compiler/main/HscStats.lhs b/compiler/main/HscStats.lhs
index a618cbcad2..d90262633c 100644
--- a/compiler/main/HscStats.lhs
+++ b/compiler/main/HscStats.lhs
@@ -159,13 +159,11 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
 
     addpr :: (Int,Int) -> Int
     add2  :: (Int,Int) -> (Int,Int) -> (Int, Int)
-    add4  :: (Int,Int,Int,Int) -> (Int,Int,Int,Int) -> (Int, Int, Int, Int)
     add5  :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int)
     add6  :: (Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int)
 
     addpr (x,y) = x+y
     add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
-    add4 (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4)
     add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
     add6 (x1,x2,x3,x4,x5,x6) (y1,y2,y3,y4,y5,y6) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6)
 \end{code}
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 052b9a689c..7aa2654ca9 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -822,7 +822,7 @@ checkValSig lhs@(L l _) ty
     -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword
     looks_like s (L _ (HsVar v))     = v == s
     looks_like s (L _ (HsApp lhs _)) = looks_like s lhs
-    looks_like s _                   = False
+    looks_like _ _                   = False
 
     foreign_RDR = mkUnqual varName (fsLit "foreign")
     generic_RDR = mkUnqual varName (fsLit "generic")
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 08d99dc8eb..27983d357d 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -556,7 +556,7 @@ u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR,
   prodDataCon_RDR, comp1DataCon_RDR, from0_RDR, from1_RDR,
   to0_RDR, to1_RDR, datatypeName_RDR, moduleName_RDR, conName_RDR,
   conFixity_RDR, conIsRecord_RDR, conIsTuple_RDR,
-  noArityDataCon_RDR, arityDataCon_RDR,
+  noArityDataCon_RDR, arityDataCon_RDR, selName_RDR,
   prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR,
   rightAssocDataCon_RDR, notAssocDataCon_RDR :: RdrName
 
diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index 36bef1183d..a5ce2eaf62 100644
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -16,10 +16,8 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2,
 
 import HsSyn
 import RnHsSyn
-import RnExpr
 import Inst
 import InstEnv
-import TcPat( addInlinePrags )
 import TcEnv
 import TcBinds
 import TcUnify
@@ -35,7 +33,6 @@ import MkId
 import Id
 import Name
 import Var
-import NameEnv
 import NameSet
 import Outputable
 import PrelNames
@@ -104,13 +101,13 @@ tcClassSigs clas sigs def_methods
        ; op_info <- mapM (addLocM tc_sig) [sig | sig@(L _ (TypeSig _ _)) <- sigs]
        ; let op_names = [ n | (n,_,_) <- op_info ]
 
-       ; sequence [ failWithTc (badMethodErr clas n)
-                  | n <- dm_bind_names, not (n `elem` op_names) ]
-		  -- Value binding for non class-method (ie no TypeSig)
+       ; sequence_ [ failWithTc (badMethodErr clas n)
+                   | n <- dm_bind_names, not (n `elem` op_names) ]
+		   -- Value binding for non class-method (ie no TypeSig)
 
-       ; sequence [ failWithTc (badGenericMethod clas n)
-                  | n <- genop_names, not (n `elem` dm_bind_names) ]
-		  -- Generic signature without value binding
+       ; sequence_ [ failWithTc (badGenericMethod clas n)
+                   | n <- genop_names, not (n `elem` dm_bind_names) ]
+		   -- Generic signature without value binding
 
        ; return op_info }
   where
@@ -183,7 +180,7 @@ tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -> [LSig Name]
 -- default method for every class op, regardless of whether or not 
 -- the programmer supplied an explicit default decl for the class.  
 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
-tcDefMeth clas tyvars this_dict binds_in sigs sig_fn prag_fn (sel_id, dm_info)
+tcDefMeth _ tyvars _ binds_in sigs sig_fn prag_fn (sel_id, dm_info)
   | NoDefMeth <- dm_info = return emptyBag
   | otherwise
   = do	{ (dm_id, tvs, sig_loc) <- tc_dm_id dm_info 
@@ -556,22 +553,6 @@ omittedATWarn :: Name -> SDoc
 omittedATWarn at
   = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
 
-badGenericInstance :: Var -> SDoc -> SDoc
-badGenericInstance sel_id because
-  = sep [ptext (sLit "Can't derive generic code for") <+> quotes (ppr sel_id),
-	 because]
-
-notSimple :: [Type] -> SDoc
-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 a1 ... an)")]
-
-notGeneric :: TyCon -> SDoc
-notGeneric tycon
-  = vcat [ptext (sLit "because the instance type constructor") <+> quotes (ppr tycon) <+> 
-	  ptext (sLit "was not compiled with -XGenerics")]
-
 badGenericInstanceType :: LHsBinds Name -> SDoc
 badGenericInstanceType binds
   = vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
@@ -589,8 +570,4 @@ dupGenericInsts tc_inst_infos
     ]
   where 
     ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
-
-mixedGenericErr :: Name -> SDoc
-mixedGenericErr op
-  = ptext (sLit "Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
 \end{code}
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index ffa240dd62..fd66cb8082 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -46,7 +46,6 @@ import Var
 import VarSet
 import PrelNames
 import SrcLoc
-import Unique
 import UniqSupply
 import Util
 import ListSetOps
@@ -325,9 +324,9 @@ tcDeriving tycl_decls inst_decls deriv_decls
 	 -- Generate the generic Representable0/1 instances from each type declaration
   ; repInstsMeta <- genGenericRepBinds is_boot tycl_decls
 	
-	; let repInsts   = concat (map (\(a,b,c) -> a) repInstsMeta)
-	      repMetaTys = map (\(a,b,c) -> b) repInstsMeta
-	      repTyCons  = map (\(a,b,c) -> c) repInstsMeta
+	; let repInsts   = concat (map (\(a,_,_) -> a) repInstsMeta)
+	      repMetaTys = map (\(_,b,_) -> b) repInstsMeta
+	      repTyCons  = map (\(_,_,c) -> c) repInstsMeta
 	-- Should we extendLocalInstEnv with repInsts?
 
 	; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ repInsts)
@@ -406,6 +405,7 @@ renameDeriv is_boot gen_binds insts
 	  clas_nm            = className clas
 
 -----------------------------------------
+{- Now unused 
 mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName)
 mkGenericBinds is_boot tycl_decls
   | is_boot 
@@ -418,6 +418,7 @@ mkGenericBinds is_boot tycl_decls
 		-- We are only interested in the data type declarations,
 		-- and then only in the ones whose 'has-generics' flag is on
 		-- The predicate tyConHasGenerics finds both of these
+-}
 \end{code}
 
 Note [Newtype deriving and unused constructors]
@@ -1494,7 +1495,7 @@ genGenericRepBinds isBoot tyclDecls
                                        , isDataDecl d ]
       let tyDecls = filter tyConHasGenerics allTyDecls
       inst1 <- mapM genGenericRepBind tyDecls
-      let (repInsts, metaTyCons, repTys) = unzip3 inst1
+      let (_repInsts, metaTyCons, _repTys) = unzip3 inst1
       metaInsts <- ASSERT (length tyDecls == length metaTyCons)
                      mapM genDtMeta (zip tyDecls metaTyCons)
       return (ASSERT (length inst1 == length metaInsts)
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 653394ff00..cb07c6964d 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -1143,7 +1143,7 @@ checkValidClass cls
     unary 	= isSingleton tyvars
     no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff]
 
-    check_op constrained_class_methods (sel_id, dm) 
+    check_op constrained_class_methods (sel_id, _) 
       = addErrCtxt (classOpCtxt sel_id tau) $ do
 	{ checkValidTheta SigmaCtxt (tail theta)
 		-- The 'tail' removes the initial (C a) from the
@@ -1164,7 +1164,7 @@ checkValidClass cls
 
 		-- Check that for a generic method, the type of 
 		-- the method is sufficiently simple
-{- -- JPM TODO
+{- -- JPM TODO  (when reinstating, remove commenting-out of badGenericMethodType
 	; checkTc (dm /= GenDefMeth || validGenericMethodType tau)
 		  (badGenericMethodType op_name op_ty)
 -}
@@ -1433,11 +1433,13 @@ genericMultiParamErr clas
   = ptext (sLit "The multi-parameter class") <+> quotes (ppr clas) <+> 
     ptext (sLit "cannot have generic methods")
 
+{-  Commented out until the call is reinstated
 badGenericMethodType :: Name -> Kind -> SDoc
 badGenericMethodType op op_ty
   = hang (ptext (sLit "Generic method type is too complex"))
        2 (vcat [ppr op <+> dcolon <+> ppr op_ty,
 		ptext (sLit "You can only use type variables, arrows, lists, and tuples")])
+-}
 
 recSynErr :: [LTyClDecl Name] -> TcRn ()
 recSynErr syn_decls
diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs
index 6d1a2df72f..20cf242696 100644
--- a/compiler/types/Generics.lhs
+++ b/compiler/types/Generics.lhs
@@ -25,7 +25,6 @@ import DataCon
 
 import TyCon
 import Name hiding (varName)
-import OccName (varName)
 import Module (moduleName, moduleNameString)
 import RdrName
 import BasicTypes
@@ -37,7 +36,6 @@ import PrelNames
 -- For generation of representation types
 import TcEnv (tcLookupTyCon)
 import TcRnMonad (TcM, newUnique)
-import TcMType (newMetaTyVar)
 import HscTypes
 	
 import SrcLoc
@@ -46,9 +44,6 @@ import Bag
 import Outputable 
 import FastString
 
-import Data.List (splitAt)
-import Debug.Trace (trace)
-
 #include "HsVersions.h"
 \end{code}
 
@@ -305,7 +300,7 @@ mkBindsRep0 tycon =
         
 -- Disabled
 mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
-mkTyConGenericBinds tycon = 
+mkTyConGenericBinds _tycon = 
   {-
     unitBag (L loc (mkFunBind (L loc from0_RDR) from0_matches))
   `unionBags`
@@ -374,8 +369,6 @@ tc_mkRep0Ty tycon metaDts =
     v1 <- tcLookupTyCon v1TyConName
     plus <- tcLookupTyCon sumTyConName
     times <- tcLookupTyCon prodTyConName
-    noSel <- tcLookupTyCon noSelTyConName
-    freshTy <- newMetaTyVar TauTv liftedTypeKind
     
     let mkSum  a b = mkTyConApp plus  [a,b]
         mkProd a b = mkTyConApp times [a,b]
@@ -506,7 +499,7 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
         conName_matches     c = mkStringLHS . showPpr . nameOccName
                               . dataConName $ c
         conFixity_matches   c = [mkSimpleHsAlt nlWildPat (fixity c)]
-        conIsRecord_matches c = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
+        conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
         -- TODO: check that this works
         conIsTuple_matches  c = [mkSimpleHsAlt nlWildPat 
                                   (nlHsApp (nlHsVar arityDataCon_RDR) 
@@ -590,8 +583,8 @@ genLR_E i n e
 mkProd_E :: US			        -- Base for unique names
 	       -> [RdrName]       -- List of variables matched on the lhs
 	       -> LHsExpr RdrName -- Resulting product expression
-mkProd_E us []   = mkM1_E (nlHsVar u1DataCon_RDR)
-mkProd_E us vars = mkM1_E (foldBal prod appVars)
+mkProd_E _ []   = mkM1_E (nlHsVar u1DataCon_RDR)
+mkProd_E _ vars = mkM1_E (foldBal prod appVars)
                    -- These M1s are meta-information for the constructor
   where
     appVars = map wrapArg_E vars
@@ -606,8 +599,8 @@ wrapArg_E v = mkM1_E (k1DataCon_RDR `nlHsVarApps` [v])
 mkProd_P :: US			      -- Base for unique names
 	       -> [RdrName]     -- List of variables to match
 	       -> LPat RdrName  -- Resulting product pattern
-mkProd_P us []   = mkM1_P (nlNullaryConPat u1DataCon_RDR)
-mkProd_P us vars = mkM1_P (foldBal prod appVars)
+mkProd_P _ []   = mkM1_P (nlNullaryConPat u1DataCon_RDR)
+mkProd_P _ vars = mkM1_P (foldBal prod appVars)
                    -- These M1s are meta-information for the constructor
   where
     appVars = map wrapArg_P vars
diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 5f348efd35..c9bf3f5d65 100644
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -949,9 +949,9 @@ isAlgType ty
 isClosedAlgType :: Type -> Bool
 isClosedAlgType ty
   = case splitTyConApp_maybe ty of
-      Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
-			    isAlgTyCon tc && not (isFamilyTyCon tc)
-      _other	         -> False
+      Just (tc, ty_args) | isAlgTyCon tc && not (isFamilyTyCon tc)
+             -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True
+      _other -> False
 \end{code}
 
 \begin{code}