X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=dad167cabdd5d1184e918d8081a46fba27205f21;hp=636ee0ea696c012a1822aa3323ea2efafc3dea38;hb=72462499b891d5779c19f3bda03f96e24f9554ae;hpb=b279a3fc517ee355844223758ef026e108535e57 diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 636ee0e..dad167c 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -15,13 +15,6 @@ The "tc" prefix is for "TypeChecker", because the type checker is the principal client. \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module TcType ( -------------------------------- -- Types @@ -48,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, @@ -62,7 +55,7 @@ module TcType ( tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX, eqKind, isSigmaTy, isOverloadedTy, isRigidTy, isBoxyTy, - isDoubleTy, isFloatTy, isIntTy, isStringTy, + isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, isIntegerTy, isBoolTy, isUnitTy, isCharTy, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, isOpenSynTyConApp, @@ -78,9 +71,10 @@ 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, + isRefineableTy, isRefineablePred, --------------------------------- -- Foreign import and export @@ -90,12 +84,14 @@ module TcType ( isFFIExternalTy, -- :: Type -> Bool isFFIDynArgumentTy, -- :: Type -> Bool isFFIDynResultTy, -- :: Type -> Bool + isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool + isFFIPrimResultTy, -- :: DynFlags -> Type -> Bool isFFILabelTy, -- :: Type -> Bool isFFIDotnetTy, -- :: DynFlags -> Type -> Bool isFFIDotnetObjTy, -- :: Type -> Bool isFFITy, -- :: Type -> Bool + isFunPtrTy, -- :: Type -> Bool tcSplitIOType_maybe, -- :: Type -> Maybe Type - toDNType, -- :: Type -> DNType -------------------------------- -- Rexported from Type @@ -103,7 +99,7 @@ module TcType ( unliftedTypeKind, liftedTypeKind, argTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, - isSubArgTypeKind, isSubKind, defaultKind, + isSubArgTypeKind, isSubKind, splitKindFunTys, defaultKind, kindVarRef, mkKindVar, Type, PredType(..), ThetaType, @@ -129,7 +125,8 @@ module TcType ( typeKind, tidyKind, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, - tcTyVarsOfType, tcTyVarsOfTypes, exactTyVarsOfType, exactTyVarsOfTypes, + tcTyVarsOfType, tcTyVarsOfTypes, tcTyVarsOfPred, exactTyVarsOfType, + exactTyVarsOfTypes, pprKind, pprParendKind, pprType, pprParendType, pprTypeApp, pprTyThingCategory, @@ -145,7 +142,6 @@ import DataCon import Class import Var import ForeignCall -import Unify import VarSet import Type import Coercion @@ -153,11 +149,9 @@ import TyCon -- others: import DynFlags -import CoreSyn import Name import NameSet import VarEnv -import OccName import PrelNames import TysWiredIn import BasicTypes @@ -165,8 +159,8 @@ import Util import Maybes import ListSetOps import Outputable +import FastString -import Data.List import Data.IORef \end{code} @@ -358,6 +352,7 @@ data UserTypeCtxt | ForSigCtxt Name -- Foreign inport or export signature | DefaultDeclCtxt -- Types in a default declaration | SpecInstCtxt -- SPECIALISE instance pragma + | ThBrackCtxt -- Template Haskell type brackets [t| ... |] -- Notes re TySynCtxt -- We allow type synonyms that aren't types; e.g. type List = [] @@ -380,7 +375,7 @@ kindVarRef tc = ASSERT ( isTcTyVar tc ) case tcTyVarDetails tc of MetaTv TauTv ref -> ref - other -> pprPanic "kindVarRef" (ppr tc) + _ -> pprPanic "kindVarRef" (ppr tc) mkKindVar :: Unique -> IORef MetaDetails -> KindVar mkKindVar u r @@ -404,30 +399,31 @@ kind_var_occ = mkOccName tvName "k" \begin{code} pprTcTyVarDetails :: TcTyVarDetails -> SDoc -- For debugging -pprTcTyVarDetails (SkolemTv _) = ptext SLIT("sk") -pprTcTyVarDetails (MetaTv BoxTv _) = ptext SLIT("box") -pprTcTyVarDetails (MetaTv TauTv _) = ptext SLIT("tau") -pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext SLIT("sig") +pprTcTyVarDetails (SkolemTv _) = ptext (sLit "sk") +pprTcTyVarDetails (MetaTv BoxTv _) = ptext (sLit "box") +pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau") +pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext (sLit "sig") pprUserTypeCtxt :: UserTypeCtxt -> SDoc -pprUserTypeCtxt (FunSigCtxt n) = ptext SLIT("the type signature for") <+> quotes (ppr n) -pprUserTypeCtxt ExprSigCtxt = ptext SLIT("an expression type signature") -pprUserTypeCtxt (ConArgCtxt c) = ptext SLIT("the type of the constructor") <+> quotes (ppr c) -pprUserTypeCtxt (TySynCtxt c) = ptext SLIT("the RHS of the type synonym") <+> quotes (ppr c) -pprUserTypeCtxt GenPatCtxt = ptext SLIT("the type pattern of a generic definition") -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 DefaultDeclCtxt = ptext SLIT("a type in a `default' declaration") -pprUserTypeCtxt SpecInstCtxt = ptext SLIT("a SPECIALISE instance pragma") +pprUserTypeCtxt (FunSigCtxt n) = ptext (sLit "the type signature for") <+> quotes (ppr n) +pprUserTypeCtxt ExprSigCtxt = ptext (sLit "an expression type signature") +pprUserTypeCtxt (ConArgCtxt c) = ptext (sLit "the type of the constructor") <+> quotes (ppr c) +pprUserTypeCtxt (TySynCtxt c) = ptext (sLit "the RHS of the type synonym") <+> quotes (ppr c) +pprUserTypeCtxt GenPatCtxt = ptext (sLit "the type pattern of a generic definition") +pprUserTypeCtxt ThBrackCtxt = ptext (sLit "a Template Haskell quotation [t|...|]") +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 DefaultDeclCtxt = ptext (sLit "a type in a `default' declaration") +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 @@ -452,26 +448,26 @@ pprSkolTvBinding tv = ASSERT ( isTcTyVar tv ) quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv) where - 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 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 = ptext SLIT("is an unknown type variable") -- Unhelpful - ppr_skol RuntimeUnkSkol = ptext SLIT("is an unknown runtime type") - ppr_skol info = sep [ptext SLIT("is a rigid type variable bound by"), + ppr_skol UnkSkol = ptext (sLit "is an unknown type variable") -- Unhelpful + 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))]] + nest 2 (ptext (sLit "at") <+> ppr (getSrcLoc tv))]] pprSkolInfo :: SkolemInfo -> SDoc 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"), +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 @@ -481,8 +477,8 @@ pprSkolInfo UnkSkol = panic "UnkSkol" pprSkolInfo RuntimeUnkSkol = panic "RuntimeUnkSkol" instance Outputable MetaDetails where - ppr Flexi = ptext SLIT("Flexi") - ppr (Indirect ty) = ptext SLIT("Indirect") <+> ppr ty + ppr Flexi = ptext (sLit "Flexi") + ppr (Indirect ty) = ptext (sLit "Indirect") <+> ppr ty \end{code} @@ -514,7 +510,7 @@ isTyConableTyVar tv SkolemTv {} -> False isSkolemTyVar tv - = ASSERT( isTcTyVar tv ) + = ASSERT2( isTcTyVar tv, ppr tv ) case tcTyVarDetails tv of SkolemTv _ -> True MetaTv _ _ -> False @@ -523,39 +519,40 @@ isExistentialTyVar tv -- Existential type variable, bound by a pattern = ASSERT( isTcTyVar tv ) case tcTyVarDetails tv of SkolemTv (PatSkol {}) -> True - other -> False + _ -> False isMetaTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) case tcTyVarDetails tv of MetaTv _ _ -> True - other -> False + _ -> False isBoxyTyVar tv = ASSERT( isTcTyVar tv ) case tcTyVarDetails tv of MetaTv BoxTv _ -> True - other -> False + _ -> False +isSigTyVar :: Var -> Bool isSigTyVar tv = ASSERT( isTcTyVar tv ) case tcTyVarDetails tv of MetaTv (SigTv _) _ -> True - other -> False + _ -> False metaTvRef :: TyVar -> IORef MetaDetails metaTvRef tv = ASSERT2( isTcTyVar tv, ppr tv ) case tcTyVarDetails tv of MetaTv _ ref -> ref - other -> pprPanic "metaTvRef" (ppr tv) + _ -> pprPanic "metaTvRef" (ppr tv) isFlexi, isIndirect :: MetaDetails -> Bool -isFlexi Flexi = True -isFlexi other = False +isFlexi Flexi = True +isFlexi _ = False isIndirect (Indirect _) = True -isIndirect other = False +isIndirect _ = False isRuntimeUnk :: TyVar -> Bool isRuntimeUnk x | isTcTyVar x @@ -593,8 +590,8 @@ isTauTy (TyVarTy tv) = ASSERT( not (isTcTyVar tv && isBoxyTyVar tv) ) isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc isTauTy (AppTy a b) = isTauTy a && isTauTy b isTauTy (FunTy a b) = isTauTy a && isTauTy b -isTauTy (PredTy p) = True -- Don't look through source types -isTauTy other = False +isTauTy (PredTy _) = True -- Don't look through source types +isTauTy _ = False isTauTyCon :: TyCon -> Bool @@ -630,7 +627,7 @@ getDFunTyKey ty | Just ty' <- tcView ty = getDFunTyKey ty' getDFunTyKey (TyVarTy tv) = getOccName tv getDFunTyKey (TyConApp tc _) = getOccName tc getDFunTyKey (AppTy fun _) = getDFunTyKey fun -getDFunTyKey (FunTy arg _) = getOccName funTyCon +getDFunTyKey (FunTy _ _) = getOccName funTyCon getDFunTyKey (ForAllTy _ t) = getDFunTyKey t getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty) -- PredTy shouldn't happen @@ -646,7 +643,6 @@ getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty) These tcSplit functions are like their non-Tc analogues, but a) they do not look through newtypes b) they do not look through PredTys - c) [future] they ignore usage-type annotations However, they are non-monadic and do not follow through mutable type variables. It's up to you to make sure this doesn't matter. @@ -656,26 +652,33 @@ 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 _ (ForAllTy tv ty) tvs | not (isCoVar tv) = split ty ty (tv:tvs) - split orig_ty t tvs = (reverse tvs, orig_ty) + split orig_ty _ tvs = (reverse tvs, orig_ty) +tcIsForAllTy :: Type -> Bool tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty' -tcIsForAllTy (ForAllTy tv ty) = not (isCoVar tv) -tcIsForAllTy t = False +tcIsForAllTy (ForAllTy tv _) = not (isCoVar tv) +tcIsForAllTy _ = False + +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 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 (ForAllTy tv ty) ts - | isCoVar tv = split ty ty (eq_pred:ts) - where - PredTy eq_pred = tyVarKind tv - split orig_ty (FunTy arg res) ts - | Just p <- tcSplitPredTy_maybe arg = split res res (p:ts) - split orig_ty ty ts = (reverse ts, orig_ty) +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 @@ -696,7 +699,7 @@ tcMultiSplitSigmaTy tcMultiSplitSigmaTy sigma = case (tcSplitSigmaTy sigma) of - ([],[],ty) -> ([], sigma) + ([], [], _) -> ([], sigma) (tvs, theta, ty) -> case tcMultiSplitSigmaTy ty of (pairs, rest) -> ((tvs,theta):pairs, rest) @@ -723,7 +726,7 @@ tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res]) -- Newtypes are opaque, so they may be split -- However, predicates are not treated -- as tycon applications by the type checker -tcSplitTyConApp_maybe other = Nothing +tcSplitTyConApp_maybe _ = Nothing ----------------------- tcSplitFunTys :: Type -> ([Type], Type) @@ -736,7 +739,7 @@ tcSplitFunTys ty = case tcSplitFunTy_maybe ty of tcSplitFunTy_maybe :: Type -> Maybe (Type, Type) 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 +tcSplitFunTy_maybe _ = Nothing -- Note the (not (isPredTy arg)) guard -- Consider (?x::Int) => Bool -- We don't want to treat this as a function type! @@ -760,8 +763,13 @@ tcSplitFunTysN ty n_args | otherwise = ([], ty) +tcSplitFunTy :: Type -> (Type, Type) tcSplitFunTy ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty) + +tcFunArgTy :: Type -> Type tcFunArgTy ty = fst (tcSplitFunTy ty) + +tcFunResultTy :: Type -> Type tcFunResultTy ty = snd (tcSplitFunTy ty) ----------------------- @@ -785,8 +793,8 @@ tcSplitAppTys ty ----------------------- tcGetTyVar_maybe :: Type -> Maybe TyVar tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty' -tcGetTyVar_maybe (TyVarTy tv) = Just tv -tcGetTyVar_maybe other = Nothing +tcGetTyVar_maybe (TyVarTy tv) = Just tv +tcGetTyVar_maybe _ = Nothing tcGetTyVar :: String -> Type -> TyVar tcGetTyVar msg ty = expectJust msg (tcGetTyVar_maybe ty) @@ -795,18 +803,29 @@ tcIsTyVarTy :: Type -> Bool tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty) ----------------------- -tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type]) +tcSplitDFunTy :: Type -> ([TyVar], Class, [Type]) -- Split the type of a dictionary function +-- We don't use tcSplitSigmaTy, because a DFun may (with NDP) +-- have non-Pred arguments, such as +-- df :: forall m. (forall b. Eq b => Eq (m b)) -> C m tcSplitDFunTy ty - = case tcSplitSigmaTy ty of { (tvs, theta, tau) -> - case tcSplitDFunHead tau of { (clas, tys) -> - (tvs, theta, clas, tys) }} + = case tcSplitForAllTys ty of { (tvs, rho) -> + case tcSplitDFunHead (drop_pred_tys rho) of { (clas, tys) -> + (tvs, clas, tys) }} + where + -- Discard the context of the dfun. This can be a mix of + -- coercion and class constraints; or (in the general NDP case) + -- some other function argument + drop_pred_tys ty | Just ty' <- tcView ty = drop_pred_tys ty' + drop_pred_tys (ForAllTy tv ty) = ASSERT( isCoVar tv ) drop_pred_tys ty + drop_pred_tys (FunTy _ ty) = drop_pred_tys ty + drop_pred_tys ty = ty tcSplitDFunHead :: Type -> (Class, [Type]) tcSplitDFunHead tau = case tcSplitPredTy_maybe tau of Just (ClassP clas tys) -> (clas, tys) - other -> panic "tcSplitDFunHead" + _ -> pprPanic "tcSplitDFunHead" (ppr tau) tcInstHeadTyNotSynonym :: Type -> Bool -- Used in Haskell-98 mode, for the argument types of an instance head @@ -814,8 +833,7 @@ tcInstHeadTyNotSynonym :: Type -> Bool -- are transparent, so we need a special function here tcInstHeadTyNotSynonym ty = case ty of - NoteTy _ ty -> tcInstHeadTyNotSynonym ty - TyConApp tc tys -> not (isSynTyCon tc) + TyConApp tc _ -> not (isSynTyCon tc) _ -> True tcInstHeadTyAppAllTyVars :: Type -> Bool @@ -823,10 +841,9 @@ tcInstHeadTyAppAllTyVars :: Type -> Bool -- These must be a constructor applied to type variable arguments tcInstHeadTyAppAllTyVars ty = case ty of - NoteTy _ ty -> tcInstHeadTyAppAllTyVars ty TyConApp _ tys -> ok tys FunTy arg res -> ok [arg, res] - other -> False + _ -> False where -- Check that all the types are type variables, -- and that each is distinct @@ -834,9 +851,8 @@ tcInstHeadTyAppAllTyVars ty where tvs = mapCatMaybes get_tv tys - get_tv (NoteTy _ ty) = get_tv ty -- Again, do not look get_tv (TyVarTy tv) = Just tv -- through synonyms - get_tv other = Nothing + get_tv _ = Nothing \end{code} @@ -852,34 +868,36 @@ tcSplitPredTy_maybe :: Type -> Maybe PredType -- Returns Just for predicates only tcSplitPredTy_maybe ty | Just ty' <- tcView ty = tcSplitPredTy_maybe ty' tcSplitPredTy_maybe (PredTy p) = Just p -tcSplitPredTy_maybe other = Nothing - +tcSplitPredTy_maybe _ = Nothing + predTyUnique :: PredType -> Unique -predTyUnique (IParam n _) = getUnique (ipNameName n) -predTyUnique (ClassP clas tys) = getUnique clas -predTyUnique (EqPred a b) = pprPanic "predTyUnique" (ppr (EqPred a b)) +predTyUnique (IParam n _) = getUnique (ipNameName n) +predTyUnique (ClassP clas _) = getUnique clas +predTyUnique (EqPred a b) = pprPanic "predTyUnique" (ppr (EqPred a b)) \end{code} --------------------- Dictionary types --------------------------------- \begin{code} +mkClassPred :: Class -> [Type] -> PredType mkClassPred clas tys = ClassP clas tys isClassPred :: PredType -> Bool -isClassPred (ClassP clas tys) = True -isClassPred other = False +isClassPred (ClassP _ _) = True +isClassPred _ = False -isTyVarClassPred (ClassP clas tys) = all tcIsTyVarTy tys -isTyVarClassPred other = False +isTyVarClassPred :: PredType -> Bool +isTyVarClassPred (ClassP _ tys) = all tcIsTyVarTy tys +isTyVarClassPred _ = False getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys) -getClassPredTys_maybe _ = Nothing +getClassPredTys_maybe _ = Nothing getClassPredTys :: PredType -> (Class, [Type]) getClassPredTys (ClassP clas tys) = (clas, tys) -getClassPredTys other = panic "getClassPredTys" +getClassPredTys _ = panic "getClassPredTys" mkDictTy :: Class -> [Type] -> Type mkDictTy clas tys = mkPredTy (ClassP clas tys) @@ -887,15 +905,52 @@ mkDictTy clas tys = mkPredTy (ClassP clas tys) isDictTy :: Type -> Bool isDictTy ty | Just ty' <- tcView ty = isDictTy ty' isDictTy (PredTy p) = isClassPred p -isDictTy other = False +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} isIPPred :: PredType -> Bool isIPPred (IParam _ _) = True -isIPPred other = False +isIPPred _ = False isInheritablePred :: PredType -> Bool -- Can be inherited by a context. For example, consider @@ -908,7 +963,7 @@ isInheritablePred :: PredType -> Bool -- which can be free in g's rhs, and shared by both calls to g isInheritablePred (ClassP _ _) = True isInheritablePred (EqPred _ _) = True -isInheritablePred other = False +isInheritablePred _ = False \end{code} --------------------- Equality predicates --------------------------------- @@ -918,28 +973,6 @@ substEqSpec subst eq_spec = [ (substTyVar subst tv, substTy subst ty) | (tv,ty) <- eq_spec] \end{code} ---------------------- The stupid theta (sigh) --------------------------------- - -\begin{code} -dataConsStupidTheta :: [DataCon] -> ThetaType --- Union the stupid thetas from all the specified constructors (non-empty) --- All the constructors should have the same result type, modulo alpha conversion --- The resulting ThetaType uses type variables from the *first* constructor in the list --- --- It's here because it's used in MkId.mkRecordSelId, and in TcExpr -dataConsStupidTheta (con1:cons) - = nubBy tcEqPred all_preds - where - all_preds = dataConStupidTheta con1 ++ other_stupids - res_ty1 = dataConOrigResTy con1 - other_stupids = [ substPred subst pred - | con <- cons - , let (tvs, _, _, res_ty) = dataConSig con - Just subst = tcMatchTy (mkVarSet tvs) res_ty res_ty1 - , pred <- dataConStupidTheta con ] -dataConsStupidTheta [] = panic "dataConsStupidTheta" -\end{code} - %************************************************************************ %* * @@ -954,36 +987,43 @@ any foralls. E.g. \begin{code} isSigmaTy :: Type -> Bool isSigmaTy ty | Just ty' <- tcView ty = isSigmaTy ty' -isSigmaTy (ForAllTy tyvar ty) = True -isSigmaTy (FunTy a b) = isPredTy a -isSigmaTy _ = False +isSigmaTy (ForAllTy _ _) = True +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 tyvar ty) = isOverloadedTy ty -isOverloadedTy (FunTy a b) = 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) isPredTy ty | Just ty' <- tcView ty = isPredTy ty' -isPredTy (PredTy sty) = True -isPredTy _ = False +isPredTy (PredTy _) = True +isPredTy _ = False \end{code} \begin{code} +isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy, + isUnitTy, isCharTy :: Type -> Bool isFloatTy = is_tc floatTyConKey isDoubleTy = is_tc doubleTyConKey isIntegerTy = is_tc integerTyConKey isIntTy = is_tc intTyConKey +isWordTy = is_tc wordTyConKey isBoolTy = is_tc boolTyConKey isUnitTy = is_tc unitTyConKey isCharTy = is_tc charTyConKey +isStringTy :: Type -> Bool isStringTy ty = case tcSplitTyConApp_maybe ty of Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty - other -> False + _ -> False is_tc :: Unique -> Type -> Bool -- Newtypes are opaque to this @@ -997,8 +1037,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} @@ -1021,8 +1062,7 @@ tcTyVarsOfType :: Type -> TcTyVarSet -- (Types.tyVarsOfTypes finds all free TyVars) tcTyVarsOfType (TyVarTy tv) = if isTcTyVar tv then unitVarSet tv else emptyVarSet -tcTyVarsOfType (TyConApp tycon tys) = tcTyVarsOfTypes tys -tcTyVarsOfType (NoteTy _ ty) = tcTyVarsOfType ty +tcTyVarsOfType (TyConApp _ tys) = tcTyVarsOfTypes tys tcTyVarsOfType (PredTy sty) = tcTyVarsOfPred sty tcTyVarsOfType (FunTy arg res) = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res tcTyVarsOfType (AppTy fun arg) = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg @@ -1062,6 +1102,15 @@ exactTyVarsOfType is used by the type checker to figure out exactly which type variables are mentioned in a type. It's also used in the smart-app checking code --- see TcExpr.tcIdApp +On the other hand, consider a *top-level* definition + f = (\x -> x) :: T a -> T a +If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then +if we have an application like (f "x") we get a confusing error message +involving Any. So the conclusion is this: when generalising + - at top level use tyVarsOfType + - in nested bindings use exactTyVarsOfType +See Trac #1813 for example. + \begin{code} exactTyVarsOfType :: TcType -> TyVarSet -- Find the free type variables (of any kind) @@ -1071,13 +1120,12 @@ exactTyVarsOfType ty where go ty | Just ty' <- tcView ty = go ty' -- This is the key line go (TyVarTy tv) = unitVarSet tv - go (TyConApp tycon tys) = exactTyVarsOfTypes tys + go (TyConApp _ tys) = exactTyVarsOfTypes tys go (PredTy ty) = go_pred ty go (FunTy arg res) = go arg `unionVarSet` go res go (AppTy fun arg) = go fun `unionVarSet` go arg go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar `unionVarSet` go_tv tyvar - go (NoteTy _ _) = panic "exactTyVarsOfType" -- Handled by tcView go_pred (IParam _ ty) = go ty go_pred (ClassP _ tys) = exactTyVarsOfTypes tys @@ -1095,16 +1143,16 @@ end of the compiler. \begin{code} tyClsNamesOfType :: Type -> NameSet -tyClsNamesOfType (TyVarTy tv) = emptyNameSet +tyClsNamesOfType (TyVarTy _) = emptyNameSet tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys -tyClsNamesOfType (NoteTy _ ty2) = tyClsNamesOfType ty2 -tyClsNamesOfType (PredTy (IParam n ty)) = tyClsNamesOfType ty +tyClsNamesOfType (PredTy (IParam _ 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 +tyClsNamesOfType (ForAllTy _ ty) = tyClsNamesOfType ty +tyClsNamesOfTypes :: [Type] -> NameSet tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys tyClsNamesOfDFunHead :: Type -> NameSet @@ -1116,7 +1164,7 @@ tyClsNamesOfDFunHead :: Type -> NameSet -- even if Foo *is* locally defined tyClsNamesOfDFunHead dfun_ty = case tcSplitSigmaTy dfun_ty of - (tvs,_,head_ty) -> tyClsNamesOfType head_ty + (_, _, head_ty) -> tyClsNamesOfType head_ty \end{code} @@ -1152,7 +1200,7 @@ tcSplitIOType_maybe ty Nothing -> Nothing Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCoI` co2) - other -> Nothing + _ -> Nothing isFFITy :: Type -> Bool -- True for any TyCon that can possibly be an arg or result of an FFI call @@ -1189,6 +1237,18 @@ isFFILabelTy :: Type -> Bool -- or a newtype of either. isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey] +isFFIPrimArgumentTy :: DynFlags -> Type -> Bool +-- Checks for valid argument type for a 'foreign import prim' +-- Currently they must all be simple unlifted types. +isFFIPrimArgumentTy dflags ty + = checkRepTyCon (legalFIPrimArgTyCon dflags) ty + +isFFIPrimResultTy :: DynFlags -> Type -> Bool +-- Checks for valid result type for a 'foreign import prim' +-- Currently it must be an unlifted type, including unboxed tuples. +isFFIPrimResultTy dflags ty + = checkRepTyCon (legalFIPrimResultTyCon dflags) ty + isFFIDotnetTy :: DynFlags -> Type -> Bool isFFIDotnetTy dflags ty = checkRepTyCon (\ tc -> (legalFIResultTyCon dflags tc || @@ -1197,54 +1257,30 @@ isFFIDotnetTy dflags ty -- it no longer does so. May need to adjust isFFIDotNetTy -- if we do want to look through newtypes. +isFFIDotnetObjTy :: Type -> Bool isFFIDotnetObjTy ty = checkRepTyCon check_tc t_ty where (_, t_ty) = tcSplitForAllTys ty check_tc tc = getName tc == objectTyConName -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 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 = panic "toDNType" -- Is this right? - where - dn_assoc :: [ (Unique, DNType) ] - dn_assoc = [ (unitTyConKey, DNUnit) - , (intTyConKey, DNInt) - , (int8TyConKey, DNInt8) - , (int16TyConKey, DNInt16) - , (int32TyConKey, DNInt32) - , (int64TyConKey, DNInt64) - , (wordTyConKey, DNInt) - , (word8TyConKey, DNWord8) - , (word16TyConKey, DNWord16) - , (word32TyConKey, DNWord32) - , (word64TyConKey, DNWord64) - , (floatTyConKey, DNFloat) - , (doubleTyConKey, DNDouble) - , (ptrTyConKey, DNPtr) - , (funPtrTyConKey, DNPtr) - , (charTyConKey, DNChar) - , (boolTyConKey, DNBool) - ] +isFunPtrTy :: Type -> Bool +isFunPtrTy = checkRepTyConKey [funPtrTyConKey] 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 @@ -1275,7 +1311,7 @@ legalFEResultTyCon tc legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool -- Checks validity of types going from Haskell -> external world -legalOutgoingTyCon dflags safety tc +legalOutgoingTyCon dflags _ tc = marshalableTyCon dflags tc legalFFITyCon :: TyCon -> Bool @@ -1283,15 +1319,17 @@ legalFFITyCon :: TyCon -> Bool legalFFITyCon tc = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon +marshalableTyCon :: DynFlags -> TyCon -> Bool marshalableTyCon dflags tc = (dopt Opt_UnliftedFFITypes dflags && isUnLiftedTyCon tc && not (isUnboxedTupleTyCon tc) && case tyConPrimRep tc of -- Note [Marshalling VoidRep] VoidRep -> False - other -> True) + _ -> True) || boxedMarshalableTyCon tc +boxedMarshalableTyCon :: TyCon -> Bool boxedMarshalableTyCon tc = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey , int32TyConKey, int64TyConKey @@ -1303,6 +1341,26 @@ boxedMarshalableTyCon tc , stablePtrTyConKey , boolTyConKey ] + +legalFIPrimArgTyCon :: DynFlags -> TyCon -> Bool +-- Check args of 'foreign import prim', only allow simple unlifted types. +-- Strictly speaking it is unnecessary to ban unboxed tuples here since +-- currently they're of the wrong kind to use in function args anyway. +legalFIPrimArgTyCon dflags tc + = dopt Opt_UnliftedFFITypes dflags + && isUnLiftedTyCon tc + && not (isUnboxedTupleTyCon tc) + +legalFIPrimResultTyCon :: DynFlags -> TyCon -> Bool +-- Check result type of 'foreign import prim'. Allow simple unlifted +-- types and also unboxed tuple result types '... -> (# , , #)' +legalFIPrimResultTyCon dflags tc + = dopt Opt_UnliftedFFITypes dflags + && isUnLiftedTyCon tc + && (isUnboxedTupleTyCon tc + || case tyConPrimRep tc of -- Note [Marshalling VoidRep] + VoidRep -> False + _ -> True) \end{code} Note [Marshalling VoidRep]