X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=388a28d08040f22d173d8a9ba6836a28fe8c018c;hp=94ea3f9b07cb78c5ed359b9583b1b8a79c2226e7;hb=7fc749a43b4b6b85d234fa95d4928648259584f4;hpb=138b885a335734039daf7debb0a7dfc3dc947c00 diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 94ea3f9..388a28d 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -1,4 +1,5 @@ - +% +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcType]{Types used in the typechecker} @@ -10,10 +11,17 @@ compiler. These parts newtypes, and predicates are meaningful. * look through usage types -The "tc" prefix is for "typechechecker", because the type checker +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 @@ -27,7 +35,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, @@ -43,7 +52,8 @@ module TcType ( tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN, tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs, tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe, - tcValidInstHeadTy, tcGetTyVar_maybe, tcGetTyVar, + tcInstHeadTyNotSynonym, tcInstHeadTyAppAllTyVars, + tcGetTyVar_maybe, tcGetTyVar, tcSplitSigmaTy, tcMultiSplitSigmaTy, --------------------------------- @@ -53,12 +63,13 @@ module TcType ( eqKind, isSigmaTy, isOverloadedTy, isRigidTy, isBoxyTy, isDoubleTy, isFloatTy, isIntTy, isStringTy, - isIntegerTy, isBoolTy, isUnitTy, + isIntegerTy, isBoolTy, isUnitTy, isCharTy, isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy, + isOpenSynTyConApp, --------------------------------- -- Misc type manipulators - deNoteType, classesOfTheta, + deNoteType, tyClsNamesOfType, tyClsNamesOfDFunHead, getDFunTyKey, @@ -68,8 +79,8 @@ module TcType ( isClassPred, isTyVarClassPred, isEqPred, mkDictTy, tcSplitPredTy_maybe, isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique, - mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName, - dataConsStupidTheta, isRefineableTy, + mkClassPred, isInheritablePred, isIPPred, + dataConsStupidTheta, isRefineableTy, isRefineablePred, --------------------------------- -- Foreign import and export @@ -107,7 +118,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 @@ -121,7 +132,7 @@ module TcType ( tcTyVarsOfType, tcTyVarsOfTypes, exactTyVarsOfType, exactTyVarsOfTypes, pprKind, pprParendKind, - pprType, pprParendType, pprTyThingCategory, + pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprPred, pprTheta, pprThetaArrow, pprClassPred ) where @@ -129,73 +140,35 @@ module TcType ( #include "HsVersions.h" -- friends: -import TypeRep ( Type(..), funTyCon, Kind ) -- friend - -import Type ( -- Re-exports - tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, - tyVarsOfTheta, Kind, PredType(..), KindVar, - ThetaType, isUnliftedTypeKind, unliftedTypeKind, - argTypeKind, - liftedTypeKind, openTypeKind, mkArrowKind, - tySuperKind, isLiftedTypeKind, - mkArrowKinds, mkForAllTy, mkForAllTys, - defaultKind, isSubArgTypeKind, isSubOpenTypeKind, - mkFunTy, mkFunTys, zipFunTys, - mkTyConApp, mkAppTy, - mkAppTys, applyTy, applyTys, - mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, - mkPredTys, isUnLiftedType, - isUnboxedTupleType, isPrimitiveType, - splitTyConApp_maybe, - tidyTopType, tidyType, tidyPred, tidyTypes, - tidyFreeTyVars, tidyOpenType, tidyOpenTypes, - tidyTyVarBndr, tidyOpenTyVar, - tidyOpenTyVars, tidyKind, - isSubKind, tcView, - - tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, - tcEqPred, tcCmpPred, tcEqTypeX, eqKind, - - TvSubst(..), - TvSubstEnv, emptyTvSubst, mkTvSubst, zipTyEnv, - mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, - getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, - extendTvSubst, extendTvSubstList, isInScope, notElemTvSubst, - substTy, substTys, substTyWith, substTheta, - substTyVar, substTyVarBndr, substPred, lookupTyVar, - - typeKind, repType, coreView, repSplitAppTy_maybe, - pprKind, pprParendKind, - pprType, pprParendType, pprTyThingCategory, - pprPred, pprTheta, pprThetaArrow, pprClassPred - ) -import TyCon ( TyCon, isUnLiftedTyCon, isSynTyCon, isOpenTyCon, - synTyConDefn, tyConUnique ) -import DataCon ( DataCon, dataConStupidTheta, dataConResTys ) -import Class ( Class ) -import Var ( TyVar, Id, isCoVar, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails ) -import ForeignCall ( Safety, DNType(..) ) -import Unify ( tcMatchTys ) +import TypeRep +import DataCon +import Class +import Var +import ForeignCall +import Unify import VarSet +import Type +import Coercion +import TyCon -- others: -import DynFlags ( DynFlags, DynFlag( Opt_GlasgowExts ), dopt ) -import Name ( Name, NamedThing(..), mkInternalName, getSrcLoc, mkSystemName ) +import DynFlags +import CoreSyn +import Name import NameSet -import VarEnv ( TidyEnv ) -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 ( equalLength ) -import Maybes ( maybeToBool, expectJust, mapCatMaybes ) -import ListSetOps ( hasNoDups ) -import List ( nubBy ) +import VarEnv +import OccName +import PrelNames +import TysWiredIn +import BasicTypes +import Util +import Maybes +import ListSetOps import Outputable -import DATA_IOREF -\end{code} +import Data.List +import Data.IORef +\end{code} %************************************************************************ %* * @@ -329,13 +302,15 @@ data BoxInfo -- b2 is another (currently empty) box. data MetaDetails - = Flexi -- Flexi type variables unify to become - -- Indirects. + = Flexi -- Flexi type variables unify to become + -- Indirects. - | Indirect TcType -- INVARIANT: - -- For a BoxTv, this type must be non-boxy - -- For a TauTv, this type must be a tau-type + | Indirect TcType -- INVARIANT: + -- For a BoxTv, this type must be non-boxy + -- For a TauTv, this type must be a tau-type +-- Generally speaking, SkolemInfo should not contain location info +-- that is contained in the Name of the tyvar with this SkolemInfo data SkolemInfo = SigSkol UserTypeCtxt -- A skolem that is created by instantiating -- a programmer-supplied type signature @@ -343,25 +318,29 @@ data SkolemInfo -- The rest are for non-scoped skolems | ClsSkol Class -- Bound at a class decl - | InstSkol Id -- Bound at an instance decl - | FamInstSkol TyCon -- Bound at a family instance decl + | InstSkol -- Bound at an instance decl + | FamInstSkol -- Bound at a family instance decl | PatSkol DataCon -- An existential type variable bound by a pattern for - SrcSpan -- a data constructor with an existential type. E.g. + -- a data constructor with an existential type. E.g. -- data T = forall a. Eq a => MkT a -- f (MkT x) = ... -- The pattern MkT x will allocate an existential type -- variable for 'a'. - | ArrowSkol SrcSpan -- An arrow form (see TcArrows) + | ArrowSkol -- An arrow form (see TcArrows) + | RuleSkol RuleName -- The LHS of a RULE | GenSkol [TcTyVar] -- Bound when doing a subsumption check for TcType -- (forall tvs. ty) - SrcSpan + + | RuntimeUnkSkol -- a type variable used to represent an unknown + -- runtime type (used in the GHCi debugger) | UnkSkol -- Unhelpful info (until I improve it) ------------------------------------- -- UserTypeCtxt describes the places where a -- programmer-written type signature can occur +-- Like SkolemInfo, no location info data UserTypeCtxt = FunSigCtxt Name -- Function type signature -- Also used for types in SPECIALISE pragmas @@ -377,7 +356,6 @@ data UserTypeCtxt | ResSigCtxt -- Result type sig -- f x :: t = .... | ForSigCtxt Name -- Foreign inport or export signature - | RuleSigCtxt Name -- Signature on a forall'd variable in a RULE | DefaultDeclCtxt -- Types in a default declaration | SpecInstCtxt -- SPECIALISE instance pragma @@ -399,6 +377,7 @@ mkKindName unique = mkSystemName unique kind_var_occ kindVarRef :: KindVar -> IORef MetaDetails kindVarRef tc = + ASSERT ( isTcTyVar tc ) case tcTyVarDetails tc of MetaTv TauTv ref -> ref other -> pprPanic "kindVarRef" (ppr tc) @@ -415,7 +394,6 @@ 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} %************************************************************************ %* * @@ -441,7 +419,6 @@ 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 (RuleSigCtxt n) = ptext SLIT("the type signature for") <+> quotes (ppr n) pprUserTypeCtxt DefaultDeclCtxt = ptext SLIT("a type in a `default' declaration") pprUserTypeCtxt SpecInstCtxt = ptext SLIT("a SPECIALISE instance pragma") @@ -462,7 +439,7 @@ tidySkolemTyVar env tv (env1, info') = tidy_skol_info env info info -> (env, info) - tidy_skol_info env (GenSkol tvs ty loc) = (env2, GenSkol tvs1 ty1 loc) + tidy_skol_info env (GenSkol tvs ty) = (env2, GenSkol tvs1 ty1) where (env1, tvs1) = tidyOpenTyVars env tvs (env2, ty1) = tidyOpenType env1 ty @@ -472,40 +449,39 @@ pprSkolTvBinding :: TcTyVar -> SDoc -- Print info about the binding of a skolem tyvar, -- or nothing if we don't have anything useful to say pprSkolTvBinding tv - = ppr_details (tcTyVarDetails tv) + = ASSERT ( isTcTyVar 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 (SigSkol ctxt) = sep [quotes (ppr tv) <+> ptext SLIT("is bound by") <+> pprUserTypeCtxt ctxt, - nest 2 (ptext SLIT("at") <+> ppr (getSrcLoc tv))] - ppr_skol info = quotes (ppr tv) <+> pprSkolInfo info + 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) = ptext SLIT("is bound by") <+> pprUserTypeCtxt ctxt -pprSkolInfo (ClsSkol cls) = ptext SLIT("is bound by the class declaration for") <+> quotes (ppr cls) -pprSkolInfo (InstSkol df) = - ptext SLIT("is bound by the instance declaration at") <+> ppr (getSrcLoc df) -pprSkolInfo (FamInstSkol tc) = - ptext SLIT("is bound by the family instance declaration at") <+> - ppr (getSrcLoc tc) -pprSkolInfo (ArrowSkol loc) = - ptext SLIT("is bound by the arrow form at") <+> ppr loc -pprSkolInfo (PatSkol dc loc) = sep [ptext SLIT("is bound by the pattern for") <+> quotes (ppr dc), - nest 2 (ptext SLIT("at") <+> ppr loc)] -pprSkolInfo (GenSkol tvs ty loc) = sep [sep [ptext SLIT("is bound by the polymorphic type"), - nest 2 (quotes (ppr (mkForAllTys tvs ty)))], - nest 2 (ptext SLIT("at") <+> ppr loc)] --- UnkSkol, SigSkol +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"), + nest 2 (quotes (ppr (mkForAllTys tvs ty)))] + +-- UnkSkol -- 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") + ppr Flexi = ptext SLIT("Flexi") ppr (Indirect ty) = ptext SLIT("Indirect") <+> ppr ty \end{code} @@ -517,11 +493,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 that 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 @@ -531,8 +522,8 @@ isSkolemTyVar tv isExistentialTyVar tv -- Existential type variable, bound by a pattern = ASSERT( isTcTyVar tv ) case tcTyVarDetails tv of - SkolemTv (PatSkol _ _) -> True - other -> False + SkolemTv (PatSkol {}) -> True + other -> False isMetaTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) @@ -554,14 +545,14 @@ isSigTyVar tv metaTvRef :: TyVar -> IORef MetaDetails metaTvRef tv - = ASSERT( isTcTyVar tv ) + = ASSERT2( isTcTyVar tv, ppr tv ) case tcTyVarDetails tv of MetaTv _ ref -> ref other -> pprPanic "metaTvRef" (ppr tv) isFlexi, isIndirect :: MetaDetails -> Bool -isFlexi Flexi = True -isFlexi other = False +isFlexi Flexi = True +isFlexi other = False isIndirect (Indirect _) = True isIndirect other = False @@ -579,7 +570,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. @@ -599,8 +590,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 @@ -608,15 +599,20 @@ isBoxyTy ty = any isBoxyTyVar (varSetElems (tcTyVarsOfType ty)) isRigidTy :: TcType -> Bool -- A type is rigid if it has no meta type variables in it -isRigidTy ty = all isSkolemTyVar (varSetElems (tcTyVarsOfType ty)) +isRigidTy ty = all isImmutableTyVar (varSetElems (tcTyVarsOfType ty)) -isRefineableTy :: TcType -> Bool +isRefineableTy :: TcType -> (Bool,Bool) -- A type should have type refinements applied to it if it has -- free type variables, and they are all rigid -isRefineableTy ty = not (null tc_tvs) && all isSkolemTyVar tc_tvs +isRefineableTy ty = (null tc_tvs, all isImmutableTyVar tc_tvs) where tc_tvs = varSetElems (tcTyVarsOfType ty) +isRefineablePred :: TcPredType -> Bool +isRefineablePred pred = not (null tc_tvs) && all isImmutableTyVar tc_tvs + where + tc_tvs = varSetElems (tcTyVarsOfPred pred) + --------------- getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to -- construct a dictionary function name @@ -696,10 +692,14 @@ tcMultiSplitSigmaTy sigma ----------------------- tcTyConAppTyCon :: Type -> TyCon -tcTyConAppTyCon ty = fst (tcSplitTyConApp ty) +tcTyConAppTyCon ty = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> tc + Nothing -> pprPanic "tcTyConAppTyCon" (pprType ty) tcTyConAppArgs :: Type -> [Type] -tcTyConAppArgs ty = snd (tcSplitTyConApp ty) +tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of + Just (_, args) -> args + Nothing -> pprPanic "tcTyConAppArgs" (pprType ty) tcSplitTyConApp :: Type -> (TyCon, [Type]) tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of @@ -724,9 +724,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 @@ -791,14 +798,23 @@ tcSplitDFunHead tau Just (ClassP clas tys) -> (clas, tys) other -> panic "tcSplitDFunHead" -tcValidInstHeadTy :: Type -> Bool +tcInstHeadTyNotSynonym :: Type -> Bool -- Used in Haskell-98 mode, for the argument types of an instance head -- These must not be type synonyms, but everywhere else type synonyms -- are transparent, so we need a special function here -tcValidInstHeadTy ty +tcInstHeadTyNotSynonym ty = case ty of - NoteTy _ ty -> tcValidInstHeadTy ty - TyConApp tc tys -> not (isSynTyCon tc) && ok tys + NoteTy _ ty -> tcInstHeadTyNotSynonym ty + TyConApp tc tys -> not (isSynTyCon tc) + _ -> True + +tcInstHeadTyAppAllTyVars :: Type -> Bool +-- Used in Haskell-98 mode, for the argument types of an instance head +-- 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 where @@ -831,10 +847,7 @@ tcSplitPredTy_maybe other = Nothing predTyUnique :: PredType -> Unique predTyUnique (IParam n _) = getUnique (ipNameName n) predTyUnique (ClassP clas tys) = getUnique clas - -mkPredName :: Unique -> SrcLoc -> PredType -> Name -mkPredName uniq loc (ClassP cls tys) = mkInternalName uniq (mkDictOcc (getOccName cls)) loc -mkPredName uniq loc (IParam ip ty) = mkInternalName uniq (getOccName (ipNameName ip)) loc +predTyUnique (EqPred a b) = pprPanic "predTyUnique" (ppr (EqPred a b)) \end{code} @@ -858,10 +871,6 @@ 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) @@ -888,11 +897,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 - -isLinearPred :: TcPredType -> Bool -isLinearPred (IParam (Linear n) _) = True -isLinearPred other = False +isInheritablePred (EqPred _ _) = True +isInheritablePred other = False \end{code} --------------------- Equality predicates --------------------------------- @@ -915,11 +921,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} @@ -962,6 +968,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 @@ -970,6 +982,15 @@ is_tc uniq ty = case tcSplitTyConApp_maybe ty of Nothing -> False \end{code} +\begin{code} +-- NB: Currently used in places where we have already expanded type synonyms; +-- hence no 'coreView'. This could, however, be changed without breaking +-- any code. +isOpenSynTyConApp :: TcTauType -> Bool +isOpenSynTyConApp (TyConApp tc _) = isOpenSynTyCon tc +isOpenSynTyConApp _other = False +\end{code} + %************************************************************************ %* * @@ -1046,6 +1067,7 @@ exactTyVarsOfType ty 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 @@ -1085,10 +1107,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} @@ -1103,22 +1121,28 @@ restricted set of types as arguments and results (the restricting factor being the ) \begin{code} -tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type) --- (isIOType t) returns (Just (IO,t')) if t is of the form (IO t'), or --- some newtype wrapping thereof +tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, CoercionI) +-- (isIOType t) returns Just (IO,t',co) +-- if co : t ~ IO t' -- returns Nothing otherwise tcSplitIOType_maybe ty - | Just (io_tycon, [io_res_ty]) <- tcSplitTyConApp_maybe ty, + = case tcSplitTyConApp_maybe ty of -- This split absolutely has to be a tcSplit, because we must -- see the IO type; and it's a newtype which is transparent to splitTyConApp. - io_tycon `hasKey` ioTyConKey - = Just (io_tycon, io_res_ty) - | Just ty' <- coreView ty -- Look through non-recursive newtypes - = tcSplitIOType_maybe ty' + Just (io_tycon, [io_res_ty]) + | io_tycon `hasKey` ioTyConKey + -> Just (io_tycon, io_res_ty, IdCo) - | otherwise - = Nothing + Just (tc, tys) + | not (isRecursiveTyCon tc) + , Just (ty, co1) <- instNewTyCon_maybe tc tys + -- Newtypes that require a coercion are ok + -> case tcSplitIOType_maybe ty of + Nothing -> Nothing + Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCoI` co2) + + other -> Nothing isFFITy :: Type -> Bool -- True for any TyCon that can possibly be an arg or result of an FFI call @@ -1159,25 +1183,15 @@ 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 +isFFIDotnetObjTy ty + = checkRepTyCon check_tc t_ty + where (_, t_ty) = tcSplitForAllTys ty - in - case tcSplitTyConApp_maybe (repType t_ty) of - Just (tc, [arg_ty]) | getName tc == objectTyConName -> True - _ -> False + check_tc tc = getName tc == objectTyConName toDNType :: Type -> DNType toDNType ty @@ -1260,7 +1274,11 @@ legalFFITyCon tc = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon marshalableTyCon dflags tc - = (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc) + = (dopt Opt_UnliftedFFITypes dflags + && isUnLiftedTyCon tc + && case tyConPrimRep tc of -- Note [Marshalling VoidRep] + VoidRep -> False + other -> True) || boxedMarshalableTyCon tc boxedMarshalableTyCon tc @@ -1275,3 +1293,12 @@ boxedMarshalableTyCon tc , boolTyConKey ] \end{code} + +Note [Marshalling VoidRep] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +We don't treat State# (whose PrimRep is VoidRep) as marshalable. +In turn that means you can't write + foreign import foo :: Int -> State# RealWorld + +Reason: the back end falls over with panic "primRepHint:VoidRep"; + and there is no compelling reason to permit it