X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=727d0abe7e0a94f83c3b2e65da2ad1d059122f47;hp=a4d43dc448d6dcd81c22e2c9231a6f11f20824be;hb=6fcf90065dc4e75b7dc6bbf238a9891a71ae5a86;hpb=6bca92c3f75df35fcb2ec23d56107783373da7e6 diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index a4d43dc..727d0ab 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -42,7 +42,7 @@ module TcType ( 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, @@ -50,9 +50,10 @@ module TcType ( -- Predicates. -- Again, newtypes are opaque tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX, + eqKind, isSigmaTy, isOverloadedTy, isRigidTy, isBoxyTy, isDoubleTy, isFloatTy, isIntTy, isStringTy, - isIntegerTy, isAddrTy, isBoolTy, isUnitTy, + isIntegerTy, isBoolTy, isUnitTy, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, --------------------------------- @@ -64,7 +65,7 @@ module TcType ( --------------------------------- -- Predicate types getClassPredTys_maybe, getClassPredTys, - isClassPred, isTyVarClassPred, + isClassPred, isTyVarClassPred, isEqPred, mkDictTy, tcSplitPredTy_maybe, isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique, mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName, @@ -88,10 +89,11 @@ module TcType ( -------------------------------- -- 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, @@ -101,7 +103,7 @@ module TcType ( -- 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, @@ -127,16 +129,17 @@ module TcType ( #include "HsVersions.h" -- friends: -import TypeRep ( Type(..), funTyCon ) -- friend +import TypeRep ( Type(..), funTyCon, Kind ) -- friend import Type ( -- Re-exports tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, - tyVarsOfTheta, Kind, PredType(..), - ThetaType, unliftedTypeKind, unboxedTypeKind, + tyVarsOfTheta, Kind, PredType(..), KindVar, + ThetaType, isUnliftedTypeKind, unliftedTypeKind, + argTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, - isLiftedTypeKind, isUnliftedTypeKind, + tySuperKind, isLiftedTypeKind, mkArrowKinds, mkForAllTy, mkForAllTys, - defaultKind, isArgTypeKind, isOpenTypeKind, + defaultKind, isSubArgTypeKind, isSubOpenTypeKind, mkFunTy, mkFunTys, zipFunTys, mkTyConApp, mkAppTy, mkAppTys, applyTy, applyTys, @@ -151,7 +154,7 @@ import Type ( -- Re-exports isSubKind, tcView, tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, - tcEqPred, tcCmpPred, tcEqTypeX, + tcEqPred, tcCmpPred, tcEqTypeX, eqKind, TvSubst(..), TvSubstEnv, emptyTvSubst, mkTvSubst, zipTyEnv, @@ -161,30 +164,31 @@ import Type ( -- Re-exports substTy, substTys, substTyWith, substTheta, substTyVar, substTyVarBndr, substPred, lookupTyVar, - typeKind, repType, coreView, + typeKind, repType, coreView, repSplitAppTy_maybe, pprKind, pprParendKind, pprType, pprParendType, pprTyThingCategory, pprPred, pprTheta, pprThetaArrow, pprClassPred ) import TyCon ( TyCon, isUnLiftedTyCon, isSynTyCon, synTyConDefn, tyConUnique ) +import Coercion ( splitForAllCo_maybe ) import DataCon ( DataCon, dataConStupidTheta, dataConResTys ) import Class ( Class ) -import Var ( TyVar, Id, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails ) -import ForeignCall ( Safety, playSafe, DNType(..) ) +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 SrcLoc ( SrcLoc, SrcSpan ) -import Util ( snocView, equalLength ) +import Util ( equalLength ) import Maybes ( maybeToBool, expectJust, mapCatMaybes ) import ListSetOps ( hasNoDups ) import List ( nubBy ) @@ -284,14 +288,14 @@ 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 would 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. +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 +bindings and mutually recursive function bindings. See the function +TcBinds.tcInstSig, and its use_skols parameter. \begin{code} @@ -385,6 +389,31 @@ data UserTypeCtxt -- 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 = + 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} %************************************************************************ @@ -420,15 +449,23 @@ pprUserTypeCtxt SpecInstCtxt = ptext SLIT("a SPECIALISE instance pragma") tidySkolemTyVar :: TidyEnv -> TcTyVar -> (TidyEnv, TcTyVar) -- Tidy the type inside a GenSkol, preparatory to printing it tidySkolemTyVar env tv - = ASSERT( isSkolemTyVar tv ) + = ASSERT( isSkolemTyVar tv || isSigTyVar 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)) + 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 loc) = (env2, GenSkol tvs1 ty1 loc) where (env1, tvs1) = tidyOpenTyVars env tvs (env2, ty1) = tidyOpenType env1 ty - info -> (env, info) + tidy_skol_info env info = (env, info) pprSkolTvBinding :: TcTyVar -> SDoc -- Print info about the binding of a skolem tyvar, @@ -532,6 +569,7 @@ isIndirect other = False %************************************************************************ \begin{code} +mkSigmaTy :: [TyVar] -> [PredType] -> Type -> Type mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau) mkPhiTy :: [PredType] -> Type -> Type @@ -605,22 +643,25 @@ 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 (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 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 (FunTy arg res) ts + | Just p <- tcSplitPredTy_maybe arg = split res res (p:ts) + split orig_ty ty ts + | Just (p, ty') <- splitForAllCo_maybe ty = split ty' ty' (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) @@ -692,20 +733,16 @@ tcSplitFunTysN ty n_args | 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) @@ -742,6 +779,7 @@ tcSplitDFunHead :: Type -> (Class, [Type]) 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 @@ -808,6 +846,11 @@ getClassPredTys_maybe _ = Nothing 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) @@ -842,6 +885,13 @@ isLinearPred (IParam (Linear n) _) = True isLinearPred other = False \end{code} +--------------------- 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) --------------------------------- \begin{code} @@ -861,6 +911,7 @@ dataConsStupidTheta (con1:cons) | con <- cons , let Just subst = tcMatchTys tvs1 res_tys1 (dataConResTys con) , pred <- dataConStupidTheta con ] +dataConsStupidTheta [] = panic "dataConsStupidTheta" \end{code} @@ -899,7 +950,6 @@ isFloatTy = is_tc floatTyConKey isDoubleTy = is_tc doubleTyConKey isIntegerTy = is_tc integerTyConKey isIntTy = is_tc intTyConKey -isAddrTy = is_tc addrTyConKey isBoolTy = is_tc boolTyConKey isUnitTy = is_tc unitTyConKey @@ -926,7 +976,8 @@ deNoteType ty = ty \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 @@ -941,8 +992,9 @@ 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] @@ -967,7 +1019,7 @@ smart-app checking code --- see TcExpr.tcIdApp \begin{code} exactTyVarsOfType :: TcType -> TyVarSet -- Find the free type variables (of any kind) --- but *expand* type synonyms. See Note [Silly type synonym] belos. +-- but *expand* type synonyms. See Note [Silly type synonym] above. exactTyVarsOfType ty = go ty where @@ -979,8 +1031,9 @@ exactTyVarsOfType ty go (AppTy fun arg) = go fun `unionVarSet` go arg go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar - go_pred (IParam _ ty) = go ty - go_pred (ClassP _ tys) = exactTyVarsOfTypes tys + go_pred (IParam _ ty) = go ty + go_pred (ClassP _ tys) = exactTyVarsOfTypes tys + go_pred (EqPred ty1 ty2) = go ty1 `unionVarSet` go ty2 exactTyVarsOfTypes :: [TcType] -> TyVarSet exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys @@ -996,6 +1049,7 @@ tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNa 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 @@ -1070,17 +1124,17 @@ isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty isFFIDynArgumentTy :: Type -> Bool -- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr, -- or a newtype of either. -isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey] +isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey] isFFIDynResultTy :: Type -> Bool -- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr, -- or a newtype of either. -isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey] +isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey] isFFILabelTy :: Type -> Bool -- The type of a foreign label must be Ptr, FunPtr, Addr, -- or a newtype of either. -isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey] +isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey] isFFIDotnetTy :: DynFlags -> Type -> Bool isFFIDotnetTy dflags ty @@ -1110,12 +1164,14 @@ 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 (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) @@ -1131,7 +1187,6 @@ toDNType ty , (word64TyConKey, DNWord64) , (floatTyConKey, DNFloat) , (doubleTyConKey, DNDouble) - , (addrTyConKey, DNPtr) , (ptrTyConKey, DNPtr) , (funPtrTyConKey, DNPtr) , (charTyConKey, DNChar) @@ -1195,7 +1250,7 @@ boxedMarshalableTyCon tc , wordTyConKey, word8TyConKey, word16TyConKey , word32TyConKey, word64TyConKey , floatTyConKey, doubleTyConKey - , addrTyConKey, ptrTyConKey, funPtrTyConKey + , ptrTyConKey, funPtrTyConKey , charTyConKey , stablePtrTyConKey , boolTyConKey