-> WhereFrom -- Tells whether it's a {-# SOURCE #-} import
-> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hiding
-> [AvailInfo] -- What's available
- -> RnMG ([AvailInfo], -- What's actually imported
- [AvailInfo], -- What's to be hidden
+ -> RnMG ([AvailInfo], -- "chosens"
+ [AvailInfo], -- "hides"
+ -- The true imports are "chosens" - "hides"
-- (It's convenient to return both the above sets, because
-- the substraction can be done more efficiently when
-- building the environment.)
rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
= pushSrcLocRn src_loc $
- doptRn Opt_GlasgowExts `thenRn` \ glaExts ->
lookupTopBndrRn name `thenRn` \ name' ->
bindTyVarsRn syn_doc tyvars $ \ tyvars' ->
- rnHsType syn_doc (unquantify glaExts ty) `thenRn` \ ty' ->
+ rnHsType syn_doc ty `thenRn` \ ty' ->
returnRn (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
where
syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
- -- For H98 we do *not* universally quantify on the RHS of a synonym
- -- Silently discard context... but the tyvars in the rest won't be in scope
- -- In interface files all types are quantified, so this is a no-op
- unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty
- unquantify glaExts ty = ty
-
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname,
tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
tcdSysNames = names, tcdLoc = src_loc})
newSpecPragmaId, newLocalId
)
import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts )
-import TcMonoType ( tcHsSigType, checkSigTyVars,
+import TcMonoType ( tcHsSigType, UserTypeCtxt(..), checkSigTyVars,
TcSigInfo(..), tcTySig, maybeSig, sigCtxt
)
import TcPat ( tcPat )
tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
-- Get and instantiate its alleged specialised type
- tcHsSigType poly_ty `thenTc` \ sig_ty ->
+ tcHsSigType (FunSigCtxt name) poly_ty `thenTc` \ sig_ty ->
-- Check that f has a more general type, and build a RHS for
-- the spec-pragma-id at the same time
\section[TcClassDcl]{Typechecking class declarations}
\begin{code}
-module TcClassDcl ( tcClassDecl1, tcClassDecls2,
+module TcClassDcl ( tcClassDecl1, checkValidClass, tcClassDecls2,
tcMethodBind, badMethodErr
) where
#include "HsVersions.h"
import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..),
- HsExpr(..), HsLit(..), HsType(..), HsPred(..),
+ HsExpr(..), HsLit(..),
mkSimpleMatch, andMonoBinds, andMonoBindList,
isClassOpSig, isPragSig,
getClassDeclSysNames, placeHolderType
import BasicTypes ( TopLevelFlag(..), RecFlag(..), StrictnessMark(..) )
import RnHsSyn ( RenamedTyClDecl,
RenamedClassOpSig, RenamedMonoBinds,
- RenamedContext, RenamedSig,
- maybeGenericMatch
+ RenamedSig, maybeGenericMatch
)
import TcHsSyn ( TcMonoBinds )
tcExtendLocalValEnv, tcExtendTyVarEnv
)
import TcBinds ( tcBindWithSigs, tcSpecSigs )
-import TcMonoType ( tcHsRecType, tcRecTheta, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig )
+import TcMonoType ( tcHsType, tcHsTheta, checkSigTyVars, sigCtxt, mkTcSig )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
-import TcMType ( tcInstTyVars )
-import TcType ( Type, ThetaType, mkTyVarTys, mkPredTys, mkClassPred, tcIsTyVarTy, tcSplitTyConApp_maybe )
+import TcMType ( tcInstTyVars, checkValidTheta, checkValidType, SourceTyCtxt(..), UserTypeCtxt(..) )
+import TcType ( Type, mkSigmaTy, mkTyVarTys, mkPredTys, mkClassPred,
+ tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitSigmaTy
+ )
import TcMonad
import Generics ( mkGenericRhs, validGenericMethodType )
import PrelInfo ( nO_METHOD_BINDING_ERROR_ID )
-import Class ( classTyVars, classBigSig, classTyCon,
+import Class ( classTyVars, classBigSig, classTyCon, className,
Class, ClassOpItem, DefMeth (..) )
import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
import DataCon ( mkDataCon )
-import Id ( Id, idType, idName )
+import Id ( idType, idName )
import Module ( Module )
import Name ( Name, NamedThing(..) )
-import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts )
+import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv )
import NameSet ( emptyNameSet )
import Outputable
import Var ( TyVar )
\begin{code}
-tcClassDecl1 :: RecFlag -> RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
-tcClassDecl1 is_rec rec_env
+tcClassDecl1 :: RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
+tcClassDecl1 rec_env
(ClassDecl {tcdCtxt = context, tcdName = class_name,
tcdTyVars = tyvar_names, tcdFDs = fundeps,
tcdSigs = class_sigs, tcdMeths = def_methods,
tcdSysNames = sys_names, tcdLoc = src_loc})
- = -- CHECK ARITY 1 FOR HASKELL 1.4
- doptsTc Opt_GlasgowExts `thenTc` \ gla_ext_opt ->
- let
- gla_exts = gla_ext_opt || not (maybeToBool def_methods)
- -- Accept extensions if gla_exts is on,
- -- or if we're looking at an interface file decl
- in -- (in which case def_methods = Nothing
-
- -- LOOK THINGS UP IN THE ENVIRONMENT
+ = -- LOOK THINGS UP IN THE ENVIRONMENT
tcLookupClass class_name `thenTc` \ clas ->
let
tyvars = classTyVars clas
in
tcExtendTyVarEnv tyvars $
- -- SOURCE-CODE CONSISTENCY CHECKS
- (case def_methods of
- Nothing -> -- Not source
- returnTc Nothing
-
- Just dms -> -- Source so do error checks
- checkTc (gla_exts || length tyvar_names == 1)
- (classArityErr class_name) `thenTc_`
-
- checkDefaultBinds clas op_names dms `thenTc` \ dm_env ->
- checkGenericClassIsUnary clas dm_env `thenTc_`
- returnTc (Just dm_env)
- ) `thenTc` \ mb_dm_env ->
+ checkDefaultBinds clas op_names def_methods `thenTc` \ mb_dm_env ->
-- CHECK THE CONTEXT
- tcSuperClasses is_rec gla_exts clas context sc_sel_names `thenTc` \ (sc_theta, sc_sel_ids) ->
+ -- The renamer has already checked that the context mentions
+ -- only the type variable of the class decl.
+ -- Context is already kind-checked
+ ASSERT( length context == length sc_sel_names )
+ tcHsTheta context `thenTc` \ sc_theta ->
-- CHECK THE CLASS SIGNATURES,
- mapTc (tcClassSig is_rec rec_env clas tyvars mb_dm_env) op_sigs `thenTc` \ sig_stuff ->
+ mapTc (tcClassSig rec_env clas tyvars mb_dm_env) op_sigs `thenTc` \ sig_stuff ->
-- MAKE THE CLASS DETAILS
let
(op_tys, op_items) = unzip sig_stuff
sc_tys = mkPredTys sc_theta
dict_component_tys = sc_tys ++ op_tys
+ sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names]
dict_con = mkDataCon datacon_name
[NotMarkedStrict | _ <- dict_component_tys]
\end{code}
\begin{code}
-checkDefaultBinds :: Class -> [Name] -> RenamedMonoBinds
- -> TcM (NameEnv Bool)
+checkDefaultBinds :: Class -> [Name] -> Maybe RenamedMonoBinds
+ -> TcM (Maybe (NameEnv Bool))
-- The returned environment says
-- x not in env => no default method
-- x -> True => generic default method
-- But do all this only for source binds
-checkDefaultBinds clas ops EmptyMonoBinds = returnTc emptyNameEnv
+checkDefaultBinds clas ops Nothing
+ = returnTc Nothing
+
+checkDefaultBinds clas ops (Just mbs)
+ = go mbs `thenTc` \ dm_env ->
+ returnTc (Just dm_env)
+ where
+ go EmptyMonoBinds = returnTc emptyNameEnv
-checkDefaultBinds clas ops (AndMonoBinds b1 b2)
- = checkDefaultBinds clas ops b1 `thenTc` \ dm_info1 ->
- checkDefaultBinds clas ops b2 `thenTc` \ dm_info2 ->
- returnTc (dm_info1 `plusNameEnv` dm_info2)
+ go (AndMonoBinds b1 b2)
+ = go b1 `thenTc` \ dm_info1 ->
+ go b2 `thenTc` \ dm_info2 ->
+ returnTc (dm_info1 `plusNameEnv` dm_info2)
-checkDefaultBinds clas ops (FunMonoBind op _ matches loc)
- = tcAddSrcLoc loc $
+ go (FunMonoBind op _ matches loc)
+ = tcAddSrcLoc loc $
-- Check that the op is from this class
- checkTc (op `elem` ops) (badMethodErr clas op) `thenTc_`
+ checkTc (op `elem` ops) (badMethodErr clas op) `thenTc_`
-- Check that all the defns ar generic, or none are
- checkTc (all_generic || none_generic) (mixedGenericErr op) `thenTc_`
+ checkTc (all_generic || none_generic) (mixedGenericErr op) `thenTc_`
- returnTc (unitNameEnv op all_generic)
- where
- n_generic = count (maybeToBool . maybeGenericMatch) matches
- none_generic = n_generic == 0
- all_generic = n_generic == length matches
-
-checkGenericClassIsUnary clas dm_env
- = -- Check that if the class has generic methods, then the
- -- class has only one parameter. We can't do generic
- -- multi-parameter type classes!
- checkTc (unary || no_generics) (genericMultiParamErr clas)
- where
- unary = length (classTyVars clas) == 1
- no_generics = not (or (nameEnvElts dm_env))
+ returnTc (unitNameEnv op all_generic)
+ where
+ n_generic = count (maybeToBool . maybeGenericMatch) matches
+ none_generic = n_generic == 0
+ all_generic = n_generic == length matches
\end{code}
\begin{code}
-tcSuperClasses :: RecFlag -> Bool -> Class
- -> RenamedContext -- class context
- -> [Name] -- Names for superclass selectors
- -> TcM (ThetaType, -- the superclass context
- [Id]) -- superclass selector Ids
-
-tcSuperClasses is_rec gla_exts clas context sc_sel_names
- = ASSERT( length context == length sc_sel_names )
- -- Check the context.
- -- The renamer has already checked that the context mentions
- -- only the type variable of the class decl.
-
- -- For std Haskell check that the context constrains only tyvars
- mapTc_ check_constraint context `thenTc_`
-
- -- Context is already kind-checked
- tcRecTheta is_rec context `thenTc` \ sc_theta ->
- let
- sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names]
- in
- -- Done
- returnTc (sc_theta, sc_sel_ids)
-
- where
- check_constraint sc = checkTc (ok sc) (superClassErr clas sc)
- ok (HsClassP c tys) | gla_exts = True
- | otherwise = all is_tyvar tys
- ok (HsIParam _ _) = False -- Never legal
-
- is_tyvar (HsTyVar _) = True
- is_tyvar other = False
-
-
-tcClassSig :: RecFlag -> RecTcEnv -- Knot tying only!
+tcClassSig :: RecTcEnv -- Knot tying only!
-> Class -- ...ditto...
-> [TyVar] -- The class type variable, used for error check only
-> Maybe (NameEnv Bool) -- Info about default methods
-- so we distinguish them in checkDefaultBinds, and pass this knowledge in the
-- Class.DefMeth data structure.
-tcClassSig is_rec unf_env clas clas_tyvars maybe_dm_env
+tcClassSig unf_env clas clas_tyvars maybe_dm_env
(ClassOpSig op_name sig_dm op_ty src_loc)
= tcAddSrcLoc src_loc $
-- Check the type signature. NB that the envt *already has*
-- bindings for the type variables; see comments in TcTyAndClassDcls.
+ tcHsType op_ty `thenTc` \ local_ty ->
- tcHsRecType is_rec op_ty `thenTc` \ local_ty ->
-
- -- Check for ambiguous class op types
let
theta = [mkClassPred clas (mkTyVarTys clas_tyvars)]
- in
- checkAmbiguity is_rec True clas_tyvars theta local_ty `thenTc` \ global_ty ->
+ global_ty = mkSigmaTy clas_tyvars theta local_ty
-- The default method's type should really come from the
-- iface file, since it could be usage-generalised, but this
-- requires altering the mess of knots in TcModule and I'm
-- of types of default methods (and dict funs) by annotating them
-- TyGenNever (in MkId). Ugh! KSW 1999-09.
- let
-- Build the selector id and default method id
sel_id = mkDictSelId op_name clas
dm_id = mkDefaultMethodId dm_name global_ty
Just True -> GenDefMeth
Just False -> DefMeth dm_id
in
- -- Check that for a generic method, the type of
- -- the method is sufficiently simple
- checkTc (dm_info /= GenDefMeth || validGenericMethodType local_ty)
- (badGenericMethodType op_name op_ty) `thenTc_`
-
returnTc (local_ty, (sel_id, dm_info))
\end{code}
+checkValidClass is called once the mutually-recursive knot has been
+tied, so we can look at things freely.
+
+\begin{code}
+checkValidClass :: Class -> TcM ()
+checkValidClass cls
+ = -- CHECK ARITY 1 FOR HASKELL 1.4
+ doptsTc Opt_GlasgowExts `thenTc` \ gla_exts ->
+
+ -- Check that the class is unary, unless GlaExs
+ checkTc (gla_exts || unary)
+ (classArityErr cls) `thenTc_`
+
+ -- Check the super-classes
+ checkValidTheta (ClassSCCtxt (className cls)) theta `thenTc_`
+
+ -- Check the class operations
+ mapTc_ check_op op_stuff `thenTc_`
+
+ -- Check that if the class has generic methods, then the
+ -- class has only one parameter. We can't do generic
+ -- multi-parameter type classes!
+ checkTc (unary || no_generics) (genericMultiParamErr cls)
+
+ where
+ (tyvars, theta, sel_ids, op_stuff) = classBigSig cls
+ unary = length tyvars == 1
+ no_generics = null [() | (_, GenDefMeth) <- op_stuff]
+
+ check_op (sel_id, dm)
+ = checkValidTheta SigmaCtxt (tail theta) `thenTc_`
+ -- The 'tail' removes the initial (C a) from the
+ -- class itself, leaving just the method type
+
+ checkValidType (FunSigCtxt op_name) tau `thenTc_`
+
+ -- Check that for a generic method, the type of
+ -- the method is sufficiently simple
+ checkTc (dm /= GenDefMeth || validGenericMethodType op_ty)
+ (badGenericMethodType op_name op_ty)
+ where
+ op_name = idName sel_id
+ op_ty = idType sel_id
+ (_,theta,tau) = tcSplitSigmaTy op_ty
+\end{code}
+
%************************************************************************
%* *
tcExtendGlobalTyVars (mkVarSet inst_tyvars)
(tcAddErrCtxt (methodCtxt sel_id) $
tcBindWithSigs NotTopLevel meth_bind
- [sig_info] meth_prags NonRecursive
+ [sig_info] meth_prags NonRecursive
) `thenTc` \ (binds, insts, _) ->
tcExtendLocalValEnv [(meth_name, meth_id)]
Contexts and errors
~~~~~~~~~~~~~~~~~~~
\begin{code}
-classArityErr class_name
- = ptext SLIT("Too many parameters for class") <+> quotes (ppr class_name)
-
-superClassErr clas sc
- = ptext SLIT("Illegal superclass constraint") <+> quotes (ppr sc)
- <+> ptext SLIT("in declaration for class") <+> quotes (ppr clas)
+classArityErr cls
+ = ptext SLIT("Too many parameters for class") <+> quotes (ppr cls)
defltMethCtxt clas
= ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas)
tcExtendGlobalTyVars
)
import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts )
-import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt )
+import TcMonoType ( tcHsSigType, UserTypeCtxt(..), checkSigTyVars, sigCtxt )
import TcPat ( badFieldCon, simpleHsLitTy )
import TcSimplify ( tcSimplifyCheck, tcSimplifyIPs )
import TcMType ( tcInstTyVars, tcInstType,
import TysWiredIn ( boolTy, mkListTy, listTyCon )
import PrelNames ( cCallableClassName,
cReturnableClassName,
- enumFromName, enumFromThenName, negateName,
+ enumFromName, enumFromThenName,
enumFromToName, enumFromThenToName,
thenMName, failMName, returnMName, ioTyConName
)
\begin{code}
tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
- = tcAddErrCtxt (exprSigCtxt in_expr) $
- tcHsSigType poly_ty `thenTc` \ sig_tc_ty ->
+ = tcHsSigType ExprSigCtxt poly_ty `thenTc` \ sig_tc_ty ->
+ tcAddErrCtxt (exprSigCtxt in_expr) $
if not (isQualifiedTy sig_tc_ty) then
-- Easy case
unifyTauTy sig_tc_ty res_ty `thenTc_`
import TcMonad
import TcEnv ( newLocalId )
-import TcMonoType ( tcHsLiftedSigType )
-import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl,
- TcForeignExportDecl )
+import TcMonoType ( tcHsSigType, UserTypeCtxt(..) )
+import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignExportDecl )
import TcExpr ( tcPolyExpr )
import Inst ( emptyLIE, LIE, plusLIE )
tcFImport fo@(ForeignImport nm hs_ty imp_decl src_loc)
= tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
- tcHsLiftedSigType hs_ty `thenTc` \ sig_ty ->
+ tcHsSigType (ForSigCtxt nm) hs_ty `thenTc` \ sig_ty ->
let
-- drop the foralls before inspecting the structure
-- of the foreign type.
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
- tcHsLiftedSigType hs_ty `thenTc` \ sig_ty ->
- tcPolyExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie, _, _, _) ->
+ tcHsSigType (ForSigCtxt nm) hs_ty `thenTc` \ sig_ty ->
+ tcPolyExpr (HsVar nm) sig_ty `thenTc` \ (rhs, lie, _, _, _) ->
tcCheckFEType sig_ty spec `thenTc_`
import TcBinds ( tcSpecSigs )
import TcClassDcl ( tcMethodBind, badMethodErr )
import TcMonad
-import TcMType ( tcInstType, tcInstTyVars )
+import TcMType ( tcInstTyVars, checkValidTheta, UserTypeCtxt(..), SourceTyCtxt(..) )
import TcType ( tcSplitDFunTy, tcIsTyVarTy, tcSplitTyConApp_maybe,
tyVarsOfTypes, mkClassPred, mkTyVarTy,
- isTyVarClassPred, inheritablePred
+ tcSplitSigmaTy, tcSplitPredTy_maybe, getClassPredTys_maybe
)
import Inst ( InstOrigin(..),
newDicts, instToId,
isLocalThing,
)
import InstEnv ( InstEnv, extendInstEnv )
-import TcMonoType ( tcHsTyVars, tcHsSigType, kcHsSigType, checkSigTyVars )
+import TcMonoType ( tcHsTyVars, kcHsSigType, tcHsType, tcHsSigType, checkSigTyVars )
import TcSimplify ( tcSimplifyCheck )
import HscTypes ( HomeSymbolTable, DFunId,
ModDetails(..), PackageInstEnv, PersistentRenamerState
import Name ( getSrcLoc )
import NameSet ( unitNameSet, nameSetToList )
import PrelInfo ( eRROR_ID )
-import PprType ( pprClassPred, pprPred )
+import PprType ( pprClassPred )
import TyCon ( TyCon, isSynTyCon )
import Subst ( mkTopTyVarSubst, substTheta )
import VarSet ( varSetElems )
\begin{code}
tcInstDecl1 :: RenamedInstDecl -> NF_TcM [InstInfo]
-- Deal with a single instance declaration
+-- Type-check all the stuff before the "where"
tcInstDecl1 decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc)
= -- Prime error recovery, set source location
recoverNF_Tc (returnNF_Tc []) $
tcAddSrcLoc src_loc $
+ tcAddErrCtxt (instDeclCtxt poly_ty) $
- -- Type-check all the stuff before the "where"
- traceTc (text "Starting inst" <+> ppr poly_ty) `thenTc_`
- tcAddErrCtxt (instDeclCtxt poly_ty) (
- tcHsSigType poly_ty
- ) `thenTc` \ poly_ty' ->
+ -- Typecheck the instance type itself. We can't use
+ -- tcHsSigType, because it's not a valid user type.
+ kcHsSigType poly_ty `thenTc_`
+ tcHsType poly_ty `thenTc` \ poly_ty' ->
let
- (tyvars, theta, clas, inst_tys) = tcSplitDFunTy poly_ty'
+ (tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
+ maybe_cls_tys = case tcSplitPredTy_maybe tau of
+ Just pred -> getClassPredTys_maybe pred
+ Nothing -> Nothing
+ Just (clas, inst_tys) = maybe_cls_tys
in
+ checkTc (maybeToBool maybe_cls_tys) (instHeadErr tau) `thenTc_`
- traceTc (text "Check validity") `thenTc_`
(case maybe_dfun_name of
Nothing -> -- A source-file instance declaration
-- contain something illegal in normal Haskell, notably
-- instance CCallable [Char]
getDOptsTc `thenTc` \ dflags ->
- checkInstValidity dflags theta clas inst_tys `thenTc_`
-
- -- Make the dfun id and return it
- traceTc (text "new name") `thenTc_`
- newDFunName clas inst_tys src_loc `thenNF_Tc` \ dfun_name ->
- returnNF_Tc (True, dfun_name)
+ checkValidTheta InstDeclCtxt theta `thenTc_`
+ checkValidInstHead dflags theta clas inst_tys `thenTc_`
+ newDFunName clas inst_tys src_loc
Just dfun_name -> -- An interface-file instance declaration
- -- Make the dfun id
- returnNF_Tc (False, dfun_name)
- ) `thenNF_Tc` \ (is_local, dfun_name) ->
+ returnNF_Tc dfun_name
+ ) `thenNF_Tc` \ dfun_name ->
- traceTc (text "Name" <+> ppr dfun_name) `thenTc_`
let
dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta
in
- returnTc [InstInfo { iDFunId = dfun_id,
- iBinds = binds, iPrags = uprags }]
+ returnTc [InstInfo { iDFunId = dfun_id, iBinds = binds, iPrags = uprags }]
\end{code}
tcHsTyVars sig_tvs (kcHsSigType hs_ty) $ \ tyvars ->
-- Type-check the instance type, and check its form
- tcHsSigType hs_ty `thenTc` \ inst_ty ->
+ tcHsSigType GenPatCtxt hs_ty `thenTc` \ inst_ty ->
checkTc (validGenericInstanceType inst_ty)
(badGenericInstanceType binds) `thenTc_`
%* *
%************************************************************************
-@scrutiniseInstanceHead@ checks the type {\em and} its syntactic constraints:
+@checkValidInstHead@ checks the type {\em and} its syntactic constraints:
it must normally look like: @instance Foo (Tycon a b c ...) ...@
The exceptions to this syntactic checking: (1)~if the @GlasgowExts@
We can also have instances for functions: @instance Foo (a -> b) ...@.
\begin{code}
-checkInstValidity dflags theta clas inst_tys
+checkValidInstHead dflags theta clas inst_tys
| null errs = returnTc ()
| otherwise = addErrsTc errs `thenNF_Tc_` failTc
where
- errs = checkInstHead dflags theta clas inst_tys ++
- [err | pred <- theta, err <- checkInstConstraint dflags pred]
-
-checkInstConstraint dflags pred
- -- Checks whether a predicate is legal in the
- -- context of an instance declaration
- | ok = []
- | otherwise = [instConstraintErr pred]
- where
- ok = inheritablePred pred &&
- (isTyVarClassPred pred || arbitrary_preds_ok)
-
- arbitrary_preds_ok = dopt Opt_AllowUndecidableInstances dflags
+ errs = check_inst_head dflags theta clas inst_tys
-
-checkInstHead dflags theta clas inst_taus
+check_inst_head dflags theta clas inst_taus
| -- CCALL CHECK
-- A user declaration of a CCallable/CReturnable instance
-- must be for a "boxed primitive" type.
\end{code}
\begin{code}
-instConstraintErr pred
- = hang (ptext SLIT("Illegal constraint") <+>
- quotes (pprPred pred) <+>
- ptext SLIT("in instance context"))
- 4 (ptext SLIT("(Instance contexts must constrain only type variables)"))
-
badGenericInstanceType binds
= vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
nest 4 (ppr binds)]
where
ppr_inst_ty (tc,inst) = ppr (simpleInstInfoTy inst)
+instHeadErr ty
+ = vcat [ptext SLIT("Illegal instance head:") <+> ppr ty,
+ ptext SLIT("Instance head must be of form <context> => <class> <types>")]
+
instTypeErr clas tys msg
= sep [ptext SLIT("Illegal instance declaration for") <+>
quotes (pprClassPred clas tys),
tcSplitRhoTyM,
--------------------------------
+ -- Checking type validity
+ Rank, UserTypeCtxt(..), checkValidType, pprUserTypeCtxt,
+ SourceTyCtxt(..), checkValidTheta,
+
+ --------------------------------
-- Unification
unifyTauTy, unifyTauTyList, unifyTauTyLists,
unifyFunTy, unifyListTy, unifyTupleTy,
-- friends:
-import TypeRep ( Type(..), SourceType(..), Kind, TyNote(..), -- friend
+import TypeRep ( Type(..), SourceType(..), TyNote(..), -- Friend; can see representation
+ Kind, TauType, ThetaType,
openKindCon, typeCon
)
-import TcType ( tcEqType,
+import TcType ( tcEqType, tcCmpPred,
tcSplitRhoTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe,
tcSplitTyConApp_maybe, tcSplitFunTy_maybe, tcSplitForAllTys,
- tcGetTyVar, tcIsTyVarTy,
+ tcGetTyVar, tcIsTyVarTy, tcSplitSigmaTy, isUnLiftedType, isIPPred,
mkAppTy, mkTyVarTy, mkTyVarTys, mkFunTy, mkTyConApp,
+ tyVarsOfPred,
liftedTypeKind, unliftedTypeKind, openTypeKind, defaultKind, superKind,
superBoxity, liftedBoxity, hasMoreBoxityInfo, typeKind,
tyVarsOfType, tyVarsOfTypes, tidyOpenType, tidyOpenTypes, tidyTyVar,
- eqKind,
+ eqKind, isTypeKind
)
import Subst ( Subst, mkTopTyVarSubst, substTy )
-import TyCon ( TyCon, mkPrimTyCon, isTupleTyCon, tyConArity, tupleTyConBoxity )
+import Class ( classArity, className )
+import TyCon ( TyCon, mkPrimTyCon, isSynTyCon, isUnboxedTupleTyCon,
+ isTupleTyCon, tyConArity, tupleTyConBoxity, tyConName )
import PrimRep ( PrimRep(VoidRep) )
import Var ( TyVar, varName, tyVarKind, tyVarName, isTyVar, mkTyVar,
isMutTyVar, isSigTyVar )
-- others:
import TcMonad -- TcType, amongst others
import TysWiredIn ( voidTy, listTyCon, mkListTy, mkTupleTy )
-
+import FunDeps ( grow )
+import PprType ( pprPred, pprSourceType, pprTheta )
import Name ( Name, NamedThing(..), setNameUnique, mkSysLocalName,
mkLocalName, mkDerivedTyConOcc, isSystemName
)
import VarSet
import BasicTypes ( Boxity, Arity, isBoxed )
+import CmdLineOpts ( dopt, DynFlag(..) )
import Unique ( Uniquable(..) )
import SrcLoc ( noSrcLoc )
import Util ( nOfThem )
+import ListSetOps ( removeDups )
import Outputable
\end{code}
-- Zonk a mutable but unbound type variable to
-- Void if it has kind Lifted
-- :Void otherwise
+ -- We know it's unbound even though we don't carry an environment,
+ -- because at the binding site for a type variable we bind the
+ -- mutable tyvar to a fresh immutable one. So the mutable store
+ -- plays the role of an environment. If we come across a mutable
+ -- type variable that isn't so bound, it must be completely free.
zonk_unbound_tyvar tv
| kind `eqKind` liftedTypeKind || kind `eqKind` openTypeKind
= putTcTyVar tv voidTy -- Just to avoid creating a new tycon in
%************************************************************************
%* *
-\subsection{The Kind variants}
+\subsection{Checking a user type}
+%* *
+%************************************************************************
+
+When dealing with a user-written type, we first translate it from an HsType
+to a Type, performing kind checking, and then check various things that should
+be true about it. We don't want to perform these checks at the same time
+as the initial translation because (a) they are unnecessary for interface-file
+types and (b) when checking a mutually recursive group of type and class decls,
+we can't "look" at the tycons/classes yet.
+
+One thing we check for is 'rank'.
+
+ Rank 0: monotypes (no foralls)
+ Rank 1: foralls at the front only, Rank 0 inside
+ Rank 2: foralls at the front, Rank 1 on left of fn arrow,
+
+ basic ::= tyvar | T basic ... basic
+
+ r2 ::= forall tvs. cxt => r2a
+ r2a ::= r1 -> r2a | basic
+ r1 ::= forall tvs. cxt => r0
+ r0 ::= r0 -> r0 | basic
+
+
+\begin{code}
+data UserTypeCtxt
+ = FunSigCtxt Name -- Function type signature
+ | ExprSigCtxt -- Expression type signature
+ | ConArgCtxt Name -- Data constructor argument
+ | TySynCtxt Name -- RHS of a type synonym decl
+ | GenPatCtxt -- Pattern in generic decl
+ -- f{| a+b |} (Inl x) = ...
+ | PatSigCtxt -- Type sig in pattern
+ -- f (x::t) = ...
+ | ResSigCtxt -- Result type sig
+ -- f x :: t = ....
+ | ForSigCtxt Name -- Foreign inport or export signature
+
+pprUserTypeCtxt (FunSigCtxt n) = ptext SLIT("the type signature for") <+> quotes (ppr n)
+pprUserTypeCtxt ExprSigCtxt = ptext SLIT("an expression type signature")
+pprUserTypeCtxt (ConArgCtxt c) = ptext SLIT("the type of constructor") <+> quotes (ppr c)
+pprUserTypeCtxt (TySynCtxt c) = ptext SLIT("the RHS of a type synonym declaration") <+> quotes (ppr c)
+pprUserTypeCtxt GenPatCtxt = ptext SLIT("the type pattern of a generic definition")
+pprUserTypeCtxt PatSigCtxt = ptext SLIT("a pattern type signature")
+pprUserTypeCtxt ResSigCtxt = ptext SLIT("a result type signature")
+pprUserTypeCtxt (ForSigCtxt n) = ptext SLIT("the foreign signature for") <+> quotes (ppr n)
+\end{code}
+
+\begin{code}
+checkValidType :: UserTypeCtxt -> Type -> TcM ()
+-- Checks that the type is valid for the given context
+checkValidType ctxt ty
+ = doptsTc Opt_GlasgowExts `thenNF_Tc` \ gla_exts ->
+ let
+ rank = case ctxt of
+ GenPatCtxt -> 0
+ PatSigCtxt -> 0
+ ResSigCtxt -> 0
+ ExprSigCtxt -> 1
+ FunSigCtxt _ | gla_exts -> 2
+ | otherwise -> 1
+ ConArgCtxt _ | gla_exts -> 2 -- We are given the type of the entire
+ | otherwise -> 1 -- constructor; hence rank 1 is ok
+ TySynCtxt _ | gla_exts -> 1
+ | otherwise -> 0
+ ForSigCtxt _ -> 1
+
+ actual_kind = typeKind ty
+
+ actual_kind_is_lifted = actual_kind `eqKind` liftedTypeKind
+
+ kind_ok = case ctxt of
+ TySynCtxt _ -> True -- Any kind will do
+ GenPatCtxt -> actual_kind_is_lifted
+ ForSigCtxt _ -> actual_kind_is_lifted
+ other -> isTypeKind actual_kind
+ in
+ tcAddErrCtxt (checkTypeCtxt ctxt ty) $
+
+ -- Check that the thing has kind Type, and is lifted if necessary
+ checkTc kind_ok (kindErr actual_kind) `thenTc_`
+
+ -- Check the internal validity of the type itself
+ check_poly_type rank ty
+
+-- Notes re TySynCtxt
+-- We allow type synonyms that aren't types; e.g. type List = []
+--
+-- If the RHS mentions tyvars that aren't in scope, we'll
+-- quantify over them:
+-- e.g. type T = a->a
+-- will become type T = forall a. a->a
+--
+-- With gla-exts that's right, but for H98 we should complain.
+
+
+----------------------------------------
+type Rank = Int
+check_poly_type :: Rank -> Type -> TcM ()
+check_poly_type rank ty
+ | rank == 0
+ = check_tau_type 0 False ty
+ | otherwise -- rank > 0
+ = let
+ (tvs, theta, tau) = tcSplitSigmaTy ty
+ in
+ check_valid_theta SigmaCtxt theta `thenTc_`
+ check_tau_type (rank-1) False tau `thenTc_`
+ checkAmbiguity tvs theta tau
+
+----------------------------------------
+check_arg_type :: Type -> TcM ()
+-- The sort of type that can instantiate a type variable,
+-- or be the argument of a type constructor.
+-- Not an unboxed tuple, not a forall.
+-- Other unboxed types are very occasionally allowed as type
+-- arguments depending on the kind of the type constructor
+--
+-- For example, we want to reject things like:
+--
+-- instance Ord a => Ord (forall s. T s a)
+-- and
+-- g :: T s (forall b.b)
+--
+-- NB: unboxed tuples can have polymorphic or unboxed args.
+-- This happens in the workers for functions returning
+-- product types with polymorphic components.
+-- But not in user code
+--
+-- Question: what about nested unboxed tuples?
+-- Currently rejected.
+check_arg_type ty
+ = check_tau_type 0 False ty `thenTc_`
+ checkTc (not (isUnLiftedType ty)) (unliftedArgErr ty)
+
+----------------------------------------
+check_tau_type :: Rank -> Bool -> Type -> TcM ()
+-- Rank is allowed rank for function args
+-- No foralls otherwise
+-- Bool is True iff unboxed tuple are allowed here
+
+check_tau_type rank ubx_tup_ok ty@(UsageTy _ _) = addErrTc (usageTyErr ty)
+check_tau_type rank ubx_tup_ok ty@(ForAllTy _ _) = addErrTc (forAllTyErr ty)
+check_tau_type rank ubx_tup_ok (SourceTy sty) = getDOptsTc `thenNF_Tc` \ dflags ->
+ check_source_ty dflags TypeCtxt sty
+check_tau_type rank ubx_tup_ok (TyVarTy _) = returnTc ()
+check_tau_type rank ubx_tup_ok ty@(FunTy arg_ty res_ty)
+ = check_poly_type rank arg_ty `thenTc_`
+ check_tau_type rank True res_ty
+
+check_tau_type rank ubx_tup_ok (AppTy ty1 ty2)
+ = check_arg_type ty1 `thenTc_` check_arg_type ty2
+
+check_tau_type rank ubx_tup_ok (NoteTy note ty)
+ = check_note note `thenTc_` check_tau_type rank ubx_tup_ok ty
+
+check_tau_type rank ubx_tup_ok ty@(TyConApp tc tys)
+ = mapTc_ check_arg_type tys `thenTc_`
+ checkTc (not (isSynTyCon tc) || syn_arity_ok) arity_msg `thenTc_`
+ checkTc (not (isUnboxedTupleTyCon tc) || ubx_tup_ok) ubx_tup_msg
+ where
+ syn_arity_ok = tc_arity <= n_args
+ -- It's OK to have an *over-applied* type synonym
+ -- data Tree a b = ...
+ -- type Foo a = Tree [a]
+ -- f :: Foo a b -> ...
+ n_args = length tys
+ tc_arity = tyConArity tc
+
+ arity_msg = arityErr "Type synonym" (tyConName tc) tc_arity n_args
+ ubx_tup_msg = ubxArgTyErr ty
+
+----------------------------------------
+check_note (FTVNote _) = returnTc ()
+check_note (SynNote ty) = check_tau_type 0 False ty
+\end{code}
+
+
+\begin{code}
+data SourceTyCtxt
+ = ClassSCCtxt Name -- Superclasses of clas
+ | SigmaCtxt -- Context of a normal for-all type
+ | DataTyCtxt Name -- Context of a data decl
+ | TypeCtxt -- Source type in an ordinary type
+ | InstDeclCtxt -- Context of an instance decl
+
+pprSourceTyCtxt (ClassSCCtxt c) = ptext SLIT("the super-classes of class") <+> quotes (ppr c)
+pprSourceTyCtxt SigmaCtxt = ptext SLIT("the context of a polymorphic type")
+pprSourceTyCtxt (DataTyCtxt tc) = ptext SLIT("the context of the data type declaration for") <+> quotes (ppr tc)
+pprSourceTyCtxt InstDeclCtxt = ptext SLIT("the context of an instance declaration")
+pprSourceTyCtxt TypeCtxt = ptext SLIT("the context of a type")
+\end{code}
+
+\begin{code}
+checkValidTheta :: SourceTyCtxt -> ThetaType -> TcM ()
+checkValidTheta ctxt theta
+ = tcAddErrCtxt (checkThetaCtxt ctxt theta) (check_valid_theta ctxt theta)
+
+-------------------------
+check_valid_theta ctxt []
+ = returnTc ()
+check_valid_theta ctxt theta
+ = getDOptsTc `thenNF_Tc` \ dflags ->
+ warnTc (not (null dups)) (dupPredWarn dups) `thenNF_Tc_`
+ mapTc_ (check_source_ty dflags ctxt) theta
+ where
+ (_,dups) = removeDups tcCmpPred theta
+
+-------------------------
+check_source_ty dflags ctxt pred@(ClassP cls tys)
+ = -- Class predicates are valid in all contexts
+ mapTc_ check_arg_type tys `thenTc_`
+ checkTc (arity == n_tys) arity_err `thenTc_`
+ checkTc (all tyvar_head tys || arby_preds_ok) (predTyVarErr pred)
+
+ where
+ class_name = className cls
+ arity = classArity cls
+ n_tys = length tys
+ arity_err = arityErr "Class" class_name arity n_tys
+
+ arby_preds_ok = case ctxt of
+ InstDeclCtxt -> dopt Opt_AllowUndecidableInstances dflags
+ other -> dopt Opt_GlasgowExts dflags
+
+check_source_ty dflags SigmaCtxt (IParam name ty) = check_arg_type ty
+check_source_ty dflags TypeCtxt (NType tc tys) = mapTc_ check_arg_type tys
+
+-- Catch-all
+check_source_ty dflags ctxt sty = failWithTc (badSourceTyErr sty)
+
+-------------------------
+tyvar_head ty -- Haskell 98 allows predicates of form
+ | tcIsTyVarTy ty = True -- C (a ty1 .. tyn)
+ | otherwise -- where a is a type variable
+ = case tcSplitAppTy_maybe ty of
+ Just (ty, _) -> tyvar_head ty
+ Nothing -> False
+\end{code}
+
+Check for ambiguity
+~~~~~~~~~~~~~~~~~~~
+ forall V. P => tau
+is ambiguous if P contains generic variables
+(i.e. one of the Vs) that are not mentioned in tau
+
+However, we need to take account of functional dependencies
+when we speak of 'mentioned in tau'. Example:
+ class C a b | a -> b where ...
+Then the type
+ forall x y. (C x y) => x
+is not ambiguous because x is mentioned and x determines y
+
+NOTE: In addition, GHC insists that at least one type variable
+in each constraint is in V. So we disallow a type like
+ forall a. Eq b => b -> b
+even in a scope where b is in scope.
+This is the is_free test below.
+
+NB; the ambiguity check is only used for *user* types, not for types
+coming from inteface files. The latter can legitimately have
+ambiguous types. Example
+
+ class S a where s :: a -> (Int,Int)
+ instance S Char where s _ = (1,1)
+ f:: S a => [a] -> Int -> (Int,Int)
+ f (_::[a]) x = (a*x,b)
+ where (a,b) = s (undefined::a)
+
+Here the worker for f gets the type
+ fw :: forall a. S a => Int -> (# Int, Int #)
+
+If the list of tv_names is empty, we have a monotype, and then we
+don't need to check for ambiguity either, because the test can't fail
+(see is_ambig).
+
+\begin{code}
+checkAmbiguity :: [TyVar] -> ThetaType -> TauType -> TcM ()
+checkAmbiguity forall_tyvars theta tau
+ = mapTc_ check_pred theta `thenTc_`
+ returnTc ()
+ where
+ tau_vars = tyVarsOfType tau
+ extended_tau_vars = grow theta tau_vars
+
+ is_ambig ct_var = (ct_var `elem` forall_tyvars) &&
+ not (ct_var `elemVarSet` extended_tau_vars)
+ is_free ct_var = not (ct_var `elem` forall_tyvars)
+
+ check_pred pred = checkTc (not any_ambig) (ambigErr pred) `thenTc_`
+ checkTc (isIPPred pred || not all_free) (freeErr pred)
+ where
+ ct_vars = varSetElems (tyVarsOfPred pred)
+ all_free = all is_free ct_vars
+ any_ambig = any is_ambig ct_vars
+\end{code}
+
+
+\begin{code}
+ambigErr pred
+ = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprPred pred),
+ nest 4 (ptext SLIT("At least one of the forall'd type variables mentioned by the constraint") $$
+ ptext SLIT("must be reachable from the type after the =>"))]
+
+freeErr pred
+ = sep [ptext SLIT("All of the type variables in the constraint") <+> quotes (pprPred pred) <+>
+ ptext SLIT("are already in scope"),
+ nest 4 (ptext SLIT("At least one must be universally quantified here"))
+ ]
+
+forAllTyErr ty = ptext SLIT("Illegal polymorphic type:") <+> ppr ty
+usageTyErr ty = ptext SLIT("Illegal usage type:") <+> ppr ty
+unliftedArgErr ty = ptext SLIT("Illegal unlifted type argument:") <+> ppr ty
+ubxArgTyErr ty = ptext SLIT("Illegal unboxed tuple type as function argument:") <+> ppr ty
+badSourceTyErr sty = ptext SLIT("Illegal constraint") <+> pprSourceType sty
+predTyVarErr pred = ptext SLIT("Non-type variables in constraint:") <+> pprPred pred
+kindErr kind = ptext SLIT("Expecting an ordinary type, but found a type of kind") <+> ppr kind
+dupPredWarn dups = ptext SLIT("Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups)
+
+checkTypeCtxt ctxt ty
+ = vcat [ptext SLIT("In the type:") <+> ppr_ty,
+ ptext SLIT("While checking") <+> pprUserTypeCtxt ctxt ]
+ where
+ -- Hack alert. If there are no tyvars, (ppr sigma_ty) will print
+ -- something strange like {Eq k} -> k -> k, because there is no
+ -- ForAll at the top of the type. Since this is going to the user
+ -- we want it to look like a proper Haskell type even then; hence the hack
+ --
+ -- This shows up in the complaint about
+ -- case C a where
+ -- op :: Eq a => a -> a
+ ppr_ty | null forall_tyvars = pprTheta theta <+> ptext SLIT("=>") <+> ppr tau
+ | otherwise = ppr ty
+ (forall_tyvars, theta, tau) = tcSplitSigmaTy ty
+
+checkThetaCtxt ctxt theta
+ = vcat [ptext SLIT("In the context:") <+> pprTheta theta,
+ ptext SLIT("While checking") <+> pprSourceTyCtxt ctxt ]
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Kind unification}
%* *
%************************************************************************
other -> unify_open_kind_help ty
unifyOpenTypeKind ty
- = case tcSplitTyConApp_maybe ty of
- Just (tycon, [_]) | tycon == typeCon -> returnTc ()
- other -> unify_open_kind_help ty
+ | isTypeKind ty = returnTc ()
+ | otherwise = unify_open_kind_help ty
unify_open_kind_help ty -- Revert to ordinary unification
= newBoxityVar `thenNF_Tc` \ boxity ->
import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TypecheckedPat )
import TcMonad
-import TcMonoType ( kcHsSigTypes, tcScopedTyVars, checkSigTyVars, tcHsSigType, sigPatCtxt )
+import TcMonoType ( kcHsSigTypes, tcScopedTyVars, checkSigTyVars, tcHsSigType, UserTypeCtxt(..), sigPatCtxt )
import Inst ( LIE, isEmptyLIE, plusLIE, emptyLIE, plusLIEs, lieToList )
import TcEnv ( TcId, tcLookupLocalIds, tcExtendLocalValEnv, tcExtendGlobalTyVars,
tcInLocalScope )
= thing_inside
tc_result_sig (Just sig) thing_inside
= tcAddScopedTyVars [sig] $
- tcHsSigType sig `thenTc` \ sig_ty ->
+ tcHsSigType ResSigCtxt sig `thenTc` \ sig_ty ->
-- Check that the signature isn't a polymorphic one, which
-- we don't permit (at present, anyway)
-- tcImports recovers internally, but if anything gave rise to
-- an error we'd better stop now, to avoid a cascade
- traceTc (text "Tc1") `thenNF_Tc_`
- tcTyAndClassDecls unf_env tycl_decls `thenTc` \ env ->
- tcSetEnv env $
+ traceTc (text "Tc1") `thenNF_Tc_`
+ tcTyAndClassDecls unf_env this_mod tycl_decls `thenTc` \ env ->
+ tcSetEnv env $
-- Typecheck the instance decls, includes deriving
traceTc (text "Tc2") `thenNF_Tc_`
m_errs_var <- newIORef (emptyBag,emptyBag)
catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
where
+ errs_var = getTcErrs down
+
my_recover m_errs_var
= do warns_and_errs <- readIORef m_errs_var
recover warns_and_errs down env
-- errors along the way.
(m_warns, m_errs) <- readIORef m_errs_var
if isEmptyBag m_errs then
- return result
+ -- No errors, so return normally, but don't lose the warnings
+ if isEmptyBag m_warns then
+ return result
+ else
+ do (warns, errs) <- readIORef errs_var
+ writeIORef errs_var (warns `unionBags` m_warns, errs)
+ return result
else
give_up -- This triggers the catch
\section[TcMonoType]{Typechecking user-specified @MonoTypes@}
\begin{code}
-module TcMonoType ( tcHsType, tcHsRecType, tcIfaceType,
- tcHsSigType, tcHsLiftedSigType,
- tcRecTheta, checkAmbiguity,
+module TcMonoType ( tcHsSigType, tcHsType, tcIfaceType, tcHsTheta,
+ UserTypeCtxt(..),
-- Kind checking
kcHsTyVar, kcHsTyVars, mkTyClTyVars,
)
import TcMType ( newKindVar, tcInstSigVars,
zonkKindEnv, zonkTcType, zonkTcTyVars, zonkTcTyVar,
- unifyKind, unifyOpenTypeKind
+ unifyKind, unifyOpenTypeKind,
+ checkValidType, UserTypeCtxt(..), pprUserTypeCtxt
)
-import TcType ( Type, Kind, SourceType(..), ThetaType, SigmaType, TauType,
+import TcType ( Type, Kind, SourceType(..), ThetaType,
mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy,
tcSplitForAllTys, tcSplitRhoTy,
hoistForAllTys, allDistinctTyVars,
liftedTypeKind, unliftedTypeKind, mkArrowKind,
mkArrowKinds, tcGetTyVar_maybe, tcGetTyVar, tcSplitFunTy_maybe,
tidyOpenType, tidyOpenTypes, tidyTyVar, tidyTyVars,
- tyVarsOfType, tyVarsOfPred, mkForAllTys,
- isUnboxedTupleType, tcIsForAllTy, isIPPred
+ tyVarsOfType, mkForAllTys
)
import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToId )
-import FunDeps ( grow )
-import PprType ( pprType, pprTheta, pprPred )
+import PprType ( pprType )
import Subst ( mkTopTyVarSubst, substTy )
import CoreFVs ( idFreeTyVars )
import Id ( mkLocalId, idName, idType )
import VarSet
import ErrUtils ( Message )
import TyCon ( TyCon, isSynTyCon, tyConArity, tyConKind )
-import Class ( classArity, classTyCon )
+import Class ( classTyCon )
import Name ( Name )
import TysWiredIn ( mkListTy, mkTupleTy, genUnitTyCon )
-import BasicTypes ( Boxity(..), RecFlag(..), isRec )
+import BasicTypes ( Boxity(..) )
import SrcLoc ( SrcLoc )
import Util ( mapAccumL, isSingleton )
import Outputable
%************************************************************************
%* *
+\subsection{Checking types}
+%* *
+%************************************************************************
+
+Generally speaking we now type-check types in three phases
+
+ 1. Kind check the HsType [kcHsType]
+ 2. Convert from HsType to Type, and hoist the foralls [tcHsType]
+ 3. Check the validity of the resultint type [checkValidType]
+
+Often these steps are done one after the othe (tcHsSigType).
+But in mutually recursive groups of type and class decls we do
+ 1 kind-check the whole group
+ 2 build TyCons/Classes in a knot-tied wa
+ 3 check the validity of types in the now-unknotted TyCons/Classes
+
+\begin{code}
+tcHsSigType :: UserTypeCtxt -> RenamedHsType -> TcM Type
+ -- Do kind checking, and hoist for-alls to the top
+tcHsSigType ctxt ty = tcAddErrCtxt (checkTypeCtxt ctxt ty) (
+ kcTypeType ty `thenTc_`
+ tcHsType ty
+ ) `thenTc` \ ty' ->
+ checkValidType ctxt ty' `thenTc_`
+ returnTc ty'
+
+checkTypeCtxt ctxt ty
+ = vcat [ptext SLIT("In the type:") <+> ppr ty,
+ ptext SLIT("While checking") <+> pprUserTypeCtxt ctxt ]
+
+tcHsType :: RenamedHsType -> TcM Type
+ -- Don't do kind checking, nor validity checking,
+ -- but do hoist for-alls to the top
+ -- 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.]
+tcHsType ty = tc_type ty `thenTc` \ ty' ->
+ returnTc (hoistForAllTys ty')
+
+tcHsTheta :: RenamedContext -> TcM ThetaType
+-- Used when we are expecting a ClassContext (i.e. no implicit params)
+-- Does not do validity checking, like tcHsType
+tcHsTheta hs_theta = mapTc tc_pred hs_theta
+
+-- In interface files the type is already kinded,
+-- and we definitely don't want to hoist for-alls.
+-- Otherwise we'll change
+-- dmfail :: forall m:(*->*) Monad m => forall a:* => String -> m a
+-- into
+-- dmfail :: forall m:(*->*) a:* Monad m => String -> m a
+-- which definitely isn't right!
+tcIfaceType ty = tc_type ty
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Kind checking}
%* *
%************************************************************************
%************************************************************************
%* *
-\subsection{Checking types}
-%* *
-%************************************************************************
-
-tcHsSigType and tcHsLiftedSigType
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-tcHsSigType and tcHsLiftedSigType are used for type signatures written by the programmer
-
- * We hoist any inner for-alls to the top
-
- * Notice that we kind-check first, because the type-check assumes
- that the kinds are already checked.
-
- * They are only called when there are no kind vars in the environment
- so the kind returned is indeed a Kind not a TcKind
-
-\begin{code}
-tcHsSigType, tcHsLiftedSigType :: RenamedHsType -> TcM Type
- -- Do kind checking, and hoist for-alls to the top
-tcHsSigType ty = kcTypeType ty `thenTc_` tcHsType ty
-tcHsLiftedSigType ty = kcLiftedType ty `thenTc_` tcHsType ty
-
-tcHsType :: RenamedHsType -> TcM Type
-tcHsRecType :: RecFlag -> RenamedHsType -> TcM Type
- -- Don't do kind checking, but do hoist for-alls to the top
- -- These are used in type and class decls, where kinding is
- -- done in advance
-tcHsType ty = tc_type NonRecursive ty `thenTc` \ ty' -> returnTc (hoistForAllTys ty')
-tcHsRecType wimp_out ty = tc_type wimp_out ty `thenTc` \ ty' -> returnTc (hoistForAllTys ty')
-
--- In interface files the type is already kinded,
--- and we definitely don't want to hoist for-alls.
--- Otherwise we'll change
--- dmfail :: forall m:(*->*) Monad m => forall a:* => String -> m a
--- into
--- dmfail :: forall m:(*->*) a:* Monad m => String -> m a
--- which definitely isn't right!
-tcIfaceType ty = tc_type NonRecursive ty
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{tc_type}
%* *
%************************************************************************
tcHsType; if you poke on too much you get a black hole. I keep
forgetting this, hence this warning!
-The wimp_out argument tells when we are in a mutually-recursive
-group of type declarations, so omit various checks else we
-get a black hole. They'll be done again later, in TcTyClDecls.tcGroup.
+So tc_type does no validity-checking. Instead that's all done
+by TcMType.checkValidType
--------------------------
*** END OF BIG WARNING ***
\begin{code}
-tc_type :: RecFlag -> RenamedHsType -> TcM Type
+tc_type :: RenamedHsType -> TcM Type
-tc_type wimp_out ty@(HsTyVar name)
- = tc_app wimp_out ty []
+tc_type ty@(HsTyVar name)
+ = tc_app ty []
-tc_type wimp_out (HsListTy ty)
- = tc_arg_type wimp_out ty `thenTc` \ tau_ty ->
+tc_type (HsListTy ty)
+ = tc_type ty `thenTc` \ tau_ty ->
returnTc (mkListTy tau_ty)
-tc_type wimp_out (HsTupleTy (HsTupCon _ boxity arity) tys)
+tc_type (HsTupleTy (HsTupCon _ boxity arity) tys)
= ASSERT( arity == length tys )
- mapTc tc_tup_arg tys `thenTc` \ tau_tys ->
+ tc_types tys `thenTc` \ tau_tys ->
returnTc (mkTupleTy boxity arity tau_tys)
- where
- tc_tup_arg = case boxity of
- Boxed -> tc_arg_type wimp_out
- Unboxed -> tc_type wimp_out
- -- Unboxed tuples can have polymorphic or unboxed args.
- -- This happens in the workers for functions returning
- -- product types with polymorphic components
-
-tc_type wimp_out (HsFunTy ty1 ty2)
- = tc_type wimp_out ty1 `thenTc` \ tau_ty1 ->
- -- Function argument can be polymorphic, but
- -- must not be an unboxed tuple
- --
- -- In a recursive loop we can't ask whether the thing is
- -- unboxed -- might be a synonym inside a synonym inside a group
- checkTc (isRec wimp_out || not (isUnboxedTupleType tau_ty1))
- (ubxArgTyErr ty1) `thenTc_`
- tc_type wimp_out ty2 `thenTc` \ tau_ty2 ->
+
+tc_type (HsFunTy ty1 ty2)
+ = tc_type ty1 `thenTc` \ tau_ty1 ->
+ tc_type ty2 `thenTc` \ tau_ty2 ->
returnTc (mkFunTy tau_ty1 tau_ty2)
-tc_type wimp_out (HsNumTy n)
+tc_type (HsNumTy n)
= ASSERT(n== 1)
returnTc (mkTyConApp genUnitTyCon [])
-tc_type wimp_out (HsOpTy ty1 op ty2) =
- tc_arg_type wimp_out ty1 `thenTc` \ tau_ty1 ->
- tc_arg_type wimp_out ty2 `thenTc` \ tau_ty2 ->
- tc_fun_type op [tau_ty1,tau_ty2]
+tc_type (HsOpTy ty1 op ty2)
+ = tc_type ty1 `thenTc` \ tau_ty1 ->
+ tc_type ty2 `thenTc` \ tau_ty2 ->
+ tc_fun_type op [tau_ty1,tau_ty2]
-tc_type wimp_out (HsAppTy ty1 ty2)
- = tc_app wimp_out ty1 [ty2]
+tc_type (HsAppTy ty1 ty2) = tc_app ty1 [ty2]
-tc_type wimp_out (HsPredTy pred)
- = tc_pred wimp_out pred `thenTc` \ pred' ->
+tc_type (HsPredTy pred)
+ = tc_pred pred `thenTc` \ pred' ->
returnTc (mkPredTy pred')
-tc_type wimp_out full_ty@(HsForAllTy (Just tv_names) ctxt ty)
+tc_type full_ty@(HsForAllTy (Just tv_names) ctxt ty)
= let
kind_check = kcHsContext ctxt `thenTc_` kcHsType ty
in
- tcHsTyVars tv_names kind_check $ \ tyvars ->
- tcRecTheta wimp_out ctxt `thenTc` \ theta ->
-
- -- Context behaves like a function type
- -- This matters. Return-unboxed-tuple analysis can
- -- give overloaded functions like
- -- f :: forall a. Num a => (# a->a, a->a #)
- -- And we want these to get through the type checker
- (if null theta then
- tc_arg_type wimp_out ty
- else
- tc_type wimp_out ty
- ) `thenTc` \ tau ->
-
- checkAmbiguity wimp_out is_source tyvars theta tau
- where
- is_source = case tv_names of
- (UserTyVar _ : _) -> True
- other -> False
-
-
- -- tc_arg_type checks that the argument of a
- -- type appplication isn't a for-all type or an unboxed tuple type
- -- For example, we want to reject things like:
- --
- -- instance Ord a => Ord (forall s. T s a)
- -- and
- -- g :: T s (forall b.b)
- --
- -- Other unboxed types are very occasionally allowed as type
- -- arguments depending on the kind of the type constructor
-
-tc_arg_type wimp_out arg_ty
- | isRec wimp_out
- = tc_type wimp_out arg_ty
+ tcHsTyVars tv_names kind_check $ \ tyvars ->
+ mapTc tc_pred ctxt `thenTc` \ theta ->
+ tc_type ty `thenTc` \ tau ->
+ returnTc (mkSigmaTy tyvars theta tau)
- | otherwise
- = tc_type wimp_out arg_ty `thenTc` \ arg_ty' ->
- checkTc (isRec wimp_out || not (tcIsForAllTy arg_ty')) (polyArgTyErr arg_ty) `thenTc_`
- checkTc (isRec wimp_out || not (isUnboxedTupleType arg_ty')) (ubxArgTyErr arg_ty) `thenTc_`
- returnTc arg_ty'
-
-tc_arg_types wimp_out arg_tys = mapTc (tc_arg_type wimp_out) arg_tys
+tc_types arg_tys = mapTc tc_type arg_tys
\end{code}
Help functions for type applications
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-tc_app :: RecFlag -> RenamedHsType -> [RenamedHsType] -> TcM Type
-tc_app wimp_out (HsAppTy ty1 ty2) tys
- = tc_app wimp_out ty1 (ty2:tys)
+tc_app :: RenamedHsType -> [RenamedHsType] -> TcM Type
+tc_app (HsAppTy ty1 ty2) tys
+ = tc_app ty1 (ty2:tys)
-tc_app wimp_out ty tys
+tc_app ty tys
= tcAddErrCtxt (appKindCtxt pp_app) $
- tc_arg_types wimp_out tys `thenTc` \ arg_tys ->
+ tc_types tys `thenTc` \ arg_tys ->
case ty of
HsTyVar fun -> tc_fun_type fun arg_tys
- other -> tc_type wimp_out ty `thenTc` \ fun_ty ->
+ other -> tc_type ty `thenTc` \ fun_ty ->
returnNF_Tc (mkAppTys fun_ty arg_tys)
where
pp_app = ppr ty <+> sep (map pprParendHsType tys)
ATyVar tv -> returnTc (mkAppTys (mkTyVarTy tv) arg_tys)
AGlobal (ATyCon tc)
- | isSynTyCon tc -> checkTc arity_ok err_msg `thenTc_`
- returnTc (mkAppTys (mkSynTy tc (take arity arg_tys))
+ | isSynTyCon tc -> returnTc (mkAppTys (mkSynTy tc (take arity arg_tys))
(drop arity arg_tys))
-
- | otherwise -> returnTc (mkTyConApp tc arg_tys)
+ | otherwise -> returnTc (mkTyConApp tc arg_tys)
where
+ arity = tyConArity tc
- arity_ok = arity <= n_args
- arity = tyConArity tc
- -- It's OK to have an *over-applied* type synonym
- -- data Tree a b = ...
- -- type Foo a = Tree [a]
- -- f :: Foo a b -> ...
- err_msg = arityErr "Type synonym" name arity n_args
- n_args = length arg_tys
other -> failWithTc (wrongThingErr "type constructor" thing name)
\end{code}
Contexts
~~~~~~~~
\begin{code}
-tcRecTheta :: RecFlag -> RenamedContext -> TcM ThetaType
- -- Used when we are expecting a ClassContext (i.e. no implicit params)
-tcRecTheta wimp_out context = mapTc (tc_pred wimp_out) context
-
-tc_pred wimp_out assn@(HsClassP class_name tys)
+tc_pred assn@(HsClassP class_name tys)
= tcAddErrCtxt (appKindCtxt (ppr assn)) $
- tc_arg_types wimp_out tys `thenTc` \ arg_tys ->
+ tc_types tys `thenTc` \ arg_tys ->
tcLookupGlobal class_name `thenTc` \ thing ->
case thing of
- AClass clas -> checkTc (arity == n_tys) err `thenTc_`
- returnTc (ClassP clas arg_tys)
- where
- arity = classArity clas
- n_tys = length tys
- err = arityErr "Class" class_name arity n_tys
+ AClass clas -> returnTc (ClassP clas arg_tys)
+ other -> failWithTc (wrongThingErr "class" (AGlobal thing) class_name)
- other -> failWithTc (wrongThingErr "class" (AGlobal thing) class_name)
-
-tc_pred wimp_out assn@(HsIParam name ty)
+tc_pred assn@(HsIParam name ty)
= tcAddErrCtxt (appKindCtxt (ppr assn)) $
- tc_arg_type wimp_out ty `thenTc` \ arg_ty ->
+ tc_type ty `thenTc` \ arg_ty ->
returnTc (IParam name arg_ty)
\end{code}
-Check for ambiguity
-~~~~~~~~~~~~~~~~~~~
- forall V. P => tau
-is ambiguous if P contains generic variables
-(i.e. one of the Vs) that are not mentioned in tau
-
-However, we need to take account of functional dependencies
-when we speak of 'mentioned in tau'. Example:
- class C a b | a -> b where ...
-Then the type
- forall x y. (C x y) => x
-is not ambiguous because x is mentioned and x determines y
-
-NOTE: In addition, GHC insists that at least one type variable
-in each constraint is in V. So we disallow a type like
- forall a. Eq b => b -> b
-even in a scope where b is in scope.
-This is the is_free test below.
-
-Notes on the 'is_source_polytype' test above
-Check ambiguity only for source-program types, not
-for types coming from inteface files. The latter can
-legitimately have ambiguous types. Example
- class S a where s :: a -> (Int,Int)
- instance S Char where s _ = (1,1)
- f:: S a => [a] -> Int -> (Int,Int)
- f (_::[a]) x = (a*x,b)
- where (a,b) = s (undefined::a)
-Here the worker for f gets the type
- fw :: forall a. S a => Int -> (# Int, Int #)
-
-If the list of tv_names is empty, we have a monotype,
-and then we don't need to check for ambiguity either,
-because the test can't fail (see is_ambig).
-
-\begin{code}
-checkAmbiguity :: RecFlag -> Bool
- -> [TyVar] -> ThetaType -> TauType
- -> TcM SigmaType
-checkAmbiguity wimp_out is_source_polytype forall_tyvars theta tau
- | isRec wimp_out = returnTc sigma_ty
- | otherwise = mapTc_ check_pred theta `thenTc_`
- returnTc sigma_ty
- where
- sigma_ty = mkSigmaTy forall_tyvars theta tau
- tau_vars = tyVarsOfType tau
- extended_tau_vars = grow theta tau_vars
-
- -- Hack alert. If there are no tyvars, (ppr sigma_ty) will print
- -- something strange like {Eq k} -> k -> k, because there is no
- -- ForAll at the top of the type. Since this is going to the user
- -- we want it to look like a proper Haskell type even then; hence the hack
- --
- -- This shows up in the complaint about
- -- case C a where
- -- op :: Eq a => a -> a
- ppr_sigma | null forall_tyvars = pprTheta theta <+> ptext SLIT("=>") <+> ppr tau
- | otherwise = ppr sigma_ty
-
- is_ambig ct_var = (ct_var `elem` forall_tyvars) &&
- not (ct_var `elemVarSet` extended_tau_vars)
- is_free ct_var = not (ct_var `elem` forall_tyvars)
-
- check_pred pred = checkTc (not any_ambig) (ambigErr pred ppr_sigma) `thenTc_`
- checkTc (isIPPred pred || not all_free) (freeErr pred ppr_sigma)
- where
- ct_vars = varSetElems (tyVarsOfPred pred)
- all_free = all is_free ct_vars
- any_ambig = is_source_polytype && any is_ambig ct_vars
-\end{code}
%************************************************************************
%* *
tcTySig (Sig v ty src_loc)
= tcAddSrcLoc src_loc $
- tcAddErrCtxt (tcsigCtxt v) $
- tcHsSigType ty `thenTc` \ sigma_tc_ty ->
+ tcHsSigType (FunSigCtxt v) ty `thenTc` \ sigma_tc_ty ->
mkTcSig (mkLocalId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig ->
returnTc sig
%************************************************************************
\begin{code}
-tcsigCtxt v = ptext SLIT("In a type signature for") <+> quotes (ppr v)
-
typeKindCtxt :: RenamedHsType -> Message
typeKindCtxt ty = sep [ptext SLIT("When checking that"),
nest 2 (quotes (ppr ty)),
pp_thing (ATyVar _) = ptext SLIT("Type variable")
pp_thing (ATcId _) = ptext SLIT("Local identifier")
pp_thing (AThing _) = ptext SLIT("Utterly bogus")
-
-ambigErr pred ppr_ty
- = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprPred pred),
- nest 4 (ptext SLIT("for the type:") <+> ppr_ty),
- nest 4 (ptext SLIT("At least one of the forall'd type variables mentioned by the constraint") $$
- ptext SLIT("must be reachable from the type after the =>"))]
-
-freeErr pred ppr_ty
- = sep [ptext SLIT("All of the type variables in the constraint") <+> quotes (pprPred pred) <+>
- ptext SLIT("are already in scope"),
- nest 4 (ptext SLIT("At least one must be universally quantified here")),
- ptext SLIT("In the type") <+> quotes ppr_ty
- ]
-
-polyArgTyErr ty = ptext SLIT("Illegal polymorphic type as argument:") <+> ppr ty
-ubxArgTyErr ty = ptext SLIT("Illegal unboxed tuple type as argument:") <+> ppr ty
\end{code}
import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupId )
import TcMType ( tcInstTyVars, newTyVarTy, unifyTauTy, unifyListTy, unifyTupleTy )
import TcType ( isTauTy, mkTyConApp, mkClassPred, liftedTypeKind )
-import TcMonoType ( tcHsSigType )
+import TcMonoType ( tcHsSigType, UserTypeCtxt(..) )
import CmdLineOpts ( opt_IrrefutableTuples )
import DataCon ( dataConSig, dataConFieldLabels,
doublePrimTy, addrPrimTy
)
import TysWiredIn ( charTy, stringTy, intTy, integerTy )
-import PrelNames ( minusName, eqStringName, eqName, geName, cCallableClassName )
+import PrelNames ( eqStringName, eqName, geName, cCallableClassName )
import BasicTypes ( isBoxed )
import Bag
import Outputable
= tcPat tc_bndr parend_pat pat_ty
tcPat tc_bndr (SigPatIn pat sig) pat_ty
- = tcHsSigType sig `thenTc` \ sig_ty ->
+ = tcHsSigType PatSigCtxt sig `thenTc` \ sig_ty ->
-- Check that the signature isn't a polymorphic one, which
-- we don't permit (at present, anyway)
import TcMType ( newTyVarTy )
import TcType ( tyVarsOfTypes, openTypeKind )
import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar )
-import TcMonoType ( kcHsSigTypes, tcHsSigType, tcScopedTyVars )
+import TcMonoType ( kcHsSigTypes, tcHsSigType, UserTypeCtxt(..), tcScopedTyVars )
import TcExpr ( tcExpr )
import TcEnv ( tcExtendLocalValEnv, isLocalThing )
import Rules ( extendRuleBase )
where
sig_tys = [t | RuleBndrSig _ t <- vars]
- new_id (RuleBndr var) = newTyVarTy openTypeKind `thenNF_Tc` \ ty ->
+ new_id (RuleBndr var) = newTyVarTy openTypeKind `thenNF_Tc` \ ty ->
returnNF_Tc (mkLocalId var ty)
- new_id (RuleBndrSig var rn_ty) = tcHsSigType rn_ty `thenTc` \ ty ->
+ new_id (RuleBndrSig var rn_ty) = tcHsSigType PatSigCtxt rn_ty `thenTc` \ ty ->
returnNF_Tc (mkLocalId var ty)
ruleCtxt name = ptext SLIT("When checking the transformation rule") <+>
isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig
)
import RnHsSyn ( RenamedTyClDecl, tyClDeclFVs )
-import BasicTypes ( RecFlag(..), NewOrData(..), isRec )
+import BasicTypes ( RecFlag(..), NewOrData(..) )
import HscTypes ( implicitTyThingIds )
+import Module ( Module )
import TcMonad
import TcEnv ( TcEnv, RecTcEnv, TcTyThing(..), TyThing(..), TyThingDetails(..),
- tcExtendKindEnv, tcLookup, tcExtendGlobalEnv, tcExtendGlobalValEnv )
-import TcTyDecls ( tcTyDecl1, kcConDetails )
-import TcClassDcl ( tcClassDecl1 )
+ tcExtendKindEnv, tcLookup, tcExtendGlobalEnv, tcExtendGlobalValEnv,
+ isLocalThing )
+import TcTyDecls ( tcTyDecl, kcConDetails, checkValidTyCon )
+import TcClassDcl ( tcClassDecl1, checkValidClass )
import TcInstDcls ( tcAddDeclCtxt )
import TcMonoType ( kcHsTyVars, kcHsType, kcHsLiftedSigType, kcHsContext, mkTyClTyVars )
import TcMType ( unifyKind, newKindVar, zonkKindEnv )
import TyCon ( TyCon, ArgVrcs, AlgTyConFlavour(..),
tyConKind, tyConDataCons,
mkSynTyCon, mkAlgTyCon, mkClassTyCon, mkForeignTyCon,
- isRecursiveTyCon )
+ )
import DataCon ( dataConOrigArgTys )
import Var ( varName )
import FiniteMap
~~~~~~~~~~~~~~~~~
\begin{code}
tcTyAndClassDecls :: RecTcEnv -- Knot tying stuff
+ -> Module -- Current module
-> [RenamedTyClDecl]
-> TcM TcEnv
-tcTyAndClassDecls unf_env decls
+tcTyAndClassDecls unf_env this_mod decls
= sortByDependency decls `thenTc` \ groups ->
- tcGroups unf_env groups
+ tcGroups unf_env this_mod groups
-tcGroups unf_env []
+tcGroups unf_env this_mod []
= tcGetEnv `thenNF_Tc` \ env ->
returnTc env
-tcGroups unf_env (group:groups)
- = tcGroup unf_env group `thenTc` \ env ->
- tcSetEnv env $
- tcGroups unf_env groups
+tcGroups unf_env this_mod (group:groups)
+ = tcGroup unf_env this_mod group `thenTc` \ env ->
+ tcSetEnv env $
+ tcGroups unf_env this_mod groups
\end{code}
Dealing with a group
to tcTyClDecl1.
-Step 6: tcTyClDecl1 again
- For a recursive group only, check all the decls again, just
- but this time with the wimp flag off. Now we can check things
- like whether a function argument is an unlifted tuple, looking
- through type synonyms properly. We can't do that in Step 5.
-
-Step 7: Extend environment
+Step 6: Extend environment
We extend the type environment with bindings not only for the TyCons and Classes,
but also for their "implicit Ids" like data constructors and class selectors
+Step 7: checkValidTyCl
+ For a recursive group only, check all the decls again, just
+ to check all the side conditions on validity. We could not
+ do this before because we were in a mutually recursive knot.
+
+
The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to
@TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s.
\begin{code}
-tcGroup :: RecTcEnv -> SCC RenamedTyClDecl -> TcM TcEnv
-tcGroup unf_env scc
+tcGroup :: RecTcEnv -> Module -> SCC RenamedTyClDecl -> TcM TcEnv
+tcGroup unf_env this_mod scc
= getDOptsTc `thenTc` \ dflags ->
-- Step 1
mapNF_Tc getInitialKind decls `thenNF_Tc` \ initial_kinds ->
rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- all_tyclss]
in
-- Step 5
- tcExtendGlobalEnv all_tyclss $
- mapTc (tcTyClDecl1 is_rec unf_env) decls `thenTc` \ tycls_details ->
+ -- Extend the environment with the final
+ -- TyCons/Classes and check the decls
+ tcExtendGlobalEnv all_tyclss $
+ mapTc (tcTyClDecl1 unf_env) decls `thenTc` \ tycls_details ->
- -- Return results
- tcGetEnv `thenNF_Tc` \ env ->
- returnTc (tycls_details, all_tyclss, env)
- ) `thenTc` \ (_, all_tyclss, env) ->
+ -- Step 6
+ -- Extend the environment with implicit Ids
+ tcExtendGlobalValEnv (implicitTyThingIds all_tyclss) $
- tcSetEnv env $
-
- traceTc (text "ready for pass 2" <+> ppr (isRec is_rec)) `thenTc_`
-
- -- Step 6
- -- For a recursive group, check all the types again,
- -- this time with the wimp flag off
- (if isRec is_rec then
- mapTc_ (tcTyClDecl1 NonRecursive unf_env) decls
- else
- returnTc ()
- ) `thenTc_`
+ -- Return results
+ tcGetEnv `thenNF_Tc` \ env ->
+ returnTc (tycls_details, tyclss, env)
+ ) `thenTc` \ (_, tyclss, env) ->
- traceTc (text "done") `thenTc_`
- -- Step 7
- -- Extend the environment with the final TyCons/Classes
- -- and their implicit Ids
- tcExtendGlobalValEnv (implicitTyThingIds all_tyclss) tcGetEnv
+ -- Step 7: Check validity; but only for things defined in this module
+ traceTc (text "ready for validity check") `thenTc_`
+ mapTc_ checkValidTyCl (filter (isLocalThing this_mod) tyclss) `thenTc_`
+ traceTc (text "done") `thenTc_`
+
+ returnTc env
where
is_rec = case scc of
AcyclicSCC decl -> [decl]
CyclicSCC decls -> decls
-tcTyClDecl1 is_rec unf_env decl
- | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 is_rec unf_env decl)
- | otherwise = tcAddDeclCtxt decl (tcTyDecl1 is_rec unf_env decl)
+tcTyClDecl1 unf_env decl
+ | isClassDecl decl = tcAddDeclCtxt decl (tcClassDecl1 unf_env decl)
+ | otherwise = tcAddDeclCtxt decl (tcTyDecl unf_env decl)
+
+checkValidTyCl (ATyCon tc) = checkValidTyCon tc
+checkValidTyCl (AClass cl) = checkValidClass cl
\end{code}
\end{code}
+
%************************************************************************
%* *
\subsection{Step 4: Building the tycon/class}
\section[TcTyDecls]{Typecheck type declarations}
\begin{code}
-module TcTyDecls ( tcTyDecl1, kcConDetails ) where
+module TcTyDecls ( tcTyDecl, checkValidTyCon, kcConDetails ) where
#include "HsVersions.h"
getBangType, getBangStrictness, conDetailsTys
)
import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext )
-import BasicTypes ( NewOrData(..), RecFlag, isRec )
+import BasicTypes ( NewOrData(..) )
-import TcMonoType ( tcHsRecType, tcHsTyVars, tcRecTheta,
+import TcMonoType ( tcHsTyVars, tcHsTheta, tcHsType,
kcHsContext, kcHsSigType, kcHsLiftedSigType
)
import TcEnv ( tcExtendTyVarEnv,
tcLookupTyCon, tcLookupRecId,
TyThingDetails(..), RecTcEnv
)
-import TcType ( tcEqType, tyVarsOfTypes, tyVarsOfPred, Type, ThetaType )
+import TcType ( tcEqType, tyVarsOfTypes, tyVarsOfPred, ThetaType )
+import TcMType ( checkValidType, UserTypeCtxt(..), checkValidTheta, SourceTyCtxt(..) )
import TcMonad
-import DataCon ( DataCon, mkDataCon, dataConFieldLabels )
+import DataCon ( DataCon, mkDataCon, dataConFieldLabels, dataConWrapId, dataConName )
import MkId ( mkDataConId, mkDataConWrapId, mkRecordSelId )
import FieldLabel
-import Var ( TyVar )
+import Var ( TyVar, idType )
import Name ( Name, NamedThing(..) )
import Outputable
-import TyCon ( TyCon, tyConTyVars )
+import TyCon ( TyCon, tyConName, tyConTheta, getSynTyConDefn, tyConTyVars, tyConDataCons, isSynTyCon )
import VarSet ( intersectVarSet, isEmptyVarSet )
import PrelNames ( unpackCStringName, unpackCStringUtf8Name )
import ListSetOps ( equivClasses )
+import List ( nubBy )
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-tcTyDecl1 :: RecFlag -> RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
-tcTyDecl1 is_rec unf_env (TySynonym {tcdName = tycon_name, tcdSynRhs = rhs})
+tcTyDecl :: RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
+tcTyDecl unf_env (TySynonym {tcdName = tycon_name, tcdSynRhs = rhs})
= tcLookupTyCon tycon_name `thenNF_Tc` \ tycon ->
tcExtendTyVarEnv (tyConTyVars tycon) $
- tcHsRecType is_rec rhs `thenTc` \ rhs_ty ->
- -- Note tcHsRecType not tcHsRecSigType; we allow type synonyms
- -- that aren't types; e.g. type List = []
- --
- -- If the RHS mentions tyvars that aren't in scope, we'll
- -- quantify over them:
- -- e.g. type T = a->a
- -- will become type T = forall a. a->a
- --
- -- With gla-exts that's right, but for H98 we should complain.
- -- We can now do that here without falling into
- -- a black hole, we still do it in rnDecl (TySynonym case)
-
+ tcHsType rhs `thenTc` \ rhs_ty ->
returnTc (tycon_name, SynTyDetails rhs_ty)
-tcTyDecl1 is_rec unf_env (TyData {tcdND = new_or_data, tcdCtxt = context,
+tcTyDecl unf_env (TyData {tcdND = new_or_data, tcdCtxt = context,
tcdName = tycon_name, tcdCons = con_decls})
= tcLookupTyCon tycon_name `thenNF_Tc` \ tycon ->
let
tyvars = tyConTyVars tycon
in
tcExtendTyVarEnv tyvars $
-
- -- Typecheck the pieces
- tcRecTheta is_rec context `thenTc` \ ctxt ->
- mapTc (tcConDecl is_rec new_or_data tycon tyvars ctxt) con_decls `thenTc` \ data_cons ->
- tcRecordSelectors is_rec unf_env tycon data_cons `thenTc` \ sel_ids ->
+ tcHsTheta context `thenTc` \ ctxt ->
+ mapTc (tcConDecl new_or_data tycon tyvars ctxt) con_decls `thenTc` \ data_cons ->
+ let
+ sel_ids = mkRecordSelectors unf_env tycon data_cons
+ in
returnTc (tycon_name, DataTyDetails ctxt data_cons sel_ids)
-tcTyDecl1 is_rec unf_env (ForeignType {tcdName = tycon_name})
+tcTyDecl unf_env (ForeignType {tcdName = tycon_name})
= returnTc (tycon_name, ForeignTyDetails)
+
+
+mkRecordSelectors unf_env tycon data_cons
+ = -- We'll check later that fields with the same name
+ -- from different constructors have the same type.
+ [ mkRecordSelId tycon field unpack_id unpackUtf8_id
+ | field <- nubBy eq_name fields ]
+ where
+ fields = [ field | con <- data_cons, field <- dataConFieldLabels con ]
+ eq_name field1 field2 = fieldLabelName field1 == fieldLabelName field2
+
+ unpack_id = tcLookupRecId unf_env unpackCStringName
+ unpackUtf8_id = tcLookupRecId unf_env unpackCStringUtf8Name
\end{code}
%************************************************************************
%* *
+\subsection{Validity check}
+%* *
+%************************************************************************
+
+checkValidTyCon is called once the mutually-recursive knot has been
+tied, so we can look at things freely.
+
+\begin{code}
+checkValidTyCon :: TyCon -> TcM ()
+checkValidTyCon tc
+ | isSynTyCon tc = checkValidType (TySynCtxt name) syn_rhs
+ | otherwise
+ = -- Check the context on the data decl
+ checkValidTheta (DataTyCtxt name) (tyConTheta tc) `thenTc_`
+
+ -- Check arg types of data constructors
+ mapTc_ check_data_con data_cons `thenTc_`
+
+ -- Check that fields with the same name share a type
+ mapTc_ check_fields groups
+
+ where
+ name = tyConName tc
+ (_, syn_rhs) = getSynTyConDefn tc
+ data_cons = tyConDataCons tc
+
+ fields = [field | con <- data_cons, field <- dataConFieldLabels con]
+ groups = equivClasses cmp_name fields
+ cmp_name field1 field2 = fieldLabelName field1 `compare` fieldLabelName field2
+
+ check_data_con con = checkValidType (ConArgCtxt (dataConName con))
+ (idType (dataConWrapId con))
+ -- This checks the argument types and
+ -- the existential context (if any)
+
+ check_fields fields@(first_field_label : other_fields)
+ -- These fields all have the same name, but are from
+ -- different constructors in the data type
+ = -- Check that all the fields in the group have the same type
+ -- NB: this check assumes that all the constructors of a given
+ -- data type use the same type variables
+ checkTc (all (tcEqType field_ty) other_tys) (fieldTypeMisMatch field_name)
+ where
+ field_ty = fieldLabelType first_field_label
+ field_name = fieldLabelName first_field_label
+ other_tys = map fieldLabelType other_fields
+\end{code}
+
+
+
+%************************************************************************
+%* *
\subsection{Kind and type check constructors}
%* *
%************************************************************************
-- going to remove the constructor while coercing it to a lifted type.
-tcConDecl :: RecFlag -> NewOrData -> TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM DataCon
-
-tcConDecl is_rec new_or_data tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc)
+tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM DataCon
+tcConDecl new_or_data tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc)
= tcAddSrcLoc src_loc $
tcHsTyVars ex_tvs (kcConDetails new_or_data ex_ctxt details) $ \ ex_tyvars ->
- tcRecTheta is_rec ex_ctxt `thenTc` \ ex_theta ->
+ tcHsTheta ex_ctxt `thenTc` \ ex_theta ->
case details of
VanillaCon btys -> tc_datacon ex_tyvars ex_theta btys
InfixCon bty1 bty2 -> tc_datacon ex_tyvars ex_theta [bty1,bty2]
RecCon fields -> tc_rec_con ex_tyvars ex_theta fields
where
tc_datacon ex_tyvars ex_theta btys
- = let
- arg_stricts = map getBangStrictness btys
- tys = map getBangType btys
- in
- mapTc (tcHsRecType is_rec) tys `thenTc` \ arg_tys ->
- mk_data_con ex_tyvars ex_theta arg_stricts arg_tys []
+ = mapTc tcHsType (map getBangType btys) `thenTc` \ arg_tys ->
+ mk_data_con ex_tyvars ex_theta (map getBangStrictness btys) arg_tys []
tc_rec_con ex_tyvars ex_theta fields
= checkTc (null ex_tyvars) (exRecConErr name) `thenTc_`
field_labels = concat field_labels_s
arg_stricts = [str | (ns, bty) <- fields,
let str = getBangStrictness bty,
- n <- ns -- One for each. E.g x,y,z :: !Int
+ n <- ns -- One for each. E.g x,y,z :: !Int
]
in
mk_data_con ex_tyvars ex_theta arg_stricts
(map fieldLabelType field_labels) field_labels
tc_field ((field_label_names, bty), tag)
- = tcHsRecType is_rec (getBangType bty) `thenTc` \ field_ty ->
+ = tcHsType (getBangType bty) `thenTc` \ field_ty ->
returnTc [mkFieldLabel (getName name) tycon field_ty tag | name <- field_label_names]
mk_data_con ex_tyvars ex_theta arg_stricts arg_tys fields
%************************************************************************
%* *
-\subsection{Record selectors}
-%* *
-%************************************************************************
-
-\begin{code}
-tcRecordSelectors is_rec unf_env tycon data_cons
- -- Omit the check that the fields have consistent types if
- -- the group is recursive; TcTyClsDecls.tcGroup will repeat
- -- with NonRecursive once we have tied the knot
- | isRec is_rec = returnTc sel_ids
- | otherwise = mapTc check groups `thenTc_`
- returnTc sel_ids
- where
- fields = [ field | con <- data_cons
- , field <- dataConFieldLabels con ]
-
- -- groups is list of fields that share a common name
- groups = equivClasses cmp_name fields
- cmp_name field1 field2 = fieldLabelName field1 `compare` fieldLabelName field2
-
- sel_ids = [ mkRecordSelId tycon field unpack_id unpackUtf8_id
- | (field : _) <- groups ]
-
- check fields@(first_field_label : other_fields)
- -- These fields all have the same name, but are from
- -- different constructors in the data type
- = -- Check that all the fields in the group have the same type
- -- NB: this check assumes that all the constructors of a given
- -- data type use the same type variables
- checkTc (all (tcEqType field_ty) other_tys) (fieldTypeMisMatch field_name)
- where
- field_ty = fieldLabelType first_field_label
- field_name = fieldLabelName first_field_label
- other_tys = map fieldLabelType other_fields
-
- unpack_id = tcLookupRecId unf_env unpackCStringName
- unpackUtf8_id = tcLookupRecId unf_env unpackCStringUtf8Name
-\end{code}
-
-
-
-%************************************************************************
-%* *
\subsection{Errors and contexts}
%* *
%************************************************************************
Kind, -- Stuff to do with kinds is insensitive to pre/post Tc
unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
superBoxity, liftedBoxity, hasMoreBoxityInfo, defaultKind, superKind,
+ isTypeKind,
Type, SourceType(..), PredType, ThetaType,
mkForAllTy, mkForAllTys,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
Kind, Type, TauType, SourceType(..), PredType, ThetaType,
unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
- mkForAllTy, mkForAllTys, defaultKind,
+ mkForAllTy, mkForAllTys, defaultKind, isTypeKind,
mkFunTy, mkFunTys, zipFunTys,
mkTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
mkTyVarTy, mkTyVarTys, mkTyConTy,
tcSplitPredTy_maybe (UsageTy _ ty) = tcSplitPredTy_maybe ty
tcSplitPredTy_maybe (SourceTy p) | isPred p = Just p
tcSplitPredTy_maybe other = Nothing
-
+
mkPredTy :: PredType -> Type
mkPredTy pred = SourceTy pred
module PprType(
pprKind, pprParendKind,
pprType, pprParendType,
- pprPred, pprTheta, pprClassPred,
+ pprSourceType, pprPred, pprTheta, pprClassPred,
pprTyVarBndr, pprTyVarBndrs,
-- Junk
pprParendKind = pprParendType
pprPred :: PredType -> SDoc
-pprPred (ClassP clas tys) = pprClassPred clas tys
-pprPred (IParam n ty) = hsep [ptext SLIT("?") <> ppr n,
+pprPred = pprSourceType
+
+pprSourceType :: SourceType -> SDoc
+pprSourceType (ClassP clas tys) = pprClassPred clas tys
+pprSourceType (IParam n ty) = hsep [ptext SLIT("?") <> ppr n,
ptext SLIT("::"), ppr ty]
+pprSourceType (NType tc tys) = ppr tc <+> hsep (map pprParendType tys)
pprClassPred :: Class -> [Type] -> SDoc
pprClassPred clas tys = ppr clas <+> hsep (map pprParendType tys)
ppr_ty ctxt_prec (NoteTy (FTVNote _) ty) = ppr_ty ctxt_prec ty
-ppr_ty ctxt_prec (SourceTy (NType tc tys))
- = ppr_tc_app ctxt_prec tc tys
-
-ppr_ty ctxt_prec (SourceTy pred) = braces (pprPred pred)
+ppr_ty ctxt_prec (SourceTy (NType tc tys)) = ppr_tc_app ctxt_prec tc tys
+ppr_ty ctxt_prec (SourceTy pred) = braces (pprPred pred)
ppr_tc_app ctxt_prec tc [] = ppr tc
ppr_tc_app ctxt_prec tc tys = maybeParen ctxt_prec tYCON_PREC
typeCon, -- :: BX -> KX
liftedTypeKind, unliftedTypeKind, openTypeKind, -- :: KX
mkArrowKind, mkArrowKinds, -- :: KX -> KX -> KX
-
+ isTypeKind,
funTyCon,
usageKindCon, -- :: KX
-- Used when generalising: default kind '?' to '*'
defaultKind kind | kind `eqKind` openTypeKind = liftedTypeKind
| otherwise = kind
+
+isTypeKind :: Kind -> Bool
+-- True of kind * and *#
+isTypeKind k = case splitTyConApp_maybe k of
+ Just (tc,[k]) -> tc == typeCon
+ other -> False
\end{code}
\begin{code}
mkTyConApp :: TyCon -> [Type] -> Type
+-- Assumes TyCon is not a SynTyCon; use mkSynTy instead for those
mkTyConApp tycon tys
| isFunTyCon tycon, [ty1,ty2] <- tys
= FunTy (mkUTyM ty1) (mkUTyM ty2)
projects / ghc-hetmet.git / commitdiff