import Var ( Var, Id, TyVar, tyVarKind )
import VarSet ( TyVarSet )
import Name ( Name, NamedThing(..), BuiltInSyntax(..), mkWiredInName )
-import OccName ( mkOccFS, tcName )
+import OccName ( mkOccNameFS, tcName, parenSymOcc )
import BasicTypes ( IPName, tupleParens )
import TyCon ( TyCon, mkFunTyCon, tyConArity, tupleTyConBoxity, isTupleTyCon, isRecursiveTyCon, isNewTyCon )
import Class ( Class )
Type -- It must be another AppTy, or TyVarTy
-- (or NoteTy of these)
- | TyConApp -- Application of a TyCon, including newtypes
- TyCon -- *Invariant* saturated appliations of FunTyCon and
+ | TyConApp -- Application of a TyCon, including newtypes *and* synonyms
+ TyCon -- *Invariant* saturated appliations of FunTyCon and
-- synonyms have their own constructors, below.
- -- However, *unsaturated* type synonyms, and FunTyCons
- -- do appear as TyConApps. (Unsaturated type synonyms
- -- can appear as the RHS of a type synonym, for exmaple.)
+ -- However, *unsaturated* FunTyCons do appear as TyConApps.
+ --
[Type] -- Might not be saturated.
+ -- Even type synonyms are not necessarily saturated;
+ -- for example unsaturated type synonyms can appear as the
+ -- RHS of a type synonym.
| FunTy -- Special case of TyConApp: TyConApp FunTyCon [t1,t2]
Type
TyNote
Type -- The expanded version
-data TyNote
- = FTVNote TyVarSet -- The free type variables of the noted expression
-
- | SynNote Type -- Used for type synonyms
- -- The Type is always a TyConApp, and is the un-expanded form.
- -- The type to which the note is attached is the expanded form.
+data TyNote = FTVNote TyVarSet -- The free type variables of the noted expression
\end{code}
-------------------------------------
-- a prefix way, thus: (->) Int# Int#. And this is unusual.
funTyConName = mkWiredInName gHC_PRIM
- (mkOccFS tcName FSLIT("(->)"))
+ (mkOccNameFS tcName FSLIT("(->)"))
funTyConKey
Nothing -- No parent object
(ATyCon funTyCon) -- Relevant TyCon
pprPred (IParam ip ty) = ppr ip <> dcolon <> pprType ty
pprClassPred :: Class -> [Type] -> SDoc
-pprClassPred clas tys = ppr clas <+> sep (map pprParendType tys)
+pprClassPred clas tys = parenSymOcc (getOccName clas) (ppr clas)
+ <+> sep (map pprParendType tys)
pprTheta :: ThetaType -> SDoc
pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
-- OK, here's the main printer
ppr_type :: Prec -> Type -> SDoc
-ppr_type p (TyVarTy tv) = ppr tv
-ppr_type p (PredTy pred) = braces (ppr pred)
-ppr_type p (NoteTy (SynNote ty1) ty2) = ppr_type p ty1
-ppr_type p (NoteTy other ty2) = ppr_type p ty2
-
-ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys
+ppr_type p (TyVarTy tv) = ppr tv
+ppr_type p (PredTy pred) = braces (ppr pred)
+ppr_type p (NoteTy other ty2) = ppr_type p ty2
+ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys
ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $
pprType t1 <+> ppr_type TyConPrec t2
+ppr_type p ty@(ForAllTy _ _) = ppr_forall_type p ty
+ppr_type p ty@(FunTy (PredTy _) _) = ppr_forall_type p ty
+
ppr_type p (FunTy ty1 ty2)
= -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
maybeParen p FunPrec $
ppr_fun_tail (FunTy ty1 ty2) = (arrow <+> ppr_type FunPrec ty1) : ppr_fun_tail ty2
ppr_fun_tail other_ty = [arrow <+> pprType other_ty]
-ppr_type p ty@(ForAllTy _ _)
+ppr_forall_type :: Prec -> Type -> SDoc
+ppr_forall_type p ty
= maybeParen p FunPrec $
sep [pprForAll tvs, pprThetaArrow ctxt, pprType tau]
where
(tvs, rho) = split1 [] ty
(ctxt, tau) = split2 [] rho
- split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
- split1 tvs (NoteTy (FTVNote _) ty) = split1 tvs ty
- split1 tvs ty = (reverse tvs, ty)
+ split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
+ split1 tvs (NoteTy _ ty) = split1 tvs ty
+ split1 tvs ty = (reverse tvs, ty)
- split2 ps (NoteTy (FTVNote _) arg -- Rather a disgusting case
+ split2 ps (NoteTy _ arg -- Rather a disgusting case
`FunTy` res) = split2 ps (arg `FunTy` res)
split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty
- split2 ps (NoteTy (FTVNote _) ty) = split2 ps ty
+ split2 ps (NoteTy _ ty) = split2 ps ty
split2 ps ty = (reverse ps, ty)
ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc
ppr_tc tc <+> sep (map (ppr_type TyConPrec) tys)
ppr_tc :: TyCon -> SDoc
-ppr_tc tc
- | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc
- then ptext SLIT("<recnt>")
- else ptext SLIT("<nt>")
- ) <> ppr tc
- | otherwise = ppr tc
-
+ppr_tc tc = parenSymOcc (getOccName tc) (pp_nt_debug <> ppr tc)
+ where
+ pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc
+ then ptext SLIT("<recnt>")
+ else ptext SLIT("<nt>"))
+ | otherwise = empty
+
-------------------
+pprForAll [] = empty
pprForAll tvs = ptext SLIT("forall") <+> sep (map pprTvBndr tvs) <> dot
pprTvBndr tv | isLiftedTypeKind kind = ppr tv