--------------------------------
-- Creating new mutable type variables
- newTyVar,
+ newTyVar, newSigTyVar,
newTyVarTy, -- Kind -> TcM TcType
newTyVarTys, -- Int -> Kind -> TcM [TcType]
- newKindVar, newKindVars, newBoxityVar,
+ newKindVar, newKindVars, newOpenTypeKind,
putTcTyVar, getTcTyVar,
newMutTyVar, readMutTyVar, writeMutTyVar,
- newHoleTyVarTy, readHoleResult, zapToType,
-
--------------------------------
-- Instantiation
tcInstTyVar, tcInstTyVars, tcInstType,
--------------------------------
-- Zonking
+ zonkType,
zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV,
zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType,
- zonkTcPredType, zonkTcTypeToType, zonkTcTyVarToTyVar, zonkKindEnv,
+ zonkTcPredType, zonkTcTyVarToTyVar, zonkKindEnv,
) where
-- friends:
import TypeRep ( Type(..), SourceType(..), TyNote(..), -- Friend; can see representation
- Kind, ThetaType
+ Kind, ThetaType, typeCon
)
import TcType ( TcType, TcThetaType, TcTauType, TcPredType,
TcTyVarSet, TcKind, TcTyVar, TyVarDetails(..),
- tcEqType, tcCmpPred,
+ tcEqType, tcCmpPred, isClassPred,
tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe,
tcSplitTyConApp_maybe, tcSplitForAllTys,
- tcIsTyVarTy, tcSplitSigmaTy,
- isUnLiftedType, isIPPred, isHoleTyVar, isTyVarTy,
+ tcIsTyVarTy, tcSplitSigmaTy, mkTyConApp,
+ isUnLiftedType, isIPPred, isTyVarTy,
mkAppTy, mkTyVarTy, mkTyVarTys,
tyVarsOfPred, getClassPredTys_maybe,
liftedTypeKind, openTypeKind, defaultKind, superKind,
superBoxity, liftedBoxity, typeKind,
tyVarsOfType, tyVarsOfTypes,
- eqKind, isTypeKind, isAnyTypeKind,
-
+ eqKind, isTypeKind,
isFFIArgumentTy, isFFIImportResultTy
)
-import qualified Type ( splitFunTys )
import Subst ( Subst, mkTopTyVarSubst, substTy )
import Class ( Class, DefMeth(..), classArity, className, classBigSig )
-import TyCon ( TyCon, mkPrimTyCon, isSynTyCon, isUnboxedTupleTyCon,
- tyConArity, tyConName, tyConKind, tyConTheta,
+import TyCon ( TyCon, isSynTyCon, isUnboxedTupleTyCon,
+ tyConArity, tyConName, tyConTheta,
getSynTyConDefn, tyConDataCons )
import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, dataConFieldLabels )
import FieldLabel ( fieldLabelName, fieldLabelType )
-import PrimRep ( PrimRep(VoidRep) )
import Var ( TyVar, idType, idName, tyVarKind, tyVarName, isTyVar,
mkTyVar, mkMutTyVar, isMutTyVar, mutTyVarRef )
-- others:
import Generics ( validGenericMethodType )
import TcRnMonad -- TcType, amongst others
-import TysWiredIn ( voidTy, listTyCon, tupleTyCon )
-import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
+import PrelNames ( hasKey )
import ForeignCall ( Safety(..) )
import FunDeps ( grow )
import PprType ( pprPred, pprSourceType, pprTheta, pprClassPred )
-import Name ( Name, NamedThing(..), setNameUnique,
- mkInternalName, mkDerivedTyConOcc,
- mkSystemTvNameEncoded,
- )
+import Name ( Name, setNameUnique, mkSystemTvNameEncoded )
import VarSet
-import BasicTypes ( Boxity(Boxed) )
import CmdLineOpts ( dopt, DynFlag(..) )
-import Unique ( Uniquable(..) )
-import SrcLoc ( noSrcLoc )
-import Util ( nOfThem, isSingleton, equalLength, notNull )
+import Util ( nOfThem, isSingleton, equalLength, notNull, lengthExceeds )
import ListSetOps ( equivClasses, removeDups )
import Outputable
\end{code}
= newUnique `thenM` \ uniq ->
newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("t")) kind VanillaTv
+newSigTyVar :: Kind -> TcM TcTyVar
+newSigTyVar kind
+ = newUnique `thenM` \ uniq ->
+ newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("s")) kind SigTv
+
newTyVarTy :: Kind -> TcM TcType
newTyVarTy kind
= newTyVar kind `thenM` \ tc_tyvar ->
newKindVars :: Int -> TcM [TcKind]
newKindVars n = mappM (\ _ -> newKindVar) (nOfThem n ())
-newBoxityVar :: TcM TcKind
-newBoxityVar
+newOpenTypeKind :: TcM TcKind -- Returns the kind (Type bx), where bx is fresh
+newOpenTypeKind
= newUnique `thenM` \ uniq ->
newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("bx")) superBoxity VanillaTv `thenM` \ kv ->
- returnM (TyVarTy kv)
+ returnM (mkTyConApp typeCon [TyVarTy kv])
\end{code}
%************************************************************************
%* *
-\subsection{'hole' type variables}
-%* *
-%************************************************************************
-
-\begin{code}
-newHoleTyVarTy :: TcM TcType
- = newUnique `thenM` \ uniq ->
- newMutTyVar (mkSystemTvNameEncoded uniq FSLIT("h")) openTypeKind HoleTv `thenM` \ tv ->
- returnM (TyVarTy tv)
-
-readHoleResult :: TcType -> TcM TcType
--- Read the answer out of a hole, constructed by newHoleTyVarTy
-readHoleResult (TyVarTy tv)
- = ASSERT( isHoleTyVar tv )
- getTcTyVar tv `thenM` \ maybe_res ->
- case maybe_res of
- Just ty -> returnM ty
- Nothing -> pprPanic "readHoleResult: empty" (ppr tv)
-readHoleResult ty = pprPanic "readHoleResult: not hole" (ppr ty)
-
-zapToType :: TcType -> TcM TcType
-zapToType (TyVarTy tv)
- | isHoleTyVar tv
- = getTcTyVar tv `thenM` \ maybe_res ->
- case maybe_res of
- Nothing -> newTyVarTy openTypeKind `thenM` \ ty ->
- putTcTyVar tv ty `thenM_`
- returnM ty
- Just ty -> returnM ty -- No need to loop; we never
- -- have chains of holes
-
-zapToType other_ty = returnM other_ty
-\end{code}
-
-%************************************************************************
-%* *
\subsection{Type instantiation}
%* *
%************************************************************************
| tyVarKind kv `eqKind` superBoxity = putTcTyVar kv liftedBoxity
| otherwise = pprPanic "zonkKindEnv" (ppr kv)
-zonkTcTypeToType :: TcType -> TcM Type
-zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty
- where
- -- Zonk a mutable but unbound type variable to an arbitrary type
- -- 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 = putTcTyVar tv (mkArbitraryType tv)
-
-
--- When the type checker finds a type variable with no binding,
--- which means it can be instantiated with an arbitrary type, it
--- usually instantiates it to Void. Eg.
---
--- length []
--- ===>
--- length Void (Nil Void)
---
--- But in really obscure programs, the type variable might have
--- a kind other than *, so we need to invent a suitably-kinded type.
---
--- This commit uses
--- Void for kind *
--- List for kind *->*
--- Tuple for kind *->...*->*
---
--- which deals with most cases. (Previously, it only dealt with
--- kind *.)
---
--- In the other cases, it just makes up a TyCon with a suitable
--- kind. If this gets into an interface file, anyone reading that
--- file won't understand it. This is fixable (by making the client
--- of the interface file make up a TyCon too) but it is tiresome and
--- never happens, so I am leaving it
-
-mkArbitraryType :: TcTyVar -> Type
--- Make up an arbitrary type whose kind is the same as the tyvar.
--- We'll use this to instantiate the (unbound) tyvar.
-mkArbitraryType tv
- | isAnyTypeKind kind = voidTy -- The vastly common case
- | otherwise = TyConApp tycon []
- where
- kind = tyVarKind tv
- (args,res) = Type.splitFunTys kind -- Kinds are simple; use Type.splitFunTys
-
- tycon | kind `eqKind` tyConKind listTyCon -- *->*
- = listTyCon -- No tuples this size
-
- | all isTypeKind args && isTypeKind res
- = tupleTyCon Boxed (length args) -- *-> ... ->*->*
-
- | otherwise
- = pprTrace "Urk! Inventing strangely-kinded void TyCon:" (ppr tc_name $$ ppr kind) $
- mkPrimTyCon tc_name kind 0 [] VoidRep
- -- Same name as the tyvar, apart from making it start with a colon (sigh)
- -- I dread to think what will happen if this gets out into an
- -- interface file. Catastrophe likely. Major sigh.
-
- tc_name = mkInternalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc
-
-- zonkTcTyVarToTyVar is applied to the *binding* occurrence
-- of a type variable, at the *end* of type checking. It changes
-- the *mutable* type variable into an *immutable* one.
%************************************************************************
\begin{code}
+-- Enumerate the contexts in which a "source type", <S>, can occur
+-- Eq a
+-- or ?x::Int
+-- or r <: {x::Int}
+-- or (N a) where N is a newtype
+
data SourceTyCtxt
= ClassSCCtxt Name -- Superclasses of clas
- | SigmaCtxt -- Context of a normal for-all type
- | DataTyCtxt Name -- Context of a data decl
+ -- class <S> => C a where ...
+ | SigmaCtxt -- Theta part of a normal for-all type
+ -- f :: <S> => a -> a
+ | DataTyCtxt Name -- Theta part of a data decl
+ -- data <S> => T a = MkT a
| TypeCtxt -- Source type in an ordinary type
+ -- f :: N a -> N a
| InstThetaCtxt -- Context of an instance decl
+ -- instance <S> => C [a] where ...
| InstHeadCtxt -- Head of an instance decl
+ -- instance ... => Eq a where ...
pprSourceTyCtxt (ClassSCCtxt c) = ptext SLIT("the super-classes of class") <+> quotes (ppr c)
pprSourceTyCtxt SigmaCtxt = ptext SLIT("the context of a polymorphic type")
where
complain pred = addErrTc (ambigErr pred)
extended_tau_vars = grow theta tau_tyvars
- is_ambig pred = any ambig_var (varSetElems (tyVarsOfPred pred))
+
+ -- Only a *class* predicate can give rise to ambiguity
+ -- An *implicit parameter* cannot. For example:
+ -- foo :: (?x :: [a]) => Int
+ -- foo = length ?x
+ -- is fine. The call site will suppply a particular 'x'
+ is_ambig pred = isClassPred pred &&
+ any ambig_var (varSetElems (tyVarsOfPred pred))
ambig_var ct_var = (ct_var `elem` forall_tyvars) &&
not (ct_var `elemVarSet` extended_tau_vars)
- is_free ct_var = not (ct_var `elem` forall_tyvars)
-
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") $$
-- This checks the argument types and
-- ambiguity of the existential context (if any)
addErrCtxt (existentialCtxt con)
- (checkFreeness ex_tvs ex_theta)
+ (checkFreeness ex_tvs ex_theta)
where
ctxt = ConArgCtxt (dataConName con)
(_, _, ex_tvs, ex_theta, _, _) = dataConSig con
}}
check_inst_head dflags clas tys
- | -- CCALL CHECK
- -- A user declaration of a CCallable/CReturnable instance
- -- must be for a "boxed primitive" type.
- (clas `hasKey` cCallableClassKey
- && not (ccallable_type first_ty))
- || (clas `hasKey` cReturnableClassKey
- && not (creturnable_type first_ty))
- = failWithTc (nonBoxedPrimCCallErr clas first_ty)
-
-- If GlasgowExts then check at least one isn't a type variable
| dopt Opt_GlasgowExts dflags
= check_tyvars dflags clas tys
where
(first_ty : _) = tys
- ccallable_type ty = isFFIArgumentTy dflags PlayRisky ty
- creturnable_type ty = isFFIImportResultTy dflags ty
-
head_shape_msg = parens (text "The instance type must be of form (T a b c)" $$
text "where T is not a synonym, and a,b,c are distinct type variables")
instTypeErr pp_ty msg
= sep [ptext SLIT("Illegal instance declaration for") <+> quotes pp_ty,
nest 4 msg]
-
-nonBoxedPrimCCallErr clas inst_ty
- = hang (ptext SLIT("Unacceptable instance type for ccall-ish class"))
- 4 (pprClassPred clas [inst_ty])
\end{code}
projects / ghc-hetmet.git / blobdiff