X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=24cf3f8722b911aa6a2e6d514c6293731b32db21;hb=a13551ce57c67a333f41f0a6fe7e05a09d0c3614;hp=eee6df90329b92d69c0a18484df412343131f30f;hpb=84923cc7de2a93c22a2f72daf9ac863959efae13;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index eee6df9..24cf3f8 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -28,7 +28,8 @@ module TcType ( UserTypeCtxt(..), pprUserTypeCtxt, TcTyVarDetails(..), BoxInfo(..), pprTcTyVarDetails, MetaDetails(Flexi, Indirect), SkolemInfo(..), pprSkolTvBinding, pprSkolInfo, - isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isBoxyTyVar, isSigTyVar, isExistentialTyVar, + isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isBoxyTyVar, + isSigTyVar, isExistentialTyVar, isTyConableTyVar, metaTvRef, isFlexi, isIndirect, @@ -54,7 +55,7 @@ module TcType ( eqKind, isSigmaTy, isOverloadedTy, isRigidTy, isBoxyTy, isDoubleTy, isFloatTy, isIntTy, isStringTy, - isIntegerTy, isBoolTy, isUnitTy, + isIntegerTy, isBoolTy, isUnitTy, isCharTy, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, --------------------------------- @@ -122,7 +123,7 @@ module TcType ( tcTyVarsOfType, tcTyVarsOfTypes, exactTyVarsOfType, exactTyVarsOfTypes, pprKind, pprParendKind, - pprType, pprParendType, pprTyThingCategory, + pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprPred, pprTheta, pprThetaArrow, pprClassPred ) where @@ -322,6 +323,9 @@ data SkolemInfo | GenSkol [TcTyVar] -- Bound when doing a subsumption check for TcType -- (forall tvs. ty) + | RuntimeUnkSkol -- a type variable used to represent an unknown + -- runtime type (used in the GHCi debugger) + | UnkSkol -- Unhelpful info (until I improve it) ------------------------------------- @@ -438,16 +442,18 @@ pprSkolTvBinding :: TcTyVar -> SDoc -- or nothing if we don't have anything useful to say pprSkolTvBinding tv = ASSERT ( isTcTyVar tv ) - ppr_details (tcTyVarDetails tv) + quotes (ppr 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 TauTv _) = ptext SLIT("is a meta type variable") + ppr_details (MetaTv BoxTv _) = 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 info = quotes (ppr tv) <+> ptext SLIT("is bound by") - <+> sep [pprSkolInfo info, nest 2 (ptext SLIT("at") <+> ppr (getSrcLoc tv))] + ppr_skol UnkSkol = empty -- Unhelpful; omit + ppr_skol RuntimeUnkSkol = ptext SLIT("is an unknown runtime type") + ppr_skol info = sep [ptext SLIT("is a rigid type variable bound by"), + sep [pprSkolInfo info, + nest 2 (ptext SLIT("at") <+> ppr (getSrcLoc tv))]] pprSkolInfo :: SkolemInfo -> SDoc pprSkolInfo (SigSkol ctxt) = pprUserTypeCtxt ctxt @@ -464,6 +470,7 @@ pprSkolInfo (GenSkol tvs ty) = sep [ptext SLIT("the polymorphic type"), -- For type variables the others are dealt with by pprSkolTvBinding. -- For Insts, these cases should not happen pprSkolInfo UnkSkol = panic "UnkSkol" +pprSkolInfo RuntimeUnkSkol = panic "RuntimeUnkSkol" instance Outputable MetaDetails where ppr Flexi = ptext SLIT("Flexi") @@ -478,11 +485,26 @@ instance Outputable MetaDetails where %************************************************************************ \begin{code} -isImmutableTyVar, isSkolemTyVar, isExistentialTyVar, isBoxyTyVar, isMetaTyVar :: TyVar -> Bool +isImmutableTyVar :: TyVar -> Bool + isImmutableTyVar tv | isTcTyVar tv = isSkolemTyVar tv | otherwise = True +isTyConableTyVar, isSkolemTyVar, isExistentialTyVar, + isBoxyTyVar, isMetaTyVar :: TcTyVar -> Bool + +isTyConableTyVar tv + -- True of a meta-type variable tha can be filled in + -- with a type constructor application; in particular, + -- not a SigTv + = ASSERT( isTcTyVar tv) + case tcTyVarDetails tv of + MetaTv BoxTv _ -> True + MetaTv TauTv _ -> True + MetaTv (SigTv {}) _ -> False + SkolemTv {} -> False + isSkolemTyVar tv = ASSERT( isTcTyVar tv ) case tcTyVarDetails tv of @@ -560,8 +582,8 @@ isTauTy other = False isTauTyCon :: TyCon -> Bool -- Returns False for type synonyms whose expansion is a polytype isTauTyCon tc - | isSynTyCon tc && not (isOpenTyCon tc) = isTauTy (snd (synTyConDefn tc)) - | otherwise = True + | isClosedSynTyCon tc = isTauTy (snd (synTyConDefn tc)) + | otherwise = True --------------- isBoxyTy :: TcType -> Bool @@ -694,9 +716,16 @@ tcSplitFunTys ty = case tcSplitFunTy_maybe ty of (args,res') = tcSplitFunTys res tcSplitFunTy_maybe :: Type -> Maybe (Type, Type) -tcSplitFunTy_maybe ty | Just ty' <- tcView ty = tcSplitFunTy_maybe ty' -tcSplitFunTy_maybe (FunTy arg res) = Just (arg, res) -tcSplitFunTy_maybe other = Nothing +tcSplitFunTy_maybe ty | Just ty' <- tcView ty = tcSplitFunTy_maybe ty' +tcSplitFunTy_maybe (FunTy arg res) | not (isPredTy arg) = Just (arg, res) +tcSplitFunTy_maybe other = Nothing + -- Note the (not (isPredTy arg)) guard + -- Consider (?x::Int) => Bool + -- We don't want to treat this as a function type! + -- A concrete example is test tc230: + -- f :: () -> (?p :: ()) => () -> () + -- + -- g = f () () tcSplitFunTysN :: TcRhoType @@ -874,11 +903,11 @@ dataConsStupidTheta (con1:cons) = nubBy tcEqPred all_preds where all_preds = dataConStupidTheta con1 ++ other_stupids - res_tys1 = dataConResTys con1 - tvs1 = tyVarsOfTypes res_tys1 + res_ty1 = dataConOrigResTy con1 other_stupids = [ substPred subst pred | con <- cons - , let Just subst = tcMatchTys tvs1 res_tys1 (dataConResTys con) + , let (tvs, _, _, res_ty) = dataConSig con + Just subst = tcMatchTy (mkVarSet tvs) res_ty res_ty1 , pred <- dataConStupidTheta con ] dataConsStupidTheta [] = panic "dataConsStupidTheta" \end{code} @@ -921,6 +950,12 @@ isIntegerTy = is_tc integerTyConKey isIntTy = is_tc intTyConKey isBoolTy = is_tc boolTyConKey isUnitTy = is_tc unitTyConKey +isCharTy = is_tc charTyConKey + +isStringTy ty + = case tcSplitTyConApp_maybe ty of + Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty + other -> False is_tc :: Unique -> Type -> Bool -- Newtypes are opaque to this @@ -1114,18 +1149,10 @@ isFFIDotnetTy :: DynFlags -> Type -> Bool isFFIDotnetTy dflags ty = checkRepTyCon (\ tc -> (legalFIResultTyCon dflags tc || isFFIDotnetObjTy ty || isStringTy ty)) ty + -- NB: isStringTy used to look through newtypes, but + -- it no longer does so. May need to adjust isFFIDotNetTy + -- if we do want to look through newtypes. --- Support String as an argument or result from a .NET FFI call. -isStringTy ty = - case tcSplitTyConApp_maybe (repType ty) of - Just (tc, [arg_ty]) - | tc == listTyCon -> - case tcSplitTyConApp_maybe (repType arg_ty) of - Just (cc,[]) -> cc == charTyCon - _ -> False - _ -> False - --- Support String as an argument or result from a .NET FFI call. isFFIDotnetObjTy ty = let (_, t_ty) = tcSplitForAllTys ty