X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcHsType.lhs;h=00bc2ede20e5575a95c4c2b982ca7c25db778b48;hp=e4b1267a91d2e13c802df0de9b1558865ce799f2;hb=f9dd1aacd7a93d4175adad9e3e3e65670157b01c;hpb=5edf58c10a0144fa8b328e18d0b7fffec2319424 diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index e4b1267..00bc2ed 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -1,11 +1,20 @@ - +% +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcMonoType]{Typechecking user-specified @MonoTypes@} \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module TcHsType ( - tcHsSigType, tcHsDeriv, + tcHsSigType, tcHsDeriv, + tcHsInstHead, tcHsQuantifiedType, UserTypeCtxt(..), -- Kind checking @@ -23,42 +32,29 @@ module TcHsType ( #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 Control.Monad \end{code} @@ -155,7 +151,25 @@ tcHsSigType ctxt hs_ty 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]) @@ -191,8 +205,7 @@ kcHsSigType ty = kcTypeType ty kcHsLiftedSigType ty = kcLiftedType ty tcHsKindedType :: LHsType Name -> TcM Type - -- Don't do kind checking, nor validity checking, - -- but do hoist for-alls to the top + -- Don't do kind checking, nor validity checking. -- This is used in type and class decls, where kinding is -- done in advance, and validity checking is done later -- [Validity checking done later because of knot-tying issues.] @@ -206,7 +219,7 @@ 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} @@ -242,15 +255,27 @@ kcCheckHsType (L span ty) exp_kind -- because checkExpectedKind already mentions -- 'ty' by name in any error message - ; checkExpectedKind ty act_kind exp_kind + ; checkExpectedKind (strip 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 + -- Wrap a context around only if we want to show that contexts. + add_ctxt (HsPredTy p) thing = thing + -- Omit invisble ones and ones user's won't grok (HsPred p). + 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 + -- (ty) or !(ty) or forall a. ty + -- when the real difficulty is with the 'ty' part. + strip (HsParTy (L _ ty)) = strip ty + strip (HsBangTy _ (L _ ty)) = strip ty + strip (HsForAllTy _ _ _ (L _ ty)) = strip ty + strip ty = ty \end{code} Here comes the main function @@ -268,100 +293,109 @@ kcHsType ty = wrapLocFstM kc_hs_type ty -- -- 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 (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 ty@(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 ty@(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 ty@(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) +-- 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 @@ -370,49 +404,58 @@ kcApps fun_kind ppr_fun args --------------------------- 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) - + = do { (ty', kind) <- kcHsType ty + ; return (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) + = do { kind <- kcClass cls + ; (tys', res_kind) <- kcApps kind (ppr cls) tys + ; return (HsClassP cls tys', res_kind) + } +kc_pred 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) + other -> 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)) + other -> wrongThingErr "class" thing cls \end{code} @@ -449,52 +492,57 @@ ds_type ty@(HsBangTy _ _) -- No bangs should be here ds_type (HsKindSig ty k) = 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 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) + = tcTyVarBndrs tv_names $ \ tyvars -> do + theta <- mapM dsHsLPred (unLoc ctxt) + tau <- dsHsType ty + return (mkSigmaTy tyvars theta tau) -dsHsTypes arg_tys = mappM dsHsType arg_tys +ds_type (HsSpliceTy {}) = panic "ds_type: HsSpliceTy" + +ds_type (HsDocTy ty _) -- Remove the doc comment + = dsHsType ty + +dsHsTypes arg_tys = mapM dsHsType arg_tys \end{code} Help functions for type applications @@ -505,19 +553,19 @@ ds_app :: HsType Name -> [LHsType Name] -> TcM Type 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) + other -> 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) + ATyVar _ ty -> return (mkAppTys ty arg_tys) + AGlobal (ATyCon tc) -> return (mkTyConApp tc arg_tys) other -> wrongThingErr "type" thing name \end{code} @@ -530,13 +578,19 @@ 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) - + = do { arg_tys <- dsHsTypes tys + ; clas <- tcLookupClass class_name + ; return (ClassP clas arg_tys) + } +dsHsPred pred@(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 @@ -561,8 +615,8 @@ tcLHsConResTy res_ty 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 = get_args (HsTyVar tc) (ty1:ty2:args) - get_args ty args = (ty, reverse 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:")) @@ -586,15 +640,14 @@ kcHsTyVars :: [LHsTyVarBndr Name] -> ([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 @@ -602,29 +655,29 @@ tcTyVarBndrs :: [LHsTyVarBndr Name] -- Kind-annotated binders, which need kind- -> 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) ----------------------------------- tcDataKindSig :: Maybe Kind -> TcM [TyVar] --- GADT decls can have a (perhpas partial) kind signature +-- 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 @@ -703,16 +756,10 @@ tcHsPatSigType ctxt hs_ty | 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 @@ -795,7 +842,6 @@ pprHsSigCtxt ctxt hs_ty = vcat [ ptext SLIT("In") <+> pprUserTypeCtxt ctxt <> co 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_n_colon n = ppr n <+> dcolon <+> ppr (unLoc hs_ty) @@ -815,5 +861,8 @@ 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")]) + +wrongEqualityErr + = failWithTc (text "Equality predicate used as a type") \end{code}