[project @ 2005-05-13 01:46:20 by dons]

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

diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs
index be08b09..54a909e 100644 (file)
--- a/ghc/compiler/typecheck/TcHsType.lhs
+++ b/ghc/compiler/typecheck/TcHsType.lhs
@@ -24,11 +24,11 @@ module TcHsType (
 #include "HsVersions.h"
 
 import HsSyn           ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr, HsBang,
-                         LHsContext, HsPred(..), LHsPred, LHsBinds,
+                         LHsContext, HsPred(..), LHsPred, LHsBinds, HsExplicitForAll(..),
                          getBangStrictness, collectSigTysFromHsBinds )
 import RnHsSyn         ( extractHsTyVars )
 import TcRnMonad
-import TcEnv           ( tcExtendTyVarEnv, tcExtendKindEnv,
+import TcEnv           ( tcExtendTyVarEnv, tcExtendKindEnvTvs, 
                          tcLookup, tcLookupClass, tcLookupTyCon,
                          TyThing(..), getInLocalScope, wrongThingErr
                        )
@@ -36,12 +36,12 @@ import TcMType              ( newKindVar, newMetaTyVar, zonkTcKindToKind,
                          checkValidType, UserTypeCtxt(..), pprHsSigCtxt
                        )
 import TcUnify         ( unifyFunKind, checkExpectedKind )
+import TcIface         ( checkWiredInTyCon )
 import TcType          ( Type, PredType(..), ThetaType, 
                          MetaDetails(Flexi), hoistForAllTys,
                          TcType, TcTyVar, TcKind, TcThetaType, TcTauType,
-                         mkForAllTys, mkFunTys, tcEqType, isPredTy, mkFunTy, 
-                         mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys, 
-                         tcSplitFunTy_maybe, tcSplitForAllTys, typeKind )
+                         mkFunTy, mkSigmaTy, mkPredTy, mkGenTyConApp, 
+                         mkTyConApp, mkAppTys, typeKind )
 import Kind            ( Kind, isLiftedTypeKind, liftedTypeKind, ubxTupleKind, 
                          openTypeKind, argTypeKind, splitKindFunTys )
 import Id              ( idName )
@@ -52,14 +52,12 @@ import Name         ( Name, mkInternalName )
 import OccName         ( mkOccName, tvName )
 import NameSet
 import PrelNames       ( genUnitTyConName )
-import Type            ( deShadowTy )
-import TysWiredIn      ( mkListTy, mkPArrTy, mkTupleTy )
+import TysWiredIn      ( mkListTy, listTyCon, mkPArrTy, parrTyCon, tupleTyCon )
 import Bag             ( bagToList )
 import BasicTypes      ( Boxity(..) )
 import SrcLoc          ( Located(..), unLoc, noLoc, srcSpanStart )
 import UniqSupply      ( uniqsFromSupply )
 import Outputable
-import List            ( nubBy )
 \end{code}
 
 
@@ -157,6 +155,7 @@ tcHsSigType ctxt hs_ty
        ; ty <- tcHsKindedType kinded_ty
        ; checkValidType ctxt ty        
        ; returnM ty }
+
 -- Used for the deriving(...) items
 tcHsDeriv :: LHsType Name -> TcM ([TyVar], Class, [Type])
 tcHsDeriv = addLocM (tc_hs_deriv [])
@@ -239,9 +238,20 @@ kcCheckHsType :: LHsType Name -> TcKind -> TcM (LHsType Name)
 -- with OpenTypeKind, because it gives better error messages
 kcCheckHsType (L span ty) exp_kind 
   = setSrcSpan span                            $
-    kc_hs_type ty                              `thenM` \ (ty', act_kind) ->
-    checkExpectedKind ty act_kind exp_kind     `thenM_`
-    returnM (L span ty')
+    do { (ty', act_kind) <- add_ctxt ty (kc_hs_type ty)
+               -- Add the context round the inner check only
+               -- because checkExpectedKind already mentions
+               -- 'ty' by name in any error message
+
+       ; checkExpectedKind ty act_kind exp_kind
+       ; return (L span ty') }
+  where
+       -- Wrap a context around only if we want to
+       -- show that contexts.  Omit invisble ones
+       -- and ones user's won't grok (HsPred p).
+    add_ctxt (HsPredTy p)                         thing = thing
+    add_ctxt (HsForAllTy Implicit tvs (L _ []) ty) thing = thing
+    add_ctxt other_ty thing = addErrCtxt (typeCtxt ty) thing
 \end{code}
 
        Here comes the main function
@@ -419,7 +429,9 @@ The type desugarer
        * Zonks any kinds
 
 It cannot fail, and does no validity checking, except for 
-structural matters, such as spurious ! annotations.
+structural matters, such as
+       (a) spurious ! annotations.
+       (b) a class used as a type
 
 \begin{code}
 dsHsType :: LHsType Name -> TcM Type
@@ -439,16 +451,21 @@ ds_type (HsKindSig ty k)
   = dsHsType ty        -- Kind checking done already
 
 ds_type (HsListTy ty)
-  = dsHsType ty                                `thenM` \ tau_ty ->
+  = dsHsType ty                        `thenM` \ tau_ty ->
+    checkWiredInTyCon listTyCon        `thenM_`
     returnM (mkListTy tau_ty)
 
 ds_type (HsPArrTy ty)
-  = dsHsType ty                                `thenM` \ tau_ty ->
+  = dsHsType ty                        `thenM` \ tau_ty ->
+    checkWiredInTyCon parrTyCon        `thenM_`
     returnM (mkPArrTy tau_ty)
 
 ds_type (HsTupleTy boxity tys)
-  = dsHsTypes tys                      `thenM` \ tau_tys ->
-    returnM (mkTupleTy boxity (length tys) tau_tys)
+  = dsHsTypes tys              `thenM` \ tau_tys ->
+    checkWiredInTyCon tycon    `thenM_`
+    returnM (mkTyConApp tycon tau_tys)
+  where
+    tycon = tupleTyCon boxity (length tys)
 
 ds_type (HsFunTy ty1 ty2)
   = dsHsType ty1                       `thenM` \ tau_ty1 ->
@@ -500,9 +517,9 @@ ds_var_app :: Name -> [Type] -> TcM Type
 ds_var_app name arg_tys 
  = tcLookup name                       `thenM` \ thing ->
     case thing of
-       ATyVar _ ty          -> returnM (mkAppTys ty arg_tys)
-       AGlobal (ATyCon tc)  -> returnM (mkGenTyConApp tc arg_tys)
-       other -> pprPanic "ds_app_type" (ppr name <+> ppr arg_tys)
+       ATyVar _ ty         -> returnM (mkAppTys ty arg_tys)
+       AGlobal (ATyCon tc) -> returnM (mkGenTyConApp tc arg_tys)
+       other               -> wrongThingErr "type" thing name
 \end{code}
 
 
@@ -575,6 +592,8 @@ gadtSigCtxt ty
 badGadtDecl ty
   = hang (ptext SLIT("Malformed constructor signature:"))
        2 (ppr ty)
+
+typeCtxt ty = ptext SLIT("In the type") <+> quotes (ppr ty)
 \end{code}
 
 %************************************************************************
@@ -591,8 +610,7 @@ kcHsTyVars :: [LHsTyVarBndr Name]
           -> TcM r
 kcHsTyVars tvs thing_inside 
   = mappM (wrapLocM kcHsTyVar) tvs     `thenM` \ bndrs ->
-    tcExtendKindEnv [(n,k) | L _ (KindedTyVar n k) <- bndrs]
-                   (thing_inside bndrs)
+    tcExtendKindEnvTvs bndrs (thing_inside bndrs)
 
 kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name)
        -- Return a *kind-annotated* binder, and a tyvar with a mutable kind in it      
@@ -774,7 +792,7 @@ been instantiated.
 \begin{code}
 data TcSigInfo
   = TcSigInfo {
-       sig_id     :: TcId,             -- *Polymorphic* binder for this value...
+       sig_id     :: TcId,             --  *Polymorphic* binder for this value...
 
        sig_scoped :: [Name],           -- Names for any scoped type variables
                                        -- Invariant: correspond 1-1 with an initial