X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsType.lhs;h=77fefc2dbc37a1613a88e118bb8d9525e2072a56;hp=b7cbc1ec75179a523274e1ec3c5124238fcf8a3b;hb=1e436f2bb208a6c990743afaf17b7c2a93c31742;hpb=9a4ef343a46e823bcf949af8501c13cc8ca98fb1

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index b7cbc1e..77fefc2 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -6,7 +6,7 @@
 
 \begin{code}
 module TcHsType (
-	tcHsSigType, tcHsDeriv, 
+	tcHsSigType, tcHsSigTypeNC, tcHsDeriv, 
 	tcHsInstHead, tcHsQuantifiedType,
 	UserTypeCtxt(..), 
 
@@ -25,6 +25,10 @@ module TcHsType (
 
 #include "HsVersions.h"
 
+#ifdef GHCI 	/* Only if bootstrapped */
+import {-# SOURCE #-}	TcSplice( kcSpliceType )
+#endif
+
 import HsSyn
 import RnHsSyn
 import TcRnMonad
@@ -35,21 +39,20 @@ import TcIface
 import TcType
 import {- Kind parts of -} Type
 import Var
+import VarSet
 import Coercion
 import TyCon
 import Class
 import Name
-import OccName
 import NameSet
 import PrelNames
 import TysWiredIn
 import BasicTypes
 import SrcLoc
+import Util
 import UniqSupply
 import Outputable
 import FastString
-
-import Control.Monad
 \end{code}
 
 
@@ -136,14 +139,19 @@ the TyCon being defined.
 %************************************************************************
 
 \begin{code}
-tcHsSigType :: UserTypeCtxt -> LHsType Name -> TcM Type
+tcHsSigType, tcHsSigTypeNC :: UserTypeCtxt -> LHsType Name -> TcM Type
   -- Do kind checking, and hoist for-alls to the top
   -- NB: it's important that the foralls that come from the top-level
   --	 HsForAllTy in hs_ty occur *first* in the returned type.
   --     See Note [Scoped] with TcSigInfo
 tcHsSigType ctxt hs_ty 
   = addErrCtxt (pprHsSigCtxt ctxt hs_ty) $
-    do	{ kinded_ty <- kcTypeType hs_ty
+    tcHsSigTypeNC ctxt hs_ty
+
+tcHsSigTypeNC ctxt hs_ty
+  = do	{ (kinded_ty, _kind) <- kc_lhs_type hs_ty
+    	  -- The kind is checked by checkValidType, and isn't necessarily
+	  -- of kind * in a Template Haskell quote eg [t| Maybe |]
 	; ty <- tcHsKindedType kinded_ty
 	; checkValidType ctxt ty	
 	; return ty }
@@ -395,12 +403,22 @@ kc_hs_type (HsForAllTy exp tv_names context ty)
 
   	; return (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind) }
 
-kc_hs_type (HsBangTy b ty) = do
-    (ty', kind) <- kc_lhs_type ty
-    return (HsBangTy b ty', kind)
+kc_hs_type (HsBangTy b ty)
+  = do { (ty', kind) <- kc_lhs_type ty
+       ; return (HsBangTy b ty', kind) }
+
+kc_hs_type ty@(HsRecTy _)
+  = failWithTc (ptext (sLit "Unexpected record type") <+> ppr ty)
+      -- Record types (which only show up temporarily in constructor signatures) 
+      -- should have been removed by now
+
+#ifdef GHCI	/* Only if bootstrapped */
+kc_hs_type (HsSpliceTy sp) = kcSpliceType sp
+#else
+kc_hs_type ty@(HsSpliceTy {}) = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty)
+#endif
 
-kc_hs_type ty@(HsSpliceTy _)
-  = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty)
+kc_hs_type (HsSpliceTyOut {}) = panic "kc_hs_type"	-- Should not happen at all
 
 -- remove the doc nodes here, no need to worry about the location since
 -- its the same for a doc node and it's child type node
@@ -542,9 +560,12 @@ ds_type ty@(HsTyVar _)
 ds_type (HsParTy ty)		-- Remove the parentheses markers
   = dsHsType ty
 
-ds_type ty@(HsBangTy _ _)	-- No bangs should be here
+ds_type ty@(HsBangTy {})    -- No bangs should be here
   = failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty)
 
+ds_type ty@(HsRecTy {})	    -- No bangs should be here
+  = failWithTc (ptext (sLit "Unexpected record type:") <+> ppr ty)
+
 ds_type (HsKindSig ty _)
   = dsHsType ty	-- Kind checking done already
 
@@ -593,11 +614,15 @@ ds_type (HsForAllTy _ tv_names ctxt ty)
     tau <- dsHsType ty
     return (mkSigmaTy tyvars theta tau)
 
-ds_type (HsSpliceTy {}) = panic "ds_type: HsSpliceTy"
-
 ds_type (HsDocTy ty _)  -- Remove the doc comment
   = dsHsType ty
 
+ds_type (HsSpliceTyOut kind) 
+  = do { kind' <- zonkTcKindToKind kind
+       ; newFlexiTyVarTy kind' }
+
+ds_type (HsSpliceTy {}) = panic "ds_type"
+
 dsHsTypes :: [LHsType Name] -> TcM [Type]
 dsHsTypes arg_tys = mapM dsHsType arg_tys
 \end{code}
@@ -874,6 +899,16 @@ tcPatSig ctxt sig res_ty
 	  	-- Check that pat_ty is rigid
 	; checkTc (isRigidTy res_ty) (wobblyPatSig sig_tvs)
 
+		-- Check that all newly-in-scope tyvars are in fact
+		-- constrained by the pattern.  This catches tiresome
+		-- cases like	
+		--	type T a = Int
+		--	f :: Int -> Int
+		-- 	f (x :: T a) = ...
+		-- Here 'a' doesn't get a binding.  Sigh
+	; let bad_tvs = filterOut (`elemVarSet` exactTyVarsOfType sig_ty) sig_tvs
+	; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs)
+
 		-- Now match the pattern signature against res_ty
 		-- For convenience, and uniform-looking error messages
 		-- we do the matching by allocating meta type variables, 
@@ -1024,6 +1059,15 @@ wobblyPatSig sig_tvs
 		<+> pprQuotedList sig_tvs)
        2 (ptext (sLit "unless the pattern has a rigid type context"))
 		
+badPatSigTvs :: TcType -> [TyVar] -> SDoc
+badPatSigTvs sig_ty bad_tvs
+  = vcat [ fsep [ptext (sLit "The type variable") <> plural bad_tvs, 
+                 quotes (pprWithCommas ppr bad_tvs), 
+          	 ptext (sLit "should be bound by the pattern signature") <+> quotes (ppr sig_ty),
+	  	 ptext (sLit "but are actually discarded by a type synonym") ]
+         , ptext (sLit "To fix this, expand the type synonym") 
+         , ptext (sLit "[Note: I hope to lift this restriction in due course]") ]
+
 scopedNonVar :: Name -> Type -> SDoc
 scopedNonVar n ty
   = vcat [sep [ptext (sLit "The scoped type variable") <+> quotes (ppr n),