Commit e79e2c39 authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu
Browse files

Fix #9062.

Removed (pprEqPred (coercionKind co)) in favor of
(pprType (coercionType co)).

Also had to make "~R#" a *symbolic* identifier and BuiltInSyntax
to squelch prefix notation and module prefixes in output. These
changes are both sensible independent of #9062.
parent 6a1d7f97
......@@ -898,9 +898,12 @@ isLexConSym cs -- Infix type or data constructors
| otherwise = startsConSym (headFS cs)
isLexVarSym fs -- Infix identifiers e.g. "+"
| fs == (fsLit "~R#") = True
| otherwise
= case (if nullFS fs then [] else unpackFS fs) of
[] -> False
(c:cs) -> startsVarSym c && all isVarSymChar cs
-- See Note [Classification of generated names]
-------------
startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool
......
......@@ -217,7 +217,7 @@ mkCast expr co
-- if to_ty `eqType` from_ty
-- then expr
-- else
WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co))
WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionType co))
(Cast expr co)
\end{code}
......
......@@ -121,7 +121,7 @@ ppr_expr add_par (Cast expr co)
if gopt Opt_SuppressCoercions dflags
then ptext (sLit "...")
else parens $
sep [ppr co, dcolon <+> pprEqPred (coercionKind co)]
sep [ppr co, dcolon <+> ppr (coercionType co)]
ppr_expr add_par expr@(Lam _ _)
......
......@@ -159,7 +159,15 @@ mkPrimTc fs unique tycon
= mkWiredInName gHC_PRIM (mkTcOccFS fs)
unique
(ATyCon tycon) -- Relevant TyCon
UserSyntax -- None are built-in syntax
UserSyntax
mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name
mkBuiltInPrimTc fs unique tycon
= mkWiredInName gHC_PRIM (mkTcOccFS fs)
unique
(ATyCon tycon) -- Relevant TyCon
BuiltInSyntax
charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, voidPrimTyConName :: Name
charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
......@@ -176,7 +184,7 @@ statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey stat
voidPrimTyConName = mkPrimTc (fsLit "Void#") voidPrimTyConKey voidPrimTyCon
proxyPrimTyConName = mkPrimTc (fsLit "Proxy#") proxyPrimTyConKey proxyPrimTyCon
eqPrimTyConName = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon
eqReprPrimTyConName = mkPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon
eqReprPrimTyConName = mkBuiltInPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon
realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon
arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon
byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon
......
......@@ -88,8 +88,8 @@ opt_co env sym co
= pprTrace "opt_co {" (ppr sym <+> ppr co $$ ppr env) $
co1 `seq`
pprTrace "opt_co done }" (ppr co1) $
(WARN( not same_co_kind, ppr co <+> dcolon <+> pprEqPred (Pair s1 t1)
$$ ppr co1 <+> dcolon <+> pprEqPred (Pair s2 t2) )
(WARN( not same_co_kind, ppr co <+> dcolon <+> ppr (coercionType co)
$$ ppr co1 <+> dcolon <+> ppr (coercionType co1) )
WARN( not (coreEqCoercion co1 simple_result),
(text "env=" <+> ppr env) $$
(text "input=" <+> ppr co) $$
......
......@@ -130,7 +130,7 @@ module Type (
-- * Pretty-printing
pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing,
pprTvBndr, pprTvBndrs, pprForAll, pprUserForAll, pprSigmaType,
pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred,
pprTheta, pprThetaArrowTy, pprClassPred,
pprKind, pprParendKind, pprSourceTyCon,
-- * Tidying type related things up for printing
......
......@@ -39,7 +39,7 @@ module TypeRep (
-- Pretty-printing
pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs,
pprTyThing, pprTyThingCategory, pprSigmaType,
pprEqPred, pprTheta, pprForAll, pprUserForAll,
pprTheta, pprForAll, pprUserForAll,
pprThetaArrowTy, pprClassPred,
pprKind, pprParendKind, pprTyLit, suppressKinds,
TyPrec(..), maybeParen, pprTcApp,
......@@ -82,7 +82,6 @@ import CoAxiom
import PrelNames
import Outputable
import FastString
import Pair
import Util
import DynFlags
......@@ -515,18 +514,6 @@ pprKind, pprParendKind :: Kind -> SDoc
pprKind = pprType
pprParendKind = pprParendType
------------------
pprEqPred :: Pair Type -> SDoc
-- NB: Maybe move to Coercion? It's only called after coercionKind anyway.
pprEqPred (Pair ty1 ty2)
= sep [ ppr_type FunPrec ty1
, nest 2 (ptext (sLit "~#"))
, ppr_type FunPrec ty2]
-- Precedence looks like (->) so that we get
-- Maybe a ~ Bool
-- (a->a) ~ Bool
-- Note parens on the latter!
------------
pprClassPred :: Class -> [Type] -> SDoc
pprClassPred clas tys = pprTypeApp (classTyCon clas) tys
......
......@@ -13,8 +13,7 @@ Roles13.convert =
`cast` (<Roles13.Wrap Roles13.Age>_R
-> Roles13.NTCo:Wrap[0] Roles13.NTCo:Age[0]
:: (Roles13.Wrap Roles13.Age -> Roles13.Wrap Roles13.Age)
~#
(Roles13.Wrap Roles13.Age -> GHC.Types.Int))
~R# (Roles13.Wrap Roles13.Age -> GHC.Types.Int))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment