X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=6b326b0e32f7cf85c8f909d08d0b65b290f35cf8;hb=5479f1a02fae9141c02a7873c57af80323b0fc0d;hp=b1862b70a385a589cb7f59af67df6492a773b481;hpb=6084fb5517da34f65034370a3695e2af3b85ce2b;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index b1862b7..6b326b0 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -41,7 +41,7 @@ module TcType ( -- Splitters -- These are important because they do not look through newtypes tcView, - tcSplitForAllTys, tcSplitPhiTy, + tcSplitForAllTys, tcSplitPhiTy, tcSplitPredFunTy_maybe, tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN, tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs, tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe, @@ -71,7 +71,8 @@ module TcType ( getClassPredTys_maybe, getClassPredTys, isClassPred, isTyVarClassPred, isEqPred, mkDictTy, tcSplitPredTy_maybe, - isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique, + isPredTy, isDictTy, isDictLikeTy, + tcSplitDFunTy, tcSplitDFunHead, predTyUnique, mkClassPred, isInheritablePred, isIPPred, dataConsStupidTheta, isRefineableTy, isRefineablePred, @@ -97,7 +98,7 @@ module TcType ( unliftedTypeKind, liftedTypeKind, argTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, - isSubArgTypeKind, isSubKind, defaultKind, + isSubArgTypeKind, isSubKind, splitKindFunTys, defaultKind, kindVarRef, mkKindVar, Type, PredType(..), ThetaType, @@ -421,7 +422,7 @@ 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 || isSigTyVar tv ) + = ASSERT( isTcTyVar tv && (isSkolemTyVar tv || isSigTyVar tv ) ) (env1, mkTcTyVar (tyVarName tv) (tyVarKind tv) info1) where (env1, info1) = case tcTyVarDetails tv of @@ -508,7 +509,7 @@ isTyConableTyVar tv SkolemTv {} -> False isSkolemTyVar tv - = ASSERT( isTcTyVar tv ) + = ASSERT2( isTcTyVar tv, ppr tv ) case tcTyVarDetails tv of SkolemTv _ -> True MetaTv _ _ -> False @@ -660,16 +661,24 @@ tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty' tcIsForAllTy (ForAllTy tv _) = not (isCoVar tv) tcIsForAllTy _ = 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 +tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type) +-- Split off the first predicate argument from a type +tcSplitPredFunTy_maybe ty | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty' +tcSplitPredFunTy_maybe (ForAllTy tv ty) + | isCoVar tv = Just (coVarPred tv, ty) +tcSplitPredFunTy_maybe (FunTy arg res) + | Just p <- tcSplitPredTy_maybe arg = Just (p, res) +tcSplitPredFunTy_maybe _ + = Nothing - split _ (ForAllTy tv ty) ts - | isCoVar tv = split ty ty (coVarPred tv : ts) - split _ (FunTy arg res) ts - | Just p <- tcSplitPredTy_maybe arg = split res res (p:ts) - split orig_ty _ ts = (reverse ts, orig_ty) +tcSplitPhiTy :: Type -> (ThetaType, Type) +tcSplitPhiTy ty + = split ty [] + where + split ty ts + = case tcSplitPredFunTy_maybe ty of + Just (pred, ty) -> split ty (pred:ts) + Nothing -> (reverse ts, ty) tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type) tcSplitSigmaTy ty = case tcSplitForAllTys ty of @@ -886,8 +895,45 @@ isDictTy :: Type -> Bool isDictTy ty | Just ty' <- tcView ty = isDictTy ty' isDictTy (PredTy p) = isClassPred p isDictTy _ = False + +isDictLikeTy :: Type -> Bool +-- Note [Dictionary-like types] +isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty' +isDictLikeTy (PredTy p) = isClassPred p +isDictLikeTy (TyConApp tc tys) + | isTupleTyCon tc = all isDictLikeTy tys +isDictLikeTy _ = False \end{code} +Note [Dictionary-like types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Being "dictionary-like" means either a dictionary type or a tuple thereof. +In GHC 6.10 we build implication constraints which construct such tuples, +and if we land up with a binding + t :: (C [a], Eq [a]) + t = blah +then we want to treat t as cheap under "-fdicts-cheap" for example. +(Implication constraints are normally inlined, but sadly not if the +occurrence is itself inside an INLINE function! Until we revise the +handling of implication constraints, that is.) This turned out to +be important in getting good arities in DPH code. Example: + + class C a + class D a where { foo :: a -> a } + instance C a => D (Maybe a) where { foo x = x } + + bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b) + {-# INLINE bar #-} + bar x y = (foo (Just x), foo (Just y)) + +Then 'bar' should jolly well have arity 4 (two dicts, two args), but +we ended up with something like + bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ... + in \x,y. ) + +This is all a bit ad-hoc; eg it relies on knowing that implication +constraints build tuples. + --------------------- Implicit parameters --------------------------------- \begin{code} @@ -957,10 +1003,13 @@ isSigmaTy (FunTy a _) = isPredTy a isSigmaTy _ = False isOverloadedTy :: Type -> Bool +-- Yes for a type of a function that might require evidence-passing +-- Used only by bindInstsOfLocalFuns/Pats +-- NB: be sure to check for type with an equality predicate; hence isCoVar isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty' -isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty -isOverloadedTy (FunTy a _) = isPredTy a -isOverloadedTy _ = False +isOverloadedTy (ForAllTy tv ty) = isCoVar tv || isOverloadedTy ty +isOverloadedTy (FunTy a _) = isPredTy a +isOverloadedTy _ = False isPredTy :: Type -> Bool -- Belongs in TcType because it does -- not look through newtypes, or predtypes (of course) @@ -999,8 +1048,9 @@ is_tc uniq ty = case tcSplitTyConApp_maybe ty of -- hence no 'coreView'. This could, however, be changed without breaking -- any code. isOpenSynTyConApp :: TcTauType -> Bool -isOpenSynTyConApp (TyConApp tc _) = isOpenSynTyCon tc -isOpenSynTyConApp _other = False +isOpenSynTyConApp (TyConApp tc tys) = isOpenSynTyCon tc && + length tys == tyConArity tc +isOpenSynTyConApp _other = False \end{code} @@ -1250,14 +1300,19 @@ toDNType ty ] checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool - -- Look through newtypes - -- Non-recursive ones are transparent to splitTyConApp, - -- but recursive ones aren't. Manuel had: - -- newtype T = MkT (Ptr T) - -- and wanted it to work... -checkRepTyCon check_tc ty - | Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc - | otherwise = False +-- Look through newtypes, but *not* foralls +-- Should work even for recursive newtypes +-- eg Manuel had: newtype T = MkT (Ptr T) +checkRepTyCon check_tc ty + = go [] ty + where + go rec_nts ty + | Just (tc,tys) <- splitTyConApp_maybe ty + = case carefullySplitNewType_maybe rec_nts tc tys of + Just (rec_nts', ty') -> go rec_nts' ty' + Nothing -> check_tc tc + | otherwise + = False checkRepTyConKey :: [Unique] -> Type -> Bool -- Like checkRepTyCon, but just looks at the TyCon key