X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=db151f1ce4a98fa879aaecfe6a383171d02d1f8a;hp=f266f4badbbfe80b529cd43dbb826bca1d1c949e;hb=654a1ba16e47d3ddabeb74b809ee6097c0770d35;hpb=54c309c0135eaa656f16d3abada41e5392a1fae0 diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index f266f4b..db151f1 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} @@ -58,7 +59,7 @@ module TcType ( --------------------------------- -- Misc type manipulators - deNoteType, classesOfTheta, + deNoteType, tyClsNamesOfType, tyClsNamesOfDFunHead, getDFunTyKey, @@ -68,8 +69,8 @@ module TcType ( isClassPred, isTyVarClassPred, isEqPred, mkDictTy, tcSplitPredTy_maybe, isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique, - mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName, - dataConsStupidTheta, isRefineableTy, + mkClassPred, isInheritablePred, isIPPred, + dataConsStupidTheta, isRefineableTy, isRefineablePred, --------------------------------- -- Foreign import and export @@ -129,71 +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, isOpenTyCon, - synTyConDefn, tyConUnique ) -import DataCon ( DataCon, dataConStupidTheta, dataConResTys ) -import Class ( Class ) -import Var ( TyVar, Id, isCoVar, 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} @@ -336,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 @@ -343,25 +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 - | FamInstSkol TyCon -- Bound at a family 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 @@ -377,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 @@ -442,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") @@ -463,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 @@ -481,27 +445,22 @@ pprSkolTvBinding tv 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 (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"), - 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" @@ -533,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 ) @@ -581,7 +540,7 @@ mkSigmaTy :: [TyVar] -> [PredType] -> Type -> Type mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau) mkPhiTy :: [PredType] -> Type -> Type -mkPhiTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta +mkPhiTy theta ty = foldr (\p r -> mkFunTy (mkPredTy p) r) ty theta \end{code} @isTauTy@ tests for nested for-alls. It should not be called on a boxy type. @@ -610,15 +569,20 @@ 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 isSkolemTyVar (varSetElems (tcTyVarsOfType ty)) +isRigidTy ty = all isImmutableTyVar (varSetElems (tcTyVarsOfType ty)) isRefineableTy :: TcType -> Bool -- A type should have type refinements applied to it if it has -- free type variables, and they are all rigid -isRefineableTy ty = not (null tc_tvs) && all isSkolemTyVar tc_tvs +isRefineableTy ty = not (null tc_tvs) && all isImmutableTyVar tc_tvs where tc_tvs = varSetElems (tcTyVarsOfType ty) +isRefineablePred :: TcPredType -> Bool +isRefineablePred pred = not (null tc_tvs) && all isImmutableTyVar tc_tvs + where + tc_tvs = varSetElems (tcTyVarsOfPred pred) + --------------- getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to -- construct a dictionary function name @@ -698,10 +662,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 @@ -833,10 +801,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} @@ -860,10 +824,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) @@ -890,11 +850,8 @@ isInheritablePred :: PredType -> Bool -- but it doesn't need to be quantified over the Num a dictionary -- which can be free in g's rhs, and shared by both calls to g isInheritablePred (ClassP _ _) = True -isInheritablePred other = False - -isLinearPred :: TcPredType -> Bool -isLinearPred (IParam (Linear n) _) = True -isLinearPred other = False +isInheritablePred (EqPred _ _) = True +isInheritablePred other = False \end{code} --------------------- Equality predicates --------------------------------- @@ -1087,10 +1044,6 @@ tyClsNamesOfDFunHead :: Type -> NameSet tyClsNamesOfDFunHead dfun_ty = case tcSplitSigmaTy dfun_ty of (tvs,_,head_ty) -> tyClsNamesOfType head_ty - -classesOfTheta :: ThetaType -> [Class] --- Looks just for ClassP things; maybe it should check -classesOfTheta preds = [ c | ClassP c _ <- preds ] \end{code}