Commit ac41c500 authored by simonpj's avatar simonpj

[project @ 2003-11-03 16:00:57 by simonpj]

Wibbles to pretty printing of types
parent a16253b8
......@@ -85,6 +85,7 @@ module TcType (
-- Rexported from Type
Kind, -- Stuff to do with kinds is insensitive to pre/post Tc
unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, isSuperKind,
superBoxity, liftedBoxity, hasMoreBoxityInfo, defaultKind, superKind,
isTypeKind, isAnyTypeKind, typeCon,
......@@ -120,6 +121,8 @@ import Type ( -- Re-exports
tyVarsOfTheta, Kind, Type, PredType(..),
ThetaType, unliftedTypeKind, typeCon,
liftedTypeKind, openTypeKind, mkArrowKind,
isLiftedTypeKind, isUnliftedTypeKind,
isOpenTypeKind, isSuperKind,
mkArrowKinds, mkForAllTy, mkForAllTys,
defaultKind, isTypeKind, isAnyTypeKind,
mkFunTy, mkFunTys, zipFunTys,
......
......@@ -30,7 +30,7 @@ module TcUnify (
import HsSyn ( HsExpr(..) )
import TcHsSyn ( mkHsLet,
ExprCoFn, idCoercion, isIdCoercion, mkCoercion, (<.>), (<$>) )
import TypeRep ( Type(..), PredType(..), TyNote(..), typeCon, openKindCon )
import TypeRep ( Type(..), PredType(..), TyNote(..), typeCon, openKindCon, isSuperKind )
import TcRnMonad -- TcType, amongst others
import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType,
......@@ -43,7 +43,7 @@ import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType,
isSkolemTyVar, isUserTyVar,
tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars,
eqKind, openTypeKind, liftedTypeKind, isTypeKind, mkArrowKind,
hasMoreBoxityInfo, allDistinctTyVars, pprType )
hasMoreBoxityInfo, allDistinctTyVars, pprType, pprKind )
import Inst ( newDicts, instToId, tcInstCall )
import TcMType ( getTcTyVar, putTcTyVar, tcInstType, newKindVar,
newTyVarTy, newTyVarTys, newOpenTypeKind,
......@@ -992,6 +992,8 @@ unifyMisMatch ty1 ty2
zonkTcType ty2 `thenM` \ ty2' ->
let
(env, [tidy_ty1, tidy_ty2]) = tidyOpenTypes emptyTidyEnv [ty1',ty2']
ppr | isSuperKind (typeKind ty1) = pprKind
| otherwise = pprType
msg = hang (ptext SLIT("Couldn't match"))
4 (sep [quotes (ppr tidy_ty1),
ptext SLIT("against"),
......
......@@ -15,6 +15,7 @@ module Type (
openKindCon, -- :: KX
typeCon, -- :: BX -> KX
liftedTypeKind, unliftedTypeKind, openTypeKind, -- :: KX
isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, isSuperKind,
mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX
isTypeKind, isAnyTypeKind,
funTyCon,
......
......@@ -17,7 +17,7 @@ module TypeRep (
openKindCon, -- :: KX
typeCon, -- :: BX -> KX
liftedTypeKind, unliftedTypeKind, openTypeKind, -- :: KX
isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, isSuperKind,
mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX
funTyCon,
......@@ -362,7 +362,7 @@ isOpenTypeKind (TyConApp tc []) = tyConName tc == openKindConName
isOpenTypeKind other = False
isSuperKind (TyConApp tc []) = tyConName tc == superKindName
isSuperTypeKind other = False
isSuperKind other = False
\end{code}
------------------------------------------
......@@ -522,11 +522,13 @@ ppr_type p ty@(ForAllTy _ _)
(tvs, rho) = split1 [] ty
(ctxt, tau) = split2 [] rho
split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
split1 tvs ty = (reverse tvs, ty)
split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
split1 tvs (NoteTy (FTVNote _) ty) = split1 tvs ty
split1 tvs ty = (reverse tvs, ty)
split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty
split2 ps ty = (reverse ps, ty)
split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty
split2 ps (NoteTy (FTVNote _) ty) = split2 ps ty
split2 ps ty = (reverse ps, ty)
ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc
ppr_tc_app p tc []
......
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