%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcType]{Types used in the typechecker}
UserTypeCtxt(..), pprUserTypeCtxt,
TcTyVarDetails(..), BoxInfo(..), pprTcTyVarDetails,
MetaDetails(Flexi, Indirect), SkolemInfo(..), pprSkolTvBinding, pprSkolInfo,
- isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isBoxyTyVar, isSigTyVar, isExistentialTyVar,
+ isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isBoxyTyVar,
+ isSigTyVar, isExistentialTyVar, isTyConableTyVar,
metaTvRef,
- isFlexi, isIndirect,
+ isFlexi, isIndirect, isRuntimeUnk, isUnk,
--------------------------------
-- Builders
tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN,
tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe,
- tcValidInstHeadTy, tcGetTyVar_maybe, tcGetTyVar,
+ tcInstHeadTyNotSynonym, tcInstHeadTyAppAllTyVars,
+ tcGetTyVar_maybe, tcGetTyVar,
tcSplitSigmaTy, tcMultiSplitSigmaTy,
---------------------------------
tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX,
eqKind,
isSigmaTy, isOverloadedTy, isRigidTy, isBoxyTy,
- isDoubleTy, isFloatTy, isIntTy, isStringTy,
- isIntegerTy, isBoolTy, isUnitTy,
+ isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
+ isIntegerTy, isBoolTy, isUnitTy, isCharTy,
isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
+ isOpenSynTyConApp,
---------------------------------
-- Misc type manipulators
- deNoteType, classesOfTheta,
+ deNoteType,
tyClsNamesOfType, tyClsNamesOfDFunHead,
getDFunTyKey,
isClassPred, isTyVarClassPred, isEqPred,
mkDictTy, tcSplitPredTy_maybe,
isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique,
- mkClassPred, isInheritablePred, isIPPred, mkPredName,
- dataConsStupidTheta, isRefineableTy,
+ mkClassPred, isInheritablePred, isIPPred,
+ dataConsStupidTheta, isRefineableTy, isRefineablePred,
---------------------------------
-- Foreign import and export
isFFIDotnetTy, -- :: DynFlags -> Type -> Bool
isFFIDotnetObjTy, -- :: Type -> Bool
isFFITy, -- :: Type -> Bool
+ isFunPtrTy, -- :: Type -> Bool
tcSplitIOType_maybe, -- :: Type -> Maybe Type
toDNType, -- :: Type -> DNType
mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, lookupTyVar,
extendTvSubst, extendTvSubstList, isInScope, mkTvSubst, zipTyEnv,
- substTy, substTys, substTyWith, substTheta, substTyVar, substTyVarBndr,
+ substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars, substTyVarBndr,
isUnLiftedType, -- Source types are always lifted
isUnboxedTupleType, -- Ditto
tcTyVarsOfType, tcTyVarsOfTypes, exactTyVarsOfType, exactTyVarsOfTypes,
pprKind, pprParendKind,
- pprType, pprParendType, pprTyThingCategory,
+ pprType, pprParendType, pprTypeApp, pprTyThingCategory,
pprPred, pprTheta, pprThetaArrow, pprClassPred
) where
#include "HsVersions.h"
-- friends:
-import TypeRep ( Type(..), funTyCon, Kind ) -- friend
-
-import Type ( -- Re-exports
- tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
- tyVarsOfTheta, Kind, PredType(..), KindVar,
- ThetaType, isUnliftedTypeKind, unliftedTypeKind,
- argTypeKind,
- liftedTypeKind, openTypeKind, mkArrowKind,
- tySuperKind, isLiftedTypeKind,
- mkArrowKinds, mkForAllTy, mkForAllTys,
- defaultKind, isSubArgTypeKind, isSubOpenTypeKind,
- mkFunTy, mkFunTys, zipFunTys,
- mkTyConApp, mkAppTy,
- mkAppTys, applyTy, applyTys,
- mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy,
- mkPredTys, isUnLiftedType,
- isUnboxedTupleType, isPrimitiveType,
- splitTyConApp_maybe,
- tidyTopType, tidyType, tidyPred, tidyTypes,
- tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
- tidyTyVarBndr, tidyOpenTyVar,
- tidyOpenTyVars, tidyKind,
- isSubKind, tcView,
-
- tcEqType, tcEqTypes, tcCmpType, tcCmpTypes,
- tcEqPred, tcCmpPred, tcEqTypeX, eqKind,
-
- TvSubst(..),
- TvSubstEnv, emptyTvSubst, mkTvSubst, zipTyEnv,
- mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst,
- getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
- extendTvSubst, extendTvSubstList, isInScope, notElemTvSubst,
- substTy, substTys, substTyWith, substTheta,
- substTyVar, substTyVarBndr, substPred, lookupTyVar,
-
- typeKind, repType, coreView, repSplitAppTy_maybe,
- pprKind, pprParendKind,
- pprType, pprParendType, pprTyThingCategory,
- pprPred, pprTheta, pprThetaArrow, pprClassPred
- )
-import TyCon ( TyCon, isUnLiftedTyCon, isSynTyCon, isOpenTyCon,
- synTyConDefn, tyConUnique )
-import DataCon ( DataCon, dataConStupidTheta, dataConResTys )
-import Class ( Class )
-import Var ( TyVar, Id, isCoVar, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails )
-import ForeignCall ( Safety, DNType(..) )
-import Unify ( tcMatchTys )
+import TypeRep
+import DataCon
+import Class
+import Var
+import ForeignCall
+import Unify
import VarSet
+import Type
+import Coercion
+import TyCon
-- others:
-import DynFlags ( DynFlags, DynFlag( Opt_GlasgowExts ), dopt )
-import Name ( Name, NamedThing(..), mkInternalName, getSrcLoc, mkSystemName )
+import DynFlags
+import Name
import NameSet
-import VarEnv ( TidyEnv )
-import OccName ( OccName, mkDictOcc, mkOccName, tvName )
-import PrelNames -- Lots (e.g. in isFFIArgumentTy)
-import TysWiredIn ( unitTyCon, charTyCon, listTyCon )
-import BasicTypes ( Arity, ipNameName )
-import SrcLoc ( SrcLoc, SrcSpan )
-import Util ( equalLength )
-import Maybes ( maybeToBool, expectJust, mapCatMaybes )
-import ListSetOps ( hasNoDups )
-import List ( nubBy )
+import VarEnv
+import OccName
+import PrelNames
+import TysWiredIn
+import BasicTypes
+import Util
+import Maybes
+import ListSetOps
import Outputable
-import DATA_IOREF
-\end{code}
+import FastString
+import Data.List
+import Data.IORef
+\end{code}
%************************************************************************
%* *
-- b2 is another (currently empty) box.
data MetaDetails
- = Flexi -- Flexi type variables unify to become
- -- Indirects.
+ = Flexi -- Flexi type variables unify to become
+ -- Indirects.
- | Indirect TcType -- INVARIANT:
- -- For a BoxTv, this type must be non-boxy
- -- For a TauTv, this type must be a tau-type
+ | Indirect TcType -- INVARIANT:
+ -- For a BoxTv, this type must be non-boxy
+ -- For a TauTv, this type must be a tau-type
+-- Generally speaking, SkolemInfo should not contain location info
+-- that is contained in the Name of the tyvar with this SkolemInfo
data SkolemInfo
= SigSkol UserTypeCtxt -- A skolem that is created by instantiating
-- a programmer-supplied type signature
-- The rest are for non-scoped skolems
| ClsSkol Class -- Bound at a class decl
- | InstSkol Id -- Bound at an instance decl
- | FamInstSkol TyCon -- Bound at a family instance decl
+ | InstSkol -- Bound at an instance decl
+ | FamInstSkol -- Bound at a family instance decl
| PatSkol DataCon -- An existential type variable bound by a pattern for
- SrcSpan -- a data constructor with an existential type. E.g.
+ -- a data constructor with an existential type. E.g.
-- data T = forall a. Eq a => MkT a
-- f (MkT x) = ...
-- The pattern MkT x will allocate an existential type
-- variable for 'a'.
- | ArrowSkol SrcSpan -- An arrow form (see TcArrows)
+ | ArrowSkol -- An arrow form (see TcArrows)
+ | RuleSkol RuleName -- The LHS of a RULE
| GenSkol [TcTyVar] -- Bound when doing a subsumption check for
TcType -- (forall tvs. ty)
- SrcSpan
+
+ | RuntimeUnkSkol -- a type variable used to represent an unknown
+ -- runtime type (used in the GHCi debugger)
| UnkSkol -- Unhelpful info (until I improve it)
-------------------------------------
-- UserTypeCtxt describes the places where a
-- programmer-written type signature can occur
+-- Like SkolemInfo, no location info
data UserTypeCtxt
= FunSigCtxt Name -- Function type signature
-- Also used for types in SPECIALISE pragmas
| ResSigCtxt -- Result type sig
-- f x :: t = ....
| ForSigCtxt Name -- Foreign inport or export signature
- | RuleSigCtxt Name -- Signature on a forall'd variable in a RULE
| DefaultDeclCtxt -- Types in a default declaration
| SpecInstCtxt -- SPECIALISE instance pragma
ASSERT ( isTcTyVar tc )
case tcTyVarDetails tc of
MetaTv TauTv ref -> ref
- other -> pprPanic "kindVarRef" (ppr tc)
+ _ -> pprPanic "kindVarRef" (ppr tc)
mkKindVar :: Unique -> IORef MetaDetails -> KindVar
mkKindVar u r
-- They may be jiggled by tidying
kind_var_occ = mkOccName tvName "k"
\end{code}
-\end{code}
%************************************************************************
%* *
\begin{code}
pprTcTyVarDetails :: TcTyVarDetails -> SDoc
-- For debugging
-pprTcTyVarDetails (SkolemTv _) = ptext SLIT("sk")
-pprTcTyVarDetails (MetaTv BoxTv _) = ptext SLIT("box")
-pprTcTyVarDetails (MetaTv TauTv _) = ptext SLIT("tau")
-pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext SLIT("sig")
+pprTcTyVarDetails (SkolemTv _) = ptext (sLit "sk")
+pprTcTyVarDetails (MetaTv BoxTv _) = ptext (sLit "box")
+pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau")
+pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext (sLit "sig")
pprUserTypeCtxt :: UserTypeCtxt -> SDoc
-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 the constructor") <+> quotes (ppr c)
-pprUserTypeCtxt (TySynCtxt c) = ptext SLIT("the RHS of the type synonym") <+> quotes (ppr c)
-pprUserTypeCtxt GenPatCtxt = ptext SLIT("the type pattern of a generic definition")
-pprUserTypeCtxt LamPatSigCtxt = ptext SLIT("a pattern type signature")
-pprUserTypeCtxt BindPatSigCtxt = ptext SLIT("a pattern type signature")
-pprUserTypeCtxt ResSigCtxt = ptext SLIT("a result type signature")
-pprUserTypeCtxt (ForSigCtxt n) = ptext SLIT("the foreign declaration for") <+> quotes (ppr n)
-pprUserTypeCtxt (RuleSigCtxt n) = ptext SLIT("the type signature for") <+> quotes (ppr n)
-pprUserTypeCtxt DefaultDeclCtxt = ptext SLIT("a type in a `default' declaration")
-pprUserTypeCtxt SpecInstCtxt = ptext SLIT("a SPECIALISE instance pragma")
+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 the constructor") <+> quotes (ppr c)
+pprUserTypeCtxt (TySynCtxt c) = ptext (sLit "the RHS of the type synonym") <+> quotes (ppr c)
+pprUserTypeCtxt GenPatCtxt = ptext (sLit "the type pattern of a generic definition")
+pprUserTypeCtxt LamPatSigCtxt = ptext (sLit "a pattern type signature")
+pprUserTypeCtxt BindPatSigCtxt = ptext (sLit "a pattern type signature")
+pprUserTypeCtxt ResSigCtxt = ptext (sLit "a result type signature")
+pprUserTypeCtxt (ForSigCtxt n) = ptext (sLit "the foreign declaration for") <+> quotes (ppr n)
+pprUserTypeCtxt DefaultDeclCtxt = ptext (sLit "a type in a `default' declaration")
+pprUserTypeCtxt SpecInstCtxt = ptext (sLit "a SPECIALISE instance pragma")
--------------------------------
(env1, info') = tidy_skol_info env info
info -> (env, info)
- tidy_skol_info env (GenSkol tvs ty loc) = (env2, GenSkol tvs1 ty1 loc)
+ tidy_skol_info env (GenSkol tvs ty) = (env2, GenSkol tvs1 ty1)
where
(env1, tvs1) = tidyOpenTyVars env tvs
(env2, ty1) = tidyOpenType env1 ty
-- or nothing if we don't have anything useful to say
pprSkolTvBinding tv
= ASSERT ( isTcTyVar tv )
- ppr_details (tcTyVarDetails tv)
+ quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv)
where
- ppr_details (MetaTv TauTv _) = quotes (ppr tv) <+> ptext SLIT("is a meta type variable")
- ppr_details (MetaTv BoxTv _) = quotes (ppr tv) <+> ptext SLIT("is a boxy type variable")
+ ppr_details (MetaTv TauTv _) = ptext (sLit "is a meta type variable")
+ ppr_details (MetaTv BoxTv _) = ptext (sLit "is a boxy type variable")
ppr_details (MetaTv (SigTv info) _) = ppr_skol info
ppr_details (SkolemTv info) = ppr_skol info
- ppr_skol UnkSkol = empty -- Unhelpful; omit
- ppr_skol (SigSkol ctxt) = sep [quotes (ppr tv) <+> ptext SLIT("is bound by") <+> pprUserTypeCtxt ctxt,
- nest 2 (ptext SLIT("at") <+> ppr (getSrcLoc tv))]
- ppr_skol info = quotes (ppr tv) <+> pprSkolInfo info
+ ppr_skol UnkSkol = ptext (sLit "is an unknown type variable") -- Unhelpful
+ ppr_skol RuntimeUnkSkol = ptext (sLit "is an unknown runtime type")
+ ppr_skol info = sep [ptext (sLit "is a rigid type variable bound by"),
+ sep [pprSkolInfo info,
+ nest 2 (ptext (sLit "at") <+> ppr (getSrcLoc tv))]]
pprSkolInfo :: SkolemInfo -> SDoc
-pprSkolInfo (SigSkol ctxt) = ptext SLIT("is bound by") <+> pprUserTypeCtxt ctxt
-pprSkolInfo (ClsSkol cls) = ptext SLIT("is bound by the class declaration for") <+> quotes (ppr cls)
-pprSkolInfo (InstSkol df) =
- ptext SLIT("is bound by the instance declaration at") <+> ppr (getSrcLoc df)
-pprSkolInfo (FamInstSkol tc) =
- ptext SLIT("is bound by the family instance declaration at") <+>
- ppr (getSrcLoc tc)
-pprSkolInfo (ArrowSkol loc) =
- ptext SLIT("is bound by the arrow form at") <+> ppr loc
-pprSkolInfo (PatSkol dc loc) = sep [ptext SLIT("is bound by the pattern for") <+> quotes (ppr dc),
- nest 2 (ptext SLIT("at") <+> ppr loc)]
-pprSkolInfo (GenSkol tvs ty loc) = sep [sep [ptext SLIT("is bound by the polymorphic type"),
- nest 2 (quotes (ppr (mkForAllTys tvs ty)))],
- nest 2 (ptext SLIT("at") <+> ppr loc)]
--- UnkSkol, SigSkol
+pprSkolInfo (SigSkol ctxt) = pprUserTypeCtxt ctxt
+pprSkolInfo (ClsSkol cls) = ptext (sLit "the class declaration for") <+> quotes (ppr cls)
+pprSkolInfo InstSkol = ptext (sLit "the instance declaration")
+pprSkolInfo FamInstSkol = ptext (sLit "the family instance declaration")
+pprSkolInfo (RuleSkol name) = ptext (sLit "the RULE") <+> doubleQuotes (ftext name)
+pprSkolInfo ArrowSkol = ptext (sLit "the arrow form")
+pprSkolInfo (PatSkol dc) = sep [ptext (sLit "the constructor") <+> quotes (ppr dc)]
+pprSkolInfo (GenSkol tvs ty) = sep [ptext (sLit "the polymorphic type"),
+ nest 2 (quotes (ppr (mkForAllTys tvs ty)))]
+
+-- UnkSkol
-- For type variables the others are dealt with by pprSkolTvBinding.
-- For Insts, these cases should not happen
pprSkolInfo UnkSkol = panic "UnkSkol"
+pprSkolInfo RuntimeUnkSkol = panic "RuntimeUnkSkol"
instance Outputable MetaDetails where
- ppr Flexi = ptext SLIT("Flexi")
- ppr (Indirect ty) = ptext SLIT("Indirect") <+> ppr ty
+ ppr Flexi = ptext (sLit "Flexi")
+ ppr (Indirect ty) = ptext (sLit "Indirect") <+> ppr ty
\end{code}
%************************************************************************
\begin{code}
-isImmutableTyVar, isSkolemTyVar, isExistentialTyVar, isBoxyTyVar, isMetaTyVar :: TyVar -> Bool
+isImmutableTyVar :: TyVar -> Bool
+
isImmutableTyVar tv
| isTcTyVar tv = isSkolemTyVar tv
| otherwise = True
+isTyConableTyVar, isSkolemTyVar, isExistentialTyVar,
+ isBoxyTyVar, isMetaTyVar :: TcTyVar -> Bool
+
+isTyConableTyVar tv
+ -- True of a meta-type variable that can be filled in
+ -- with a type constructor application; in particular,
+ -- not a SigTv
+ = ASSERT( isTcTyVar tv)
+ case tcTyVarDetails tv of
+ MetaTv BoxTv _ -> True
+ MetaTv TauTv _ -> True
+ MetaTv (SigTv {}) _ -> False
+ SkolemTv {} -> False
+
isSkolemTyVar tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
isExistentialTyVar tv -- Existential type variable, bound by a pattern
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
- SkolemTv (PatSkol _ _) -> True
- other -> False
+ SkolemTv (PatSkol {}) -> True
+ _ -> False
isMetaTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
MetaTv _ _ -> True
- other -> False
+ _ -> False
isBoxyTyVar tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
MetaTv BoxTv _ -> True
- other -> False
+ _ -> False
+isSigTyVar :: Var -> Bool
isSigTyVar tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
MetaTv (SigTv _) _ -> True
- other -> False
+ _ -> False
metaTvRef :: TyVar -> IORef MetaDetails
metaTvRef tv
- = ASSERT( isTcTyVar tv )
+ = ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
MetaTv _ ref -> ref
- other -> pprPanic "metaTvRef" (ppr tv)
+ _ -> pprPanic "metaTvRef" (ppr tv)
isFlexi, isIndirect :: MetaDetails -> Bool
isFlexi Flexi = True
-isFlexi other = False
+isFlexi _ = False
isIndirect (Indirect _) = True
-isIndirect other = False
+isIndirect _ = False
+
+isRuntimeUnk :: TyVar -> Bool
+isRuntimeUnk x | isTcTyVar x
+ , SkolemTv RuntimeUnkSkol <- tcTyVarDetails x = True
+ | otherwise = False
+
+isUnk :: TyVar -> Bool
+isUnk x | isTcTyVar x
+ , SkolemTv UnkSkol <- tcTyVarDetails x = True
+ | otherwise = False
\end{code}
mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau)
mkPhiTy :: [PredType] -> Type -> Type
-mkPhiTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
+mkPhiTy theta ty = foldr (\p r -> mkFunTy (mkPredTy p) r) ty theta
\end{code}
@isTauTy@ tests for nested for-alls. It should not be called on a boxy type.
isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc
isTauTy (AppTy a b) = isTauTy a && isTauTy b
isTauTy (FunTy a b) = isTauTy a && isTauTy b
-isTauTy (PredTy p) = True -- Don't look through source types
-isTauTy other = False
+isTauTy (PredTy _) = True -- Don't look through source types
+isTauTy _ = False
isTauTyCon :: TyCon -> Bool
-- Returns False for type synonyms whose expansion is a polytype
isTauTyCon tc
- | isSynTyCon tc && not (isOpenTyCon tc) = isTauTy (snd (synTyConDefn tc))
- | otherwise = True
+ | isClosedSynTyCon tc = isTauTy (snd (synTyConDefn tc))
+ | otherwise = True
---------------
isBoxyTy :: TcType -> Bool
isRigidTy :: TcType -> Bool
-- A type is rigid if it has no meta type variables in it
-isRigidTy ty = all isSkolemTyVar (varSetElems (tcTyVarsOfType ty))
+isRigidTy ty = all isImmutableTyVar (varSetElems (tcTyVarsOfType ty))
-isRefineableTy :: TcType -> Bool
+isRefineableTy :: TcType -> (Bool,Bool)
-- A type should have type refinements applied to it if it has
-- free type variables, and they are all rigid
-isRefineableTy ty = not (null tc_tvs) && all isSkolemTyVar tc_tvs
+isRefineableTy ty = (null tc_tvs, all isImmutableTyVar tc_tvs)
where
tc_tvs = varSetElems (tcTyVarsOfType ty)
+isRefineablePred :: TcPredType -> Bool
+isRefineablePred pred = not (null tc_tvs) && all isImmutableTyVar tc_tvs
+ where
+ tc_tvs = varSetElems (tcTyVarsOfPred pred)
+
---------------
getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
-- construct a dictionary function name
getDFunTyKey (TyVarTy tv) = getOccName tv
getDFunTyKey (TyConApp tc _) = getOccName tc
getDFunTyKey (AppTy fun _) = getDFunTyKey fun
-getDFunTyKey (FunTy arg _) = getOccName funTyCon
+getDFunTyKey (FunTy _ _) = getOccName funTyCon
getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty)
-- PredTy shouldn't happen
tcSplitForAllTys ty = split ty ty []
where
split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
- split orig_ty (ForAllTy tv ty) tvs
+ split _ (ForAllTy tv ty) tvs
| not (isCoVar tv) = split ty ty (tv:tvs)
- split orig_ty t tvs = (reverse tvs, orig_ty)
+ split orig_ty _ tvs = (reverse tvs, orig_ty)
+tcIsForAllTy :: Type -> Bool
tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty'
-tcIsForAllTy (ForAllTy tv ty) = not (isCoVar tv)
-tcIsForAllTy t = False
+tcIsForAllTy (ForAllTy tv _) = not (isCoVar tv)
+tcIsForAllTy _ = False
tcSplitPhiTy :: Type -> (ThetaType, Type)
tcSplitPhiTy ty = split ty ty []
where
split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
- split orig_ty (ForAllTy tv ty) ts
- | isCoVar tv = split ty ty (eq_pred:ts)
- where
- PredTy eq_pred = tyVarKind tv
- split orig_ty (FunTy arg res) ts
+ split _ (ForAllTy tv ty) ts
+ | isCoVar tv = split ty ty (coVarPred tv : ts)
+ split _ (FunTy arg res) ts
| Just p <- tcSplitPredTy_maybe arg = split res res (p:ts)
- split orig_ty ty ts = (reverse ts, orig_ty)
+ split orig_ty _ ts = (reverse ts, orig_ty)
tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)
tcSplitSigmaTy ty = case tcSplitForAllTys ty of
tcMultiSplitSigmaTy sigma
= case (tcSplitSigmaTy sigma) of
- ([],[],ty) -> ([], sigma)
+ ([], [], _) -> ([], sigma)
(tvs, theta, ty) -> case tcMultiSplitSigmaTy ty of
(pairs, rest) -> ((tvs,theta):pairs, rest)
-- Newtypes are opaque, so they may be split
-- However, predicates are not treated
-- as tycon applications by the type checker
-tcSplitTyConApp_maybe other = Nothing
+tcSplitTyConApp_maybe _ = Nothing
-----------------------
tcSplitFunTys :: Type -> ([Type], Type)
(args,res') = tcSplitFunTys res
tcSplitFunTy_maybe :: Type -> Maybe (Type, Type)
-tcSplitFunTy_maybe ty | Just ty' <- tcView ty = tcSplitFunTy_maybe ty'
-tcSplitFunTy_maybe (FunTy arg res) = Just (arg, res)
-tcSplitFunTy_maybe other = Nothing
+tcSplitFunTy_maybe ty | Just ty' <- tcView ty = tcSplitFunTy_maybe ty'
+tcSplitFunTy_maybe (FunTy arg res) | not (isPredTy arg) = Just (arg, res)
+tcSplitFunTy_maybe _ = Nothing
+ -- Note the (not (isPredTy arg)) guard
+ -- Consider (?x::Int) => Bool
+ -- We don't want to treat this as a function type!
+ -- A concrete example is test tc230:
+ -- f :: () -> (?p :: ()) => () -> ()
+ --
+ -- g = f () ()
tcSplitFunTysN
:: TcRhoType
| otherwise
= ([], ty)
+tcSplitFunTy :: Type -> (Type, Type)
tcSplitFunTy ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty)
+
+tcFunArgTy :: Type -> Type
tcFunArgTy ty = fst (tcSplitFunTy ty)
+
+tcFunResultTy :: Type -> Type
tcFunResultTy ty = snd (tcSplitFunTy ty)
-----------------------
-----------------------
tcGetTyVar_maybe :: Type -> Maybe TyVar
tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty'
-tcGetTyVar_maybe (TyVarTy tv) = Just tv
-tcGetTyVar_maybe other = Nothing
+tcGetTyVar_maybe (TyVarTy tv) = Just tv
+tcGetTyVar_maybe _ = Nothing
tcGetTyVar :: String -> Type -> TyVar
tcGetTyVar msg ty = expectJust msg (tcGetTyVar_maybe ty)
tcSplitDFunHead tau
= case tcSplitPredTy_maybe tau of
Just (ClassP clas tys) -> (clas, tys)
- other -> panic "tcSplitDFunHead"
+ _ -> panic "tcSplitDFunHead"
-tcValidInstHeadTy :: Type -> Bool
+tcInstHeadTyNotSynonym :: Type -> Bool
-- Used in Haskell-98 mode, for the argument types of an instance head
-- These must not be type synonyms, but everywhere else type synonyms
-- are transparent, so we need a special function here
-tcValidInstHeadTy ty
+tcInstHeadTyNotSynonym ty
= case ty of
- NoteTy _ ty -> tcValidInstHeadTy ty
- TyConApp tc tys -> not (isSynTyCon tc) && ok tys
+ TyConApp tc _ -> not (isSynTyCon tc)
+ _ -> True
+
+tcInstHeadTyAppAllTyVars :: Type -> Bool
+-- Used in Haskell-98 mode, for the argument types of an instance head
+-- These must be a constructor applied to type variable arguments
+tcInstHeadTyAppAllTyVars ty
+ = case ty of
+ TyConApp _ tys -> ok tys
FunTy arg res -> ok [arg, res]
- other -> False
+ _ -> False
where
-- Check that all the types are type variables,
-- and that each is distinct
where
tvs = mapCatMaybes get_tv tys
- get_tv (NoteTy _ ty) = get_tv ty -- Again, do not look
get_tv (TyVarTy tv) = Just tv -- through synonyms
- get_tv other = Nothing
+ get_tv _ = Nothing
\end{code}
-- Returns Just for predicates only
tcSplitPredTy_maybe ty | Just ty' <- tcView ty = tcSplitPredTy_maybe ty'
tcSplitPredTy_maybe (PredTy p) = Just p
-tcSplitPredTy_maybe other = Nothing
-
-predTyUnique :: PredType -> Unique
-predTyUnique (IParam n _) = getUnique (ipNameName n)
-predTyUnique (ClassP clas tys) = getUnique clas
+tcSplitPredTy_maybe _ = Nothing
-mkPredName :: Unique -> SrcLoc -> PredType -> Name
-mkPredName uniq loc (ClassP cls tys) = mkInternalName uniq (mkDictOcc (getOccName cls)) loc
-mkPredName uniq loc (IParam ip ty) = mkInternalName uniq (getOccName (ipNameName ip)) loc
+predTyUnique :: PredType -> Unique
+predTyUnique (IParam n _) = getUnique (ipNameName n)
+predTyUnique (ClassP clas _) = getUnique clas
+predTyUnique (EqPred a b) = pprPanic "predTyUnique" (ppr (EqPred a b))
\end{code}
--------------------- Dictionary types ---------------------------------
\begin{code}
+mkClassPred :: Class -> [Type] -> PredType
mkClassPred clas tys = ClassP clas tys
isClassPred :: PredType -> Bool
-isClassPred (ClassP clas tys) = True
-isClassPred other = False
+isClassPred (ClassP _ _) = True
+isClassPred _ = False
-isTyVarClassPred (ClassP clas tys) = all tcIsTyVarTy tys
-isTyVarClassPred other = False
+isTyVarClassPred :: PredType -> Bool
+isTyVarClassPred (ClassP _ tys) = all tcIsTyVarTy tys
+isTyVarClassPred _ = False
getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
-getClassPredTys_maybe _ = Nothing
+getClassPredTys_maybe _ = Nothing
getClassPredTys :: PredType -> (Class, [Type])
getClassPredTys (ClassP clas tys) = (clas, tys)
-getClassPredTys other = panic "getClassPredTys"
-
-isEqPred :: PredType -> Bool
-isEqPred (EqPred {}) = True
-isEqPred _ = False
+getClassPredTys _ = panic "getClassPredTys"
mkDictTy :: Class -> [Type] -> Type
mkDictTy clas tys = mkPredTy (ClassP clas tys)
isDictTy :: Type -> Bool
isDictTy ty | Just ty' <- tcView ty = isDictTy ty'
isDictTy (PredTy p) = isClassPred p
-isDictTy other = False
+isDictTy _ = False
\end{code}
--------------------- Implicit parameters ---------------------------------
\begin{code}
isIPPred :: PredType -> Bool
isIPPred (IParam _ _) = True
-isIPPred other = False
+isIPPred _ = False
isInheritablePred :: PredType -> Bool
-- Can be inherited by a context. For example, consider
-- but it doesn't need to be quantified over the Num a dictionary
-- which can be free in g's rhs, and shared by both calls to g
isInheritablePred (ClassP _ _) = True
-isInheritablePred other = False
+isInheritablePred (EqPred _ _) = True
+isInheritablePred _ = False
\end{code}
--------------------- Equality predicates ---------------------------------
= nubBy tcEqPred all_preds
where
all_preds = dataConStupidTheta con1 ++ other_stupids
- res_tys1 = dataConResTys con1
- tvs1 = tyVarsOfTypes res_tys1
+ res_ty1 = dataConOrigResTy con1
other_stupids = [ substPred subst pred
| con <- cons
- , let Just subst = tcMatchTys tvs1 res_tys1 (dataConResTys con)
+ , let (tvs, _, _, res_ty) = dataConSig con
+ Just subst = tcMatchTy (mkVarSet tvs) res_ty res_ty1
, pred <- dataConStupidTheta con ]
dataConsStupidTheta [] = panic "dataConsStupidTheta"
\end{code}
\begin{code}
isSigmaTy :: Type -> Bool
isSigmaTy ty | Just ty' <- tcView ty = isSigmaTy ty'
-isSigmaTy (ForAllTy tyvar ty) = True
-isSigmaTy (FunTy a b) = isPredTy a
-isSigmaTy _ = False
+isSigmaTy (ForAllTy _ _) = True
+isSigmaTy (FunTy a _) = isPredTy a
+isSigmaTy _ = False
isOverloadedTy :: Type -> Bool
isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty'
-isOverloadedTy (ForAllTy tyvar ty) = isOverloadedTy ty
-isOverloadedTy (FunTy a b) = isPredTy a
-isOverloadedTy _ = False
+isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty
+isOverloadedTy (FunTy a _) = isPredTy a
+isOverloadedTy _ = False
isPredTy :: Type -> Bool -- Belongs in TcType because it does
-- not look through newtypes, or predtypes (of course)
isPredTy ty | Just ty' <- tcView ty = isPredTy ty'
-isPredTy (PredTy sty) = True
-isPredTy _ = False
+isPredTy (PredTy _) = True
+isPredTy _ = False
\end{code}
\begin{code}
+isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy,
+ isUnitTy, isCharTy :: Type -> Bool
isFloatTy = is_tc floatTyConKey
isDoubleTy = is_tc doubleTyConKey
isIntegerTy = is_tc integerTyConKey
isIntTy = is_tc intTyConKey
+isWordTy = is_tc wordTyConKey
isBoolTy = is_tc boolTyConKey
isUnitTy = is_tc unitTyConKey
+isCharTy = is_tc charTyConKey
+
+isStringTy :: Type -> Bool
+isStringTy ty
+ = case tcSplitTyConApp_maybe ty of
+ Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty
+ _ -> False
is_tc :: Unique -> Type -> Bool
-- Newtypes are opaque to this
Nothing -> False
\end{code}
+\begin{code}
+-- NB: Currently used in places where we have already expanded type synonyms;
+-- hence no 'coreView'. This could, however, be changed without breaking
+-- any code.
+isOpenSynTyConApp :: TcTauType -> Bool
+isOpenSynTyConApp (TyConApp tc _) = isOpenSynTyCon tc
+isOpenSynTyConApp _other = False
+\end{code}
+
%************************************************************************
%* *
-- (Types.tyVarsOfTypes finds all free TyVars)
tcTyVarsOfType (TyVarTy tv) = if isTcTyVar tv then unitVarSet tv
else emptyVarSet
-tcTyVarsOfType (TyConApp tycon tys) = tcTyVarsOfTypes tys
-tcTyVarsOfType (NoteTy _ ty) = tcTyVarsOfType ty
+tcTyVarsOfType (TyConApp _ tys) = tcTyVarsOfTypes tys
tcTyVarsOfType (PredTy sty) = tcTyVarsOfPred sty
tcTyVarsOfType (FunTy arg res) = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res
tcTyVarsOfType (AppTy fun arg) = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg
which type variables are mentioned in a type. It's also used in the
smart-app checking code --- see TcExpr.tcIdApp
+On the other hand, consider a *top-level* definition
+ f = (\x -> x) :: T a -> T a
+If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then
+if we have an application like (f "x") we get a confusing error message
+involving Any. So the conclusion is this: when generalising
+ - at top level use tyVarsOfType
+ - in nested bindings use exactTyVarsOfType
+See Trac #1813 for example.
+
\begin{code}
exactTyVarsOfType :: TcType -> TyVarSet
-- Find the free type variables (of any kind)
where
go ty | Just ty' <- tcView ty = go ty' -- This is the key line
go (TyVarTy tv) = unitVarSet tv
- go (TyConApp tycon tys) = exactTyVarsOfTypes tys
+ go (TyConApp _ tys) = exactTyVarsOfTypes tys
go (PredTy ty) = go_pred ty
go (FunTy arg res) = go arg `unionVarSet` go res
go (AppTy fun arg) = go fun `unionVarSet` go arg
\begin{code}
tyClsNamesOfType :: Type -> NameSet
-tyClsNamesOfType (TyVarTy tv) = emptyNameSet
+tyClsNamesOfType (TyVarTy _) = emptyNameSet
tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
-tyClsNamesOfType (NoteTy _ ty2) = tyClsNamesOfType ty2
-tyClsNamesOfType (PredTy (IParam n ty)) = tyClsNamesOfType ty
+tyClsNamesOfType (PredTy (IParam _ ty)) = tyClsNamesOfType ty
tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
tyClsNamesOfType (PredTy (EqPred ty1 ty2)) = tyClsNamesOfType ty1 `unionNameSets` tyClsNamesOfType ty2
tyClsNamesOfType (FunTy arg res) = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res
tyClsNamesOfType (AppTy fun arg) = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg
-tyClsNamesOfType (ForAllTy tyvar ty) = tyClsNamesOfType ty
+tyClsNamesOfType (ForAllTy _ ty) = tyClsNamesOfType ty
+tyClsNamesOfTypes :: [Type] -> NameSet
tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys
tyClsNamesOfDFunHead :: Type -> NameSet
-- even if Foo *is* locally defined
tyClsNamesOfDFunHead dfun_ty
= case tcSplitSigmaTy dfun_ty of
- (tvs,_,head_ty) -> tyClsNamesOfType head_ty
-
-classesOfTheta :: ThetaType -> [Class]
--- Looks just for ClassP things; maybe it should check
-classesOfTheta preds = [ c | ClassP c _ <- preds ]
+ (_, _, head_ty) -> tyClsNamesOfType head_ty
\end{code}
being the )
\begin{code}
-tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type)
--- (isIOType t) returns (Just (IO,t')) if t is of the form (IO t'), or
--- some newtype wrapping thereof
+tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, CoercionI)
+-- (isIOType t) returns Just (IO,t',co)
+-- if co : t ~ IO t'
-- returns Nothing otherwise
tcSplitIOType_maybe ty
- | Just (io_tycon, [io_res_ty]) <- tcSplitTyConApp_maybe ty,
+ = case tcSplitTyConApp_maybe ty of
-- This split absolutely has to be a tcSplit, because we must
-- see the IO type; and it's a newtype which is transparent to splitTyConApp.
- io_tycon `hasKey` ioTyConKey
- = Just (io_tycon, io_res_ty)
- | Just ty' <- coreView ty -- Look through non-recursive newtypes
- = tcSplitIOType_maybe ty'
+ Just (io_tycon, [io_res_ty])
+ | io_tycon `hasKey` ioTyConKey
+ -> Just (io_tycon, io_res_ty, IdCo)
- | otherwise
- = Nothing
+ Just (tc, tys)
+ | not (isRecursiveTyCon tc)
+ , Just (ty, co1) <- instNewTyCon_maybe tc tys
+ -- Newtypes that require a coercion are ok
+ -> case tcSplitIOType_maybe ty of
+ Nothing -> Nothing
+ Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCoI` co2)
+
+ _ -> Nothing
isFFITy :: Type -> Bool
-- True for any TyCon that can possibly be an arg or result of an FFI call
isFFIDotnetTy dflags ty
= checkRepTyCon (\ tc -> (legalFIResultTyCon dflags tc ||
isFFIDotnetObjTy ty || isStringTy ty)) ty
+ -- NB: isStringTy used to look through newtypes, but
+ -- it no longer does so. May need to adjust isFFIDotNetTy
+ -- if we do want to look through newtypes.
--- Support String as an argument or result from a .NET FFI call.
-isStringTy ty =
- case tcSplitTyConApp_maybe (repType ty) of
- Just (tc, [arg_ty])
- | tc == listTyCon ->
- case tcSplitTyConApp_maybe (repType arg_ty) of
- Just (cc,[]) -> cc == charTyCon
- _ -> False
- _ -> False
-
--- Support String as an argument or result from a .NET FFI call.
-isFFIDotnetObjTy ty =
- let
+isFFIDotnetObjTy :: Type -> Bool
+isFFIDotnetObjTy ty
+ = checkRepTyCon check_tc t_ty
+ where
(_, t_ty) = tcSplitForAllTys ty
- in
- case tcSplitTyConApp_maybe (repType t_ty) of
- Just (tc, [arg_ty]) | getName tc == objectTyConName -> True
- _ -> False
+ check_tc tc = getName tc == objectTyConName
+
+isFunPtrTy :: Type -> Bool
+isFunPtrTy = checkRepTyConKey [funPtrTyConKey]
toDNType :: Type -> DNType
toDNType ty
legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
-- Checks validity of types going from Haskell -> external world
-legalOutgoingTyCon dflags safety tc
+legalOutgoingTyCon dflags _ tc
= marshalableTyCon dflags tc
legalFFITyCon :: TyCon -> Bool
legalFFITyCon tc
= isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon
+marshalableTyCon :: DynFlags -> TyCon -> Bool
marshalableTyCon dflags tc
- = (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
+ = (dopt Opt_UnliftedFFITypes dflags
+ && isUnLiftedTyCon tc
+ && not (isUnboxedTupleTyCon tc)
+ && case tyConPrimRep tc of -- Note [Marshalling VoidRep]
+ VoidRep -> False
+ _ -> True)
|| boxedMarshalableTyCon tc
+boxedMarshalableTyCon :: TyCon -> Bool
boxedMarshalableTyCon tc
= getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
, int32TyConKey, int64TyConKey
, boolTyConKey
]
\end{code}
+
+Note [Marshalling VoidRep]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+We don't treat State# (whose PrimRep is VoidRep) as marshalable.
+In turn that means you can't write
+ foreign import foo :: Int -> State# RealWorld
+
+Reason: the back end falls over with panic "primRepHint:VoidRep";
+ and there is no compelling reason to permit it