X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=e79ce7ff3c21709b03afcfc01761559dfa5cae26;hp=5df12f592dc40c4e1e03fc4a3e4135efbcec7d56;hb=0656c72a8f4fda30c348bdf40449d105e4ce00ce;hpb=e21c922fcdd1dac193bd8ff5670787daa3c21a12

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 5df12f5..e79ce7f 100644
--- 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}
 %*									*
 %************************************************************************