-
+%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcMonoType]{Typechecking user-specified @MonoTypes@}
#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
\end{code}
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.]
-- 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
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)
+ 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
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
-- 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
+ ; 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)
+ = do { kind <- kcClass cls
+ ; (tys', res_kind) <- kcApps kind (ppr cls) tys
+ ; returnM (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
+ ; returnM (HsEqualP ty1 ty2, liftedTypeKind)
+ }
---------------------------
kcTyVar :: Name -> TcM TcKind
dsHsType ty `thenM` \ tau ->
returnM (mkSigmaTy tyvars theta tau)
+ds_type (HsSpliceTy {}) = panic "ds_type: HsSpliceTy"
+
dsHsTypes arg_tys = mappM dsHsType arg_tys
\end{code}
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
+ ; returnM (ClassP clas arg_tys)
+ }
+dsHsPred pred@(HsEqualP ty1 ty2)
+ = do { arg_ty1 <- dsHsType ty1
+ ; arg_ty2 <- dsHsType ty2
+ ; returnM (EqPred arg_ty1 arg_ty2)
+ }
dsHsPred (HsIParam name ty)
- = dsHsType ty `thenM` \ arg_ty ->
- returnM (IParam name arg_ty)
+ = do { arg_ty <- dsHsType ty
+ ; returnM (IParam name arg_ty)
+ }
\end{code}
GADT constructor signatures
\begin{code}
tcLHsConResTy :: LHsType Name -> TcM (TyCon, [TcType])
-tcLHsConResTy ty@(L span _)
- = setSrcSpan span $
- addErrCtxt (gadtResCtxt ty) $
- tc_con_res ty []
-
-tc_con_res (L _ (HsAppTy fun res_ty)) res_tys
- = do { res_ty' <- dsHsType res_ty
- ; tc_con_res fun (res_ty' : res_tys) }
-
-tc_con_res ty@(L _ (HsTyVar name)) res_tys
- = do { thing <- tcLookup name
- ; case thing of
- AGlobal (ATyCon tc) -> return (tc, res_tys)
- other -> failWithTc (badGadtDecl ty)
- }
-
-tc_con_res ty _ = failWithTc (badGadtDecl ty)
+tcLHsConResTy res_ty
+ = addErrCtxt (gadtResCtxt res_ty) $
+ case get_largs 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)
+ 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:"))
-----------------------------------
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)
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)
projects / ghc-hetmet.git / blobdiff