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 ...@@ -898,9 +898,12 @@ isLexConSym cs -- Infix type or data constructors
| otherwise = startsConSym (headFS cs) | otherwise = startsConSym (headFS cs)
isLexVarSym fs -- Infix identifiers e.g. "+" isLexVarSym fs -- Infix identifiers e.g. "+"
| fs == (fsLit "~R#") = True
| otherwise
= case (if nullFS fs then [] else unpackFS fs) of = case (if nullFS fs then [] else unpackFS fs) of
[] -> False [] -> False
(c:cs) -> startsVarSym c && all isVarSymChar cs (c:cs) -> startsVarSym c && all isVarSymChar cs
-- See Note [Classification of generated names]
------------- -------------
startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool
......
...@@ -217,7 +217,7 @@ mkCast expr co ...@@ -217,7 +217,7 @@ mkCast expr co
-- if to_ty `eqType` from_ty -- if to_ty `eqType` from_ty
-- then expr -- then expr
-- else -- 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) (Cast expr co)
\end{code} \end{code}
......
...@@ -121,7 +121,7 @@ ppr_expr add_par (Cast expr co) ...@@ -121,7 +121,7 @@ ppr_expr add_par (Cast expr co)
if gopt Opt_SuppressCoercions dflags if gopt Opt_SuppressCoercions dflags
then ptext (sLit "...") then ptext (sLit "...")
else parens $ else parens $
sep [ppr co, dcolon <+> pprEqPred (coercionKind co)] sep [ppr co, dcolon <+> ppr (coercionType co)]
ppr_expr add_par expr@(Lam _ _) ppr_expr add_par expr@(Lam _ _)
......
...@@ -159,7 +159,15 @@ mkPrimTc fs unique tycon ...@@ -159,7 +159,15 @@ mkPrimTc fs unique tycon
= mkWiredInName gHC_PRIM (mkTcOccFS fs) = mkWiredInName gHC_PRIM (mkTcOccFS fs)
unique unique
(ATyCon tycon) -- Relevant TyCon (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, 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 charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
...@@ -176,7 +184,7 @@ statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey stat ...@@ -176,7 +184,7 @@ statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey stat
voidPrimTyConName = mkPrimTc (fsLit "Void#") voidPrimTyConKey voidPrimTyCon voidPrimTyConName = mkPrimTc (fsLit "Void#") voidPrimTyConKey voidPrimTyCon
proxyPrimTyConName = mkPrimTc (fsLit "Proxy#") proxyPrimTyConKey proxyPrimTyCon proxyPrimTyConName = mkPrimTc (fsLit "Proxy#") proxyPrimTyConKey proxyPrimTyCon
eqPrimTyConName = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon eqPrimTyConName = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon
eqReprPrimTyConName = mkPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon eqReprPrimTyConName = mkBuiltInPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon
realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon
arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon
byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon
......
...@@ -88,8 +88,8 @@ opt_co env sym co ...@@ -88,8 +88,8 @@ opt_co env sym co
= pprTrace "opt_co {" (ppr sym <+> ppr co $$ ppr env) $ = pprTrace "opt_co {" (ppr sym <+> ppr co $$ ppr env) $
co1 `seq` co1 `seq`
pprTrace "opt_co done }" (ppr co1) $ pprTrace "opt_co done }" (ppr co1) $
(WARN( not same_co_kind, ppr co <+> dcolon <+> pprEqPred (Pair s1 t1) (WARN( not same_co_kind, ppr co <+> dcolon <+> ppr (coercionType co)
$$ ppr co1 <+> dcolon <+> pprEqPred (Pair s2 t2) ) $$ ppr co1 <+> dcolon <+> ppr (coercionType co1) )
WARN( not (coreEqCoercion co1 simple_result), WARN( not (coreEqCoercion co1 simple_result),
(text "env=" <+> ppr env) $$ (text "env=" <+> ppr env) $$
(text "input=" <+> ppr co) $$ (text "input=" <+> ppr co) $$
......
...@@ -130,7 +130,7 @@ module Type ( ...@@ -130,7 +130,7 @@ module Type (
-- * Pretty-printing -- * Pretty-printing
pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing,
pprTvBndr, pprTvBndrs, pprForAll, pprUserForAll, pprSigmaType, pprTvBndr, pprTvBndrs, pprForAll, pprUserForAll, pprSigmaType,
pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred, pprTheta, pprThetaArrowTy, pprClassPred,
pprKind, pprParendKind, pprSourceTyCon, pprKind, pprParendKind, pprSourceTyCon,
-- * Tidying type related things up for printing -- * Tidying type related things up for printing
......
...@@ -39,7 +39,7 @@ module TypeRep ( ...@@ -39,7 +39,7 @@ module TypeRep (
-- Pretty-printing -- Pretty-printing
pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs, pprType, pprParendType, pprTypeApp, pprTvBndr, pprTvBndrs,
pprTyThing, pprTyThingCategory, pprSigmaType, pprTyThing, pprTyThingCategory, pprSigmaType,
pprEqPred, pprTheta, pprForAll, pprUserForAll, pprTheta, pprForAll, pprUserForAll,
pprThetaArrowTy, pprClassPred, pprThetaArrowTy, pprClassPred,
pprKind, pprParendKind, pprTyLit, suppressKinds, pprKind, pprParendKind, pprTyLit, suppressKinds,
TyPrec(..), maybeParen, pprTcApp, TyPrec(..), maybeParen, pprTcApp,
...@@ -82,7 +82,6 @@ import CoAxiom ...@@ -82,7 +82,6 @@ import CoAxiom
import PrelNames import PrelNames
import Outputable import Outputable
import FastString import FastString
import Pair
import Util import Util
import DynFlags import DynFlags
...@@ -515,18 +514,6 @@ pprKind, pprParendKind :: Kind -> SDoc ...@@ -515,18 +514,6 @@ pprKind, pprParendKind :: Kind -> SDoc
pprKind = pprType pprKind = pprType
pprParendKind = pprParendType 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 :: Class -> [Type] -> SDoc
pprClassPred clas tys = pprTypeApp (classTyCon clas) tys pprClassPred clas tys = pprTypeApp (classTyCon clas) tys
......
...@@ -13,8 +13,7 @@ Roles13.convert = ...@@ -13,8 +13,7 @@ Roles13.convert =
`cast` (<Roles13.Wrap Roles13.Age>_R `cast` (<Roles13.Wrap Roles13.Age>_R
-> Roles13.NTCo:Wrap[0] Roles13.NTCo:Age[0] -> Roles13.NTCo:Wrap[0] Roles13.NTCo:Age[0]
:: (Roles13.Wrap Roles13.Age -> Roles13.Wrap Roles13.Age) :: (Roles13.Wrap Roles13.Age -> Roles13.Wrap Roles13.Age)
~# ~R# (Roles13.Wrap Roles13.Age -> GHC.Types.Int))
(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