[project @ 2005-08-11 08:04:33 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs
index 8155820..5f186d1 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,
-                         mkFunTy, 
-                         mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys, 
-                         typeKind )
+                         mkFunTy, mkSigmaTy, mkPredTy, mkGenTyConApp, 
+                         mkTyConApp, mkAppTys, typeKind )
 import Kind            ( Kind, isLiftedTypeKind, liftedTypeKind, ubxTupleKind, 
                          openTypeKind, argTypeKind, splitKindFunTys )
 import Id              ( idName )
@@ -51,10 +51,11 @@ import Class                ( Class, classTyCon )
 import Name            ( Name, mkInternalName )
 import OccName         ( mkOccName, tvName )
 import NameSet
+import NameEnv
 import PrelNames       ( genUnitTyConName )
-import TysWiredIn      ( mkListTy, mkPArrTy, mkTupleTy )
+import TysWiredIn      ( mkListTy, listTyCon, mkPArrTy, parrTyCon, tupleTyCon )
 import Bag             ( bagToList )
-import BasicTypes      ( Boxity(..) )
+import BasicTypes      ( Boxity(..), RecFlag )
 import SrcLoc          ( Located(..), unLoc, noLoc, srcSpanStart )
 import UniqSupply      ( uniqsFromSupply )
 import Outputable
@@ -238,9 +239,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
@@ -440,16 +452,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 ->
@@ -576,6 +593,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}
 
 %************************************************************************
@@ -592,8 +611,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      
@@ -744,11 +762,11 @@ tcHsPatSigType ctxt hs_ty
                ; return (tyvars, sig_ty) }
        }
 
-tcAddLetBoundTyVars :: LHsBinds Name -> TcM a -> TcM a
+tcAddLetBoundTyVars :: [(RecFlag,LHsBinds Name)] -> TcM a -> TcM a
 -- Turgid funciton, used for type variables bound by the patterns of a let binding
 
 tcAddLetBoundTyVars binds thing_inside
-  = go (collectSigTysFromHsBinds (bagToList binds)) thing_inside
+  = go (concatMap (collectSigTysFromHsBinds . snd) binds) thing_inside
   where
     go [] thing_inside = thing_inside
     go (hs_ty:hs_tys) thing_inside
@@ -775,7 +793,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
@@ -818,9 +836,8 @@ instance Outputable TcSigInfo where
        = ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau
 
 lookupSig :: [TcSigInfo] -> TcSigFun   -- Search for a particular signature
-lookupSig [] name = Nothing
-lookupSig (sig : sigs) name
-  | name == idName (sig_id sig) = Just sig
-  | otherwise                  = lookupSig sigs name
+lookupSig sigs = lookupNameEnv env
+  where
+    env = mkNameEnv [(idName (sig_id sig), sig) | sig <- sigs]
 \end{code}