From ce2ea8274f72199ac32d5219fcadb0aaeb968707 Mon Sep 17 00:00:00 2001 From: unknown Date: Thu, 14 Apr 2011 10:53:23 +0100 Subject: [PATCH] Small fixes to the generics branch to get rid of warnings, plus a false ASSERT failure --- compiler/basicTypes/OccName.lhs | 6 +++++- compiler/main/HscStats.lhs | 2 -- compiler/parser/RdrHsSyn.lhs | 2 +- compiler/prelude/PrelNames.lhs | 2 +- compiler/typecheck/TcClassDcl.lhs | 37 +++++++---------------------------- compiler/typecheck/TcDeriv.lhs | 11 ++++++----- compiler/typecheck/TcTyClsDecls.lhs | 6 ++++-- compiler/types/Generics.lhs | 19 ++++++------------ compiler/types/Type.lhs | 6 +++--- 9 files changed, 33 insertions(+), 58 deletions(-) diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index 238c091..2e462a2 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 a618cbc..d902626 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 052b9a6..7aa2654 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 08d99dc..27983d3 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 36bef11..a5ce2ea 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 ffa240d..fd66cb8 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 653394f..cb07c69 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 6d1a2df..20cf242 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 5f348ef..c9bf3f5 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} -- 1.7.10.4