X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsExpr.lhs;h=e79ce7ff3c21709b03afcfc01761559dfa5cae26;hb=5723262f616ac02ddf637f6ff480a599c737ea0d;hp=9df432b989ee4938e5b644edbe11851d066db6f3;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;p=ghc-hetmet.git

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 9df432b..e79ce7f 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -52,7 +52,6 @@ import CostCentre
 import Id
 import Var
 import VarSet
-import PrelInfo
 import DataCon
 import TysWiredIn
 import BasicTypes
@@ -223,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
@@ -346,8 +349,14 @@ dsExpr (HsDo PArrComp stmts body result_ty)
   where
     [elt_ty] = tcTyConAppArgs result_ty
 
-dsExpr (HsIf guard_expr then_expr else_expr)
-  = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr
+dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
+  = do { pred <- dsLExpr guard_expr
+       ; b1 <- dsLExpr then_expr
+       ; b2 <- dsLExpr else_expr
+       ; case mb_fun of
+           Just fun -> do { core_fun <- dsExpr fun
+                          ; return (mkCoreApps core_fun [pred,b1,b2]) }
+           Nothing  -> return $ mkIfThenElse pred b1 b2 }
 \end{code}
 
 
@@ -886,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}
 %*									*
 %************************************************************************