X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcType.lhs;h=50ac35ab50a97d0a65ac6d795704440ec82d7638;hp=0025a5e685cca15dca7f08012dbdbd3f0d1f173d;hb=4d8c7c976104d2e39a1183967ec0f254a0fc0a47;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516 diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 0025a5e..50ac35a 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -28,9 +28,9 @@ module TcType ( MetaDetails(Flexi, Indirect), MetaInfo(..), SkolemInfo(..), pprSkolTvBinding, pprSkolInfo, isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy, - isSigTyVar, isExistentialTyVar, isTyConableTyVar, + isSigTyVar, isOverlappableTyVar, isTyConableTyVar, metaTvRef, - isFlexi, isIndirect, isRuntimeUnk, isUnk, + isFlexi, isIndirect, isUnkSkol, isRuntimeUnkSkol, -------------------------------- -- Builders @@ -123,7 +123,8 @@ module TcType ( -- Type substitutions TvSubst(..), -- Representation visible to a few friends TvSubstEnv, emptyTvSubst, substEqSpec, - mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst, + mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, + mkTopTvSubst, notElemTvSubst, unionTvSubst, getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, lookupTyVar, extendTvSubst, extendTvSubstList, isInScope, mkTvSubst, zipTyEnv, substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars, substTyVarBndr, @@ -274,17 +275,18 @@ TcBinds.tcInstSig, and its use_skols parameter. data TcTyVarDetails = SkolemTv SkolemInfo -- A skolem constant - | FlatSkol TcType -- The "skolem" obtained by flattening during - -- constraint simplification + | FlatSkol TcType + -- The "skolem" obtained by flattening during + -- constraint simplification - -- In comments we will use the notation alpha[flat = ty] - -- to represent a flattening skolem variable alpha - -- identified with type ty. - + -- In comments we will use the notation alpha[flat = ty] + -- to represent a flattening skolem variable alpha + -- identified with type ty. + | MetaTv MetaInfo (IORef MetaDetails) data MetaDetails - = Flexi -- Flexi type variables unify to become Indirects + = Flexi -- Flexi type variables unify to become Indirects | Indirect TcType data MetaInfo @@ -301,6 +303,11 @@ data MetaInfo -- The Name is the name of the function from whose -- type signature we got this skolem + | TcsTv -- A MetaTv allocated by the constraint solver + -- Its particular property is that it is always "touchable" + -- Nevertheless, the constraint solver has to try to guess + -- what type to instantiate it to + ---------------------------------- -- SkolemInfo describes a site where -- a) type variables are skolemised @@ -328,12 +335,10 @@ data SkolemInfo | RuleSkol RuleName -- The LHS of a RULE | GenSkol TcType -- Bound when doing a subsumption check for ty + | RuntimeUnkSkol -- a type variable used to represent an unknown -- runtime type (used in the GHCi debugger) - | NoScSkol -- Used for the "self" superclass when solving - -- superclasses; don't generate superclasses of me - | UnkSkol -- Unhelpful info (until I improve it) ------------------------------------- @@ -405,8 +410,9 @@ kind_var_occ = mkOccName tvName "k" pprTcTyVarDetails :: TcTyVarDetails -> SDoc -- For debugging pprTcTyVarDetails (SkolemTv _) = ptext (sLit "sk") -pprTcTyVarDetails (FlatSkol _) = ptext (sLit "fsk") +pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk") pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau") +pprTcTyVarDetails (MetaTv TcsTv _) = ptext (sLit "tcs") pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext (sLit "sig") pprUserTypeCtxt :: UserTypeCtxt -> SDoc @@ -431,9 +437,10 @@ pprSkolTvBinding tv quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv) where ppr_details (SkolemTv info) = ppr_skol info - ppr_details (FlatSkol _) = ptext (sLit "is a flattening type variable") - ppr_details (MetaTv TauTv _) = ptext (sLit "is a meta type variable") - ppr_details (MetaTv (SigTv n) _) = ptext (sLit "is bound by the type signature for") <+> quotes (ppr n) + ppr_details (FlatSkol {}) = ptext (sLit "is a flattening type variable") + ppr_details (MetaTv (SigTv n) _) = ptext (sLit "is bound by the type signature for") + <+> quotes (ppr n) + ppr_details (MetaTv _ _) = ptext (sLit "is a meta type variable") ppr_skol UnkSkol = ptext (sLit "is an unknown type variable") -- Unhelpful ppr_skol RuntimeUnkSkol = ptext (sLit "is an unknown runtime type") @@ -441,6 +448,9 @@ pprSkolTvBinding tv sep [pprSkolInfo info, nest 2 (ptext (sLit "at") <+> ppr (getSrcLoc tv))]] +instance Outputable SkolemInfo where + ppr = pprSkolInfo + pprSkolInfo :: SkolemInfo -> SDoc -- Complete the sentence "is a rigid type variable bound by..." pprSkolInfo (SigSkol ctxt) = pprUserTypeCtxt ctxt @@ -448,7 +458,6 @@ pprSkolInfo (IPSkol ips) = ptext (sLit "the implicit-parameter bindings for") <+> pprWithCommas ppr ips pprSkolInfo (ClsSkol cls) = ptext (sLit "the class declaration for") <+> quotes (ppr cls) pprSkolInfo InstSkol = ptext (sLit "the instance declaration") -pprSkolInfo NoScSkol = ptext (sLit "the instance declaration (self)") 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") @@ -605,7 +614,7 @@ isImmutableTyVar tv | isTcTyVar tv = isSkolemTyVar tv | otherwise = True -isTyConableTyVar, isSkolemTyVar, isExistentialTyVar, +isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar, isMetaTyVar :: TcTyVar -> Bool isTyConableTyVar tv @@ -614,8 +623,8 @@ isTyConableTyVar tv -- not a SigTv = ASSERT( isTcTyVar tv) case tcTyVarDetails tv of - MetaTv TauTv _ -> True - _ -> False + MetaTv (SigTv _) _ -> False + _ -> True isSkolemTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) @@ -624,11 +633,14 @@ isSkolemTyVar tv FlatSkol {} -> True MetaTv {} -> False -isExistentialTyVar tv -- Existential type variable, bound by a pattern +-- isOverlappableTyVar has a unique purpose. +-- See Note [Binding when looking up instances] in InstEnv. +isOverlappableTyVar tv = ASSERT( isTcTyVar tv ) case tcTyVarDetails tv of - SkolemTv (PatSkol {}) -> True - _ -> False + SkolemTv (PatSkol {}) -> True + SkolemTv (InstSkol {}) -> True + _ -> False isMetaTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) @@ -661,15 +673,17 @@ isFlexi _ = False isIndirect (Indirect _) = True isIndirect _ = False -isRuntimeUnk :: TyVar -> Bool -isRuntimeUnk x | isTcTyVar x - , SkolemTv RuntimeUnkSkol <- tcTyVarDetails x = True - | otherwise = False - -isUnk :: TyVar -> Bool -isUnk x | isTcTyVar x - , SkolemTv UnkSkol <- tcTyVarDetails x = True - | otherwise = False +isRuntimeUnkSkol :: TyVar -> Bool +-- Called only in TcErrors; see Note [Runtime skolems] there +isRuntimeUnkSkol x | isTcTyVar x + , SkolemTv RuntimeUnkSkol <- tcTyVarDetails x + = True + | otherwise = False + +isUnkSkol :: TyVar -> Bool +isUnkSkol x | isTcTyVar x + , SkolemTv UnkSkol <- tcTyVarDetails x = True + | otherwise = False \end{code} @@ -942,6 +956,9 @@ 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 + | Just ty' <- tcView ty -- Look through synonyms + = tcInstHeadTyAppAllTyVars ty' + | otherwise = case ty of TyConApp _ tys -> ok tys FunTy arg res -> ok [arg, res] @@ -1010,8 +1027,6 @@ getClassPredTys _ = panic "getClassPredTys" mkDictTy :: Class -> [Type] -> Type mkDictTy clas tys = mkPredTy (ClassP clas tys) - - isDictLikeTy :: Type -> Bool -- Note [Dictionary-like types] isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty' @@ -1416,7 +1431,7 @@ legalFFITyCon tc marshalableTyCon :: DynFlags -> TyCon -> Bool marshalableTyCon dflags tc - = (dopt Opt_UnliftedFFITypes dflags + = (xopt Opt_UnliftedFFITypes dflags && isUnLiftedTyCon tc && not (isUnboxedTupleTyCon tc) && case tyConPrimRep tc of -- Note [Marshalling VoidRep] @@ -1442,7 +1457,7 @@ legalFIPrimArgTyCon :: DynFlags -> TyCon -> Bool -- 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 + = xopt Opt_UnliftedFFITypes dflags && isUnLiftedTyCon tc && not (isUnboxedTupleTyCon tc) @@ -1450,7 +1465,7 @@ 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 + = xopt Opt_UnliftedFFITypes dflags && isUnLiftedTyCon tc && (isUnboxedTupleTyCon tc || case tyConPrimRep tc of -- Note [Marshalling VoidRep]