X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=3eb14198457ffe3a2c0cfa7d6c402d6e5de67463;hp=55e20fc3cf62e40140ac2a29004b49ad555e58b4;hb=f4510d27c5883fe7e8570f4dd49d45a8b0122f2c;hpb=15cb792d18b1094e98c035dca6ecec5dad516056 diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 55e20fc..3eb1419 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -1,4 +1,5 @@ - +% +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcType]{Types used in the typechecker} @@ -10,7 +11,7 @@ compiler. These parts 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} @@ -68,7 +69,7 @@ module TcType ( isClassPred, isTyVarClassPred, isEqPred, mkDictTy, tcSplitPredTy_maybe, isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique, - mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName, + mkClassPred, isInheritablePred, isIPPred, dataConsStupidTheta, isRefineableTy, --------------------------------- @@ -129,70 +130,33 @@ module TcType ( #include "HsVersions.h" -- friends: -import TypeRep ( Type(..), funTyCon, Kind ) -- friend - -import Type ( -- Re-exports - tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, - tyVarsOfTheta, Kind, PredType(..), KindVar, - ThetaType, isUnliftedTypeKind, unliftedTypeKind, - argTypeKind, - liftedTypeKind, openTypeKind, mkArrowKind, - tySuperKind, isLiftedTypeKind, - mkArrowKinds, mkForAllTy, mkForAllTys, - defaultKind, isSubArgTypeKind, isSubOpenTypeKind, - 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, eqKind, - - 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, repSplitAppTy_maybe, - pprKind, pprParendKind, - pprType, pprParendType, pprTyThingCategory, - pprPred, pprTheta, pprThetaArrow, pprClassPred - ) -import TyCon ( TyCon, isUnLiftedTyCon, isSynTyCon, synTyConDefn, tyConUnique ) -import DataCon ( DataCon, dataConStupidTheta, dataConResTys ) -import Class ( Class ) -import Var ( TyVar, Id, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails ) -import ForeignCall ( Safety, DNType(..) ) -import Unify ( tcMatchTys ) +import TypeRep +import DataCon +import Class +import Var +import ForeignCall +import Unify import VarSet +import Type +import TyCon -- others: -import DynFlags ( DynFlags, DynFlag( Opt_GlasgowExts ), dopt ) -import Name ( Name, NamedThing(..), mkInternalName, getSrcLoc, mkSystemName ) +import DynFlags +import CoreSyn +import Name import NameSet -import VarEnv ( TidyEnv ) -import OccName ( OccName, mkDictOcc, mkOccName, tvName ) -import PrelNames -- Lots (e.g. in isFFIArgumentTy) -import TysWiredIn ( unitTyCon, charTyCon, listTyCon ) -import BasicTypes ( IPName(..), Arity, ipNameName ) -import SrcLoc ( SrcLoc, SrcSpan ) -import Util ( equalLength ) -import Maybes ( maybeToBool, expectJust, mapCatMaybes ) -import ListSetOps ( hasNoDups ) -import List ( nubBy ) +import VarEnv +import OccName +import PrelNames +import TysWiredIn +import BasicTypes +import Util +import Maybes +import ListSetOps import Outputable -import DATA_IOREF + +import Data.List +import Data.IORef \end{code} @@ -335,6 +299,8 @@ data MetaDetails -- 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 @@ -342,24 +308,26 @@ data SkolemInfo -- The rest are for non-scoped skolems | ClsSkol Class -- Bound at a class decl - | InstSkol Id -- Bound at an instance decl + | InstSkol -- Bound at an instance decl + | FamInstSkol -- Bound at a family instance decl | PatSkol DataCon -- An existential type variable bound by a pattern for - SrcSpan -- a data constructor with an existential type. E.g. + -- a data constructor with an existential type. E.g. -- data T = forall a. Eq a => MkT a -- f (MkT x) = ... -- The pattern MkT x will allocate an existential type -- variable for 'a'. - | ArrowSkol SrcSpan -- An arrow form (see TcArrows) + | ArrowSkol -- An arrow form (see TcArrows) + | RuleSkol RuleName -- The LHS of a RULE | GenSkol [TcTyVar] -- Bound when doing a subsumption check for TcType -- (forall tvs. ty) - SrcSpan | UnkSkol -- Unhelpful info (until I improve it) ------------------------------------- -- UserTypeCtxt describes the places where a -- programmer-written type signature can occur +-- Like SkolemInfo, no location info data UserTypeCtxt = FunSigCtxt Name -- Function type signature -- Also used for types in SPECIALISE pragmas @@ -375,7 +343,6 @@ data UserTypeCtxt | ResSigCtxt -- Result type sig -- f x :: t = .... | ForSigCtxt Name -- Foreign inport or export signature - | RuleSigCtxt Name -- Signature on a forall'd variable in a RULE | DefaultDeclCtxt -- Types in a default declaration | SpecInstCtxt -- SPECIALISE instance pragma @@ -397,6 +364,7 @@ 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) @@ -439,7 +407,6 @@ 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 (RuleSigCtxt n) = ptext SLIT("the type signature for") <+> quotes (ppr n) pprUserTypeCtxt DefaultDeclCtxt = ptext SLIT("a type in a `default' declaration") pprUserTypeCtxt SpecInstCtxt = ptext SLIT("a SPECIALISE instance pragma") @@ -460,7 +427,7 @@ tidySkolemTyVar env tv (env1, info') = tidy_skol_info env info info -> (env, info) - tidy_skol_info env (GenSkol tvs ty loc) = (env2, GenSkol tvs1 ty1 loc) + tidy_skol_info env (GenSkol tvs ty) = (env2, GenSkol tvs1 ty1) where (env1, tvs1) = tidyOpenTyVars env tvs (env2, ty1) = tidyOpenType env1 ty @@ -470,29 +437,30 @@ pprSkolTvBinding :: TcTyVar -> SDoc -- Print info about the binding of a skolem tyvar, -- or nothing if we don't have anything useful to say pprSkolTvBinding tv - = ppr_details (tcTyVarDetails tv) + = ASSERT ( isTcTyVar tv ) + ppr_details (tcTyVarDetails tv) where ppr_details (MetaTv TauTv _) = quotes (ppr tv) <+> ptext SLIT("is a meta type variable") ppr_details (MetaTv BoxTv _) = quotes (ppr tv) <+> ptext SLIT("is a boxy type variable") ppr_details (MetaTv (SigTv info) _) = ppr_skol info ppr_details (SkolemTv info) = ppr_skol info - ppr_skol UnkSkol = empty -- Unhelpful; omit - ppr_skol (SigSkol ctxt) = sep [quotes (ppr tv) <+> ptext SLIT("is bound by") <+> pprUserTypeCtxt ctxt, - nest 2 (ptext SLIT("at") <+> ppr (getSrcLoc tv))] - ppr_skol info = quotes (ppr tv) <+> pprSkolInfo info + ppr_skol UnkSkol = empty -- Unhelpful; omit + ppr_skol info = quotes (ppr tv) <+> ptext SLIT("is bound by") + <+> sep [pprSkolInfo info, nest 2 (ptext SLIT("at") <+> ppr (getSrcLoc tv))] pprSkolInfo :: SkolemInfo -> SDoc -pprSkolInfo (SigSkol ctxt) = ptext SLIT("is bound by") <+> pprUserTypeCtxt ctxt -pprSkolInfo (ClsSkol cls) = ptext SLIT("is bound by the class declaration for") <+> quotes (ppr cls) -pprSkolInfo (InstSkol df) = ptext SLIT("is bound by the instance declaration at") <+> ppr (getSrcLoc df) -pprSkolInfo (ArrowSkol loc) = ptext SLIT("is bound by the arrow form at") <+> ppr loc -pprSkolInfo (PatSkol dc loc) = sep [ptext SLIT("is bound by the pattern for") <+> quotes (ppr dc), - nest 2 (ptext SLIT("at") <+> ppr loc)] -pprSkolInfo (GenSkol tvs ty loc) = sep [sep [ptext SLIT("is bound by the polymorphic type"), - nest 2 (quotes (ppr (mkForAllTys tvs ty)))], - nest 2 (ptext SLIT("at") <+> ppr loc)] --- UnkSkol, SigSkol +pprSkolInfo (SigSkol ctxt) = pprUserTypeCtxt ctxt +pprSkolInfo (ClsSkol cls) = ptext SLIT("the class declaration for") <+> quotes (ppr cls) +pprSkolInfo InstSkol = ptext SLIT("the instance declaration") +pprSkolInfo FamInstSkol = ptext SLIT("the family instance declaration") +pprSkolInfo (RuleSkol name) = ptext SLIT("the RULE") <+> doubleQuotes (ftext name) +pprSkolInfo ArrowSkol = ptext SLIT("the arrow form") +pprSkolInfo (PatSkol dc) = sep [ptext SLIT("the constructor") <+> quotes (ppr dc)] +pprSkolInfo (GenSkol tvs ty) = sep [ptext SLIT("the polymorphic type"), + nest 2 (quotes (ppr (mkForAllTys tvs ty)))] + +-- UnkSkol -- For type variables the others are dealt with by pprSkolTvBinding. -- For Insts, these cases should not happen pprSkolInfo UnkSkol = panic "UnkSkol" @@ -524,8 +492,8 @@ isSkolemTyVar tv isExistentialTyVar tv -- Existential type variable, bound by a pattern = ASSERT( isTcTyVar tv ) case tcTyVarDetails tv of - SkolemTv (PatSkol _ _) -> True - other -> False + SkolemTv (PatSkol {}) -> True + other -> False isMetaTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) @@ -591,8 +559,9 @@ isTauTy other = False 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 @@ -642,17 +611,23 @@ tcSplitForAllTys :: Type -> ([TyVar], Type) 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 -> (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 (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) @@ -682,10 +657,14 @@ tcMultiSplitSigmaTy sigma ----------------------- 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 @@ -817,10 +796,6 @@ tcSplitPredTy_maybe other = Nothing predTyUnique :: PredType -> Unique predTyUnique (IParam n _) = getUnique (ipNameName n) predTyUnique (ClassP clas tys) = getUnique clas - -mkPredName :: Unique -> SrcLoc -> PredType -> Name -mkPredName uniq loc (ClassP cls tys) = mkInternalName uniq (mkDictOcc (getOccName cls)) loc -mkPredName uniq loc (IParam ip ty) = mkInternalName uniq (getOccName (ipNameName ip)) loc \end{code} @@ -844,10 +819,6 @@ getClassPredTys :: PredType -> (Class, [Type]) getClassPredTys (ClassP clas tys) = (clas, tys) getClassPredTys other = panic "getClassPredTys" -isEqPred :: PredType -> Bool -isEqPred (EqPred {}) = True -isEqPred _ = False - mkDictTy :: Class -> [Type] -> Type mkDictTy clas tys = mkPredTy (ClassP clas tys) @@ -875,10 +846,6 @@ isInheritablePred :: PredType -> Bool -- which can be free in g's rhs, and shared by both calls to g isInheritablePred (ClassP _ _) = True isInheritablePred other = False - -isLinearPred :: TcPredType -> Bool -isLinearPred (IParam (Linear n) _) = True -isLinearPred other = False \end{code} --------------------- Equality predicates --------------------------------- @@ -981,9 +948,14 @@ tcTyVarsOfType (NoteTy _ ty) = tcTyVarsOfType ty 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 @@ -1026,11 +998,15 @@ exactTyVarsOfType 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}