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.

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index e5d763c..073e873 100644 (file)
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -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 #-}

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 5df12f5..e79ce7f 100644 (file)
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -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
@@ -891,6 +895,36 @@ dsMDo ctxt tbl stmts body result_ty
 
 %************************************************************************
 %*                                                                     *
+                 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}
 %*                                                                     *
 %************************************************************************

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 00eb543..513c97f 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -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

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index e2e2dfe..40910f6 100644 (file)
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -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

diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index 8482a7c..c24d021 100644 (file)
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -1114,6 +1114,14 @@
          </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>
             <entry>dynamic</entry>

diff --git a/docs/users_guide/using.xml b/docs/users_guide/using.xml
index be82322..22c8861 100644 (file)
--- a/docs/users_guide/using.xml
+++ b/docs/users_guide/using.xml
@@ -1175,6 +1175,21 @@ foreign import "&f" f :: FunPtr t
       </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>
           <indexterm><primary><option>-fwarn-implicit-prelude</option></primary></indexterm>