-
+%
% (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}
tcSplitForAllTys, tcSplitPhiTy,
tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN,
tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
- tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys,
+ tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe,
tcValidInstHeadTy, 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, isBoolTy, isUnitTy,
---------------------------------
-- Predicate types
getClassPredTys_maybe, getClassPredTys,
- isClassPred, isTyVarClassPred,
+ isClassPred, isTyVarClassPred, isEqPred,
mkDictTy, tcSplitPredTy_maybe,
isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique,
- mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName,
+ mkClassPred, isInheritablePred, isIPPred, mkPredName,
dataConsStupidTheta, isRefineableTy,
---------------------------------
--------------------------------
-- Rexported from Type
Kind, -- Stuff to do with kinds is insensitive to pre/post Tc
- unliftedTypeKind, liftedTypeKind, unboxedTypeKind,
+ unliftedTypeKind, liftedTypeKind, argTypeKind,
openTypeKind, mkArrowKind, mkArrowKinds,
- isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
- isArgTypeKind, isSubKind, defaultKind,
+ 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,
#include "HsVersions.h"
-- friends:
-import TypeRep ( Type(..), funTyCon ) -- friend
-
-import Type ( -- Re-exports
- tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
- tyVarsOfTheta, Kind, PredType(..),
- ThetaType, unliftedTypeKind, unboxedTypeKind,
- 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, coreView,
- pprKind, pprParendKind,
- pprType, pprParendType, pprTyThingCategory,
- pprPred, pprTheta, pprThetaArrow, pprClassPred
- )
-import TyCon ( TyCon, isUnLiftedTyCon, isSynTyCon, synTyConDefn, tyConUnique )
+import TypeRep ( Type(..), funTyCon, Kind ) -- friend
+
+import Type
+import TyCon ( TyCon, isUnLiftedTyCon, isSynTyCon, isOpenTyCon,
+ synTyConDefn, tyConUnique )
import DataCon ( DataCon, dataConStupidTheta, dataConResTys )
import Class ( Class )
-import Var ( TyVar, Id, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails )
+import Var ( TyVar, Id, isCoVar, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails )
import ForeignCall ( Safety, DNType(..) )
import Unify ( tcMatchTys )
import VarSet
-- others:
import DynFlags ( DynFlags, DynFlag( Opt_GlasgowExts ), dopt )
-import Name ( Name, NamedThing(..), mkInternalName, getSrcLoc )
+import Name ( Name, NamedThing(..), mkInternalName, getSrcLoc, mkSystemName )
import NameSet
import VarEnv ( TidyEnv )
-import OccName ( OccName, mkDictOcc )
+import OccName ( OccName, mkDictOcc, mkOccName, tvName )
import PrelNames -- Lots (e.g. in isFFIArgumentTy)
import TysWiredIn ( unitTyCon, charTyCon, listTyCon )
-import BasicTypes ( IPName(..), Arity, ipNameName )
+import BasicTypes ( Arity, ipNameName )
import SrcLoc ( SrcLoc, SrcSpan )
-import Util ( snocView, equalLength )
+import Util ( equalLength )
import Maybes ( maybeToBool, expectJust, mapCatMaybes )
import ListSetOps ( hasNoDups )
import List ( nubBy )
import Outputable
-import DATA_IOREF
+
+import Data.IORef
\end{code}
-- The rest are for non-scoped skolems
| ClsSkol Class -- Bound at a class decl
| InstSkol Id -- Bound at an instance decl
+ | FamInstSkol TyCon -- Bound at a family instance decl
| 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
-- 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}
\end{code}
%************************************************************************
-- 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 )
+ 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")
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 (InstSkol df) =
+ ptext SLIT("is bound by the instance declaration at") <+> ppr (getSrcLoc df)
+pprSkolInfo (FamInstSkol tc) =
+ ptext SLIT("is bound by the family instance declaration at") <+>
+ ppr (getSrcLoc tc)
+pprSkolInfo (ArrowSkol loc) =
+ ptext SLIT("is bound by the arrow form at") <+> ppr loc
pprSkolInfo (PatSkol dc loc) = sep [ptext SLIT("is bound by the pattern for") <+> quotes (ppr dc),
nest 2 (ptext SLIT("at") <+> ppr loc)]
pprSkolInfo (GenSkol tvs ty loc) = sep [sep [ptext SLIT("is bound by the polymorphic type"),
%************************************************************************
\begin{code}
+mkSigmaTy :: [TyVar] -> [PredType] -> Type -> Type
mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau)
mkPhiTy :: [PredType] -> Type -> 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
+ | isSynTyCon tc && not (isOpenTyCon tc) = isTauTy (snd (synTyConDefn tc))
+ | otherwise = True
---------------
isBoxyTy :: TcType -> Bool
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
| 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
-- Used in Haskell-98 mode, for the argument types of an instance head
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)
-- which can be free in g's rhs, and shared by both calls to g
isInheritablePred (ClassP _ _) = 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) ---------------------------------
| con <- cons
, let Just subst = tcMatchTys tvs1 res_tys1 (dataConResTys con)
, pred <- dataConStupidTheta con ]
+dataConsStupidTheta [] = panic "dataConsStupidTheta"
\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]
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_pred (IParam _ ty) = go ty
- go_pred (ClassP _ tys) = exactTyVarsOfTypes tys
+ 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
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)
projects / ghc-hetmet.git / blobdiff