-%
+
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcType]{Types used in the typechecker}
TcTyVar, TcTyVarSet, TcKind,
--------------------------------
- -- TyVarDetails
- TyVarDetails(..), isUserTyVar, isSkolemTyVar,
- tyVarBindingInfo,
+ -- MetaDetails
+ Expected(..), TcRef, TcTyVarDetails(..),
+ MetaDetails(Flexi, Indirect), SkolemInfo(..), pprTcTyVar, pprSkolInfo,
+ isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isExistentialTyVar, metaTvRef,
+ isFlexi, isIndirect,
--------------------------------
-- Builders
- mkPhiTy, mkSigmaTy,
+ mkPhiTy, mkSigmaTy, hoistForAllTys,
--------------------------------
-- Splitters
tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy,
tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitSigmaTy,
- tcSplitMethodTy, tcGetTyVar_maybe, tcGetTyVar,
+ tcGetTyVar_maybe, tcGetTyVar,
---------------------------------
-- Predicates.
-- Again, newtypes are opaque
- tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred,
+ tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX,
isSigmaTy, isOverloadedTy,
isDoubleTy, isFloatTy, isIntTy,
isIntegerTy, isAddrTy, isBoolTy, isUnitTy,
isTauTy, tcIsTyVarTy, tcIsForAllTy,
- allDistinctTyVars,
---------------------------------
-- Misc type manipulators
getClassPredTys_maybe, getClassPredTys,
isClassPred, isTyVarClassPred,
mkDictTy, tcSplitPredTy_maybe,
- isPredTy, isDictTy, tcSplitDFunTy, predTyUnique,
+ isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique,
mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName,
---------------------------------
toDNType, -- :: Type -> DNType
- ---------------------------------
- -- Unifier and matcher
- unifyTysX, unifyTyListsX, unifyExtendTysX,
- matchTy, matchTys, match,
-
--------------------------------
-- Rexported from Type
Kind, -- Stuff to do with kinds is insensitive to pre/post Tc
mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
+ -- Type substitutions
+ TvSubst(..), -- Representation visible to a few friends
+ TvSubstEnv, emptyTvSubst,
+ mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst,
+ getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
+ extendTvSubst, extendTvSubstList, isInScope,
+ substTy, substTys, substTyWith, substTheta, substTyVar, substTyVarBndr,
+
isUnLiftedType, -- Source types are always lifted
isUnboxedTupleType, -- Ditto
isPrimitiveType,
tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
- tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars,
+ tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, tidySkolemTyVar,
typeKind,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
pprKind, pprParendKind,
- pprType, pprParendType,
+ pprType, pprParendType, pprTyThingCategory,
pprPred, pprTheta, pprThetaArrow, pprClassPred
) where
import Type ( -- Re-exports
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
- tyVarsOfTheta, Kind, Type, PredType(..),
+ tyVarsOfTheta, Kind, PredType(..),
ThetaType, unliftedTypeKind,
liftedTypeKind, openTypeKind, mkArrowKind,
isLiftedTypeKind, isUnliftedTypeKind,
- isOpenTypeKind,
mkArrowKinds, mkForAllTy, mkForAllTys,
defaultKind, isArgTypeKind, isOpenTypeKind,
mkFunTy, mkFunTys, zipFunTys,
tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
tidyTyVarBndr, tidyOpenTyVar,
tidyOpenTyVars,
- isSubKind,
+ isSubKind, deShadowTy,
+
+ tcEqType, tcEqTypes, tcCmpType, tcCmpTypes,
+ tcEqPred, tcCmpPred, tcEqTypeX,
+
+ TvSubst(..),
+ TvSubstEnv, emptyTvSubst,
+ mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst,
+ getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
+ extendTvSubst, extendTvSubstList, isInScope,
+ substTy, substTys, substTyWith, substTheta, substTyVar, substTyVarBndr,
+
typeKind, repType,
pprKind, pprParendKind,
- pprType, pprParendType,
+ pprType, pprParendType, pprTyThingCategory,
pprPred, pprTheta, pprThetaArrow, pprClassPred
)
import TyCon ( TyCon, isUnLiftedTyCon, tyConUnique )
+import DataCon ( DataCon )
import Class ( Class )
-import Var ( TyVar, tyVarKind, tcTyVarDetails )
+import Var ( TyVar, Id, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails )
import ForeignCall ( Safety, playSafe, DNType(..) )
-import VarEnv
import VarSet
-- others:
import CmdLineOpts ( DynFlags, DynFlag( Opt_GlasgowExts ), dopt )
import Name ( Name, NamedThing(..), mkInternalName, getSrcLoc )
import NameSet
+import VarEnv ( TidyEnv )
import OccName ( OccName, mkDictOcc )
import PrelNames -- Lots (e.g. in isFFIArgumentTy)
import TysWiredIn ( unitTyCon, charTyCon, listTyCon )
import BasicTypes ( IPName(..), ipNameName )
-import Unique ( Unique, Uniquable(..) )
-import SrcLoc ( SrcLoc )
-import Util ( cmpList, thenCmp, equalLength, snocView )
+import SrcLoc ( SrcLoc, SrcSpan )
+import Util ( snocView )
import Maybes ( maybeToBool, expectJust )
import Outputable
+import DATA_IOREF
\end{code}
type TcSigmaType = TcType
type TcRhoType = TcType
type TcTauType = TcType
-
type TcKind = Kind
+type TcTyVarSet = TyVarSet
+
+type TcRef a = IORef a
+data Expected ty = Infer (TcRef ty) -- The hole to fill in for type inference
+ | Check ty -- The type to check during type checking
\end{code}
It's knot-tied back to Var.lhs. There is no reason in principle
why Var.lhs shouldn't actually have the definition, but it "belongs" here.
+Note [Signature skolems]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+
+ x :: [a]
+ y :: b
+ (x,y,z) = ([y,z], z, head x)
+
+Here, x and y have type sigs, which go into the environment. We used to
+instantiate their types with skolem constants, and push those types into
+the RHS, so we'd typecheck the RHS with type
+ ( [a*], b*, c )
+where a*, b* are skolem constants, and c is an ordinary meta type varible.
+
+The trouble is that the occurrences of z in the RHS force a* and b* to
+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 woudl 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.
+
+
\begin{code}
type TcTyVar = TyVar -- Used only during type inference
-data TyVarDetails
- = SigTv -- Introduced when instantiating a type signature,
- -- prior to checking that the defn of a fn does
- -- have the expected type. Should not be instantiated.
- -- f :: forall a. a -> a
- -- f = e
- -- When checking e, with expected type (a->a), we
- -- should not instantiate a
-
- | ClsTv -- Scoped type variable introduced by a class decl
- -- class C a where ...
-
- | InstTv -- Ditto, but instance decl
-
- | PatSigTv -- Scoped type variable, introduced by a pattern
- -- type signature \ x::a -> e
-
- | VanillaTv -- Everything else
-
-isUserTyVar :: TcTyVar -> Bool -- Avoid unifying these if possible
-isUserTyVar tv = case tcTyVarDetails tv of
- VanillaTv -> False
- other -> True
-
-isSkolemTyVar :: TcTyVar -> Bool
-isSkolemTyVar tv = case tcTyVarDetails tv of
- SigTv -> True
- ClsTv -> True
- InstTv -> True
- oteher -> False
-
-tyVarBindingInfo :: TcTyVar -> SDoc -- Used in checkSigTyVars
-tyVarBindingInfo tv
- = sep [ptext SLIT("is bound by the") <+> details (tcTyVarDetails tv),
- ptext SLIT("at") <+> ppr (getSrcLoc tv)]
+-- A TyVarDetails is inside a TyVar
+data TcTyVarDetails
+ = MetaTv (IORef MetaDetails) -- A meta type variable stands for a tau-type
+ | SkolemTv SkolemInfo -- A skolem constant
+ | SigSkolTv Name (IORef MetaDetails) -- Ditto, but from a type signature;
+ -- see Note [Signature skolems]
+ -- The MetaDetails, if filled in, will
+ -- always be another SigSkolTv
+
+data SkolemInfo
+ = SigSkol Name -- Bound at a type signature
+ | ClsSkol Class -- Bound at a class decl
+ | InstSkol Id -- Bound at an instance decl
+ | PatSkol DataCon -- An existential type variable bound by a pattern for
+ SrcSpan -- 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)
+
+ | GenSkol [TcTyVar] -- Bound when doing a subsumption check for
+ TcType -- (forall tvs. ty)
+ SrcSpan
+
+data MetaDetails
+ = Flexi -- Flexi type variables unify to become
+ -- Indirects.
+
+ | Indirect TcType -- Type indirections, treated as wobbly
+ -- for the purpose of GADT unification.
+
+tidySkolemTyVar :: TidyEnv -> TcTyVar -> (TidyEnv, TcTyVar)
+-- Tidy the type inside a GenSkol, preparatory to printing it
+tidySkolemTyVar env tv
+ = ASSERT( isSkolemTyVar 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))
+ where
+ (env1, tvs1) = tidyOpenTyVars env tvs
+ (env2, ty1) = tidyOpenType env1 ty
+ info -> (env, info)
+
+pprTcTyVar :: TcTyVar -> SDoc
+-- Print tyvar with info about its binding
+pprTcTyVar tv
+ = quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv)
where
- details SigTv = ptext SLIT("type signature")
- details ClsTv = ptext SLIT("class declaration")
- details InstTv = ptext SLIT("instance declaration")
- details PatSigTv = ptext SLIT("pattern type signature")
- details VanillaTv = ptext SLIT("//vanilla//") -- Ditto
+ ppr_details (MetaTv _) = ptext SLIT("is a meta type variable")
+ ppr_details (SigSkolTv id _) = ptext SLIT("is bound by") <+> pprSkolInfo (SigSkol id)
+ ppr_details (SkolemTv info) = ptext SLIT("is bound by") <+> pprSkolInfo info
+
+pprSkolInfo :: SkolemInfo -> SDoc
+pprSkolInfo (SigSkol id) = ptext SLIT("the type signature for") <+> quotes (ppr id)
+pprSkolInfo (ClsSkol cls) = ptext SLIT("the class declaration for") <+> quotes (ppr cls)
+pprSkolInfo (InstSkol df) = ptext SLIT("the instance declaration at") <+> ppr (getSrcLoc df)
+pprSkolInfo (ArrowSkol loc) = ptext SLIT("the arrow form at") <+> ppr loc
+pprSkolInfo (PatSkol dc loc) = sep [ptext SLIT("the pattern for") <+> quotes (ppr dc),
+ nest 2 (ptext SLIT("at") <+> ppr loc)]
+pprSkolInfo (GenSkol tvs ty loc) = sep [ptext SLIT("the polymorphic type")
+ <+> quotes (ppr (mkForAllTys tvs ty)),
+ nest 2 (ptext SLIT("at") <+> ppr loc)]
+
+instance Outputable MetaDetails where
+ ppr Flexi = ptext SLIT("Flexi")
+ ppr (Indirect ty) = ptext SLIT("Indirect") <+> ppr ty
+
+isImmutableTyVar, isSkolemTyVar, isExistentialTyVar, isMetaTyVar :: TyVar -> Bool
+isImmutableTyVar tv
+ | isTcTyVar tv = isSkolemTyVar tv
+ | otherwise = True
+
+isSkolemTyVar tv
+ = ASSERT( isTcTyVar tv )
+ case tcTyVarDetails tv of
+ SkolemTv _ -> True
+ SigSkolTv _ _ -> True
+ MetaTv _ -> False
+
+isExistentialTyVar tv -- Existential type variable, bound by a pattern
+ = ASSERT( isTcTyVar tv )
+ case tcTyVarDetails tv of
+ SkolemTv (PatSkol _ _) -> True
+ other -> False
+
+isMetaTyVar tv
+ = ASSERT( isTcTyVar tv )
+ case tcTyVarDetails tv of
+ MetaTv _ -> True
+ other -> False
+
+metaTvRef :: TyVar -> IORef MetaDetails
+metaTvRef tv
+ = ASSERT( isTcTyVar tv )
+ case tcTyVarDetails tv of
+ MetaTv ref -> ref
+ other -> pprPanic "metaTvRef" (ppr tv)
+
+isFlexi, isIndirect :: MetaDetails -> Bool
+isFlexi Flexi = True
+isFlexi other = False
+
+isIndirect (Indirect _) = True
+isIndirect other = False
\end{code}
-\begin{code}
-type TcTyVarSet = TyVarSet
-\end{code}
%************************************************************************
%* *
isTauTy :: Type -> Bool
isTauTy (TyVarTy v) = True
isTauTy (TyConApp _ tys) = all isTauTy tys
-isTauTy (NewTcApp _ tys) = all isTauTy tys
isTauTy (AppTy a b) = isTauTy a && isTauTy b
isTauTy (FunTy a b) = isTauTy a && isTauTy b
isTauTy (PredTy p) = True -- Don't look through source types
-- construct a dictionary function name
getDFunTyKey (TyVarTy tv) = getOccName tv
getDFunTyKey (TyConApp tc _) = getOccName tc
-getDFunTyKey (NewTcApp tc _) = getOccName tc
getDFunTyKey (AppTy fun _) = getDFunTyKey fun
getDFunTyKey (NoteTy _ t) = getDFunTyKey t
getDFunTyKey (FunTy arg _) = getOccName funTyCon
tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
-tcSplitTyConApp_maybe (NewTcApp tc tys) = Just (tc, tys)
tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
tcSplitTyConApp_maybe (NoteTy n ty) = tcSplitTyConApp_maybe ty
-- Newtypes are opaque, so they may be split
tcSplitAppTy_maybe (TyConApp tc tys) = case snocView tys of
Just (tys', ty') -> Just (TyConApp tc tys', ty')
Nothing -> Nothing
-tcSplitAppTy_maybe (NewTcApp tc tys) = case snocView tys of
- Just (tys', ty') -> Just (NewTcApp tc tys', ty')
- Nothing -> Nothing
tcSplitAppTy_maybe other = Nothing
tcSplitAppTy ty = case tcSplitAppTy_maybe ty of
tcIsTyVarTy :: Type -> Bool
tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty)
-\end{code}
-
-The type of a method for class C is always of the form:
- Forall a1..an. C a1..an => sig_ty
-where sig_ty is the type given by the method's signature, and thus in general
-is a ForallTy. At the point that splitMethodTy is called, it is expected
-that the outer Forall has already been stripped off. splitMethodTy then
-returns (C a1..an, sig_ty') where sig_ty' is sig_ty with any Notes stripped off.
-
-\begin{code}
-tcSplitMethodTy :: Type -> (PredType, Type)
-tcSplitMethodTy ty = split ty
- where
- split (FunTy arg res) = case tcSplitPredTy_maybe arg of
- Just p -> (p, res)
- Nothing -> panic "splitMethodTy"
- split (NoteTy n ty) = split ty
- split _ = panic "splitMethodTy"
tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
-- Split the type of a dictionary function
tcSplitDFunTy ty
- = case tcSplitSigmaTy ty of { (tvs, theta, tau) ->
- case tcSplitPredTy_maybe tau of { Just (ClassP clas tys) ->
+ = case tcSplitSigmaTy ty of { (tvs, theta, tau) ->
+ case tcSplitDFunHead tau of { (clas, tys) ->
(tvs, theta, clas, tys) }}
-\end{code}
-
-(allDistinctTyVars tys tvs) = True
- iff
-all the types tys are type variables,
-distinct from each other and from tvs.
-This is useful when checking that unification hasn't unified signature
-type variables. For example, if the type sig is
- f :: forall a b. a -> b -> b
-we want to check that 'a' and 'b' havn't
- (a) been unified with a non-tyvar type
- (b) been unified with each other (all distinct)
- (c) been unified with a variable free in the environment
-
-\begin{code}
-allDistinctTyVars :: [Type] -> TyVarSet -> Bool
+tcSplitDFunHead :: Type -> (Class, [Type])
+tcSplitDFunHead tau
+ = case tcSplitPredTy_maybe tau of
+ Just (ClassP clas tys) -> (clas, tys)
+\end{code}
-allDistinctTyVars [] acc
- = True
-allDistinctTyVars (ty:tys) acc
- = case tcGetTyVar_maybe ty of
- Nothing -> False -- (a)
- Just tv | tv `elemVarSet` acc -> False -- (b) or (c)
- | otherwise -> allDistinctTyVars tys (acc `extendVarSet` tv)
-\end{code}
%************************************************************************
tcSplitPredTy_maybe :: Type -> Maybe PredType
-- Returns Just for predicates only
tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty
-tcSplitPredTy_maybe (PredTy p) = Just p
+tcSplitPredTy_maybe (PredTy p) = Just p
tcSplitPredTy_maybe other = Nothing
predTyUnique :: PredType -> Unique
%************************************************************************
%* *
-\subsection{Comparison}
-%* *
-%************************************************************************
-
-Comparison, taking note of newtypes, predicates, etc,
-
-\begin{code}
-tcEqType :: Type -> Type -> Bool
-tcEqType ty1 ty2 = case ty1 `tcCmpType` ty2 of { EQ -> True; other -> False }
-
-tcEqTypes :: [Type] -> [Type] -> Bool
-tcEqTypes ty1 ty2 = case ty1 `tcCmpTypes` ty2 of { EQ -> True; other -> False }
-
-tcEqPred :: PredType -> PredType -> Bool
-tcEqPred p1 p2 = case p1 `tcCmpPred` p2 of { EQ -> True; other -> False }
-
--------------
-tcCmpType :: Type -> Type -> Ordering
-tcCmpType ty1 ty2 = cmpTy emptyVarEnv ty1 ty2
-
-tcCmpTypes tys1 tys2 = cmpTys emptyVarEnv tys1 tys2
-
-tcCmpPred p1 p2 = cmpPredTy emptyVarEnv p1 p2
--------------
-cmpTys env tys1 tys2 = cmpList (cmpTy env) tys1 tys2
-
--------------
-cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering
- -- The "env" maps type variables in ty1 to type variables in ty2
- -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
- -- we in effect substitute tv2 for tv1 in t1 before continuing
-
- -- Look through NoteTy
-cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2
-cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2
-
- -- Deal with equal constructors
-cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
- Just tv1a -> tv1a `compare` tv2
- Nothing -> tv1 `compare` tv2
-
-cmpTy env (PredTy p1) (PredTy p2) = cmpPredTy env p1 p2
-cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
-cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
-cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
-cmpTy env (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
-cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2
-
- -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < NewTcApp < ForAllTy < PredTy
-cmpTy env (AppTy _ _) (TyVarTy _) = GT
-
-cmpTy env (FunTy _ _) (TyVarTy _) = GT
-cmpTy env (FunTy _ _) (AppTy _ _) = GT
-
-cmpTy env (TyConApp _ _) (TyVarTy _) = GT
-cmpTy env (TyConApp _ _) (AppTy _ _) = GT
-cmpTy env (TyConApp _ _) (FunTy _ _) = GT
-
-cmpTy env (NewTcApp _ _) (TyVarTy _) = GT
-cmpTy env (NewTcApp _ _) (AppTy _ _) = GT
-cmpTy env (NewTcApp _ _) (FunTy _ _) = GT
-cmpTy env (NewTcApp _ _) (TyConApp _ _) = GT
-
-cmpTy env (ForAllTy _ _) (TyVarTy _) = GT
-cmpTy env (ForAllTy _ _) (AppTy _ _) = GT
-cmpTy env (ForAllTy _ _) (FunTy _ _) = GT
-cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT
-cmpTy env (ForAllTy _ _) (NewTcApp _ _) = GT
-
-cmpTy env (PredTy _) t2 = GT
-
-cmpTy env _ _ = LT
-\end{code}
-
-\begin{code}
-cmpPredTy :: TyVarEnv TyVar -> PredType -> PredType -> Ordering
-cmpPredTy env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2)
- -- Compare types as well as names for implicit parameters
- -- This comparison is used exclusively (I think) for the
- -- finite map built in TcSimplify
-cmpPredTy env (IParam _ _) (ClassP _ _) = LT
-cmpPredTy env (ClassP _ _) (IParam _ _) = GT
-cmpPredTy env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
-\end{code}
-
-PredTypes are used as a FM key in TcSimplify,
-so we take the easy path and make them an instance of Ord
-
-\begin{code}
-instance Eq PredType where { (==) = tcEqPred }
-instance Ord PredType where { compare = tcCmpPred }
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Predicates}
%* *
%************************************************************************
\end{code}
+
+
+%************************************************************************
+%* *
+ Hoisting for-alls
+%* *
+%************************************************************************
+
+hoistForAllTys is used for user-written type signatures only
+We want to 'look through' type synonyms when doing this
+so it's better done on the Type than the HsType
+
+It moves all the foralls and constraints to the top
+e.g. T -> forall a. a ==> forall a. T -> a
+ T -> (?x::Int) -> Int ==> (?x::Int) -> T -> Int
+
+Also: it eliminates duplicate constraints. These can show up
+when hoisting constraints, notably implicit parameters.
+
+It tries hard to retain type synonyms if hoisting does not break one
+up. Not only does this improve error messages, but there's a tricky
+interaction with Haskell 98. H98 requires no unsaturated type
+synonyms, which is checked by checkValidType. This runs after
+hoisting, so we don't want hoisting to remove the SynNotes! (We can't
+run validity checking before hoisting because in mutually-recursive
+type definitions we postpone validity checking until after the knot is
+tied.)
+
+\begin{code}
+hoistForAllTys :: Type -> Type
+hoistForAllTys ty
+ = go (deShadowTy ty)
+ -- Running over ty with an empty substitution gives it the
+ -- no-shadowing property. This is important. For example:
+ -- type Foo r = forall a. a -> r
+ -- foo :: Foo (Foo ())
+ -- Here the hoisting should give
+ -- foo :: forall a a1. a -> a1 -> ()
+ --
+ -- What about type vars that are lexically in scope in the envt?
+ -- We simply rely on them having a different unique to any
+ -- binder in 'ty'. Otherwise we'd have to slurp the in-scope-tyvars
+ -- out of the envt, which is boring and (I think) not necessary.
+
+ where
+ go (TyVarTy tv) = TyVarTy tv
+ go (TyConApp tc tys) = TyConApp tc (map go tys)
+ go (PredTy pred) = PredTy pred -- No nested foralls
+ go (NoteTy (SynNote ty1) ty2) = NoteTy (SynNote (go ty1)) (go ty2)
+ go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
+ go (FunTy arg res) = mk_fun_ty (go arg) (go res)
+ go (AppTy fun arg) = AppTy (go fun) (go arg)
+ go (ForAllTy tv ty) = ForAllTy tv (go ty)
+
+ -- mk_fun_ty does all the work.
+ -- It's building t1 -> t2:
+ -- if t2 is a for-all type, push t1 inside it
+ -- if t2 is (pred -> t3), check for duplicates
+ mk_fun_ty ty1 ty2
+ | not (isSigmaTy ty2) -- No forall's, or context =>
+ = FunTy ty1 ty2
+ | PredTy p1 <- ty1 -- ty1 is a predicate
+ = if p1 `elem` theta then -- so check for duplicates
+ ty2
+ else
+ mkSigmaTy tvs (p1:theta) tau
+ | otherwise
+ = mkSigmaTy tvs theta (FunTy ty1 tau)
+ where
+ (tvs, theta, tau) = tcSplitSigmaTy ty2
+\end{code}
+
+
%************************************************************************
%* *
\subsection{Misc}
-- Remove synonyms, but not predicate types
deNoteType ty@(TyVarTy tyvar) = ty
deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
-deNoteType (NewTcApp tycon tys) = NewTcApp tycon (map deNoteType tys)
deNoteType (PredTy p) = PredTy (deNotePredType p)
deNoteType (NoteTy _ ty) = deNoteType ty
deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg)
tyClsNamesOfType :: Type -> NameSet
tyClsNamesOfType (TyVarTy tv) = emptyNameSet
tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
-tyClsNamesOfType (NewTcApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
tyClsNamesOfType (NoteTy (SynNote ty1) ty2) = tyClsNamesOfType ty1
tyClsNamesOfType (NoteTy other_note ty2) = tyClsNamesOfType ty2
tyClsNamesOfType (PredTy (IParam n ty)) = tyClsNamesOfType ty
\end{code}
-%************************************************************************
-%* *
-\subsection{Unification with an explicit substitution}
-%* *
-%************************************************************************
-
-Unify types with an explicit substitution and no monad.
-Ignore usage annotations.
-
-\begin{code}
-type MySubst
- = (TyVarSet, -- Set of template tyvars
- TyVarSubstEnv) -- Not necessarily idempotent
-
-unifyTysX :: TyVarSet -- Template tyvars
- -> Type
- -> Type
- -> Maybe TyVarSubstEnv
-unifyTysX tmpl_tyvars ty1 ty2
- = uTysX ty1 ty2 (\(_,s) -> Just s) (tmpl_tyvars, emptySubstEnv)
-
-unifyExtendTysX :: TyVarSet -- Template tyvars
- -> TyVarSubstEnv -- Substitution to start with
- -> Type
- -> Type
- -> Maybe TyVarSubstEnv -- Extended substitution
-unifyExtendTysX tmpl_tyvars subst ty1 ty2
- = uTysX ty1 ty2 (\(_,s) -> Just s) (tmpl_tyvars, subst)
-
-unifyTyListsX :: TyVarSet -> [Type] -> [Type]
- -> Maybe TyVarSubstEnv
-unifyTyListsX tmpl_tyvars tys1 tys2
- = uTyListsX tys1 tys2 (\(_,s) -> Just s) (tmpl_tyvars, emptySubstEnv)
-
-
-uTysX :: Type
- -> Type
- -> (MySubst -> Maybe result)
- -> MySubst
- -> Maybe result
-
-uTysX (NoteTy _ ty1) ty2 k subst = uTysX ty1 ty2 k subst
-uTysX ty1 (NoteTy _ ty2) k subst = uTysX ty1 ty2 k subst
-
- -- Variables; go for uVar
-uTysX (TyVarTy tyvar1) (TyVarTy tyvar2) k subst
- | tyvar1 == tyvar2
- = k subst
-uTysX (TyVarTy tyvar1) ty2 k subst@(tmpls,_)
- | tyvar1 `elemVarSet` tmpls
- = uVarX tyvar1 ty2 k subst
-uTysX ty1 (TyVarTy tyvar2) k subst@(tmpls,_)
- | tyvar2 `elemVarSet` tmpls
- = uVarX tyvar2 ty1 k subst
-
- -- Predicates
-uTysX (PredTy (IParam n1 t1)) (PredTy (IParam n2 t2)) k subst
- | n1 == n2 = uTysX t1 t2 k subst
-uTysX (PredTy (ClassP c1 tys1)) (PredTy (ClassP c2 tys2)) k subst
- | c1 == c2 = uTyListsX tys1 tys2 k subst
-
- -- Functions; just check the two parts
-uTysX (FunTy fun1 arg1) (FunTy fun2 arg2) k subst
- = uTysX fun1 fun2 (uTysX arg1 arg2 k) subst
-
- -- Type constructors must match
-uTysX (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) k subst
- | tc1 == tc2 = uTyListsX tys1 tys2 k subst
-uTysX (TyConApp con1 tys1) (TyConApp con2 tys2) k subst
- | (con1 == con2 && equalLength tys1 tys2)
- = uTyListsX tys1 tys2 k subst
-
- -- Applications need a bit of care!
- -- They can match FunTy and TyConApp, so use splitAppTy_maybe
- -- NB: we've already dealt with type variables and Notes,
- -- so if one type is an App the other one jolly well better be too
-uTysX (AppTy s1 t1) ty2 k subst
- = case tcSplitAppTy_maybe ty2 of
- Just (s2, t2) -> uTysX s1 s2 (uTysX t1 t2 k) subst
- Nothing -> Nothing -- Fail
-
-uTysX ty1 (AppTy s2 t2) k subst
- = case tcSplitAppTy_maybe ty1 of
- Just (s1, t1) -> uTysX s1 s2 (uTysX t1 t2 k) subst
- Nothing -> Nothing -- Fail
-
- -- Not expecting for-alls in unification
-#ifdef DEBUG
-uTysX (ForAllTy _ _) ty2 k subst = panic "Unify.uTysX subst:ForAllTy (1st arg)"
-uTysX ty1 (ForAllTy _ _) k subst = panic "Unify.uTysX subst:ForAllTy (2nd arg)"
-#endif
-
- -- Anything else fails
-uTysX ty1 ty2 k subst = Nothing
-
-
-uTyListsX [] [] k subst = k subst
-uTyListsX (ty1:tys1) (ty2:tys2) k subst = uTysX ty1 ty2 (uTyListsX tys1 tys2 k) subst
-uTyListsX tys1 tys2 k subst = Nothing -- Fail if the lists are different lengths
-\end{code}
-
-\begin{code}
--- Invariant: tv1 is a unifiable variable
-uVarX tv1 ty2 k subst@(tmpls, env)
- = case lookupSubstEnv env tv1 of
- Just (DoneTy ty1) -> -- Already bound
- uTysX ty1 ty2 k subst
-
- Nothing -- Not already bound
- | typeKind ty2 == tyVarKind tv1
- && occur_check_ok ty2
- -> -- No kind mismatch nor occur check
- k (tmpls, extendSubstEnv env tv1 (DoneTy ty2))
-
- | otherwise -> Nothing -- Fail if kind mis-match or occur check
- where
- occur_check_ok ty = all occur_check_ok_tv (varSetElems (tyVarsOfType ty))
- occur_check_ok_tv tv | tv1 == tv = False
- | otherwise = case lookupSubstEnv env tv of
- Nothing -> True
- Just (DoneTy ty) -> occur_check_ok ty
-\end{code}
-
-
-
-%************************************************************************
-%* *
-\subsection{Matching on types}
-%* *
-%************************************************************************
-
-Matching is a {\em unidirectional} process, matching a type against a
-template (which is just a type with type variables in it). The
-matcher assumes that there are no repeated type variables in the
-template, so that it simply returns a mapping of type variables to
-types. It also fails on nested foralls.
-
-@matchTys@ matches corresponding elements of a list of templates and
-types. It and @matchTy@ both ignore usage annotations, unlike the
-main function @match@.
-
-\begin{code}
-matchTy :: TyVarSet -- Template tyvars
- -> Type -- Template
- -> Type -- Proposed instance of template
- -> Maybe TyVarSubstEnv -- Matching substitution
-
-
-matchTys :: TyVarSet -- Template tyvars
- -> [Type] -- Templates
- -> [Type] -- Proposed instance of template
- -> Maybe (TyVarSubstEnv, -- Matching substitution
- [Type]) -- Left over instance types
-
-matchTy tmpls ty1 ty2 = match ty1 ty2 tmpls (\ senv -> Just senv) emptySubstEnv
-
-matchTys tmpls tys1 tys2 = match_list tys1 tys2 tmpls
- (\ (senv,tys) -> Just (senv,tys))
- emptySubstEnv
-\end{code}
-
-@match@ is the main function. It takes a flag indicating whether
-usage annotations are to be respected.
-
-\begin{code}
-match :: Type -> Type -- Current match pair
- -> TyVarSet -- Template vars
- -> (TyVarSubstEnv -> Maybe result) -- Continuation
- -> TyVarSubstEnv -- Current subst
- -> Maybe result
-
--- When matching against a type variable, see if the variable
--- has already been bound. If so, check that what it's bound to
--- is the same as ty; if not, bind it and carry on.
-
-match (TyVarTy v) ty tmpls k senv
- | v `elemVarSet` tmpls
- = -- v is a template variable
- case lookupSubstEnv senv v of
- Nothing | typeKind ty `isSubKind` tyVarKind v
- -- We do a kind check, just as in the uVarX above
- -- The kind check is needed to avoid bogus matches
- -- of (a b) with (c d), where the kinds don't match
- -- An occur check isn't needed when matching.
- -> k (extendSubstEnv senv v (DoneTy ty))
-
- | otherwise -> Nothing -- Fails
-
- Just (DoneTy ty') | ty' `tcEqType` ty -> k senv -- Succeeds
- | otherwise -> Nothing -- Fails
-
- | otherwise
- = -- v is not a template variable; ty had better match
- -- Can't use (==) because types differ
- case tcGetTyVar_maybe ty of
- Just v' | v == v' -> k senv -- Success
- other -> Nothing -- Failure
- -- This tcGetTyVar_maybe is *required* because it must strip Notes.
- -- I guess the reason the Note-stripping case is *last* rather than first
- -- is to preserve type synonyms etc., so I'm not moving it to the
- -- top; but this means that (without the deNotetype) a type
- -- variable may not match the pattern (TyVarTy v') as one would
- -- expect, due to an intervening Note. KSW 2000-06.
-
- -- Predicates
-match (PredTy (IParam n1 t1)) (PredTy (IParam n2 t2)) tmpls k senv
- | n1 == n2 = match t1 t2 tmpls k senv
-match (PredTy (ClassP c1 tys1)) (PredTy (ClassP c2 tys2)) tmpls k senv
- | c1 == c2 = match_list_exactly tys1 tys2 tmpls k senv
-
- -- Functions; just check the two parts
-match (FunTy arg1 res1) (FunTy arg2 res2) tmpls k senv
- = match arg1 arg2 tmpls (match res1 res2 tmpls k) senv
-
- -- If the template is an application, try to make the
- -- thing we are matching look like an application
-match (AppTy fun1 arg1) ty2 tmpls k senv
- = case tcSplitAppTy_maybe ty2 of
- Just (fun2,arg2) -> match fun1 fun2 tmpls (match arg1 arg2 tmpls k) senv
- Nothing -> Nothing -- Fail
-
- -- Newtypes are opaque; predicate types should not happen
-match (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) tmpls k senv
- | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv
-match (TyConApp tc1 tys1) (TyConApp tc2 tys2) tmpls k senv
- | tc1 == tc2 = match_list_exactly tys1 tys2 tmpls k senv
-
- -- With type synonyms, we have to be careful for the exact
- -- same reasons as in the unifier. Please see the
- -- considerable commentary there before changing anything
- -- here! (WDP 95/05)
-match (NoteTy n1 ty1) ty2 tmpls k senv = match ty1 ty2 tmpls k senv
-match ty1 (NoteTy n2 ty2) tmpls k senv = match ty1 ty2 tmpls k senv
-
--- Catch-all fails
-match _ _ _ _ _ = Nothing
-
-match_list_exactly tys1 tys2 tmpls k senv
- = match_list tys1 tys2 tmpls k' senv
- where
- k' (senv', tys2') | null tys2' = k senv' -- Succeed
- | otherwise = Nothing -- Fail
-
-match_list [] tys2 tmpls k senv = k (senv, tys2)
-match_list (ty1:tys1) [] tmpls k senv = Nothing -- Not enough arg tys => failure
-match_list (ty1:tys1) (ty2:tys2) tmpls k senv
- = match ty1 ty2 tmpls (match_list tys1 tys2 tmpls k) senv
-\end{code}
projects / ghc-hetmet.git / blobdiff