[commit: ghc] wip/custom-type-errors: Refactor to avoid code duplication; rendering is now a pure function. (3a68b8b)
git at git.haskell.org
git at git.haskell.org
Sat Oct 31 19:16:51 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/custom-type-errors
Link : http://ghc.haskell.org/trac/ghc/changeset/3a68b8bb8b8f193430cdd131382366600a4b78c3/ghc
>---------------------------------------------------------------
commit 3a68b8bb8b8f193430cdd131382366600a4b78c3
Author: Iavor S. Diatchki <iavor.diatchki at gmail.com>
Date: Sat Oct 31 12:16:47 2015 -0700
Refactor to avoid code duplication; rendering is now a pure function.
>---------------------------------------------------------------
3a68b8bb8b8f193430cdd131382366600a4b78c3
compiler/typecheck/TcErrors.hs | 84 ++++++++++++++++-------------------------
compiler/typecheck/TcRnTypes.hs | 23 ++++++-----
2 files changed, 47 insertions(+), 60 deletions(-)
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index 6aca014..c60406b 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -33,7 +33,6 @@ import PrelNames( typeableClassName
, typeErrorShowTypeDataConName
, typeErrorAppendDataConName
, typeErrorVAppendDataConName
- , errorMessageTypeErrorFamName
)
import Id
import Var
@@ -51,7 +50,7 @@ import DynFlags
import StaticFlags ( opt_PprStyle_Debug )
import ListSetOps ( equivClasses )
-import Control.Monad ( when, liftM2, guard )
+import Control.Monad ( when )
import Data.Maybe
import Data.List ( partition, mapAccumL, nub, sortBy )
@@ -450,55 +449,38 @@ mkUserTypeErrorReporter ctxt
= mapM_ $ \ct -> maybeReportError ctxt =<< mkUserTypeError ctxt ct
mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg
-mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct =<< render msgT
- where
- ctT = ctPred ct
- getMsg t = do (tc,[_,msg]) <- splitTyConApp_maybe t
- guard (tyConName tc == errorMessageTypeErrorFamName)
- return msg
-
- msgT -- TypeError msg ~ Something
- | Just (_,t1,_) <- getEqPredTys_maybe ctT
- , Just msg <- getMsg t1 = msg
-
- -- Something ~ TypeError msg
- | Just (_,_,t2) <- getEqPredTys_maybe ctT
- , Just msg <- getMsg t2 = msg
-
- | Just (_,ts) <- getClassPredTys_maybe ctT
- , msg : _ <- mapMaybe getMsg ts = msg
-
- -- TypeError msg
- | Just msg <- getMsg ctT = msg
-
- | otherwise = pprPanic "mkUserTypeError" (ppr ctT)
-
-
-
- render ty = case splitTyConApp_maybe ty of
-
- -- Text "Something"
- Just (tc,[txt])
- | tyConName tc == typeErrorTextDataConName
- , Just str <- isStrLitTy txt -> return (ftext str)
-
- -- ShowType t
- Just (tc,[_k,t])
- | tyConName tc == typeErrorShowTypeDataConName ->
- return (ppr t)
-
- -- t1 :<>: t2
- Just (tc,[t1,t2])
- | tyConName tc == typeErrorAppendDataConName ->
- liftM2 (<>) (render t1) (render t2)
-
- -- t1 :$$: t2
- Just (tc,[t1,t2])
- | tyConName tc == typeErrorVAppendDataConName ->
- liftM2 ($$) (render t1) (render t2)
-
- -- An uneavaluated type function
- _ -> return (ppr ty)
+mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct
+ $ renderUserTypeError
+ $ 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)
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 8212d0c..232f9df 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -61,7 +61,7 @@ module TcRnTypes(
isCDictCan_Maybe, isCFunEqCan_maybe,
isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt,
isGivenCt, isHoleCt, isOutOfScopeCt, isExprHoleCt, isTypeHoleCt,
- isUserTypeErrorCt,
+ isUserTypeErrorCt, getUserTypeErrorMsg,
ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin,
mkNonCanonical, mkNonCanonicalCt,
ctEvPred, ctEvLoc, ctEvOrigin, ctEvEqRel,
@@ -148,7 +148,7 @@ import GHC.Fingerprint
import PrelNames(errorMessageTypeErrorFamName)
import Data.Set (Set)
-import Control.Monad (ap, liftM)
+import Control.Monad (ap, liftM, guard, msum)
#ifdef GHCI
import Data.Map ( Map )
@@ -1447,17 +1447,22 @@ isTypeHoleCt _ = False
-- 1. TypeError msg
-- 2. TypeError msg ~ Something (and the other way around)
-- 3. C (TypeError msg) (for any parameter of class constraint)
-isUserTypeErrorCt :: Ct -> Bool
-isUserTypeErrorCt ct
- | Just (_,t1,t2) <- getEqPredTys_maybe ctT = isTyErr t1 || isTyErr t2
- | Just (_,ts) <- getClassPredTys_maybe ctT = any isTyErr ts
+getUserTypeErrorMsg :: Ct -> Maybe Type
+getUserTypeErrorMsg ct
+ | Just (_,t1,t2) <- getEqPredTys_maybe ctT = oneOf [t1,t2]
+ | Just (_,ts) <- getClassPredTys_maybe ctT = oneOf ts
| otherwise = isTyErr ctT
where
ctT = ctPred ct
- isTyErr t = case splitTyConApp_maybe t of
- Just (tc,_) -> tyConName tc == errorMessageTypeErrorFamName
- _ -> False
+ isTyErr t = do (tc,[_,msg]) <- splitTyConApp_maybe t
+ guard (tyConName tc == errorMessageTypeErrorFamName)
+ return msg
+ oneOf xs = msum (map isTyErr xs)
+isUserTypeErrorCt :: Ct -> Bool
+isUserTypeErrorCt ct = case getUserTypeErrorMsg ct of
+ Just _ -> True
+ _ -> False
instance Outputable Ct where
ppr ct = ppr (cc_ev ct) <+> parens (text ct_sort)
More information about the ghc-commits
mailing list