From: Ian Lynagh Date: Tue, 6 May 2008 21:08:58 +0000 (+0000) Subject: Make TcGenDeriv warning-free X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=d107207d57f6102f580578e7c168b7317b04b9c4 Make TcGenDeriv warning-free --- diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs index eecf43b..ea9a33f 100644 --- a/compiler/typecheck/TcGenDeriv.lhs +++ b/compiler/typecheck/TcGenDeriv.lhs @@ -11,13 +11,6 @@ This module is nominally ``subordinate'' to @TcDeriv@, which is the This is where we do all the grimy bindings' generation. \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 TcGenDeriv ( DerivAuxBind(..), DerivAuxBinds, isDupAux, @@ -72,10 +65,10 @@ data DerivAuxBind -- Please add these auxiliary top-level bindings | GenMaxTag TyCon -- ...and maxTag isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool -isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1==tc2 -isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1==tc2 -isDupAux (GenMaxTag tc1) (GenMaxTag tc2) = tc1==tc2 -isDupAux b1 b2 = False +isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1 == tc2 +isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1 == tc2 +isDupAux (GenMaxTag tc1) (GenMaxTag tc2) = tc1 == tc2 +isDupAux _ _ = False \end{code} @@ -1045,9 +1038,10 @@ wrapOpBackquotes s | isSym s = s | otherwise = '`' : s ++ "`" isSym :: String -> Bool -isSym "" = False -isSym (c:cs) = startsVarSym c || startsConSym c +isSym "" = False +isSym (c : _) = startsVarSym c || startsConSym c +mk_showString_app :: String -> LHsExpr RdrName mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str)) \end{code} @@ -1148,7 +1142,7 @@ gen_Data_binds :: FixityEnv -> TyCon -> (LHsBinds RdrName, -- The method bindings DerivAuxBinds) -- Auxiliary bindings -gen_Data_binds fix_env tycon +gen_Data_binds _ tycon = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind], -- Auxiliary definitions: the data type and constructors DerivAuxBind datatype_bind : map mk_con_bind data_cons) @@ -1237,6 +1231,8 @@ gen_Data_binds fix_env tycon fixity | is_infix = infix_RDR | otherwise = prefix_RDR +gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR, + mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR :: RdrName gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl") gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold") toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr") @@ -1344,6 +1340,7 @@ careful_compare_Case :: -- checks for primitive types... -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName +cmp_eq_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b -- Was: compare_gen_Case cmp_eq_RDR @@ -1384,7 +1381,7 @@ assoc_ty_id :: String -- The class involved -> [(Type,a)] -- The table -> Type -- The type -> a -- The result of the lookup -assoc_ty_id cls_str tycon tbl ty +assoc_ty_id cls_str _ tbl ty | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+> text "for primitive type" <+> ppr ty) | otherwise = head res @@ -1411,6 +1408,7 @@ lt_op_tbl = ,(doublePrimTy, DoubleLtOp) ] +box_con_tbl :: [(Type, RdrName)] box_con_tbl = [(charPrimTy, getRdrName charDataCon) ,(intPrimTy, getRdrName intDataCon) @@ -1437,7 +1435,7 @@ eq_Expr tycon ty a b = genOpApp a eq_op b \begin{code} untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName -untag_Expr tycon [] expr = expr +untag_Expr _ [] expr = expr untag_Expr tycon ((untag_this, put_tag_here) : more) expr = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-} [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)] @@ -1476,15 +1474,18 @@ nested_compose_Expr (e:es) -- impossible_Expr is used in case RHSs that should never happen. -- We generate these to keep the desugarer from complaining that they *might* happen! +impossible_Expr :: LHsExpr RdrName impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv")) -- illegal_Expr is used when signalling error conditions in the RHS of a derived -- method. It is currently only used by Enum.{succ,pred} +illegal_Expr :: String -> String -> String -> LHsExpr RdrName illegal_Expr meth tp msg = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg))) -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you -- to include the value of a_RDR in the error string. +illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName illegal_toEnum_tag tp maxtag = nlHsApp (nlHsVar error_RDR) (nlHsApp (nlHsApp (nlHsVar append_RDR) @@ -1502,15 +1503,19 @@ illegal_toEnum_tag tp maxtag = (nlHsVar maxtag)) (nlHsLit (mkHsString ")")))))) +parenify :: LHsExpr RdrName -> LHsExpr RdrName parenify e@(L _ (HsVar _)) = e parenify e = mkHsPar e -- genOpApp wraps brackets round the operator application, so that the -- renamer won't subsequently try to re-associate it. +genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2) \end{code} \begin{code} +a_RDR, b_RDR, c_RDR, d_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR, + cmp_eq_RDR :: RdrName a_RDR = mkVarUnqual (fsLit "a") b_RDR = mkVarUnqual (fsLit "b") c_RDR = mkVarUnqual (fsLit "c") @@ -1523,10 +1528,13 @@ ch_RDR = mkVarUnqual (fsLit "c#") dh_RDR = mkVarUnqual (fsLit "d#") cmp_eq_RDR = mkVarUnqual (fsLit "cmp_eq") +as_RDRs, bs_RDRs, cs_RDRs :: [RdrName] as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] +a_Expr, b_Expr, c_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, + false_Expr, true_Expr :: LHsExpr RdrName a_Expr = nlHsVar a_RDR b_Expr = nlHsVar b_RDR c_Expr = nlHsVar c_RDR @@ -1536,6 +1544,7 @@ gtTag_Expr = nlHsVar gtTag_RDR false_Expr = nlHsVar false_RDR true_Expr = nlHsVar true_RDR +a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat RdrName a_Pat = nlVarPat a_RDR b_Pat = nlVarPat b_RDR c_Pat = nlVarPat c_RDR @@ -1543,12 +1552,13 @@ d_Pat = nlVarPat d_RDR k_Pat = nlVarPat k_RDR z_Pat = nlVarPat z_RDR -con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName +con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName -- Generates Orig s RdrName, for the binding positions con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_" tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_" maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_" +mk_tc_deriv_name :: TyCon -> [Char] -> RdrName mk_tc_deriv_name tycon str = mkDerivedRdrName tc_name mk_occ where @@ -1562,8 +1572,11 @@ s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports PrelNames, so PrelNames can't import PrimOp. \begin{code} +primOpRdrName :: PrimOp -> RdrName primOpRdrName op = getRdrName (primOpId op) +minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, leInt_RDR, + tagToEnum_RDR :: RdrName minusInt_RDR = primOpRdrName IntSubOp eqInt_RDR = primOpRdrName IntEqOp ltInt_RDR = primOpRdrName IntLtOp @@ -1571,5 +1584,6 @@ geInt_RDR = primOpRdrName IntGeOp leInt_RDR = primOpRdrName IntLeOp tagToEnum_RDR = primOpRdrName TagToEnumOp +error_RDR :: RdrName error_RDR = getRdrName eRROR_ID \end{code}