-
+%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcType]{Types used in the typechecker}
newtypes, and predicates are meaningful.
* look through usage types
-The "tc" prefix is for "typechechecker", because the type checker
+The "tc" prefix is for "TypeChecker", because the type checker
is the principal client.
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module TcType (
--------------------------------
-- Types
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,
tcSplitForAllTys, tcSplitPhiTy,
tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN,
tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
- tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys,
- tcValidInstHeadTy, tcGetTyVar_maybe, tcGetTyVar,
+ tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe,
+ tcInstHeadTyNotSynonym, tcInstHeadTyAppAllTyVars,
+ tcGetTyVar_maybe, tcGetTyVar,
tcSplitSigmaTy, tcMultiSplitSigmaTy,
---------------------------------
-- Predicates.
-- Again, newtypes are opaque
tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX,
+ eqKind,
isSigmaTy, isOverloadedTy, isRigidTy, isBoxyTy,
isDoubleTy, isFloatTy, isIntTy, isStringTy,
- isIntegerTy, isAddrTy, isBoolTy, isUnitTy,
+ isIntegerTy, isBoolTy, isUnitTy, isCharTy,
isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
+ isOpenSynTyConApp,
---------------------------------
-- Misc type manipulators
- deNoteType, classesOfTheta,
+ deNoteType,
tyClsNamesOfType, tyClsNamesOfDFunHead,
getDFunTyKey,
---------------------------------
-- Predicate types
getClassPredTys_maybe, getClassPredTys,
- isClassPred, isTyVarClassPred,
+ isClassPred, isTyVarClassPred, isEqPred,
mkDictTy, tcSplitPredTy_maybe,
isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique,
- mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName,
- dataConsStupidTheta, isRefineableTy,
+ mkClassPred, isInheritablePred, isIPPred,
+ dataConsStupidTheta, isRefineableTy, isRefineablePred,
---------------------------------
-- Foreign import and export
isFFIDotnetTy, -- :: DynFlags -> Type -> Bool
isFFIDotnetObjTy, -- :: Type -> Bool
isFFITy, -- :: Type -> Bool
-
+ tcSplitIOType_maybe, -- :: Type -> Maybe Type
toDNType, -- :: Type -> DNType
--------------------------------
-- Rexported from Type
Kind, -- Stuff to do with kinds is insensitive to pre/post Tc
- unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
- isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
- isArgTypeKind, isSubKind, defaultKind,
+ unliftedTypeKind, liftedTypeKind, argTypeKind,
+ openTypeKind, mkArrowKind, mkArrowKinds,
+ isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind,
+ isSubArgTypeKind, isSubKind, defaultKind,
+ kindVarRef, mkKindVar,
Type, PredType(..), ThetaType,
mkForAllTy, mkForAllTys,
-- Type substitutions
TvSubst(..), -- Representation visible to a few friends
- TvSubstEnv, emptyTvSubst,
+ TvSubstEnv, emptyTvSubst, substEqSpec,
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 ) -- friend
-
-import Type ( -- Re-exports
- tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
- tyVarsOfTheta, Kind, PredType(..),
- ThetaType, unliftedTypeKind,
- liftedTypeKind, openTypeKind, mkArrowKind,
- isLiftedTypeKind, isUnliftedTypeKind,
- mkArrowKinds, mkForAllTy, mkForAllTys,
- defaultKind, isArgTypeKind, isOpenTypeKind,
- 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,
-
- 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,
- pprKind, pprParendKind,
- pprType, pprParendType, pprTyThingCategory,
- pprPred, pprTheta, pprThetaArrow, pprClassPred
- )
-import TyCon ( TyCon, isUnLiftedTyCon, isSynTyCon, synTyConDefn, tyConUnique )
-import DataCon ( DataCon, dataConStupidTheta, dataConResTys )
-import Class ( Class )
-import Var ( TyVar, Id, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails )
-import ForeignCall ( Safety, playSafe, 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 )
+import DynFlags
+import CoreSyn
+import Name
import NameSet
-import VarEnv ( TidyEnv )
-import OccName ( OccName, mkDictOcc )
-import PrelNames -- Lots (e.g. in isFFIArgumentTy)
-import TysWiredIn ( unitTyCon, charTyCon, listTyCon )
-import BasicTypes ( IPName(..), Arity, ipNameName )
-import SrcLoc ( SrcLoc, SrcSpan )
-import Util ( snocView, 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 Data.List
+import Data.IORef
+\end{code}
%************************************************************************
%* *
be the *same*, so we can't make them into skolem constants that don't unify
with each other. Alas.
-On the other hand, we *must* use skolems for signature type variables,
-becuase GADT type refinement refines skolems only.
-
One solution would be insist that in the above defn the programmer uses
the same type variable in both type signatures. But that takes explanation.
The alternative (currently implemented) is to have a special kind of skolem
-constant, SigSkokTv, which can unify with other SigSkolTvs.
+constant, SigTv, which can unify with other SigTvs. These are *not* treated
+as righd for the purposes of GADTs. And they are used *only* for pattern
+bindings and mutually recursive function bindings. See the function
+TcBinds.tcInstSig, and its use_skols parameter.
\begin{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
+ | 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
-- will become type T = forall a. a->a
--
-- With gla-exts that's right, but for H98 we should complain.
+
+---------------------------------
+-- Kind variables:
+
+mkKindName :: Unique -> Name
+mkKindName unique = mkSystemName unique kind_var_occ
+
+kindVarRef :: KindVar -> IORef MetaDetails
+kindVarRef tc =
+ ASSERT ( isTcTyVar tc )
+ case tcTyVarDetails tc of
+ MetaTv TauTv ref -> ref
+ other -> pprPanic "kindVarRef" (ppr tc)
+
+mkKindVar :: Unique -> IORef MetaDetails -> KindVar
+mkKindVar u r
+ = mkTcTyVar (mkKindName u)
+ tySuperKind -- not sure this is right,
+ -- do we need kind vars for
+ -- coercions?
+ (MetaTv TauTv r)
+
+kind_var_occ :: OccName -- Just one for all KindVars
+ -- They may be jiggled by tidying
+kind_var_occ = mkOccName tvName "k"
\end{code}
%************************************************************************
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")
tidySkolemTyVar :: TidyEnv -> TcTyVar -> (TidyEnv, TcTyVar)
-- Tidy the type inside a GenSkol, preparatory to printing it
tidySkolemTyVar env tv
- = ASSERT( isSkolemTyVar tv )
+ = ASSERT( isSkolemTyVar tv || isSigTyVar tv )
(env1, mkTcTyVar (tyVarName tv) (tyVarKind tv) info1)
where
(env1, info1) = case tcTyVarDetails tv of
- SkolemTv (GenSkol tvs ty loc) -> (env2, SkolemTv (GenSkol tvs1 ty1 loc))
+ SkolemTv info -> (env1, SkolemTv info')
+ where
+ (env1, info') = tidy_skol_info env info
+ MetaTv (SigTv info) box -> (env1, MetaTv (SigTv info') box)
+ where
+ (env1, info') = tidy_skol_info env info
+ info -> (env, info)
+
+ tidy_skol_info env (GenSkol tvs ty) = (env2, GenSkol tvs1 ty1)
where
(env1, tvs1) = tidyOpenTyVars env tvs
(env2, ty1) = tidyOpenType env1 ty
- info -> (env, info)
+ tidy_skol_info env info = (env, info)
pprSkolTvBinding :: TcTyVar -> SDoc
-- Print info about the binding of a skolem tyvar,
-- or nothing if we don't have anything useful to say
pprSkolTvBinding tv
- = ppr_details (tcTyVarDetails tv)
+ = ASSERT ( isTcTyVar 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 (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 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
+ other -> False
isMetaTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
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)
isFlexi, isIndirect :: MetaDetails -> Bool
-isFlexi Flexi = True
-isFlexi other = False
+isFlexi Flexi = True
+isFlexi other = False
isIndirect (Indirect _) = True
isIndirect other = False
%************************************************************************
\begin{code}
+mkSigmaTy :: [TyVar] -> [PredType] -> Type -> Type
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 = isTauTy (snd (synTyConDefn tc))
- | otherwise = True
+isTauTyCon tc
+ | 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
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 ty ty (tv:tvs)
- split orig_ty t tvs = (reverse tvs, orig_ty)
+ split orig_ty (ForAllTy tv ty) tvs
+ | not (isCoVar tv) = split ty ty (tv:tvs)
+ split orig_ty t tvs = (reverse tvs, orig_ty)
tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty'
-tcIsForAllTy (ForAllTy tv ty) = True
+tcIsForAllTy (ForAllTy tv ty) = not (isCoVar tv)
tcIsForAllTy t = False
-tcSplitPhiTy :: Type -> ([PredType], Type)
+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 (FunTy arg res) ts = case tcSplitPredTy_maybe arg of
- Just p -> split res res (p:ts)
- Nothing -> (reverse ts, orig_ty)
+
+ 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
+ | Just p <- tcSplitPredTy_maybe arg = split res res (p:ts)
split orig_ty ty ts = (reverse ts, orig_ty)
+tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)
tcSplitSigmaTy ty = case tcSplitForAllTys ty of
(tvs, rho) -> case tcSplitPhiTy rho of
(theta, tau) -> (tvs, theta, tau)
-----------------------
tcTyConAppTyCon :: Type -> TyCon
-tcTyConAppTyCon ty = fst (tcSplitTyConApp ty)
+tcTyConAppTyCon ty = case tcSplitTyConApp_maybe ty of
+ Just (tc, _) -> tc
+ Nothing -> pprPanic "tcTyConAppTyCon" (pprType ty)
tcTyConAppArgs :: Type -> [Type]
-tcTyConAppArgs ty = snd (tcSplitTyConApp ty)
+tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of
+ Just (_, args) -> args
+ Nothing -> pprPanic "tcTyConAppArgs" (pprType ty)
tcSplitTyConApp :: Type -> (TyCon, [Type])
tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of
(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
| otherwise
= ([], ty)
-tcFunArgTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> arg }
-tcFunResultTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> res }
-
+tcSplitFunTy ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty)
+tcFunArgTy ty = fst (tcSplitFunTy ty)
+tcFunResultTy ty = snd (tcSplitFunTy ty)
-----------------------
tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
tcSplitAppTy_maybe ty | Just ty' <- tcView ty = tcSplitAppTy_maybe ty'
-tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
-tcSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
-tcSplitAppTy_maybe (TyConApp tc tys) = case snocView tys of
- Just (tys', ty') -> Just (TyConApp tc tys', ty')
- Nothing -> Nothing
-tcSplitAppTy_maybe other = Nothing
+tcSplitAppTy_maybe ty = repSplitAppTy_maybe ty
+tcSplitAppTy :: Type -> (Type, Type)
tcSplitAppTy ty = case tcSplitAppTy_maybe ty of
Just stuff -> stuff
Nothing -> pprPanic "tcSplitAppTy" (pprType ty)
tcSplitDFunHead tau
= case tcSplitPredTy_maybe tau of
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 -> 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 -> tcValidInstHeadTy ty
- TyConApp tc tys -> not (isSynTyCon tc) && ok tys
+ 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
+predTyUnique (EqPred a b) = pprPanic "predTyUnique" (ppr (EqPred a b))
\end{code}
getClassPredTys :: PredType -> (Class, [Type])
getClassPredTys (ClassP clas tys) = (clas, tys)
+getClassPredTys other = 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 (PredTy p) = isClassPred p
+isDictTy other = False
\end{code}
--------------------- Implicit parameters ---------------------------------
-- 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}
-isLinearPred :: TcPredType -> Bool
-isLinearPred (IParam (Linear n) _) = True
-isLinearPred other = False
+--------------------- Equality predicates ---------------------------------
+\begin{code}
+substEqSpec :: TvSubst -> [(TyVar,Type)] -> [(TcType,TcType)]
+substEqSpec subst eq_spec = [ (substTyVar subst tv, substTy subst ty)
+ | (tv,ty) <- eq_spec]
\end{code}
--------------------- The stupid theta (sigh) ---------------------------------
= 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}
isDoubleTy = is_tc doubleTyConKey
isIntegerTy = is_tc integerTyConKey
isIntTy = is_tc intTyConKey
-isAddrTy = is_tc addrTyConKey
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
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}
+
%************************************************************************
%* *
\begin{code}
tcTyVarsOfType :: Type -> TcTyVarSet
--- Just the tc type variables free in the type
+-- Just the *TcTyVars* free in the type
+-- (Types.tyVarsOfTypes finds all free TyVars)
tcTyVarsOfType (TyVarTy tv) = if isTcTyVar tv then unitVarSet tv
else emptyVarSet
tcTyVarsOfType (TyConApp tycon 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
-tcTyVarsOfType (ForAllTy tyvar ty) = tcTyVarsOfType ty `delVarSet` tyvar
+tcTyVarsOfType (ForAllTy tyvar ty) = (tcTyVarsOfType ty `delVarSet` tyvar)
+ `unionVarSet` tcTyVarsOfTyVar tyvar
-- We do sometimes quantify over skolem TcTyVars
+tcTyVarsOfTyVar :: TcTyVar -> TyVarSet
+tcTyVarsOfTyVar tv | isCoVar tv = tcTyVarsOfType (tyVarKind tv)
+ | otherwise = emptyVarSet
+
tcTyVarsOfTypes :: [Type] -> TyVarSet
tcTyVarsOfTypes tys = foldr (unionVarSet.tcTyVarsOfType) emptyVarSet tys
tcTyVarsOfPred :: PredType -> TyVarSet
-tcTyVarsOfPred (IParam _ ty) = tcTyVarsOfType ty
-tcTyVarsOfPred (ClassP _ tys) = tcTyVarsOfTypes tys
+tcTyVarsOfPred (IParam _ ty) = tcTyVarsOfType ty
+tcTyVarsOfPred (ClassP _ tys) = tcTyVarsOfTypes tys
+tcTyVarsOfPred (EqPred ty1 ty2) = tcTyVarsOfType ty1 `unionVarSet` tcTyVarsOfType ty2
\end{code}
Note [Silly type synonym]
\begin{code}
exactTyVarsOfType :: TcType -> TyVarSet
-- Find the free type variables (of any kind)
--- but *expand* type synonyms. See Note [Silly type synonym] belos.
+-- but *expand* type synonyms. See Note [Silly type synonym] above.
exactTyVarsOfType ty
= go ty
where
go (FunTy arg res) = go arg `unionVarSet` go res
go (AppTy fun arg) = go fun `unionVarSet` go arg
go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar
+ `unionVarSet` go_tv tyvar
+ go (NoteTy _ _) = panic "exactTyVarsOfType" -- Handled by tcView
- go_pred (IParam _ ty) = go ty
- go_pred (ClassP _ tys) = exactTyVarsOfTypes tys
+ go_pred (IParam _ ty) = go ty
+ go_pred (ClassP _ tys) = exactTyVarsOfTypes tys
+ go_pred (EqPred ty1 ty2) = go ty1 `unionVarSet` go ty2
+
+ go_tv tyvar | isCoVar tyvar = go (tyVarKind tyvar)
+ | otherwise = emptyVarSet
exactTyVarsOfTypes :: [TcType] -> TyVarSet
exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys
tyClsNamesOfType (NoteTy _ ty2) = tyClsNamesOfType ty2
tyClsNamesOfType (PredTy (IParam n 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
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}
being the )
\begin{code}
+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
+ = 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.
+
+ Just (io_tycon, [io_res_ty])
+ | io_tycon `hasKey` ioTyConKey
+ -> Just (io_tycon, io_res_ty, IdCo)
+
+ 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)
+
+ other -> Nothing
+
isFFITy :: Type -> Bool
-- True for any TyCon that can possibly be an arg or result of an FFI call
isFFITy ty = checkRepTyCon legalFFITyCon ty
isFFIDynArgumentTy :: Type -> Bool
-- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr,
-- or a newtype of either.
-isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
+isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
isFFIDynResultTy :: Type -> Bool
-- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr,
-- or a newtype of either.
-isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
+isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
isFFILabelTy :: Type -> Bool
-- The type of a foreign label must be Ptr, FunPtr, Addr,
-- or a newtype of either.
-isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
+isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
isFFIDotnetTy :: DynFlags -> Type -> Bool
isFFIDotnetTy dflags ty
- = checkRepTyCon (\ tc -> not (isByteArrayLikeTyCon tc) &&
- (legalFIResultTyCon dflags tc ||
+ = 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 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
toDNType :: Type -> DNType
toDNType ty
| isStringTy ty = DNString
| isFFIDotnetObjTy ty = DNObject
- | Just (tc,argTys) <- tcSplitTyConApp_maybe ty =
- case lookup (getUnique tc) dn_assoc of
+ | Just (tc,argTys) <- tcSplitTyConApp_maybe ty
+ = case lookup (getUnique tc) dn_assoc of
Just x -> x
Nothing
| tc `hasKey` ioTyConKey -> toDNType (head argTys)
- | otherwise -> pprPanic ("toDNType: unsupported .NET type") (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc)
+ | otherwise -> pprPanic ("toDNType: unsupported .NET type")
+ (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc)
+ | otherwise = panic "toDNType" -- Is this right?
where
dn_assoc :: [ (Unique, DNType) ]
dn_assoc = [ (unitTyConKey, DNUnit)
, (word64TyConKey, DNWord64)
, (floatTyConKey, DNFloat)
, (doubleTyConKey, DNDouble)
- , (addrTyConKey, DNPtr)
, (ptrTyConKey, DNPtr)
, (funPtrTyConKey, DNPtr)
, (charTyConKey, DNChar)
\begin{code}
legalFEArgTyCon :: TyCon -> Bool
--- It's illegal to return foreign objects and (mutable)
--- bytearrays from a _ccall_ / foreign declaration
--- (or be passed them as arguments in foreign exported functions).
legalFEArgTyCon tc
- | isByteArrayLikeTyCon tc
- = False
- -- It's also illegal to make foreign exports that take unboxed
+ -- It's illegal to make foreign exports that take unboxed
-- arguments. The RTS API currently can't invoke such things. --SDM 7/2000
- | otherwise
= boxedMarshalableTyCon tc
legalFIResultTyCon :: DynFlags -> TyCon -> Bool
legalFIResultTyCon dflags tc
- | isByteArrayLikeTyCon tc = False
| tc == unitTyCon = True
| otherwise = marshalableTyCon dflags tc
legalFEResultTyCon :: TyCon -> Bool
legalFEResultTyCon tc
- | isByteArrayLikeTyCon tc = False
| tc == unitTyCon = True
| otherwise = boxedMarshalableTyCon tc
legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
-- Checks validity of types going from Haskell -> external world
legalOutgoingTyCon dflags safety tc
- | playSafe safety && isByteArrayLikeTyCon tc
- = False
- | otherwise
= marshalableTyCon dflags tc
legalFFITyCon :: TyCon -> Bool
= isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon
marshalableTyCon dflags tc
- = (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
+ = (dopt Opt_UnliftedFFITypes dflags
+ && isUnLiftedTyCon tc
+ && case tyConPrimRep tc of -- Note [Marshalling VoidRep]
+ VoidRep -> False
+ other -> True)
|| boxedMarshalableTyCon tc
boxedMarshalableTyCon tc
, wordTyConKey, word8TyConKey, word16TyConKey
, word32TyConKey, word64TyConKey
, floatTyConKey, doubleTyConKey
- , addrTyConKey, ptrTyConKey, funPtrTyConKey
+ , ptrTyConKey, funPtrTyConKey
, charTyConKey
, stablePtrTyConKey
- , byteArrayTyConKey, mutableByteArrayTyConKey
, boolTyConKey
]
-
-isByteArrayLikeTyCon :: TyCon -> Bool
-isByteArrayLikeTyCon tc =
- getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
\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
projects / ghc-hetmet.git / blobdiff