Define DsUtils.mkCastDs and use it

This change avoids a spurious WARNing from mkCast.  In the output of
the desugarer (only, I think) we can have a cast where the type of the
expression and cast don't syntactically match, because of an enclosing
type-let binding.

3 files changed, 31 insertions, 12 deletions

diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index e5c787a478..b6edf7c35f 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -798,7 +798,7 @@ dsHsWrapper (WpFun c1 c2 t1 _) e = do { x <- newSysLocalDs t1
                                       ; e2 <- dsHsWrapper c2 (e `mkCoreAppDs` e1)
                                       ; return (Lam x e2) }
 dsHsWrapper (WpCast co)       e = ASSERT(tcCoercionRole co == Representational)
-                                  dsTcCoercion co (mkCast e)
+                                  dsTcCoercion co (mkCastDs e)
 dsHsWrapper (WpEvLam ev)      e = return $ Lam ev e
 dsHsWrapper (WpTyLam tv)      e = return $ Lam tv e
 dsHsWrapper (WpEvApp    tm)   e = liftM (App e) (dsEvTerm tm)
@@ -839,7 +839,7 @@ dsEvTerm (EvId v) = return (Var v)
 
 dsEvTerm (EvCast tm co)
   = do { tm' <- dsEvTerm tm
-       ; dsTcCoercion co $ mkCast tm' }
+       ; dsTcCoercion co $ mkCastDs tm' }
                         -- 'v' is always a lifted evidence variable so it is
                         -- unnecessary to call varToCoreExpr v here.
 
@@ -920,7 +920,7 @@ dsEvTypeable ev =
                 $ mkLams [mkWildValBinder proxyT] (Var repName)
 
      -- package up the method as `Typeable` dictionary
-     return $ mkCast method $ mkSymCo $ getTypeableCo tyCl ty
+     return $ mkCastDs method $ mkSymCo $ getTypeableCo tyCl ty
 
   where
   -- co: method -> Typeable k t
@@ -933,7 +933,7 @@ dsEvTypeable ev =
   getRep tc (ev,t) =
     do typeableExpr <- dsEvTerm ev
        let co     = getTypeableCo tc t
-           method = mkCast typeableExpr co
+           method = mkCastDs typeableExpr co
            proxy  = mkTyApps (Var proxyHashId) [typeKind t, t]
        return (mkApps method [proxy])
 
@@ -1042,7 +1042,7 @@ dsEvCallStack cs = do
                   -- so we use unwrapIP to strip the dictionary wrapper
                   -- See Note [Overview of implicit CallStacks]
                   let ip_co = unwrapIP (exprType tmExpr)
-                  return (pushCS nameExpr locExpr (mkCast tmExpr ip_co))
+                  return (pushCS nameExpr locExpr (mkCastDs tmExpr ip_co))
   case cs of
     EvCsTop name loc tm -> mkPush name loc tm
     EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm
diff --git a/compiler/deSugar/DsCCall.hs b/compiler/deSugar/DsCCall.hs
index 19ac062ce9..26551b58fa 100644
--- a/compiler/deSugar/DsCCall.hs
+++ b/compiler/deSugar/DsCCall.hs
@@ -21,7 +21,7 @@ module DsCCall
 import CoreSyn
 
 import DsMonad
-
+import DsUtils( mkCastDs )
 import CoreUtils
 import MkCore
 import Var
@@ -138,7 +138,7 @@ unboxArg arg
 
   -- Recursive newtypes
   | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty
-  = unboxArg (mkCast arg co)
+  = unboxArg (mkCastDs arg co)
 
   -- Booleans
   | Just tc <- tyConAppTyCon_maybe arg_ty,
@@ -338,7 +338,7 @@ resultWrapper result_ty
   -- Newtypes
   | Just (co, rep_ty) <- topNormaliseNewType_maybe result_ty
   = do (maybe_ty, wrapper) <- resultWrapper rep_ty
-       return (maybe_ty, \e -> mkCast (wrapper e) (mkSymCo co))
+       return (maybe_ty, \e -> mkCastDs (wrapper e) (mkSymCo co))
 
   -- The type might contain foralls (eg. for dummy type arguments,
   -- referring to 'Ptr a' is legal).
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
index f94b831a6f..819944312b 100644
--- a/compiler/deSugar/DsUtils.hs
+++ b/compiler/deSugar/DsUtils.hs
@@ -24,7 +24,7 @@ module DsUtils (
         mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,
         wrapBind, wrapBinds,
 
-        mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs,
+        mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,
 
         seqVar,
 
@@ -44,6 +44,7 @@ import {-# SOURCE #-}   Match ( matchSimply )
 
 import HsSyn
 import TcHsSyn
+import Coercion( Coercion, isReflCo )
 import TcType( tcSplitTyConApp )
 import CoreSyn
 import DsMonad
@@ -549,10 +550,22 @@ mkCoreAppDs fun arg = mkCoreApp fun arg  -- The rest is done in MkCore
 mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr
 mkCoreAppsDs fun args = foldl mkCoreAppDs fun args
 
+mkCastDs :: CoreExpr -> Coercion -> CoreExpr
+-- We define a desugarer-specific verison of CoreUtils.mkCast,
+-- because in the immediate output of the desugarer, we can have
+-- apparently-mis-matched coercions:  E.g.
+--     let a = b
+--     in (x :: a) |> (co :: b ~ Int)
+-- Lint know about type-bindings for let and does not complain
+-- So here we do not make the assertion checks that we make in
+-- CoreUtils.mkCast; and we do less peephole optimisation too
+mkCastDs e co | isReflCo co = e
+              | otherwise   = Cast e co
+
 {-
 ************************************************************************
 *                                                                      *
-\subsection[mkSelectorBind]{Make a selector bind}
+               Tuples and selector bindings
 *                                                                      *
 ************************************************************************
 
@@ -720,7 +733,7 @@ mkBigLHsPatTup = mkChunkified mkLHsPatTup
 {-
 ************************************************************************
 *                                                                      *
-\subsection[mkFailurePair]{Code for pattern-matching and other failures}
+        Code for pattern-matching and other failures
 *                                                                      *
 ************************************************************************
 
@@ -805,7 +818,13 @@ entered at most once.  Adding a dummy 'realWorld' token argument makes
 it clear that sharing is not an issue.  And that in turn makes it more
 CPR-friendly.  This matters a lot: if you don't get it right, you lose
 the tail call property.  For example, see Trac #3403.
--}
+
+
+************************************************************************
+*                                                                      *
+              Ticks
+*                                                                      *
+********************************************************************* -}
 
 mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr
 mkOptTickBox = flip (foldr Tick)