[project @ 2003-12-10 17:25:12 by simonmar]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcMType.lhs

diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs
index 7c75d91..41e556a 100644 (file)
--- a/ghc/compiler/typecheck/TcMType.lhs
+++ b/ghc/compiler/typecheck/TcMType.lhs
@@ -14,7 +14,7 @@ module TcMType (
   newTyVar, newSigTyVar,
   newTyVarTy,          -- Kind -> TcM TcType
   newTyVarTys,         -- Int -> Kind -> TcM [TcType]
-  newKindVar, newKindVars, newBoxityVar,
+  newKindVar, newKindVars, newOpenTypeKind,
   putTcTyVar, getTcTyVar,
   newMutTyVar, readMutTyVar, writeMutTyVar, 
 
@@ -24,7 +24,7 @@ module TcMType (
 
   --------------------------------
   -- Checking type validity
-  Rank, UserTypeCtxt(..), checkValidType, pprUserTypeCtxt,
+  Rank, UserTypeCtxt(..), checkValidType, pprHsSigCtxt,
   SourceTyCtxt(..), checkValidTheta, checkFreeness,
   checkValidInstHead, instTypeErr, checkAmbiguity,
   arityErr, 
@@ -43,12 +43,13 @@ module TcMType (
 
 
 -- friends:
+import HsSyn           ( LHsType )
 import TypeRep         ( Type(..), PredType(..), TyNote(..),    -- Friend; can see representation
                          Kind, ThetaType
                        ) 
 import TcType          ( TcType, TcThetaType, TcTauType, TcPredType,
                          TcTyVarSet, TcKind, TcTyVar, TyVarDetails(..),
-                         tcEqType, tcCmpPred, isClassPred,
+                         tcEqType, tcCmpPred, isClassPred, mkTyConApp, typeCon,
                          tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe, 
                          tcSplitTyConApp_maybe, tcSplitForAllTys,
                          tcIsTyVarTy, tcSplitSigmaTy, tcIsTyVarTy,
@@ -61,7 +62,7 @@ import TcType         ( TcType, TcThetaType, TcTauType, TcPredType,
                          superBoxity, liftedBoxity, typeKind,
                          tyVarsOfType, tyVarsOfTypes, 
                          eqKind, isTypeKind, 
-                       )
+                         pprPred, pprTheta, pprClassPred )
 import Subst           ( Subst, mkTopTyVarSubst, substTy )
 import Class           ( Class, classArity, className )
 import TyCon           ( TyCon, isSynTyCon, isUnboxedTupleTyCon, 
@@ -72,12 +73,12 @@ import Var          ( TyVar, tyVarKind, tyVarName, isTyVar,
 -- others:
 import TcRnMonad          -- TcType, amongst others
 import FunDeps         ( grow )
-import PprType         ( pprPred, pprTheta, pprClassPred )
 import Name            ( Name, setNameUnique, mkSystemTvNameEncoded )
 import VarSet
 import CmdLineOpts     ( dopt, DynFlag(..) )
 import Util            ( nOfThem, isSingleton, equalLength, notNull )
 import ListSetOps      ( removeDups )
+import SrcLoc          ( unLoc )
 import Outputable
 \end{code}
 
@@ -132,6 +133,10 @@ newBoxityVar :: TcM TcKind -- Really TcBoxity
     newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("bx")) 
                superBoxity VanillaTv                     `thenM` \ kv ->
     returnM (TyVarTy kv)
+
+newOpenTypeKind :: TcM TcKind
+newOpenTypeKind = newBoxityVar `thenM` \ bx_var ->
+                 returnM (mkTyConApp typeCon [bx_var])
 \end{code}
 
 
@@ -526,16 +531,22 @@ data UserTypeCtxt
 -- With gla-exts that's right, but for H98 we should complain. 
 
 
-pprUserTypeCtxt (FunSigCtxt n)         = ptext SLIT("the type signature for") <+> quotes (ppr n)
-pprUserTypeCtxt ExprSigCtxt            = ptext SLIT("an expression type signature")
-pprUserTypeCtxt (ConArgCtxt c)         = ptext SLIT("the type of constructor") <+> quotes (ppr c)
-pprUserTypeCtxt (TySynCtxt c)          = ptext SLIT("the RHS of a type synonym declaration") <+> quotes (ppr c)
-pprUserTypeCtxt GenPatCtxt             = ptext SLIT("the type pattern of a generic definition")
-pprUserTypeCtxt PatSigCtxt             = ptext SLIT("a pattern type signature")
-pprUserTypeCtxt ResSigCtxt             = ptext SLIT("a result type signature")
-pprUserTypeCtxt (ForSigCtxt n)         = ptext SLIT("the foreign signature for") <+> quotes (ppr n)
-pprUserTypeCtxt (RuleSigCtxt n) = ptext SLIT("the type signature on") <+> quotes (ppr n)
-pprUserTypeCtxt DefaultDeclCtxt = ptext SLIT("a `default' declaration")
+pprHsSigCtxt :: UserTypeCtxt -> LHsType Name -> SDoc
+pprHsSigCtxt ctxt hs_ty = pprUserTypeCtxt (unLoc hs_ty) ctxt
+
+pprUserTypeCtxt ty (FunSigCtxt n)  = sep [ptext SLIT("In the type signature:"), pp_sig n ty]
+pprUserTypeCtxt ty ExprSigCtxt     = sep [ptext SLIT("In an expression type signature:"), nest 2 (ppr ty)]
+pprUserTypeCtxt ty (ConArgCtxt c)  = sep [ptext SLIT("In the type of the constructor"), pp_sig c ty]
+pprUserTypeCtxt ty (TySynCtxt c)   = sep [ptext SLIT("In the RHS of the type synonym") <+> quotes (ppr c) <> comma,
+                                         nest 2 (ptext SLIT(", namely") <+> ppr ty)]
+pprUserTypeCtxt ty GenPatCtxt      = sep [ptext SLIT("In the type pattern of a generic definition:"), nest 2 (ppr ty)]
+pprUserTypeCtxt ty PatSigCtxt      = sep [ptext SLIT("In a pattern type signature:"), nest 2 (ppr ty)]
+pprUserTypeCtxt ty ResSigCtxt      = sep [ptext SLIT("In a result type signature:"), nest 2 (ppr ty)]
+pprUserTypeCtxt ty (ForSigCtxt n)  = sep [ptext SLIT("In the foreign declaration:"), pp_sig n ty]
+pprUserTypeCtxt ty (RuleSigCtxt n) = sep [ptext SLIT("In the type signature:"), pp_sig n ty]
+pprUserTypeCtxt ty DefaultDeclCtxt = sep [ptext SLIT("In a type in a `default' declaration:"), nest 2 (ppr ty)]
+
+pp_sig n ty = nest 2 (ppr n <+> dcolon <+> ppr ty)
 \end{code}
 
 \begin{code}