[commit: ghc] wip/custom-type-errors: Move recognition of `TypeError msg` to Type.hs (cfc359e)

[git at git.haskell.org]

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

On branch  : wip/custom-type-errors
Link       : http://ghc.haskell.org/trac/ghc/changeset/cfc359e1fdf8137a2ff6fec99acb17202c1a5802/ghc

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

commit cfc359e1fdf8137a2ff6fec99acb17202c1a5802
Author: Iavor S. Diatchki <iavor.diatchki at gmail.com>
Date:   Sat Oct 31 12:48:24 2015 -0700

    Move recognition of `TypeError msg` to Type.hs


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

cfc359e1fdf8137a2ff6fec99acb17202c1a5802
 compiler/typecheck/TcErrors.hs  |  4 ++--
 compiler/typecheck/TcRnTypes.hs | 10 +++-------
 compiler/types/Type.hs          | 14 +++++++++++++-
 3 files changed, 18 insertions(+), 10 deletions(-)

diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index c60406b..d83a0dd 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -452,8 +452,8 @@ mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg
 mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct
                         $ renderUserTypeError
                         $ case getUserTypeErrorMsg ct of
-                            Just msg -> msg
-                            Nothing  -> pprPanic "mkUserTypeError" (ppr ct)
+                            Just (_,msg) -> msg
+                            Nothing      -> pprPanic "mkUserTypeError" (ppr ct)
 
 -- | Render a type corresponding to a user type error into a SDoc.
 renderUserTypeError :: Type -> SDoc
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 232f9df..9e51a9b 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -145,7 +145,6 @@ import Outputable
 import ListSetOps
 import FastString
 import GHC.Fingerprint
-import PrelNames(errorMessageTypeErrorFamName)
 
 import Data.Set (Set)
 import Control.Monad (ap, liftM, guard, msum)
@@ -1447,17 +1446,14 @@ isTypeHoleCt _ = False
 --    1. TypeError msg
 --    2. TypeError msg ~ Something  (and the other way around)
 --    3. C (TypeError msg)          (for any parameter of class constraint)
-getUserTypeErrorMsg :: Ct -> Maybe Type
+getUserTypeErrorMsg :: Ct -> Maybe (Kind, Type)
 getUserTypeErrorMsg ct
   | Just (_,t1,t2) <- getEqPredTys_maybe ctT    = oneOf [t1,t2]
   | Just (_,ts)    <- getClassPredTys_maybe ctT = oneOf ts
-  | otherwise                                   = isTyErr ctT
+  | otherwise                                   = isUserErrorTy ctT
   where
   ctT       = ctPred ct
-  isTyErr t = do (tc,[_,msg]) <- splitTyConApp_maybe t
-                 guard (tyConName tc == errorMessageTypeErrorFamName)
-                 return msg
-  oneOf xs  = msum (map isTyErr xs)
+  oneOf xs  = msum (map isUserErrorTy xs)
 
 isUserTypeErrorCt :: Ct -> Bool
 isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index a2feeef..b4da6af 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -38,6 +38,8 @@ module Type (
         mkNumLitTy, isNumLitTy,
         mkStrLitTy, isStrLitTy,
 
+        isUserErrorTy,
+
         coAxNthLHS,
 
         -- (Newtypes)
@@ -164,7 +166,8 @@ import TysPrim
 import {-# SOURCE #-} TysWiredIn ( eqTyCon, coercibleTyCon, typeNatKind, typeSymbolKind )
 import PrelNames ( eqTyConKey, coercibleTyConKey,
                    ipTyConKey, openTypeKindTyConKey,
-                   constraintKindTyConKey, liftedTypeKindTyConKey )
+                   constraintKindTyConKey, liftedTypeKindTyConKey,
+                   errorMessageTypeErrorFamName )
 import CoAxiom
 
 -- others
@@ -447,6 +450,15 @@ isStrLitTy ty | Just ty1 <- tcView ty = isStrLitTy ty1
 isStrLitTy (LitTy (StrTyLit s)) = Just s
 isStrLitTy _                    = Nothing
 
+
+-- | Is this type a custom user error?
+-- If so, give us the kind and the error message.
+isUserErrorTy :: Type -> Maybe (Kind,Type)
+isUserErrorTy t = do (tc,[k,msg]) <- splitTyConApp_maybe t
+                     guard (tyConName tc == errorMessageTypeErrorFamName)
+                     return (k,msg)
+
+
 {-
 ---------------------------------------------------------------------
                                 FunTy