Three improvements to Template Haskell (fixes #3467)

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

diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index a63c2ce..77fefc2 100644 (file)
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -39,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}
 
 
@@ -416,9 +415,11 @@ kc_hs_type ty@(HsRecTy _)
 #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)
+kc_hs_type ty@(HsSpliceTy {}) = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty)
 #endif
 
+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
 kc_hs_type (HsDocTy ty _)
@@ -613,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}
@@ -894,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, 
@@ -1044,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),