-
+%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcMonoType]{Typechecking user-specified @MonoTypes@}
\begin{code}
module TcHsType (
- tcHsSigType, tcHsDeriv,
+ tcHsSigType, tcHsDeriv,
+ tcHsInstHead, tcHsQuantifiedType,
UserTypeCtxt(..),
-- Kind checking
#include "HsVersions.h"
-import HsSyn ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr,
- LHsContext, HsPred(..), LHsPred, HsExplicitForAll(..) )
-import RnHsSyn ( extractHsTyVars )
+import HsSyn
+import RnHsSyn
import TcRnMonad
-import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnvTvs,
- tcLookup, tcLookupClass, tcLookupTyCon,
- TyThing(..), getInLocalScope, getScopedTyVarBinds,
- wrongThingErr
- )
-import TcMType ( newKindVar,
- zonkTcKindToKind,
- tcInstBoxyTyVar, readFilledBox,
- checkValidType
- )
-import TcUnify ( boxyUnify, unifyFunKind, checkExpectedKind )
-import TcIface ( checkWiredInTyCon )
-import TcType ( Type, PredType(..), ThetaType, BoxySigmaType,
- TcType, TcKind, isRigidTy,
- UserTypeCtxt(..), pprUserTypeCtxt,
- substTyWith, mkTyVarTys, tcEqType,
- tcIsTyVarTy, mkFunTy, mkSigmaTy, mkPredTy,
- mkTyConApp, mkAppTys, typeKind )
-import Kind ( Kind, isLiftedTypeKind, liftedTypeKind, ubxTupleKind,
- openTypeKind, argTypeKind, splitKindFunTys )
-import Var ( TyVar, mkTyVar, tyVarName )
-import TyCon ( TyCon, tyConKind )
-import Class ( Class, classTyCon )
-import Name ( Name, mkInternalName )
-import OccName ( mkOccName, tvName )
+import TcEnv
+import TcMType
+import TcUnify
+import TcIface
+import TcType
+import {- Kind parts of -} Type
+import Var
+import TyCon
+import Class
+import Name
+import OccName
import NameSet
-import PrelNames ( genUnitTyConName )
-import TysWiredIn ( mkListTy, listTyCon, mkPArrTy, parrTyCon, tupleTyCon )
-import BasicTypes ( Boxity(..) )
-import SrcLoc ( Located(..), unLoc, noLoc, getLoc, srcSpanStart )
-import UniqSupply ( uniqsFromSupply )
+import PrelNames
+import TysWiredIn
+import BasicTypes
+import SrcLoc
+import UniqSupply
import Outputable
+import FastString
+
+import Control.Monad
\end{code}
do { kinded_ty <- kcTypeType hs_ty
; ty <- tcHsKindedType kinded_ty
; checkValidType ctxt ty
- ; returnM ty }
+ ; return ty }
+
+tcHsInstHead :: LHsType Name -> TcM ([TyVar], ThetaType, Type)
+-- Typecheck an instance head. We can't use
+-- tcHsSigType, because it's not a valid user type.
+tcHsInstHead hs_ty
+ = do { kinded_ty <- kcHsSigType hs_ty
+ ; poly_ty <- tcHsKindedType kinded_ty
+ ; return (tcSplitSigmaTy poly_ty) }
+
+tcHsQuantifiedType :: [LHsTyVarBndr Name] -> LHsType Name -> TcM ([TyVar], Type)
+-- Behave very like type-checking (HsForAllTy sig_tvs hs_ty),
+-- except that we want to keep the tvs separate
+tcHsQuantifiedType tv_names hs_ty
+ = kcHsTyVars tv_names $ \ tv_names' ->
+ do { kc_ty <- kcHsSigType hs_ty
+ ; tcTyVarBndrs tv_names' $ \ tvs ->
+ do { ty <- dsHsType kc_ty
+ ; return (tvs, ty) } }
-- Used for the deriving(...) items
-tcHsDeriv :: LHsType Name -> TcM ([TyVar], Class, [Type])
-tcHsDeriv = addLocM (tc_hs_deriv [])
+tcHsDeriv :: HsType Name -> TcM ([TyVar], Class, [Type])
+tcHsDeriv = tc_hs_deriv []
+tc_hs_deriv :: [LHsTyVarBndr Name] -> HsType Name
+ -> TcM ([TyVar], Class, [Type])
tc_hs_deriv tv_names (HsPredTy (HsClassP cls_name hs_tys))
= kcHsTyVars tv_names $ \ tv_names' ->
do { cls_kind <- kcClass cls_name
- ; (tys, res_kind) <- kcApps cls_kind (ppr cls_name) hs_tys
+ ; (tys, _res_kind) <- kcApps cls_kind (ppr cls_name) hs_tys
; tcTyVarBndrs tv_names' $ \ tyvars ->
do { arg_tys <- dsHsTypes tys
; cls <- tcLookupClass cls_name
tc_hs_deriv (tv_names1 ++ tv_names2) ty
tc_hs_deriv _ other
- = failWithTc (ptext SLIT("Illegal deriving item") <+> ppr other)
+ = failWithTc (ptext (sLit "Illegal deriving item") <+> ppr other)
\end{code}
These functions are used during knot-tying in
tcHsBangType :: LHsType Name -> TcM Type
-- Permit a bang, but discard it
-tcHsBangType (L span (HsBangTy b ty)) = tcHsKindedType ty
-tcHsBangType ty = tcHsKindedType ty
+tcHsBangType (L _ (HsBangTy _ ty)) = tcHsKindedType ty
+tcHsBangType ty = tcHsKindedType ty
tcHsKindedContext :: LHsContext Name -> TcM ThetaType
-- Used when we are expecting a ClassContext (i.e. no implicit params)
-- Does not do validity checking, like tcHsKindedType
-tcHsKindedContext hs_theta = addLocM (mappM dsHsLPred) hs_theta
+tcHsKindedContext hs_theta = addLocM (mapM dsHsLPred) hs_theta
\end{code}
; return (L span ty') }
where
-- Wrap a context around only if we want to show that contexts.
+ add_ctxt (HsPredTy _) thing = thing
-- Omit invisble ones and ones user's won't grok (HsPred p).
- add_ctxt (HsPredTy p) thing = thing
- add_ctxt (HsForAllTy Implicit tvs (L _ []) (L _ ty)) thing = add_ctxt ty thing
- add_ctxt other_ty thing = addErrCtxt (typeCtxt ty) thing
+ add_ctxt (HsForAllTy _ _ (L _ []) _) thing = thing
+ -- Omit wrapping if the theta-part is empty
+ -- Reason: the recursive call to kcLiftedType, in the ForAllTy
+ -- case of kc_hs_type, will do the wrapping instead
+ -- and we don't want to duplicate
+ add_ctxt other_ty thing = addErrCtxt (typeCtxt other_ty) thing
-- We infer the kind of the type, and then complain if it's
-- not right. But we don't want to complain about
--
-- The translated type has explicitly-kinded type-variable binders
-kc_hs_type (HsParTy ty)
- = kcHsType ty `thenM` \ (ty', kind) ->
- returnM (HsParTy ty', kind)
+kc_hs_type :: HsType Name -> TcM (HsType Name, TcKind)
+kc_hs_type (HsParTy ty) = do
+ (ty', kind) <- kcHsType ty
+ return (HsParTy ty', kind)
-kc_hs_type (HsTyVar name)
- = kcTyVar name `thenM` \ kind ->
- returnM (HsTyVar name, kind)
+kc_hs_type (HsTyVar name) = do
+ kind <- kcTyVar name
+ return (HsTyVar name, kind)
-kc_hs_type (HsListTy ty)
- = kcLiftedType ty `thenM` \ ty' ->
- returnM (HsListTy ty', liftedTypeKind)
+kc_hs_type (HsListTy ty) = do
+ ty' <- kcLiftedType ty
+ return (HsListTy ty', liftedTypeKind)
-kc_hs_type (HsPArrTy ty)
- = kcLiftedType ty `thenM` \ ty' ->
- returnM (HsPArrTy ty', liftedTypeKind)
+kc_hs_type (HsPArrTy ty) = do
+ ty' <- kcLiftedType ty
+ return (HsPArrTy ty', liftedTypeKind)
kc_hs_type (HsNumTy n)
- = returnM (HsNumTy n, liftedTypeKind)
-
-kc_hs_type (HsKindSig ty k)
- = kcCheckHsType ty k `thenM` \ ty' ->
- returnM (HsKindSig ty' k, k)
-
-kc_hs_type (HsTupleTy Boxed tys)
- = mappM kcLiftedType tys `thenM` \ tys' ->
- returnM (HsTupleTy Boxed tys', liftedTypeKind)
-
-kc_hs_type (HsTupleTy Unboxed tys)
- = mappM kcTypeType tys `thenM` \ tys' ->
- returnM (HsTupleTy Unboxed tys', ubxTupleKind)
-
-kc_hs_type (HsFunTy ty1 ty2)
- = kcCheckHsType ty1 argTypeKind `thenM` \ ty1' ->
- kcTypeType ty2 `thenM` \ ty2' ->
- returnM (HsFunTy ty1' ty2', liftedTypeKind)
-
-kc_hs_type ty@(HsOpTy ty1 op ty2)
- = addLocM kcTyVar op `thenM` \ op_kind ->
- kcApps op_kind (ppr op) [ty1,ty2] `thenM` \ ([ty1',ty2'], res_kind) ->
- returnM (HsOpTy ty1' op ty2', res_kind)
-
-kc_hs_type ty@(HsAppTy ty1 ty2)
- = kcHsType fun_ty `thenM` \ (fun_ty', fun_kind) ->
- kcApps fun_kind (ppr fun_ty) arg_tys `thenM` \ ((arg_ty':arg_tys'), res_kind) ->
- returnM (foldl mk_app (HsAppTy fun_ty' arg_ty') arg_tys', res_kind)
+ = return (HsNumTy n, liftedTypeKind)
+
+kc_hs_type (HsKindSig ty k) = do
+ ty' <- kcCheckHsType ty k
+ return (HsKindSig ty' k, k)
+
+kc_hs_type (HsTupleTy Boxed tys) = do
+ tys' <- mapM kcLiftedType tys
+ return (HsTupleTy Boxed tys', liftedTypeKind)
+
+kc_hs_type (HsTupleTy Unboxed tys) = do
+ tys' <- mapM kcTypeType tys
+ return (HsTupleTy Unboxed tys', ubxTupleKind)
+
+kc_hs_type (HsFunTy ty1 ty2) = do
+ ty1' <- kcCheckHsType ty1 argTypeKind
+ ty2' <- kcTypeType ty2
+ return (HsFunTy ty1' ty2', liftedTypeKind)
+
+kc_hs_type (HsOpTy ty1 op ty2) = do
+ op_kind <- addLocM kcTyVar op
+ ([ty1',ty2'], res_kind) <- kcApps op_kind (ppr op) [ty1,ty2]
+ return (HsOpTy ty1' op ty2', res_kind)
+
+kc_hs_type (HsAppTy ty1 ty2) = do
+ (fun_ty', fun_kind) <- kcHsType fun_ty
+ ((arg_ty':arg_tys'), res_kind) <- kcApps fun_kind (ppr fun_ty) arg_tys
+ return (foldl mk_app (HsAppTy fun_ty' arg_ty') arg_tys', res_kind)
where
(fun_ty, arg_tys) = split ty1 [ty2]
split (L _ (HsAppTy f a)) as = split f (a:as)
split f as = (f,as)
mk_app fun arg = HsAppTy (noLoc fun) arg -- Add noLocs for inner nodes of
- -- the application; they are never used
-
-kc_hs_type (HsPredTy pred)
- = kcHsPred pred `thenM` \ pred' ->
- returnM (HsPredTy pred', liftedTypeKind)
+ -- the application; they are
+ -- never used
+
+kc_hs_type (HsPredTy (HsEqualP _ _))
+ = wrongEqualityErr
+
+kc_hs_type (HsPredTy pred) = do
+ pred' <- kcHsPred pred
+ return (HsPredTy pred', liftedTypeKind)
kc_hs_type (HsForAllTy exp tv_names context ty)
- = kcHsTyVars tv_names $ \ tv_names' ->
- kcHsContext context `thenM` \ ctxt' ->
- kcLiftedType ty `thenM` \ ty' ->
- -- The body of a forall is usually a type, but in principle
- -- there's no reason to prohibit *unlifted* types.
- -- In fact, GHC can itself construct a function with an
- -- unboxed tuple inside a for-all (via CPR analyis; see
- -- typecheck/should_compile/tc170)
- --
- -- Still, that's only for internal interfaces, which aren't
- -- kind-checked, so we only allow liftedTypeKind here
- returnM (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind)
-
-kc_hs_type (HsBangTy b ty)
- = do { (ty', kind) <- kcHsType ty
- ; return (HsBangTy b ty', kind) }
+ = kcHsTyVars tv_names $ \ tv_names' ->
+ do { ctxt' <- kcHsContext context
+ ; ty' <- kcLiftedType ty
+ -- The body of a forall is usually a type, but in principle
+ -- there's no reason to prohibit *unlifted* types.
+ -- In fact, GHC can itself construct a function with an
+ -- unboxed tuple inside a for-all (via CPR analyis; see
+ -- typecheck/should_compile/tc170)
+ --
+ -- Still, that's only for internal interfaces, which aren't
+ -- kind-checked, so we only allow liftedTypeKind here
+
+ ; return (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind) }
+
+kc_hs_type (HsBangTy b ty) = do
+ (ty', kind) <- kcHsType ty
+ return (HsBangTy b ty', kind)
kc_hs_type ty@(HsSpliceTy _)
- = failWithTc (ptext SLIT("Unexpected type splice:") <+> ppr ty)
+ = failWithTc (ptext (sLit "Unexpected type splice:") <+> ppr ty)
+-- 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 _)
+ = kc_hs_type (unLoc ty)
---------------------------
kcApps :: TcKind -- Function kind
-> SDoc -- Function
-> [LHsType Name] -- Arg types
-> TcM ([LHsType Name], TcKind) -- Kind-checked args
-kcApps fun_kind ppr_fun args
- = split_fk fun_kind (length args) `thenM` \ (arg_kinds, res_kind) ->
- zipWithM kc_arg args arg_kinds `thenM` \ args' ->
- returnM (args', res_kind)
+kcApps fun_kind ppr_fun args = do
+ (arg_kinds, res_kind) <- split_fk fun_kind (length args)
+ args' <- zipWithM kc_arg args arg_kinds
+ return (args', res_kind)
where
- split_fk fk 0 = returnM ([], fk)
- split_fk fk n = unifyFunKind fk `thenM` \ mb_fk ->
- case mb_fk of
- Nothing -> failWithTc too_many_args
- Just (ak,fk') -> split_fk fk' (n-1) `thenM` \ (aks, rk) ->
- returnM (ak:aks, rk)
+ split_fk fk 0 = return ([], fk)
+ split_fk fk n = do mb_fk <- unifyFunKind fk
+ case mb_fk of
+ Nothing -> failWithTc too_many_args
+ Just (ak,fk') -> do (aks, rk) <- split_fk fk' (n-1)
+ return (ak:aks, rk)
kc_arg arg arg_kind = kcCheckHsType arg arg_kind
- too_many_args = ptext SLIT("Kind error:") <+> quotes ppr_fun <+>
- ptext SLIT("is applied to too many type arguments")
+ too_many_args = ptext (sLit "Kind error:") <+> quotes ppr_fun <+>
+ ptext (sLit "is applied to too many type arguments")
---------------------------
kcHsContext :: LHsContext Name -> TcM (LHsContext Name)
-kcHsContext ctxt = wrapLocM (mappM kcHsLPred) ctxt
+kcHsContext ctxt = wrapLocM (mapM kcHsLPred) ctxt
kcHsLPred :: LHsPred Name -> TcM (LHsPred Name)
kcHsLPred = wrapLocM kcHsPred
kcHsPred :: HsPred Name -> TcM (HsPred Name)
-kcHsPred pred -- Checks that the result is of kind liftedType
- = kc_pred pred `thenM` \ (pred', kind) ->
- checkExpectedKind pred kind liftedTypeKind `thenM_`
- returnM pred'
+kcHsPred pred = do -- Checks that the result is of kind liftedType
+ (pred', kind) <- kc_pred pred
+ checkExpectedKind pred kind liftedTypeKind
+ return pred'
---------------------------
kc_pred :: HsPred Name -> TcM (HsPred Name, TcKind)
-- Does *not* check for a saturated
-- application (reason: used from TcDeriv)
-kc_pred pred@(HsIParam name ty)
- = kcHsType ty `thenM` \ (ty', kind) ->
- returnM (HsIParam name ty', kind)
-
-kc_pred pred@(HsClassP cls tys)
- = kcClass cls `thenM` \ kind ->
- kcApps kind (ppr cls) tys `thenM` \ (tys', res_kind) ->
- returnM (HsClassP cls tys', res_kind)
+kc_pred (HsIParam name ty)
+ = do { (ty', kind) <- kcHsType ty
+ ; return (HsIParam name ty', kind)
+ }
+kc_pred (HsClassP cls tys)
+ = do { kind <- kcClass cls
+ ; (tys', res_kind) <- kcApps kind (ppr cls) tys
+ ; return (HsClassP cls tys', res_kind)
+ }
+kc_pred (HsEqualP ty1 ty2)
+ = do { (ty1', kind1) <- kcHsType ty1
+-- ; checkExpectedKind ty1 kind1 liftedTypeKind
+ ; (ty2', kind2) <- kcHsType ty2
+-- ; checkExpectedKind ty2 kind2 liftedTypeKind
+ ; checkExpectedKind ty2 kind2 kind1
+ ; return (HsEqualP ty1' ty2', liftedTypeKind)
+ }
---------------------------
kcTyVar :: Name -> TcM TcKind
-kcTyVar name -- Could be a tyvar or a tycon
- = traceTc (text "lk1" <+> ppr name) `thenM_`
- tcLookup name `thenM` \ thing ->
- traceTc (text "lk2" <+> ppr name <+> ppr thing) `thenM_`
+kcTyVar name = do -- Could be a tyvar or a tycon
+ traceTc (text "lk1" <+> ppr name)
+ thing <- tcLookup name
+ traceTc (text "lk2" <+> ppr name <+> ppr thing)
case thing of
- ATyVar _ ty -> returnM (typeKind ty)
- AThing kind -> returnM kind
- AGlobal (ATyCon tc) -> returnM (tyConKind tc)
- other -> wrongThingErr "type" thing name
+ ATyVar _ ty -> return (typeKind ty)
+ AThing kind -> return kind
+ AGlobal (ATyCon tc) -> return (tyConKind tc)
+ _ -> wrongThingErr "type" thing name
kcClass :: Name -> TcM TcKind
-kcClass cls -- Must be a class
- = tcLookup cls `thenM` \ thing ->
+kcClass cls = do -- Must be a class
+ thing <- tcLookup cls
case thing of
- AThing kind -> returnM kind
- AGlobal (AClass cls) -> returnM (tyConKind (classTyCon cls))
- other -> wrongThingErr "class" thing cls
+ AThing kind -> return kind
+ AGlobal (AClass cls) -> return (tyConKind (classTyCon cls))
+ _ -> wrongThingErr "class" thing cls
\end{code}
-- All HsTyVarBndrs in the intput type are kind-annotated
dsHsType ty = ds_type (unLoc ty)
-ds_type ty@(HsTyVar name)
+ds_type :: HsType Name -> TcM Type
+ds_type ty@(HsTyVar _)
= ds_app ty []
ds_type (HsParTy ty) -- Remove the parentheses markers
= dsHsType ty
ds_type ty@(HsBangTy _ _) -- No bangs should be here
- = failWithTc (ptext SLIT("Unexpected strictness annotation:") <+> ppr ty)
+ = failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty)
-ds_type (HsKindSig ty k)
+ds_type (HsKindSig ty _)
= dsHsType ty -- Kind checking done already
-ds_type (HsListTy ty)
- = dsHsType ty `thenM` \ tau_ty ->
- checkWiredInTyCon listTyCon `thenM_`
- returnM (mkListTy tau_ty)
+ds_type (HsListTy ty) = do
+ tau_ty <- dsHsType ty
+ checkWiredInTyCon listTyCon
+ return (mkListTy tau_ty)
-ds_type (HsPArrTy ty)
- = dsHsType ty `thenM` \ tau_ty ->
- checkWiredInTyCon parrTyCon `thenM_`
- returnM (mkPArrTy tau_ty)
+ds_type (HsPArrTy ty) = do
+ tau_ty <- dsHsType ty
+ checkWiredInTyCon parrTyCon
+ return (mkPArrTy tau_ty)
-ds_type (HsTupleTy boxity tys)
- = dsHsTypes tys `thenM` \ tau_tys ->
- checkWiredInTyCon tycon `thenM_`
- returnM (mkTyConApp tycon tau_tys)
+ds_type (HsTupleTy boxity tys) = do
+ tau_tys <- dsHsTypes tys
+ checkWiredInTyCon tycon
+ return (mkTyConApp tycon tau_tys)
where
tycon = tupleTyCon boxity (length tys)
-ds_type (HsFunTy ty1 ty2)
- = dsHsType ty1 `thenM` \ tau_ty1 ->
- dsHsType ty2 `thenM` \ tau_ty2 ->
- returnM (mkFunTy tau_ty1 tau_ty2)
+ds_type (HsFunTy ty1 ty2) = do
+ tau_ty1 <- dsHsType ty1
+ tau_ty2 <- dsHsType ty2
+ return (mkFunTy tau_ty1 tau_ty2)
-ds_type (HsOpTy ty1 (L span op) ty2)
- = dsHsType ty1 `thenM` \ tau_ty1 ->
- dsHsType ty2 `thenM` \ tau_ty2 ->
+ds_type (HsOpTy ty1 (L span op) ty2) = do
+ tau_ty1 <- dsHsType ty1
+ tau_ty2 <- dsHsType ty2
setSrcSpan span (ds_var_app op [tau_ty1,tau_ty2])
ds_type (HsNumTy n)
- = ASSERT(n==1)
- tcLookupTyCon genUnitTyConName `thenM` \ tc ->
- returnM (mkTyConApp tc [])
+ = ASSERT(n==1) do
+ tc <- tcLookupTyCon genUnitTyConName
+ return (mkTyConApp tc [])
ds_type ty@(HsAppTy _ _)
= ds_app ty []
-ds_type (HsPredTy pred)
- = dsHsPred pred `thenM` \ pred' ->
- returnM (mkPredTy pred')
+ds_type (HsPredTy pred) = do
+ pred' <- dsHsPred pred
+ return (mkPredTy pred')
+
+ds_type (HsForAllTy _ tv_names ctxt ty)
+ = tcTyVarBndrs tv_names $ \ tyvars -> do
+ theta <- mapM dsHsLPred (unLoc ctxt)
+ tau <- dsHsType ty
+ return (mkSigmaTy tyvars theta tau)
-ds_type full_ty@(HsForAllTy exp tv_names ctxt ty)
- = tcTyVarBndrs tv_names $ \ tyvars ->
- mappM dsHsLPred (unLoc ctxt) `thenM` \ theta ->
- dsHsType ty `thenM` \ tau ->
- returnM (mkSigmaTy tyvars theta tau)
+ds_type (HsSpliceTy {}) = panic "ds_type: HsSpliceTy"
+
+ds_type (HsDocTy ty _) -- Remove the doc comment
+ = dsHsType ty
-dsHsTypes arg_tys = mappM dsHsType arg_tys
+dsHsTypes :: [LHsType Name] -> TcM [Type]
+dsHsTypes arg_tys = mapM dsHsType arg_tys
\end{code}
Help functions for type applications
ds_app (HsAppTy ty1 ty2) tys
= ds_app (unLoc ty1) (ty2:tys)
-ds_app ty tys
- = dsHsTypes tys `thenM` \ arg_tys ->
+ds_app ty tys = do
+ arg_tys <- dsHsTypes tys
case ty of
HsTyVar fun -> ds_var_app fun arg_tys
- other -> ds_type ty `thenM` \ fun_ty ->
- returnM (mkAppTys fun_ty arg_tys)
+ _ -> do fun_ty <- ds_type ty
+ return (mkAppTys fun_ty arg_tys)
ds_var_app :: Name -> [Type] -> TcM Type
-ds_var_app name arg_tys
- = tcLookup name `thenM` \ thing ->
+ds_var_app name arg_tys = do
+ thing <- tcLookup name
case thing of
- ATyVar _ ty -> returnM (mkAppTys ty arg_tys)
- AGlobal (ATyCon tc) -> returnM (mkTyConApp tc arg_tys)
- other -> wrongThingErr "type" thing name
+ ATyVar _ ty -> return (mkAppTys ty arg_tys)
+ AGlobal (ATyCon tc) -> return (mkTyConApp tc arg_tys)
+ _ -> wrongThingErr "type" thing name
\end{code}
dsHsLPred :: LHsPred Name -> TcM PredType
dsHsLPred pred = dsHsPred (unLoc pred)
-dsHsPred pred@(HsClassP class_name tys)
- = dsHsTypes tys `thenM` \ arg_tys ->
- tcLookupClass class_name `thenM` \ clas ->
- returnM (ClassP clas arg_tys)
-
+dsHsPred :: HsPred Name -> TcM PredType
+dsHsPred (HsClassP class_name tys)
+ = do { arg_tys <- dsHsTypes tys
+ ; clas <- tcLookupClass class_name
+ ; return (ClassP clas arg_tys)
+ }
+dsHsPred (HsEqualP ty1 ty2)
+ = do { arg_ty1 <- dsHsType ty1
+ ; arg_ty2 <- dsHsType ty2
+ ; return (EqPred arg_ty1 arg_ty2)
+ }
dsHsPred (HsIParam name ty)
- = dsHsType ty `thenM` \ arg_ty ->
- returnM (IParam name arg_ty)
+ = do { arg_ty <- dsHsType ty
+ ; return (IParam name arg_ty)
+ }
\end{code}
GADT constructor signatures
\begin{code}
tcLHsConResTy :: LHsType Name -> TcM (TyCon, [TcType])
-tcLHsConResTy res_ty
- = addErrCtxt (gadtResCtxt res_ty) $
- case get_largs res_ty [] of
+tcLHsConResTy (L span res_ty)
+ = setSrcSpan span $
+ case get_args res_ty [] of
(HsTyVar tc_name, args)
-> do { args' <- mapM dsHsType args
; thing <- tcLookup tc_name
; case thing of
AGlobal (ATyCon tc) -> return (tc, args')
- other -> failWithTc (badGadtDecl res_ty) }
- other -> failWithTc (badGadtDecl res_ty)
+ _ -> failWithTc (badGadtDecl res_ty) }
+ _ -> failWithTc (badGadtDecl res_ty)
where
-- We can't call dsHsType on res_ty, and then do tcSplitTyConApp_maybe
-- because that causes a black hole, and for good reason. Building
-- the type means expanding type synonyms, and we can't do that
-- inside the "knot". So we have to work by steam.
- get_largs (L _ ty) args = get_args ty args
- get_args (HsAppTy fun arg) args = get_largs fun (arg:args)
- get_args (HsParTy ty) args = get_largs ty args
- get_args (HsOpTy ty1 (L span tc) ty2) args = (HsTyVar tc, ty1:ty2:args)
- get_args ty args = (ty, args)
-
-gadtResCtxt ty
- = hang (ptext SLIT("In the result type of a data constructor:"))
- 2 (ppr ty)
+ get_args (HsAppTy (L _ fun) arg) args = get_args fun (arg:args)
+ get_args (HsParTy (L _ ty)) args = get_args ty args
+ get_args (HsOpTy ty1 (L _ tc) ty2) args = (HsTyVar tc, ty1:ty2:args)
+ get_args ty args = (ty, args)
+
+badGadtDecl :: HsType Name -> SDoc
badGadtDecl ty
- = hang (ptext SLIT("Malformed constructor result type:"))
+ = hang (ptext (sLit "Malformed constructor result type:"))
2 (ppr ty)
-typeCtxt ty = ptext SLIT("In the type") <+> quotes (ppr ty)
+typeCtxt :: HsType Name -> SDoc
+typeCtxt ty = ptext (sLit "In the type") <+> quotes (ppr ty)
\end{code}
%************************************************************************
-> ([LHsTyVarBndr Name] -> TcM r) -- These binders are kind-annotated
-- They scope over the thing inside
-> TcM r
-kcHsTyVars tvs thing_inside
- = mappM (wrapLocM kcHsTyVar) tvs `thenM` \ bndrs ->
+kcHsTyVars tvs thing_inside = do
+ bndrs <- mapM (wrapLocM kcHsTyVar) tvs
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
-kcHsTyVar (UserTyVar name) = newKindVar `thenM` \ kind ->
- returnM (KindedTyVar name kind)
-kcHsTyVar (KindedTyVar name kind) = returnM (KindedTyVar name kind)
+kcHsTyVar (UserTyVar name) = KindedTyVar name <$> newKindVar
+kcHsTyVar (KindedTyVar name kind) = return (KindedTyVar name kind)
------------------
tcTyVarBndrs :: [LHsTyVarBndr Name] -- Kind-annotated binders, which need kind-zonking
-> TcM r
-- Used when type-checking types/classes/type-decls
-- Brings into scope immutable TyVars, not mutable ones that require later zonking
-tcTyVarBndrs bndrs thing_inside
- = mapM (zonk . unLoc) bndrs `thenM` \ tyvars ->
+tcTyVarBndrs bndrs thing_inside = do
+ tyvars <- mapM (zonk . unLoc) bndrs
tcExtendTyVarEnv tyvars (thing_inside tyvars)
where
zonk (KindedTyVar name kind) = do { kind' <- zonkTcKindToKind kind
; return (mkTyVar name kind') }
- zonk (UserTyVar name) = pprTrace "Un-kinded tyvar" (ppr name) $
+ zonk (UserTyVar name) = WARN( True, ptext (sLit "Un-kinded tyvar") <+> ppr name )
return (mkTyVar name liftedTypeKind)
-----------------------------------
-- GADT decls can have a (perhaps partial) kind signature
-- e.g. data T :: * -> * -> * where ...
-- This function makes up suitable (kinded) type variables for
--- the argument kinds, and checks that the result kind is indeed *
+-- the argument kinds, and checks that the result kind is indeed *.
+-- We use it also to make up argument type variables for for data instances.
tcDataKindSig Nothing = return []
tcDataKindSig (Just kind)
= do { checkTc (isLiftedTypeKind res_kind) (badKindSig kind)
; span <- getSrcSpanM
; us <- newUniqueSupply
- ; let loc = srcSpanStart span
- uniqs = uniqsFromSupply us
- ; return [ mk_tv loc uniq str kind
+ ; let uniqs = uniqsFromSupply us
+ ; return [ mk_tv span uniq str kind
| ((kind, str), uniq) <- arg_kinds `zip` names `zip` uniqs ] }
where
(arg_kinds, res_kind) = splitKindFunTys kind
badKindSig :: Kind -> SDoc
badKindSig kind
- = hang (ptext SLIT("Kind signature on data type declaration has non-* return kind"))
+ = hang (ptext (sLit "Kind signature on data type declaration has non-* return kind"))
2 (ppr kind)
\end{code}
| n <- nameSetToList (extractHsTyVars hs_ty),
not (in_scope n) ]
- -- Behave very like type-checking (HsForAllTy sig_tvs hs_ty),
- -- except that we want to keep the tvs separate
- ; (kinded_tvs, kinded_ty) <- kcHsTyVars sig_tvs $ \ kinded_tvs -> do
- { kinded_ty <- kcTypeType hs_ty
- ; return (kinded_tvs, kinded_ty) }
- ; tcTyVarBndrs kinded_tvs $ \ tyvars -> do
- { sig_ty <- dsHsType kinded_ty
+ ; (tyvars, sig_ty) <- tcHsQuantifiedType sig_tvs hs_ty
; checkValidType ctxt sig_ty
; return (tyvars, sig_ty)
- } }
+ }
tcPatSig :: UserTypeCtxt
-> LHsType Name
-- So we just have an ASSERT here
; let in_pat_bind = case ctxt of
BindPatSigCtxt -> True
- other -> False
+ _ -> False
; ASSERT( not in_pat_bind || null sig_tvs ) return ()
-- Check that pat_ty is rigid
; return (res_ty, tv_binds)
} }
where
- check in_scope [] = return ()
+ check _ [] = return ()
check in_scope ((n,ty):rest) = do { check_one in_scope n ty
; check ((n,ty):in_scope) rest }
\begin{code}
pprHsSigCtxt :: UserTypeCtxt -> LHsType Name -> SDoc
-pprHsSigCtxt ctxt hs_ty = vcat [ ptext SLIT("In") <+> pprUserTypeCtxt ctxt <> colon,
+pprHsSigCtxt ctxt hs_ty = vcat [ ptext (sLit "In") <+> pprUserTypeCtxt ctxt <> colon,
nest 2 (pp_sig ctxt) ]
where
pp_sig (FunSigCtxt n) = pp_n_colon n
pp_sig (ConArgCtxt n) = pp_n_colon n
pp_sig (ForSigCtxt n) = pp_n_colon n
- pp_sig (RuleSigCtxt n) = pp_n_colon n
- pp_sig other = ppr (unLoc hs_ty)
+ pp_sig _ = ppr (unLoc hs_ty)
pp_n_colon n = ppr n <+> dcolon <+> ppr (unLoc hs_ty)
-
+wobblyPatSig :: [Var] -> SDoc
wobblyPatSig sig_tvs
- = hang (ptext SLIT("A pattern type signature cannot bind scoped type variables")
+ = hang (ptext (sLit "A pattern type signature cannot bind scoped type variables")
<+> pprQuotedList sig_tvs)
- 2 (ptext SLIT("unless the pattern has a rigid type context"))
+ 2 (ptext (sLit "unless the pattern has a rigid type context"))
+scopedNonVar :: Name -> Type -> SDoc
scopedNonVar n ty
- = vcat [sep [ptext SLIT("The scoped type variable") <+> quotes (ppr n),
- nest 2 (ptext SLIT("is bound to the type") <+> quotes (ppr ty))],
- nest 2 (ptext SLIT("You can only bind scoped type variables to type variables"))]
-
-dupInScope n n' ty
- = hang (ptext SLIT("The scoped type variables") <+> quotes (ppr n) <+> ptext SLIT("and") <+> quotes (ppr n'))
- 2 (vcat [ptext SLIT("are bound to the same type (variable)"),
- ptext SLIT("Distinct scoped type variables must be distinct")])
+ = vcat [sep [ptext (sLit "The scoped type variable") <+> quotes (ppr n),
+ nest 2 (ptext (sLit "is bound to the type") <+> quotes (ppr ty))],
+ nest 2 (ptext (sLit "You can only bind scoped type variables to type variables"))]
+
+dupInScope :: Name -> Name -> Type -> SDoc
+dupInScope n n' _
+ = hang (ptext (sLit "The scoped type variables") <+> quotes (ppr n) <+> ptext (sLit "and") <+> quotes (ppr n'))
+ 2 (vcat [ptext (sLit "are bound to the same type (variable)"),
+ ptext (sLit "Distinct scoped type variables must be distinct")])
+
+wrongEqualityErr :: TcM (HsType Name, TcKind)
+wrongEqualityErr
+ = failWithTc (text "Equality predicate used as a type")
\end{code}
projects / ghc-hetmet.git / blobdiff