--------------------------------
-- Types
TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
- TcTyVar, TcTyVarSet, TcKind,
-
- BoxyTyVar, BoxySigmaType, BoxyRhoType, BoxyThetaType, BoxyType,
+ TcCoercion, TcTyVar, TcTyVarSet, TcKind, TcCoVar,
--------------------------------
-- MetaDetails
UserTypeCtxt(..), pprUserTypeCtxt,
- TcTyVarDetails(..), BoxInfo(..), pprTcTyVarDetails,
- MetaDetails(Flexi, Indirect), SkolemInfo(..), pprSkolTvBinding, pprSkolInfo,
- isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isBoxyTyVar,
- isSigTyVar, isExistentialTyVar, isTyConableTyVar,
+ TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv,
+ MetaDetails(Flexi, Indirect), MetaInfo(..),
+ isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy,
+ isSigTyVar, isOverlappableTyVar, isTyConableTyVar,
metaTvRef,
- isFlexi, isIndirect, isRuntimeUnk, isUnk,
+ isFlexi, isIndirect, isRuntimeUnkSkol,
--------------------------------
-- Builders
tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe,
tcInstHeadTyNotSynonym, tcInstHeadTyAppAllTyVars,
tcGetTyVar_maybe, tcGetTyVar,
- tcSplitSigmaTy, tcMultiSplitSigmaTy,
+ tcSplitSigmaTy, tcDeepSplitSigmaTy_maybe,
---------------------------------
-- Predicates.
-- Again, newtypes are opaque
- tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX,
+ eqType, eqTypes, eqPred, cmpType, cmpTypes, cmpPred, eqTypeX,
eqKind,
- isSigmaTy, isOverloadedTy, isRigidTy, isBoxyTy,
+ isSigmaTy, isOverloadedTy,
isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
isIntegerTy, isBoolTy, isUnitTy, isCharTy,
isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
- isOpenSynTyConApp,
+ isSynFamilyTyConApp,
---------------------------------
-- Misc type manipulators
deNoteType,
- tyClsNamesOfType, tyClsNamesOfDFunHead,
+ orphNamesOfType, orphNamesOfDFunHead, orphNamesOfCo,
getDFunTyKey,
---------------------------------
-- Predicate types
- getClassPredTys_maybe, getClassPredTys,
- isClassPred, isTyVarClassPred, isEqPred,
- mkDictTy, tcSplitPredTy_maybe,
- isPredTy, isDictTy, isDictLikeTy,
- tcSplitDFunTy, tcSplitDFunHead, predTyUnique,
- mkClassPred, isInheritablePred, isIPPred,
- isRefineableTy, isRefineablePred,
+ mkMinimalBySCs, transSuperClasses, immSuperClasses,
+
+ -- * Tidying type related things up for printing
+ tidyType, tidyTypes,
+ tidyOpenType, tidyOpenTypes,
+ tidyTyVarBndr, tidyFreeTyVars,
+ tidyOpenTyVar, tidyOpenTyVars,
+ tidyTopType, tidyPred,
+ tidyKind,
+ tidyCo, tidyCos,
---------------------------------
-- Foreign import and export
isFFIExternalTy, -- :: Type -> Bool
isFFIDynArgumentTy, -- :: Type -> Bool
isFFIDynResultTy, -- :: Type -> Bool
+ isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool
+ isFFIPrimResultTy, -- :: DynFlags -> Type -> Bool
isFFILabelTy, -- :: Type -> Bool
isFFIDotnetTy, -- :: DynFlags -> Type -> Bool
isFFIDotnetObjTy, -- :: Type -> Bool
isFFITy, -- :: Type -> Bool
isFunPtrTy, -- :: 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
+ -- Rexported from Kind
+ Kind, typeKind,
unliftedTypeKind, liftedTypeKind, argTypeKind,
openTypeKind, mkArrowKind, mkArrowKinds,
isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind,
isSubArgTypeKind, isSubKind, splitKindFunTys, defaultKind,
kindVarRef, mkKindVar,
- Type, PredType(..), ThetaType,
+ --------------------------------
+ -- Rexported from Type
+ Type, Pred(..), PredType, ThetaType,
mkForAllTy, mkForAllTys,
mkFunTy, mkFunTys, zipFunTys,
mkTyConApp, mkAppTy, mkAppTys, applyTy, applyTys,
mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
+ getClassPredTys_maybe, getClassPredTys,
+ isClassPred, isTyVarClassPred, isEqPred,
+ mkClassPred, mkIPPred, splitPredTy_maybe,
+ mkDictTy, isPredTy, isDictTy, isDictLikeTy,
+ tcSplitDFunTy, tcSplitDFunHead,
+ isIPPred, mkEqPred,
+
-- Type substitutions
TvSubst(..), -- Representation visible to a few friends
- TvSubstEnv, emptyTvSubst, substEqSpec,
- mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
- getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, lookupTyVar,
- extendTvSubst, extendTvSubstList, isInScope, mkTvSubst, zipTyEnv,
- substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars, substTyVarBndr,
+ TvSubstEnv, emptyTvSubst,
+ mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst,
+ mkTopTvSubst, notElemTvSubst, unionTvSubst,
+ getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
+ Type.lookupTyVar, Type.extendTvSubst, Type.substTyVarBndr,
+ extendTvSubstList, isInScope, mkTvSubst, zipTyEnv,
+ Type.substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars,
isUnLiftedType, -- Source types are always lifted
isUnboxedTupleType, -- Ditto
isPrimitiveType,
- tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
- tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, tidySkolemTyVar,
- typeKind, tidyKind,
-
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
tcTyVarsOfType, tcTyVarsOfTypes, tcTyVarsOfPred, exactTyVarsOfType,
exactTyVarsOfTypes,
pprKind, pprParendKind,
pprType, pprParendType, pprTypeApp, pprTyThingCategory,
- pprPred, pprTheta, pprThetaArrow, pprClassPred
+ pprPred, pprTheta, pprThetaArrow, pprThetaArrowTy, pprClassPred
) where
#include "HsVersions.h"
-- friends:
+import Kind
import TypeRep
-import DataCon
import Class
import Var
import ForeignCall
-- others:
import DynFlags
-import Name
+import Name hiding (varName)
import NameSet
import VarEnv
-import OccName
import PrelNames
import TysWiredIn
import BasicTypes
import Outputable
import FastString
-import Data.List
+import Data.List( mapAccumL )
import Data.IORef
\end{code}
\begin{code}
type TcTyVar = TyVar -- Used only during type inference
+type TcCoVar = CoVar -- Used only during type inference; mutable
type TcType = Type -- A TcType can have mutable type variables
-- Invariant on ForAllTy in TcTypes:
-- forall a. T
-- a cannot occur inside a MutTyVar in T; that is,
-- T is "flattened" before quantifying over a
+type TcCoercion = Coercion -- A TcCoercion can contain TcTypes.
+
-- These types do not have boxy type variables in them
type TcPredType = PredType
type TcThetaType = ThetaType
type TcTauType = TcType
type TcKind = Kind
type TcTyVarSet = TyVarSet
-
--- These types may have boxy type variables in them
-type BoxyTyVar = TcTyVar
-type BoxyRhoType = TcType
-type BoxyThetaType = TcThetaType
-type BoxySigmaType = TcType
-type BoxyType = TcType
\end{code}
The alternative (currently implemented) is to have a special kind of skolem
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
+as rigid 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}
-- A TyVarDetails is inside a TyVar
data TcTyVarDetails
- = SkolemTv SkolemInfo -- A skolem constant
+ = SkolemTv -- A skolem
+ Bool -- True <=> this skolem type variable can be overlapped
+ -- when looking up instances
+ -- See Note [Binding when looking up instances] in InstEnv
+
+ | RuntimeUnk -- Stands for an as-yet-unknown type in the GHCi
+ -- interactive context
+
+ | FlatSkol TcType
+ -- The "skolem" obtained by flattening during
+ -- constraint simplification
+
+ -- In comments we will use the notation alpha[flat = ty]
+ -- to represent a flattening skolem variable alpha
+ -- identified with type ty.
+
+ | MetaTv MetaInfo (IORef MetaDetails)
+
+vanillaSkolemTv, superSkolemTv :: TcTyVarDetails
+-- See Note [Binding when looking up instances] in InstEnv
+vanillaSkolemTv = SkolemTv False -- Might be instantiated
+superSkolemTv = SkolemTv True -- Treat this as a completely distinct type
- | MetaTv BoxInfo (IORef MetaDetails)
-
-data BoxInfo
- = BoxTv -- The contents is a (non-boxy) sigma-type
- -- That is, this MetaTv is a "box"
+data MetaDetails
+ = Flexi -- Flexi type variables unify to become Indirects
+ | Indirect TcType
- | TauTv -- The contents is a (non-boxy) tau-type
- -- That is, this MetaTv is an ordinary unification variable
+instance Outputable MetaDetails where
+ ppr Flexi = ptext (sLit "Flexi")
+ ppr (Indirect ty) = ptext (sLit "Indirect") <+> ppr ty
- | SigTv SkolemInfo -- A variant of TauTv, except that it should not be
- -- unified with a type, only with a type variable
- -- SigTvs are only distinguished to improve error messages
- -- see Note [Signature skolems]
- -- The MetaDetails, if filled in, will
- -- always be another SigTv or a SkolemTv
+data MetaInfo
+ = TauTv -- This MetaTv is an ordinary unification variable
+ -- A TauTv is always filled in with a tau-type, which
+ -- never contains any ForAlls
--- INVARIANTS:
--- A TauTv is always filled in with a tau-type, which
--- never contains any BoxTvs, nor any ForAlls
---
--- However, a BoxTv can contain a type that contains further BoxTvs
--- Notably, when typechecking an explicit list, say [e1,e2], with
--- expected type being a box b1, we fill in b1 with (List b2), where
--- b2 is another (currently empty) box.
+ | SigTv -- A variant of TauTv, except that it should not be
+ -- unified with a type, only with a type variable
+ -- SigTvs are only distinguished to improve error messages
+ -- see Note [Signature skolems]
+ -- The MetaDetails, if filled in, will
+ -- always be another SigTv or a SkolemTv
-data MetaDetails
- = 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
-
--- 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
- -- Location of the binding site is on the TyVar
-
- -- The rest are for non-scoped skolems
- | ClsSkol Class -- Bound at a class 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
- -- 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 -- 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)
-
- | RuntimeUnkSkol -- a type variable used to represent an unknown
- -- runtime type (used in the GHCi debugger)
-
- | UnkSkol -- Unhelpful info (until I improve it)
+ | TcsTv -- A MetaTv allocated by the constraint solver
+ -- Its particular property is that it is always "touchable"
+ -- Nevertheless, the constraint solver has to try to guess
+ -- what type to instantiate it to
-------------------------------------
--- UserTypeCtxt describes the places where a
--- programmer-written type signature can occur
--- Like SkolemInfo, no location info
-data UserTypeCtxt
+-- UserTypeCtxt describes the origin of the polymorphic type
+-- in the places where we need to an expression has that type
+
+data UserTypeCtxt
= FunSigCtxt Name -- Function type signature
-- Also used for types in SPECIALISE pragmas
| ExprSigCtxt -- Expression type signature
| ForSigCtxt Name -- Foreign inport or export signature
| DefaultDeclCtxt -- Types in a default declaration
| SpecInstCtxt -- SPECIALISE instance pragma
+ | ThBrackCtxt -- Template Haskell type brackets [t| ... |]
+
+ | GenSigCtxt -- Higher-rank or impredicative situations
+ -- e.g. (f e) where f has a higher-rank type
+ -- We might want to elaborate this
-- Notes re TySynCtxt
-- We allow type synonyms that aren't types; e.g. type List = []
\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 (RuntimeUnk {}) = ptext (sLit "rt")
+pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk")
+pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau")
+pprTcTyVarDetails (MetaTv TcsTv _) = ptext (sLit "tcs")
+pprTcTyVarDetails (MetaTv SigTv _) = ptext (sLit "sig")
pprUserTypeCtxt :: UserTypeCtxt -> SDoc
pprUserTypeCtxt (FunSigCtxt n) = ptext (sLit "the type signature for") <+> quotes (ppr n)
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 ThBrackCtxt = ptext (sLit "a Template Haskell quotation [t|...|]")
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")
+pprUserTypeCtxt GenSigCtxt = ptext (sLit "a type expected by the context")
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{TidyType}
+%* *
+%************************************************************************
+
+\begin{code}
+-- | This tidies up a type for printing in an error message, or in
+-- an interface file.
+--
+-- It doesn't change the uniques at all, just the print names.
+tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
+tidyTyVarBndr (tidy_env, subst) tyvar
+ = case tidyOccName tidy_env occ1 of
+ (tidy', occ') -> ((tidy', subst'), tyvar')
+ where
+ subst' = extendVarEnv subst tyvar tyvar'
+ tyvar' = setTyVarName tyvar name'
+ name' = tidyNameOcc name occ'
+ where
+ name = tyVarName tyvar
+ occ = getOccName name
+ -- System Names are for unification variables;
+ -- when we tidy them we give them a trailing "0" (or 1 etc)
+ -- so that they don't take precedence for the un-modified name
+ occ1 | isSystemName name = mkTyVarOcc (occNameString occ ++ "0")
+ | otherwise = occ
---------------------------------
-tidySkolemTyVar :: TidyEnv -> TcTyVar -> (TidyEnv, TcTyVar)
--- Tidy the type inside a GenSkol, preparatory to printing it
-tidySkolemTyVar env tv
- = ASSERT( isTcTyVar tv && (isSkolemTyVar tv || isSigTyVar tv ) )
- (env1, mkTcTyVar (tyVarName tv) (tyVarKind tv) info1)
+---------------
+tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
+-- ^ Add the free 'TyVar's to the env in tidy form,
+-- so that we can tidy the type they are free in
+tidyFreeTyVars env tyvars = fst (tidyOpenTyVars env (varSetElems tyvars))
+
+---------------
+tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
+tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars
+
+---------------
+tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
+-- ^ Treat a new 'TyVar' as a binder, and give it a fresh tidy name
+-- using the environment if one has not already been allocated. See
+-- also 'tidyTyVarBndr'
+tidyOpenTyVar env@(_, subst) tyvar
+ = case lookupVarEnv subst tyvar of
+ Just tyvar' -> (env, tyvar') -- Already substituted
+ Nothing -> tidyTyVarBndr env tyvar -- Treat it as a binder
+
+---------------
+tidyType :: TidyEnv -> Type -> Type
+tidyType env@(_, subst) ty
+ = go ty
where
- (env1, info1) = case tcTyVarDetails tv of
- 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
- 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
- = ASSERT ( isTcTyVar tv )
- quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv)
+ go (TyVarTy tv) = case lookupVarEnv subst tv of
+ Nothing -> expand tv
+ Just tv' -> expand tv'
+ go (TyConApp tycon tys) = let args = map go tys
+ in args `seqList` TyConApp tycon args
+ go (PredTy sty) = PredTy (tidyPred env sty)
+ go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg)
+ go (FunTy fun arg) = (FunTy $! (go fun)) $! (go arg)
+ go (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty)
+ where
+ (envp, tvp) = tidyTyVarBndr env tv
+
+ -- Expand FlatSkols, the skolems introduced by flattening process
+ -- We don't want to show them in type error messages
+ expand tv | isTcTyVar tv
+ , FlatSkol ty <- tcTyVarDetails tv
+ = go ty
+ | otherwise
+ = TyVarTy tv
+
+---------------
+tidyTypes :: TidyEnv -> [Type] -> [Type]
+tidyTypes env tys = map (tidyType env) tys
+
+---------------
+tidyPred :: TidyEnv -> PredType -> PredType
+tidyPred env (IParam n ty) = IParam n (tidyType env ty)
+tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
+tidyPred env (EqPred ty1 ty2) = EqPred (tidyType env ty1) (tidyType env ty2)
+
+---------------
+-- | Grabs the free type variables, tidies them
+-- and then uses 'tidyType' to work over the type itself
+tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
+tidyOpenType env ty
+ = (env', tidyType env' ty)
where
- 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 = 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) = 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"
+ env' = tidyFreeTyVars env (tyVarsOfType ty)
-instance Outputable MetaDetails where
- ppr Flexi = ptext (sLit "Flexi")
- ppr (Indirect ty) = ptext (sLit "Indirect") <+> ppr ty
+---------------
+tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
+tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
+
+---------------
+-- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment)
+tidyTopType :: Type -> Type
+tidyTopType ty = tidyType emptyTidyEnv ty
+
+---------------
+tidyKind :: TidyEnv -> Kind -> (TidyEnv, Kind)
+tidyKind env k = tidyOpenType env k
\end{code}
+%************************************************************************
+%* *
+ Tidying coercions
+%* *
+%************************************************************************
+
+\begin{code}
+
+tidyCo :: TidyEnv -> Coercion -> Coercion
+tidyCo env@(_, subst) co
+ = go co
+ where
+ go (Refl ty) = Refl (tidyType env ty)
+ go (TyConAppCo tc cos) = let args = map go cos
+ in args `seqList` TyConAppCo tc args
+ go (AppCo co1 co2) = (AppCo $! go co1) $! go co2
+ go (ForAllCo tv co) = ForAllCo tvp $! (tidyCo envp co)
+ where
+ (envp, tvp) = tidyTyVarBndr env tv
+ go (CoVarCo cv) = case lookupVarEnv subst cv of
+ Nothing -> CoVarCo cv
+ Just cv' -> CoVarCo cv'
+ go (AxiomInstCo con cos) = let args = tidyCos env cos
+ in args `seqList` AxiomInstCo con args
+ go (UnsafeCo ty1 ty2) = (UnsafeCo $! tidyType env ty1) $! tidyType env ty2
+ go (SymCo co) = SymCo $! go co
+ go (TransCo co1 co2) = (TransCo $! go co1) $! go co2
+ go (NthCo d co) = NthCo d $! go co
+ go (InstCo co ty) = (InstCo $! go co) $! tidyType env ty
+
+tidyCos :: TidyEnv -> [Coercion] -> [Coercion]
+tidyCos env = map (tidyCo env)
+
+\end{code}
%************************************************************************
%* *
| isTcTyVar tv = isSkolemTyVar tv
| otherwise = True
-isTyConableTyVar, isSkolemTyVar, isExistentialTyVar,
- isBoxyTyVar, isMetaTyVar :: TcTyVar -> Bool
+isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar,
+ isMetaTyVar :: TcTyVar -> Bool
isTyConableTyVar tv
-- True of a meta-type variable that can be filled in
-- not a SigTv
= ASSERT( isTcTyVar tv)
case tcTyVarDetails tv of
- MetaTv BoxTv _ -> True
- MetaTv TauTv _ -> True
- MetaTv (SigTv {}) _ -> False
- SkolemTv {} -> False
+ MetaTv SigTv _ -> False
+ _ -> True
isSkolemTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
- SkolemTv _ -> True
- MetaTv _ _ -> False
+ SkolemTv {} -> True
+ FlatSkol {} -> True
+ RuntimeUnk {} -> True
+ MetaTv {} -> False
-isExistentialTyVar tv -- Existential type variable, bound by a pattern
+isOverlappableTyVar tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
- SkolemTv (PatSkol {}) -> True
- _ -> False
+ SkolemTv overlappable -> overlappable
+ _ -> False
isMetaTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
MetaTv _ _ -> True
_ -> False
-isBoxyTyVar tv
- = ASSERT( isTcTyVar tv )
- case tcTyVarDetails tv of
- MetaTv BoxTv _ -> True
- _ -> False
+isMetaTyVarTy :: TcType -> Bool
+isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv
+isMetaTyVarTy _ = False
isSigTyVar :: Var -> Bool
isSigTyVar tv
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
- MetaTv (SigTv _) _ -> True
- _ -> False
+ MetaTv SigTv _ -> True
+ _ -> False
metaTvRef :: TyVar -> IORef MetaDetails
metaTvRef tv
isIndirect (Indirect _) = True
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
+isRuntimeUnkSkol :: TyVar -> Bool
+-- Called only in TcErrors; see Note [Runtime skolems] there
+isRuntimeUnkSkol x
+ | isTcTyVar x, RuntimeUnk <- tcTyVarDetails x = True
+ | otherwise = False
\end{code}
\begin{code}
isTauTy :: Type -> Bool
isTauTy ty | Just ty' <- tcView ty = isTauTy ty'
-isTauTy (TyVarTy tv) = ASSERT( not (isTcTyVar tv && isBoxyTyVar tv) )
- True
+isTauTy (TyVarTy _) = True
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 _) = True -- Don't look through source types
isTauTy _ = False
-
isTauTyCon :: TyCon -> Bool
-- Returns False for type synonyms whose expansion is a polytype
isTauTyCon tc
| otherwise = True
---------------
-isBoxyTy :: TcType -> Bool
-isBoxyTy ty = any isBoxyTyVar (varSetElems (tcTyVarsOfType ty))
-
-isRigidTy :: TcType -> Bool
--- A type is rigid if it has no meta type variables in it
-isRigidTy ty = all isImmutableTyVar (varSetElems (tcTyVarsOfType ty))
-
-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 = (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
+getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
-- construct a dictionary function name
getDFunTyKey ty | Just ty' <- tcView ty = getDFunTyKey ty'
getDFunTyKey (TyVarTy tv) = getOccName tv
These tcSplit functions are like their non-Tc analogues, but
a) they do not look through newtypes
b) they do not look through PredTys
- c) [future] they ignore usage-type annotations
However, they are non-monadic and do not follow through mutable type
variables. It's up to you to make sure this doesn't matter.
tcSplitForAllTys ty = split ty ty []
where
split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
- split _ (ForAllTy tv ty) tvs
- | not (isCoVar tv) = split ty ty (tv:tvs)
- split orig_ty _ tvs = (reverse tvs, orig_ty)
+ split _ (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
+ split orig_ty _ tvs = (reverse tvs, orig_ty)
tcIsForAllTy :: Type -> Bool
tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty'
-tcIsForAllTy (ForAllTy tv _) = not (isCoVar tv)
-tcIsForAllTy _ = False
+tcIsForAllTy (ForAllTy {}) = True
+tcIsForAllTy _ = False
tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type)
-- Split off the first predicate argument from a type
tcSplitPredFunTy_maybe ty | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty'
-tcSplitPredFunTy_maybe (ForAllTy tv ty)
- | isCoVar tv = Just (coVarPred tv, ty)
tcSplitPredFunTy_maybe (FunTy arg res)
- | Just p <- tcSplitPredTy_maybe arg = Just (p, res)
+ | Just p <- splitPredTy_maybe arg = Just (p, res)
tcSplitPredFunTy_maybe _
= Nothing
(theta, tau) -> (tvs, theta, tau)
-----------------------
-tcMultiSplitSigmaTy
- :: TcSigmaType
- -> ( [([TyVar], ThetaType)], -- forall as.C => forall bs.D
- TcSigmaType) -- The rest of the type
-
--- We need a loop here because we are now prepared to entertain
--- types like
--- f:: forall a. Eq a => forall b. Baz b => tau
--- We want to instantiate this to
--- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
-
-tcMultiSplitSigmaTy sigma
- = case (tcSplitSigmaTy sigma) of
- ([], [], _) -> ([], sigma)
- (tvs, theta, ty) -> case tcMultiSplitSigmaTy ty of
- (pairs, rest) -> ((tvs,theta):pairs, rest)
+tcDeepSplitSigmaTy_maybe
+ :: TcSigmaType -> Maybe ([TcType], [TyVar], ThetaType, TcSigmaType)
+-- Looks for a *non-trivial* quantified type, under zero or more function arrows
+-- By "non-trivial" we mean either tyvars or constraints are non-empty
+
+tcDeepSplitSigmaTy_maybe ty
+ | Just (arg_ty, res_ty) <- tcSplitFunTy_maybe ty
+ , Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty
+ = Just (arg_ty:arg_tys, tvs, theta, rho)
+
+ | (tvs, theta, rho) <- tcSplitSigmaTy ty
+ , not (null tvs && null theta)
+ = Just ([], tvs, theta, rho)
+
+ | otherwise = Nothing
-----------------------
tcTyConAppTyCon :: Type -> TyCon
tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty)
-----------------------
-tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
+tcSplitDFunTy :: Type -> ([TyVar], Int, Class, [Type])
-- Split the type of a dictionary function
+-- We don't use tcSplitSigmaTy, because a DFun may (with NDP)
+-- have non-Pred arguments, such as
+-- df :: forall m. (forall b. Eq b => Eq (m b)) -> C m
tcSplitDFunTy ty
- = case tcSplitSigmaTy ty of { (tvs, theta, tau) ->
- case tcSplitDFunHead tau of { (clas, tys) ->
- (tvs, theta, clas, tys) }}
+ = case tcSplitForAllTys ty of { (tvs, rho) ->
+ case split_dfun_args 0 rho of { (n_theta, tau) ->
+ case tcSplitDFunHead tau of { (clas, tys) ->
+ (tvs, n_theta, clas, tys) }}}
+ where
+ -- Count the context of the dfun. This can be a mix of
+ -- coercion and class constraints; or (in the general NDP case)
+ -- some other function argument
+ split_dfun_args n ty | Just ty' <- tcView ty = split_dfun_args n ty'
+ split_dfun_args n (FunTy _ ty) = split_dfun_args (n+1) ty
+ split_dfun_args n ty = (n, ty)
tcSplitDFunHead :: Type -> (Class, [Type])
tcSplitDFunHead tau
- = case tcSplitPredTy_maybe tau of
+ = case splitPredTy_maybe tau of
Just (ClassP clas tys) -> (clas, tys)
- _ -> panic "tcSplitDFunHead"
+ _ -> pprPanic "tcSplitDFunHead" (ppr tau)
tcInstHeadTyNotSynonym :: Type -> Bool
-- Used in Haskell-98 mode, for the argument types of an instance head
-- 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
+ | Just ty' <- tcView ty -- Look through synonyms
+ = tcInstHeadTyAppAllTyVars ty'
+ | otherwise
= case ty of
TyConApp _ tys -> ok tys
FunTy arg res -> ok [arg, res]
%* *
%************************************************************************
-\begin{code}
-tcSplitPredTy_maybe :: Type -> Maybe PredType
- -- Returns Just for predicates only
-tcSplitPredTy_maybe ty | Just ty' <- tcView ty = tcSplitPredTy_maybe ty'
-tcSplitPredTy_maybe (PredTy p) = Just p
-tcSplitPredTy_maybe _ = Nothing
-
-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 _ _) = True
-isClassPred _ = 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 :: PredType -> (Class, [Type])
-getClassPredTys (ClassP clas tys) = (clas, tys)
-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 _ = False
-
-isDictLikeTy :: Type -> Bool
--- Note [Dictionary-like types]
-isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty'
-isDictLikeTy (PredTy p) = isClassPred p
-isDictLikeTy (TyConApp tc tys)
- | isTupleTyCon tc = all isDictLikeTy tys
-isDictLikeTy _ = False
-\end{code}
-
-Note [Dictionary-like types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Being "dictionary-like" means either a dictionary type or a tuple thereof.
-In GHC 6.10 we build implication constraints which construct such tuples,
-and if we land up with a binding
- t :: (C [a], Eq [a])
- t = blah
-then we want to treat t as cheap under "-fdicts-cheap" for example.
-(Implication constraints are normally inlined, but sadly not if the
-occurrence is itself inside an INLINE function! Until we revise the
-handling of implication constraints, that is.) This turned out to
-be important in getting good arities in DPH code. Example:
-
- class C a
- class D a where { foo :: a -> a }
- instance C a => D (Maybe a) where { foo x = x }
-
- bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b)
- {-# INLINE bar #-}
- bar x y = (foo (Just x), foo (Just y))
-
-Then 'bar' should jolly well have arity 4 (two dicts, two args), but
-we ended up with something like
- bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ...
- in \x,y. <blah>)
-
-This is all a bit ad-hoc; eg it relies on knowing that implication
-constraints build tuples.
-
---------------------- Implicit parameters ---------------------------------
-
-\begin{code}
-isIPPred :: PredType -> Bool
-isIPPred (IParam _ _) = True
-isIPPred _ = False
-
-isInheritablePred :: PredType -> Bool
--- Can be inherited by a context. For example, consider
--- f x = let g y = (?v, y+x)
--- in (g 3 with ?v = 8,
--- g 4 with ?v = 9)
--- The point is that g's type must be quantifed over ?v:
--- g :: (?v :: a) => a -> a
--- 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 (EqPred _ _) = True
-isInheritablePred _ = False
-\end{code}
+Superclasses
---------------------- Equality predicates ---------------------------------
\begin{code}
-substEqSpec :: TvSubst -> [(TyVar,Type)] -> [(TcType,TcType)]
-substEqSpec subst eq_spec = [ (substTyVar subst tv, substTy subst ty)
- | (tv,ty) <- eq_spec]
+mkMinimalBySCs :: [PredType] -> [PredType]
+-- Remove predicates that can be deduced from others by superclasses
+mkMinimalBySCs ptys = [ ploc | ploc <- ptys
+ , ploc `not_in_preds` rec_scs ]
+ where
+ rec_scs = concatMap trans_super_classes ptys
+ not_in_preds p ps = null (filter (eqPred p) ps)
+ trans_super_classes (ClassP cls tys) = transSuperClasses cls tys
+ trans_super_classes _other_pty = []
+
+transSuperClasses :: Class -> [Type] -> [PredType]
+transSuperClasses cls tys
+ = foldl (\pts p -> trans_sc p ++ pts) [] $
+ immSuperClasses cls tys
+ where trans_sc :: PredType -> [PredType]
+ trans_sc this_pty@(ClassP cls tys)
+ = foldl (\pts p -> trans_sc p ++ pts) [this_pty] $
+ immSuperClasses cls tys
+ trans_sc pty = [pty]
+
+immSuperClasses :: Class -> [Type] -> [PredType]
+immSuperClasses cls tys
+ = substTheta (zipTopTvSubst tyvars tys) sc_theta
+ where (tyvars,sc_theta,_,_) = classBigSig cls
\end{code}
isOverloadedTy :: Type -> Bool
-- Yes for a type of a function that might require evidence-passing
--- Used only by bindInstsOfLocalFuns/Pats
--- NB: be sure to check for type with an equality predicate; hence isCoVar
+-- Used only by bindLocalMethods
isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty'
-isOverloadedTy (ForAllTy tv ty) = isCoVar tv || 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 _) = True
-isPredTy _ = False
+isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty
+isOverloadedTy (FunTy a _) = isPredTy a
+isOverloadedTy _ = 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 tys) = isOpenSynTyCon tc &&
+isSynFamilyTyConApp :: TcTauType -> Bool
+isSynFamilyTyConApp (TyConApp tc tys) = isSynFamilyTyCon tc &&
length tys == tyConArity tc
-isOpenSynTyConApp _other = False
+isSynFamilyTyConApp _other = False
\end{code}
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)
- `unionVarSet` tcTyVarsOfTyVar tyvar
+tcTyVarsOfType (ForAllTy tyvar ty) = tcTyVarsOfType ty `delVarSet` 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 (EqPred ty1 ty2) = tcTyVarsOfType ty1 `unionVarSet` tcTyVarsOfType ty2
\end{code}
-Note [Silly type synonym]
-~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
- type T a = Int
-What are the free tyvars of (T x)? Empty, of course!
-Here's the example that Ralf Laemmel showed me:
- foo :: (forall a. C u a -> C u a) -> u
- mappend :: Monoid u => u -> u -> u
-
- bar :: Monoid u => u
- bar = foo (\t -> t `mappend` t)
-We have to generalise at the arg to f, and we don't
-want to capture the constraint (Monad (C u a)) because
-it appears to mention a. Pretty silly, but it was useful to him.
-
-exactTyVarsOfType is used by the type checker to figure out exactly
-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)
--- but *expand* type synonyms. See Note [Silly type synonym] above.
-exactTyVarsOfType ty
- = go ty
- where
- go ty | Just ty' <- tcView ty = go ty' -- This is the key line
- go (TyVarTy tv) = unitVarSet tv
- 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
- go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar
- `unionVarSet` go_tv tyvar
-
- 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
-\end{code}
-
Find the free tycons and classes of a type. This is used in the front
end of the compiler.
\begin{code}
-tyClsNamesOfType :: Type -> NameSet
-tyClsNamesOfType (TyVarTy _) = emptyNameSet
-tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
-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 _ ty) = tyClsNamesOfType ty
-
-tyClsNamesOfTypes :: [Type] -> NameSet
-tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys
-
-tyClsNamesOfDFunHead :: Type -> NameSet
+orphNamesOfType :: Type -> NameSet
+orphNamesOfType ty | Just ty' <- tcView ty = orphNamesOfType ty'
+ -- Look through type synonyms (Trac #4912)
+orphNamesOfType (TyVarTy _) = emptyNameSet
+orphNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon)
+ `unionNameSets` orphNamesOfTypes tys
+orphNamesOfType (PredTy (IParam _ ty)) = orphNamesOfType ty
+orphNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl)
+ `unionNameSets` orphNamesOfTypes tys
+orphNamesOfType (PredTy (EqPred ty1 ty2)) = orphNamesOfType ty1
+ `unionNameSets` orphNamesOfType ty2
+orphNamesOfType (FunTy arg res) = orphNamesOfType arg `unionNameSets` orphNamesOfType res
+orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSets` orphNamesOfType arg
+orphNamesOfType (ForAllTy _ ty) = orphNamesOfType ty
+
+orphNamesOfTypes :: [Type] -> NameSet
+orphNamesOfTypes tys = foldr (unionNameSets . orphNamesOfType) emptyNameSet tys
+
+orphNamesOfDFunHead :: Type -> NameSet
-- Find the free type constructors and classes
-- of the head of the dfun instance type
-- The 'dfun_head_type' is because of
-- instance Foo a => Baz T where ...
-- The decl is an orphan if Baz and T are both not locally defined,
-- even if Foo *is* locally defined
-tyClsNamesOfDFunHead dfun_ty
+orphNamesOfDFunHead dfun_ty
= case tcSplitSigmaTy dfun_ty of
- (_, _, head_ty) -> tyClsNamesOfType head_ty
+ (_, _, head_ty) -> orphNamesOfType head_ty
+
+orphNamesOfCo :: Coercion -> NameSet
+orphNamesOfCo (Refl ty) = orphNamesOfType ty
+orphNamesOfCo (TyConAppCo tc cos) = unitNameSet (getName tc) `unionNameSets` orphNamesOfCos cos
+orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2
+orphNamesOfCo (ForAllCo _ co) = orphNamesOfCo co
+orphNamesOfCo (CoVarCo _) = emptyNameSet
+orphNamesOfCo (AxiomInstCo con cos) = orphNamesOfCoCon con `unionNameSets` orphNamesOfCos cos
+orphNamesOfCo (UnsafeCo ty1 ty2) = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2
+orphNamesOfCo (SymCo co) = orphNamesOfCo co
+orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2
+orphNamesOfCo (NthCo _ co) = orphNamesOfCo co
+orphNamesOfCo (InstCo co ty) = orphNamesOfCo co `unionNameSets` orphNamesOfType ty
+
+orphNamesOfCos :: [Coercion] -> NameSet
+orphNamesOfCos = foldr (unionNameSets . orphNamesOfCo) emptyNameSet
+
+orphNamesOfCoCon :: CoAxiom -> NameSet
+orphNamesOfCoCon (CoAxiom { co_ax_lhs = ty1, co_ax_rhs = ty2 })
+ = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2
\end{code}
being the )
\begin{code}
-tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, CoercionI)
+tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, Coercion)
-- (isIOType t) returns Just (IO,t',co)
-- if co : t ~ IO t'
-- returns Nothing otherwise
Just (io_tycon, [io_res_ty])
| io_tycon `hasKey` ioTyConKey
- -> Just (io_tycon, io_res_ty, IdCo)
+ -> Just (io_tycon, io_res_ty, mkReflCo ty)
Just (tc, tys)
| not (isRecursiveTyCon tc)
-- Newtypes that require a coercion are ok
-> case tcSplitIOType_maybe ty of
Nothing -> Nothing
- Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCoI` co2)
+ Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCo` co2)
_ -> Nothing
-- or a newtype of either.
isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
+isFFIPrimArgumentTy :: DynFlags -> Type -> Bool
+-- Checks for valid argument type for a 'foreign import prim'
+-- Currently they must all be simple unlifted types.
+isFFIPrimArgumentTy dflags ty
+ = checkRepTyCon (legalFIPrimArgTyCon dflags) ty
+
+isFFIPrimResultTy :: DynFlags -> Type -> Bool
+-- Checks for valid result type for a 'foreign import prim'
+-- Currently it must be an unlifted type, including unboxed tuples.
+isFFIPrimResultTy dflags ty
+ = checkRepTyCon (legalFIPrimResultTyCon dflags) ty
+
isFFIDotnetTy :: DynFlags -> Type -> Bool
isFFIDotnetTy dflags ty
= checkRepTyCon (\ tc -> (legalFIResultTyCon dflags tc ||
isFunPtrTy :: Type -> Bool
isFunPtrTy = checkRepTyConKey [funPtrTyConKey]
-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 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 = panic "toDNType" -- Is this right?
- where
- dn_assoc :: [ (Unique, DNType) ]
- dn_assoc = [ (unitTyConKey, DNUnit)
- , (intTyConKey, DNInt)
- , (int8TyConKey, DNInt8)
- , (int16TyConKey, DNInt16)
- , (int32TyConKey, DNInt32)
- , (int64TyConKey, DNInt64)
- , (wordTyConKey, DNInt)
- , (word8TyConKey, DNWord8)
- , (word16TyConKey, DNWord16)
- , (word32TyConKey, DNWord32)
- , (word64TyConKey, DNWord64)
- , (floatTyConKey, DNFloat)
- , (doubleTyConKey, DNDouble)
- , (ptrTyConKey, DNPtr)
- , (funPtrTyConKey, DNPtr)
- , (charTyConKey, DNChar)
- , (boolTyConKey, DNBool)
- ]
-
checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
-- Look through newtypes, but *not* foralls
-- Should work even for recursive newtypes
marshalableTyCon :: DynFlags -> TyCon -> Bool
marshalableTyCon dflags tc
- = (dopt Opt_UnliftedFFITypes dflags
+ = (xopt Opt_UnliftedFFITypes dflags
&& isUnLiftedTyCon tc
&& not (isUnboxedTupleTyCon tc)
&& case tyConPrimRep tc of -- Note [Marshalling VoidRep]
, stablePtrTyConKey
, boolTyConKey
]
+
+legalFIPrimArgTyCon :: DynFlags -> TyCon -> Bool
+-- Check args of 'foreign import prim', only allow simple unlifted types.
+-- Strictly speaking it is unnecessary to ban unboxed tuples here since
+-- currently they're of the wrong kind to use in function args anyway.
+legalFIPrimArgTyCon dflags tc
+ = xopt Opt_UnliftedFFITypes dflags
+ && isUnLiftedTyCon tc
+ && not (isUnboxedTupleTyCon tc)
+
+legalFIPrimResultTyCon :: DynFlags -> TyCon -> Bool
+-- Check result type of 'foreign import prim'. Allow simple unlifted
+-- types and also unboxed tuple result types '... -> (# , , #)'
+legalFIPrimResultTyCon dflags tc
+ = xopt Opt_UnliftedFFITypes dflags
+ && isUnLiftedTyCon tc
+ && (isUnboxedTupleTyCon tc
+ || case tyConPrimRep tc of -- Note [Marshalling VoidRep]
+ VoidRep -> False
+ _ -> True)
\end{code}
Note [Marshalling VoidRep]
projects / ghc-hetmet.git / blobdiff