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,
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,
---------------------------------
eqKind,
isSigmaTy, isOverloadedTy, isRigidTy, isBoxyTy,
isDoubleTy, isFloatTy, isIntTy, isStringTy,
- isIntegerTy, isBoolTy, isUnitTy,
+ isIntegerTy, isBoolTy, isUnitTy, isCharTy,
isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
---------------------------------
-- 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
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
-- others:
import DynFlags
+import CoreSyn
import Name
import NameSet
import VarEnv
import PrelNames
import TysWiredIn
import BasicTypes
-import SrcLoc
import Util
import Maybes
import ListSetOps
-- 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
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")
(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 = empty -- Unhelpful; omit
+ 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")
%************************************************************************
\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 tha 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
+ other -> False
isMetaTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
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.
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
-- 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 = not (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
(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 other = 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
Just (ClassP clas tys) -> (clas, tys)
other -> 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
+ NoteTy _ ty -> tcInstHeadTyNotSynonym ty
+ TyConApp tc tys -> 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
+ NoteTy _ ty -> tcInstHeadTyAppAllTyVars ty
+ TyConApp _ tys -> ok tys
FunTy arg res -> ok [arg, res]
other -> False
where
predTyUnique :: PredType -> Unique
predTyUnique (IParam n _) = getUnique (ipNameName n)
predTyUnique (ClassP clas tys) = getUnique clas
-
-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
\end{code}
-- 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 other = 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}
isIntTy = is_tc intTyConKey
isBoolTy = is_tc boolTyConKey
isUnitTy = is_tc unitTyConKey
+isCharTy = is_tc charTyConKey
+
+isStringTy ty
+ = case tcSplitTyConApp_maybe ty of
+ Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty
+ other -> False
is_tc :: Unique -> Type -> Bool
-- Newtypes are opaque to this
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 ]
\end{code}
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
(_, t_ty) = tcSplitForAllTys ty
= isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon
marshalableTyCon dflags tc
- = (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
+ = (dopt Opt_UnliftedFFITypes dflags && isUnLiftedTyCon tc)
|| boxedMarshalableTyCon tc
boxedMarshalableTyCon tc