[commit: ghc] master: Make a variant of mkCastErr for kind coercions (18cedbb)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/18cedbb55c7a0bdbfade4d28d3bb8927277df8d8/ghc

>---------------------------------------------------------------

commit 18cedbb55c7a0bdbfade4d28d3bb8927277df8d8
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Fri Jul 6 10:53:00 2018 -0400

    Make a variant of mkCastErr for kind coercions
    
    Summary:
    I discovered when debugging #15346 that the Core Lint error
    message for ill typed casts always mentions types of enclosed
    //expressions//, even if the thing being casted is actually a type.
    This generalizes `mkCastErr` a bit to allow it to give the proper
    labelling for kind coercions.
    
    Test Plan: Run on failing program in #15346, read the Core Lint error
    
    Reviewers: goldfire, bgamari, simonpj
    
    Reviewed By: simonpj
    
    Subscribers: simonpj, rwbarton, thomie, carter
    
    Differential Revision: https://phabricator.haskell.org/D4940


>---------------------------------------------------------------

18cedbb55c7a0bdbfade4d28d3bb8927277df8d8
 compiler/coreSyn/CoreLint.hs | 32 +++++++++++++++++++++++++-------
 1 file changed, 25 insertions(+), 7 deletions(-)

diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index fb421a1..d2724ba 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -1370,7 +1370,7 @@ lintType ty@(LitTy l) = lintTyLit l >> return (typeKind ty)
 lintType (CastTy ty co)
   = do { k1 <- lintType ty
        ; (k1', k2) <- lintStarCoercion co
-       ; ensureEqTys k1 k1' (mkCastErr ty co k1' k1)
+       ; ensureEqTys k1 k1' (mkCastTyErr ty co k1' k1)
        ; return k2 }
 
 lintType (CoercionTy co)
@@ -2477,14 +2477,32 @@ mkArityMsg binder
          ]
            where (StrictSig dmd_ty) = idStrictness binder
 -}
-mkCastErr :: Outputable casted => casted -> Coercion -> Type -> Type -> MsgDoc
-mkCastErr expr co from_ty expr_ty
-  = vcat [text "From-type of Cast differs from type of enclosed expression",
-          text "From-type:" <+> ppr from_ty,
-          text "Type of enclosed expr:" <+> ppr expr_ty,
-          text "Actual enclosed expr:" <+> ppr expr,
+mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc
+mkCastErr expr = mk_cast_err "expression" "type" (ppr expr)
+
+mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> MsgDoc
+mkCastTyErr ty = mk_cast_err "type" "kind" (ppr ty)
+
+mk_cast_err :: String -- ^ What sort of casted thing this is
+                      --   (\"expression\" or \"type\").
+            -> String -- ^ What sort of coercion is being used
+                      --   (\"type\" or \"kind\").
+            -> SDoc   -- ^ The thing being casted.
+            -> Coercion -> Type -> Type -> MsgDoc
+mk_cast_err thing_str co_str pp_thing co from_ty thing_ty
+  = vcat [from_msg <+> text "of Cast differs from" <+> co_msg
+            <+> text "of" <+> enclosed_msg,
+          from_msg <> colon <+> ppr from_ty,
+          text (capitalise co_str) <+> text "of" <+> enclosed_msg <> colon
+            <+> ppr thing_ty,
+          text "Actual" <+> enclosed_msg <> colon <+> pp_thing,
           text "Coercion used in cast:" <+> ppr co
          ]
+  where
+    co_msg, from_msg, enclosed_msg :: SDoc
+    co_msg       = text co_str
+    from_msg     = text "From-" <> co_msg
+    enclosed_msg = text "enclosed" <+> text thing_str
 
 mkBadUnivCoMsg :: LeftOrRight -> Coercion -> SDoc
 mkBadUnivCoMsg lr co