\begin{code}
module TcHsType (
- tcHsSigType, tcHsDeriv,
+ tcHsSigType, tcHsSigTypeNC, tcHsDeriv,
tcHsInstHead, tcHsQuantifiedType,
UserTypeCtxt(..),
#include "HsVersions.h"
+#ifdef GHCI /* Only if bootstrapped */
+import {-# SOURCE #-} TcSplice( kcSpliceType )
+#endif
+
import HsSyn
import RnHsSyn
import TcRnMonad
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}
%************************************************************************
\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 }
; 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
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
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}
-- 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,
<+> 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),