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

plus a false ASSERT failure

diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index 238c091..2e462a2 100644 (file)
--- 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,
         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,
        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"
 
 -- 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)
 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)
 
 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 a618cbc..d902626 100644 (file)
--- 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)
 
     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)
     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}
     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 052b9a6..7aa2654 100644 (file)
--- 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
     -- 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")
 
     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 08d99dc..27983d3 100644 (file)
--- 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,
   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
 
   prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR,
   rightAssocDataCon_RDR, notAssocDataCon_RDR :: RdrName
 

diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index 36bef11..a5ce2ea 100644 (file)
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -16,10 +16,8 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2,
 
 import HsSyn
 import RnHsSyn
 
 import HsSyn
 import RnHsSyn

-import RnExpr

 import Inst
 import InstEnv
 import Inst
 import InstEnv

-import TcPat( addInlinePrags )

 import TcEnv
 import TcBinds
 import TcUnify
 import TcEnv
 import TcBinds
 import TcUnify

@@ -35,7 +33,6 @@ import MkId
 import Id
 import Name
 import Var
 import Id
 import Name
 import Var

-import NameEnv

 import NameSet
 import Outputable
 import PrelNames
 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 ]
 
        ; 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
 
        ; 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.)
 -- 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 
   | 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)
 
 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"),
 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)
     ]
   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}
 \end{code}

diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index ffa240d..fd66cb8 100644 (file)
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -46,7 +46,6 @@ import Var
 import VarSet
 import PrelNames
 import SrcLoc
 import VarSet
 import PrelNames
 import SrcLoc

-import Unique

 import UniqSupply
 import Util
 import ListSetOps
 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
        
         -- 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)
        -- 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
 
 -----------------------------------------
          clas_nm            = className clas
 
 -----------------------------------------

+{- Now unused 

 mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName)
 mkGenericBinds is_boot tycl_decls
   | is_boot 
 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
                -- 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]
 \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
                                        , 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)
       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 653394f..cb07c69 100644 (file)
--- 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]
 
     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
       = 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
 
                -- 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)
 -}
        ; 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")
 
   = 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")])
 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
 
 recSynErr :: [LTyClDecl Name] -> TcRn ()
 recSynErr syn_decls

diff --git a/compiler/types/Generics.lhs b/compiler/types/Generics.lhs
index 6d1a2df..20cf242 100644 (file)
--- a/compiler/types/Generics.lhs
+++ b/compiler/types/Generics.lhs
@@ -25,7 +25,6 @@ import DataCon
 
 import TyCon
 import Name hiding (varName)
 
 import TyCon
 import Name hiding (varName)

-import OccName (varName)

 import Module (moduleName, moduleNameString)
 import RdrName
 import BasicTypes
 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)
 -- For generation of representation types
 import TcEnv (tcLookupTyCon)
 import TcRnMonad (TcM, newUnique)

-import TcMType (newMetaTyVar)

 import HscTypes
        
 import SrcLoc
 import HscTypes
        
 import SrcLoc

@@ -46,9 +44,6 @@ import Bag
 import Outputable 
 import FastString
 
 import Outputable 
 import FastString
 

-import Data.List (splitAt)
-import Debug.Trace (trace)
-

 #include "HsVersions.h"
 \end{code}
 
 #include "HsVersions.h"
 \end{code}
 

@@ -305,7 +300,7 @@ mkBindsRep0 tycon =
         
 -- Disabled
 mkTyConGenericBinds :: TyCon -> LHsBinds RdrName
         
 -- Disabled
 mkTyConGenericBinds :: TyCon -> LHsBinds RdrName

-mkTyConGenericBinds tycon = 
+mkTyConGenericBinds _tycon = 

   {-
     unitBag (L loc (mkFunBind (L loc from0_RDR) from0_matches))
   `unionBags`
   {-
     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
     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]
     
     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)]
         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) 
         -- 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                         -- 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
                    -- 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                       -- 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
                    -- 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 5f348ef..c9bf3f5 100644 (file)
--- 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
 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}
 \end{code}
 
 \begin{code}