Move custom rendering for `ErrorMessage` to Type.hs

2 files changed, 38 insertions, 36 deletions

diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index d83a0dd68b..5fdd7def0d 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -28,12 +28,7 @@ import TcEvidence
 import Name
 import RdrName ( lookupGRE_Name, GlobalRdrEnv, mkRdrUnqual )
 import Class( className )
-import PrelNames( typeableClassName
-                , typeErrorTextDataConName
-                , typeErrorShowTypeDataConName
-                , typeErrorAppendDataConName
-                , typeErrorVAppendDataConName
-                )
+import PrelNames( typeableClassName )
 import Id
 import Var
 import VarSet
@@ -450,38 +445,11 @@ mkUserTypeErrorReporter ctxt
 
 mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg
 mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct
-                        $ renderUserTypeError
+                        $ pprUserTypeErrorTy
                         $ case getUserTypeErrorMsg ct of
                             Just (_,msg) -> msg
                             Nothing      -> pprPanic "mkUserTypeError" (ppr ct)
 
--- | Render a type corresponding to a user type error into a SDoc.
-renderUserTypeError :: Type -> SDoc
-renderUserTypeError ty =
-  case splitTyConApp_maybe ty of
-
-    -- Text "Something"
-    Just (tc,[txt])
-      | tyConName tc == typeErrorTextDataConName
-      , Just str <- isStrLitTy txt -> ftext str
-
-    -- ShowType t
-    Just (tc,[_k,t])
-      | tyConName tc == typeErrorShowTypeDataConName -> ppr t
-
-    -- t1 :<>: t2
-    Just (tc,[t1,t2])
-      | tyConName tc == typeErrorAppendDataConName ->
-        renderUserTypeError t1 <> renderUserTypeError t2
-
-    -- t1 :$$: t2
-    Just (tc,[t1,t2])
-      | tyConName tc == typeErrorVAppendDataConName ->
-        renderUserTypeError t1 $$ renderUserTypeError t2
-
-    -- An uneavaluated type function
-    _ -> ppr ty
-
 
 mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)
                              -- Make error message for a group
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index b4da6af669..3bb3856fb9 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -38,7 +38,7 @@ module Type (
         mkNumLitTy, isNumLitTy,
         mkStrLitTy, isStrLitTy,
 
-        isUserErrorTy,
+        isUserErrorTy, pprUserTypeErrorTy,
 
         coAxNthLHS,
 
@@ -167,7 +167,12 @@ import {-# SOURCE #-} TysWiredIn ( eqTyCon, coercibleTyCon, typeNatKind, typeSym
 import PrelNames ( eqTyConKey, coercibleTyConKey,
                    ipTyConKey, openTypeKindTyConKey,
                    constraintKindTyConKey, liftedTypeKindTyConKey,
-                   errorMessageTypeErrorFamName )
+                   errorMessageTypeErrorFamName,
+                   typeErrorTextDataConName,
+                   typeErrorShowTypeDataConName,
+                   typeErrorAppendDataConName,
+                   typeErrorVAppendDataConName
+                )
 import CoAxiom
 
 -- others
@@ -458,6 +463,35 @@ isUserErrorTy t = do (tc,[k,msg]) <- splitTyConApp_maybe t
                      guard (tyConName tc == errorMessageTypeErrorFamName)
                      return (k,msg)
 
+-- | Render a type corresponding to a user type error into a SDoc.
+pprUserTypeErrorTy :: Type -> SDoc
+pprUserTypeErrorTy ty =
+  case splitTyConApp_maybe ty of
+
+    -- Text "Something"
+    Just (tc,[txt])
+      | tyConName tc == typeErrorTextDataConName
+      , Just str <- isStrLitTy txt -> ftext str
+
+    -- ShowType t
+    Just (tc,[_k,t])
+      | tyConName tc == typeErrorShowTypeDataConName -> ppr t
+
+    -- t1 :<>: t2
+    Just (tc,[t1,t2])
+      | tyConName tc == typeErrorAppendDataConName ->
+        pprUserTypeErrorTy t1 <> pprUserTypeErrorTy t2
+
+    -- t1 :$$: t2
+    Just (tc,[t1,t2])
+      | tyConName tc == typeErrorVAppendDataConName ->
+        pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2
+
+    -- An uneavaluated type function
+    _ -> ppr ty
+
+
+
 
 {-
 ---------------------------------------------------------------------