Add warning for probable identities (fromIntegral and friends)

[ghc-hetmet.git] / compiler / deSugar / DsExpr.lhs

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}
 %*                                                                     *
 %************************************************************************