Commit 0656c72a authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Add warning for probable identities (fromIntegral and friends)

See Trac #4488.  The basic idea is to check for

    fun :: ty -> ty

where fun is one of
  toIntegerName     toRationalName
  fromIntegralName  realToFracName

There's a (documented) flag to control it -fwarn-identities.
Currently -Wall switches it on.
parent e21c922f
......@@ -337,8 +337,9 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
= putSrcSpanDs loc $
do { let bndrs' = [var | RuleBndr (L _ var) <- vars]
; lhs' <- unsetOptM Opt_EnableRewriteRules $
dsLExpr lhs -- Note [Desugaring RULE left hand sides]
; lhs' <- unsetOptM Opt_EnableRewriteRules $
unsetOptM Opt_WarnIdentities $
dsLExpr lhs -- Note [Desugaring RULE left hand sides]
; rhs' <- dsLExpr rhs
......@@ -359,6 +360,7 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
; return (Just rule)
} } }
\end{code}
Note [Desugaring RULE left hand sides]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For the LHS of a RULE we do *not* want to desugar
......@@ -369,4 +371,6 @@ switching off EnableRewriteRules. See DsExpr.dsExplicitList.
That keeps the desugaring of list comprehensions simple too.
Nor do we want to warn of conversion identities on the LHS;
the rule is precisly to optimise them:
{-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
......@@ -222,9 +222,13 @@ dsExpr (HsVar var) = return (Var var)
dsExpr (HsIPVar ip) = return (Var (ipNameName ip))
dsExpr (HsLit lit) = dsLit lit
dsExpr (HsOverLit lit) = dsOverLit lit
dsExpr (HsWrap co_fn e) = do { co_fn' <- dsHsWrapper co_fn
; e' <- dsExpr e
; return (co_fn' e') }
dsExpr (HsWrap co_fn e)
= do { co_fn' <- dsHsWrapper co_fn
; e' <- dsExpr e
; warn_id <- doptDs Opt_WarnIdentities
; when warn_id $ warnAboutIdentities e' co_fn'
; return (co_fn' e') }
dsExpr (NegApp expr neg_expr)
= App <$> dsExpr neg_expr <*> dsLExpr expr
......@@ -889,6 +893,36 @@ dsMDo ctxt tbl stmts body result_ty
\end{code}
%************************************************************************
%* *
Warning about identities
%* *
%************************************************************************
Warn about functions that convert between one type and another
when the to- and from- types are the same. Then it's probably
(albeit not definitely) the identity
\begin{code}
warnAboutIdentities :: CoreExpr -> (CoreExpr -> CoreExpr) -> DsM ()
warnAboutIdentities (Var v) co_fn
| idName v `elem` conversionNames
, let fun_ty = exprType (co_fn (Var v))
, Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
, arg_ty `tcEqType` res_ty -- So we are converting ty -> ty
= warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty
, nest 2 $ ptext (sLit "can probably be omitted")
, parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)"))
])
warnAboutIdentities _ _ = return ()
conversionNames :: [Name]
conversionNames
= [ toIntegerName, toRationalName
, fromIntegralName, realToFracName ]
-- We can't easily add fromIntegerName, fromRationalName,
-- becuase they are generated by literals
\end{code}
%************************************************************************
%* *
\subsection{Errors and contexts}
......
......@@ -199,6 +199,7 @@ data DynFlag
| Opt_WarnDodgyImports
| Opt_WarnOrphans
| Opt_WarnAutoOrphans
| Opt_WarnIdentities
| Opt_WarnTabs
| Opt_WarnUnrecognisedPragmas
| Opt_WarnDodgyForeignImports
......@@ -1422,6 +1423,7 @@ fFlags = [
( "warn-deprecations", Opt_WarnWarningsDeprecations, nop ),
( "warn-deprecated-flags", Opt_WarnDeprecatedFlags, nop ),
( "warn-orphans", Opt_WarnOrphans, nop ),
( "warn-identities", Opt_WarnIdentities, nop ),
( "warn-auto-orphans", Opt_WarnAutoOrphans, nop ),
( "warn-tabs", Opt_WarnTabs, nop ),
( "warn-unrecognised-pragmas", Opt_WarnUnrecognisedPragmas, nop ),
......@@ -1735,7 +1737,8 @@ minusWallOpts
Opt_WarnMissingSigs,
Opt_WarnHiShadows,
Opt_WarnOrphans,
Opt_WarnUnusedDoBind
Opt_WarnUnusedDoBind,
Opt_WarnIdentities
]
-- minuswRemovesOpts should be every warning option
......
......@@ -136,9 +136,12 @@ basicKnownKeyNames
traversableClassName,
-- Numeric stuff
negateName, minusName,
fromRationalName, fromIntegerName,
geName, eqName,
negateName, minusName, geName, eqName,
-- Conversion functions
fromRationalName, fromIntegerName,
toIntegerName, toRationalName,
fromIntegralName, realToFracName,
-- String stuff
fromStringName,
......@@ -639,7 +642,7 @@ fstName, sndName :: Name
fstName = varQual dATA_TUPLE (fsLit "fst") fstIdKey
sndName = varQual dATA_TUPLE (fsLit "snd") sndIdKey
-- Module PrelNum
-- Module GHC.Num
numClassName, fromIntegerName, minusName, negateName, plusIntegerName,
timesIntegerName,
integerTyConName, smallIntegerName :: Name
......@@ -652,10 +655,11 @@ timesIntegerName = varQual gHC_INTEGER (fsLit "timesInteger") timesIntegerIdKe
integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey
smallIntegerName = varQual gHC_INTEGER (fsLit "smallInteger") smallIntegerIdKey
-- PrelReal types and classes
-- GHC.Real types and classes
rationalTyConName, ratioTyConName, ratioDataConName, realClassName,
integralClassName, realFracClassName, fractionalClassName,
fromRationalName :: Name
fromRationalName, toIntegerName, toRationalName, fromIntegralName,
realToFracName :: Name
rationalTyConName = tcQual gHC_REAL (fsLit "Rational") rationalTyConKey
ratioTyConName = tcQual gHC_REAL (fsLit "Ratio") ratioTyConKey
ratioDataConName = conName gHC_REAL (fsLit ":%") ratioDataConKey
......@@ -663,7 +667,11 @@ realClassName = clsQual gHC_REAL (fsLit "Real") realClassKey
integralClassName = clsQual gHC_REAL (fsLit "Integral") integralClassKey
realFracClassName = clsQual gHC_REAL (fsLit "RealFrac") realFracClassKey
fractionalClassName = clsQual gHC_REAL (fsLit "Fractional") fractionalClassKey
fromRationalName = methName gHC_REAL (fsLit "fromRational") fromRationalClassOpKey
fromRationalName = methName gHC_REAL (fsLit "fromRational") fromRationalClassOpKey
toIntegerName = methName gHC_REAL (fsLit "toInteger") toIntegerClassOpKey
toRationalName = methName gHC_REAL (fsLit "toRational") toRationalClassOpKey
fromIntegralName = varQual gHC_REAL (fsLit "fromIntegral") fromIntegralIdKey
realToFracName = varQual gHC_REAL (fsLit "realToFrac") realToFracIdKey
-- PrelFloat classes
floatingClassName, realFloatClassName :: Name
......@@ -1286,6 +1294,12 @@ fromStringClassOpKey = mkPreludeMiscIdUnique 125
toAnnotationWrapperIdKey :: Unique
toAnnotationWrapperIdKey = mkPreludeMiscIdUnique 126
-- Conversion functions
fromIntegralIdKey, realToFracIdKey, toIntegerClassOpKey, toRationalClassOpKey :: Unique
fromIntegralIdKey = mkPreludeMiscIdUnique 127
realToFracIdKey = mkPreludeMiscIdUnique 128
toIntegerClassOpKey = mkPreludeMiscIdUnique 129
toRationalClassOpKey = mkPreludeMiscIdUnique 130
---------------- Template Haskell -------------------
-- USES IdUniques 200-399
......
......@@ -1113,6 +1113,14 @@
<entry><option>-fno-warn-hi-shadowing</option></entry>
</row>
<row>
<entry><option>-fwarn-identities</option></entry>
<entry>warn about uses of Prelude numeric conversions that are probably
the identity (and hence could be omitted)</entry>
<entry>dynamic</entry>
<entry><option>-fno-warn-identities</option></entry>
</row>
<row>
<entry><option>-fwarn-implicit-prelude</option></entry>
<entry>warn when the Prelude is implicitly imported</entry>
......
......@@ -1174,6 +1174,21 @@ foreign import "&amp;f" f :: FunPtr t
</listitem>
</varlistentry>
<varlistentry>
<term><option>-fwarn-identities</option>:</term>
<listitem>
<indexterm><primary><option>-fwarn-identities</option></primary></indexterm>
<para>Causes the compiler to emit a warning when a Prelude numeric
conversion converts a type T to the same type T; such calls
are probably no-ops and can be omitted. The functions checked for
are: <literal>toInteger</literal>,
<literal>toRational</literal>,
<literal>fromIntegral</literal>,
and <literal>realToFrac</literal>.
</para>
</listitem>
</varlistentry>
<varlistentry>
<term><option>-fwarn-implicit-prelude</option>:</term>
<listitem>
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment