X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=24cf3f8722b911aa6a2e6d514c6293731b32db21;hb=a13551ce57c67a333f41f0a6fe7e05a09d0c3614;hp=60474b1f6ce233fc5179b45222dcaa910781dc82;hpb=2423c249f5ca7785d0ec89eb33e72662da7561c1;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 60474b1..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,12 +55,12 @@ module TcType ( eqKind, isSigmaTy, isOverloadedTy, isRigidTy, isBoxyTy, isDoubleTy, isFloatTy, isIntTy, isStringTy, - isIntegerTy, isBoolTy, isUnitTy, + isIntegerTy, isBoolTy, isUnitTy, isCharTy, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, --------------------------------- -- Misc type manipulators - deNoteType, classesOfTheta, + deNoteType, tyClsNamesOfType, tyClsNamesOfDFunHead, getDFunTyKey, @@ -108,7 +109,7 @@ module TcType ( mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst, getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, lookupTyVar, extendTvSubst, extendTvSubstList, isInScope, mkTvSubst, zipTyEnv, - substTy, substTys, substTyWith, substTheta, substTyVar, substTyVarBndr, + substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars, substTyVarBndr, isUnLiftedType, -- Source types are always lifted isUnboxedTupleType, -- Ditto @@ -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 @@ -540,7 +562,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. @@ -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 @@ -850,7 +879,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 +isInheritablePred (EqPred _ _) = True +isInheritablePred other = False \end{code} --------------------- Equality predicates --------------------------------- @@ -873,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} @@ -920,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 @@ -1043,10 +1079,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} @@ -1117,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