2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcType]{Types used in the typechecker}
6 This module provides the Type interface for front-end parts of the
9 * treat "source types" as opaque:
10 newtypes, and predicates are meaningful.
11 * look through usage types
13 The "tc" prefix is for "typechechecker", because the type checker
14 is the principal client.
18 --------------------------------
20 TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
21 TcTyVar, TcTyVarSet, TcKind,
23 --------------------------------
26 MetaDetails(Flexi, Indirect), SkolemInfo(..), pprSkolemTyVar,
27 isImmutableTyVar, isSkolemTyVar, isMetaTyVar, skolemTvInfo, metaTvRef,
30 --------------------------------
34 --------------------------------
36 -- These are important because they do not look through newtypes
37 tcSplitForAllTys, tcSplitPhiTy,
38 tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy,
39 tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
40 tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitSigmaTy,
41 tcSplitMethodTy, tcGetTyVar_maybe, tcGetTyVar,
43 ---------------------------------
45 -- Again, newtypes are opaque
46 tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred,
47 isSigmaTy, isOverloadedTy,
48 isDoubleTy, isFloatTy, isIntTy,
49 isIntegerTy, isAddrTy, isBoolTy, isUnitTy,
50 isTauTy, tcIsTyVarTy, tcIsForAllTy,
52 ---------------------------------
53 -- Misc type manipulators
54 deNoteType, classesOfTheta,
55 tyClsNamesOfType, tyClsNamesOfDFunHead,
58 ---------------------------------
60 getClassPredTys_maybe, getClassPredTys,
61 isClassPred, isTyVarClassPred,
62 mkDictTy, tcSplitPredTy_maybe,
63 isPredTy, isDictTy, tcSplitDFunTy, predTyUnique,
64 mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName,
66 ---------------------------------
67 -- Foreign import and export
68 isFFIArgumentTy, -- :: DynFlags -> Safety -> Type -> Bool
69 isFFIImportResultTy, -- :: DynFlags -> Type -> Bool
70 isFFIExportResultTy, -- :: Type -> Bool
71 isFFIExternalTy, -- :: Type -> Bool
72 isFFIDynArgumentTy, -- :: Type -> Bool
73 isFFIDynResultTy, -- :: Type -> Bool
74 isFFILabelTy, -- :: Type -> Bool
75 isFFIDotnetTy, -- :: DynFlags -> Type -> Bool
76 isFFIDotnetObjTy, -- :: Type -> Bool
77 isFFITy, -- :: Type -> Bool
79 toDNType, -- :: Type -> DNType
81 --------------------------------
82 -- Rexported from Type
83 Kind, -- Stuff to do with kinds is insensitive to pre/post Tc
84 unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
85 isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
86 isArgTypeKind, isSubKind, defaultKind,
88 Type, PredType(..), ThetaType,
89 mkForAllTy, mkForAllTys,
90 mkFunTy, mkFunTys, zipFunTys,
91 mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
92 mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
95 TvSubst(..), -- Representation visible to a few friends
96 TvSubstEnv, emptyTvSubst,
97 mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst,
98 getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
99 extendTvSubst, extendTvSubstList, isInScope,
100 substTy, substTys, substTyWith, substTheta, substTyVar,
102 isUnLiftedType, -- Source types are always lifted
103 isUnboxedTupleType, -- Ditto
106 tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
107 tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars,
110 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
112 pprKind, pprParendKind,
113 pprType, pprParendType, pprTyThingCategory,
114 pprPred, pprTheta, pprThetaArrow, pprClassPred
118 #include "HsVersions.h"
121 import TypeRep ( Type(..), TyNote(..), funTyCon ) -- friend
123 import Type ( -- Re-exports
124 tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
125 tyVarsOfTheta, Kind, Type, PredType(..),
126 ThetaType, unliftedTypeKind,
127 liftedTypeKind, openTypeKind, mkArrowKind,
128 isLiftedTypeKind, isUnliftedTypeKind,
130 mkArrowKinds, mkForAllTy, mkForAllTys,
131 defaultKind, isArgTypeKind, isOpenTypeKind,
132 mkFunTy, mkFunTys, zipFunTys,
133 mkTyConApp, mkGenTyConApp, mkAppTy,
134 mkAppTys, mkSynTy, applyTy, applyTys,
135 mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy,
136 mkPredTys, isUnLiftedType,
137 isUnboxedTupleType, isPrimitiveType,
139 tidyTopType, tidyType, tidyPred, tidyTypes,
140 tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
141 tidyTyVarBndr, tidyOpenTyVar,
145 TvSubstEnv, emptyTvSubst,
146 mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst,
147 getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
148 extendTvSubst, extendTvSubstList, isInScope,
149 substTy, substTys, substTyWith, substTheta, substTyVar,
152 pprKind, pprParendKind,
153 pprType, pprParendType, pprTyThingCategory,
154 pprPred, pprTheta, pprThetaArrow, pprClassPred
156 import TyCon ( TyCon, isUnLiftedTyCon, tyConUnique )
157 import DataCon ( DataCon )
158 import Class ( Class )
159 import Var ( TyVar, Id, isTcTyVar, tcTyVarDetails )
160 import ForeignCall ( Safety, playSafe, DNType(..) )
165 import CmdLineOpts ( DynFlags, DynFlag( Opt_GlasgowExts ), dopt )
166 import Name ( Name, NamedThing(..), mkInternalName, getSrcLoc )
168 import OccName ( OccName, mkDictOcc )
169 import PrelNames -- Lots (e.g. in isFFIArgumentTy)
170 import TysWiredIn ( unitTyCon, charTyCon, listTyCon )
171 import BasicTypes ( IPName(..), ipNameName )
172 import Unique ( Unique, Uniquable(..) )
173 import SrcLoc ( SrcLoc, SrcSpan )
174 import Util ( cmpList, thenCmp, snocView )
175 import Maybes ( maybeToBool, expectJust )
181 %************************************************************************
185 %************************************************************************
187 The type checker divides the generic Type world into the
188 following more structured beasts:
190 sigma ::= forall tyvars. phi
191 -- A sigma type is a qualified type
193 -- Note that even if 'tyvars' is empty, theta
194 -- may not be: e.g. (?x::Int) => Int
196 -- Note that 'sigma' is in prenex form:
197 -- all the foralls are at the front.
198 -- A 'phi' type has no foralls to the right of
206 -- A 'tau' type has no quantification anywhere
207 -- Note that the args of a type constructor must be taus
209 | tycon tau_1 .. tau_n
213 -- In all cases, a (saturated) type synonym application is legal,
214 -- provided it expands to the required form.
217 type TcType = Type -- A TcType can have mutable type variables
218 -- Invariant on ForAllTy in TcTypes:
220 -- a cannot occur inside a MutTyVar in T; that is,
221 -- T is "flattened" before quantifying over a
223 type TcPredType = PredType
224 type TcThetaType = ThetaType
225 type TcSigmaType = TcType
226 type TcRhoType = TcType
227 type TcTauType = TcType
229 type TcTyVarSet = TyVarSet
233 %************************************************************************
235 \subsection{TyVarDetails}
237 %************************************************************************
239 TyVarDetails gives extra info about type variables, used during type
240 checking. It's attached to mutable type variables only.
241 It's knot-tied back to Var.lhs. There is no reason in principle
242 why Var.lhs shouldn't actually have the definition, but it "belongs" here.
245 type TcTyVar = TyVar -- Used only during type inference
247 -- A TyVarDetails is inside a TyVar
249 = SkolemTv SkolemInfo -- A skolem constant
250 | MetaTv (IORef MetaDetails) -- A meta type variable stands for a tau-type
253 = SigSkol Name -- Bound at a type signature
254 | ClsSkol Class -- Bound at a class decl
255 | InstSkol Id -- Bound at an instance decl
256 | PatSkol DataCon -- An existential type variable bound by a pattern for
257 SrcSpan -- a data constructor with an existential type. E.g.
258 -- data T = forall a. Eq a => MkT a
260 -- The pattern MkT x will allocate an existential type
262 | ArrowSkol SrcSpan -- An arrow form (see TcArrows)
264 | GenSkol TcType -- Bound when doing a subsumption check for this type
268 = Flexi -- Flexi type variables unify to become
271 | Indirect TcType -- Type indirections, treated as wobbly
272 -- for the purpose of GADT unification.
274 pprSkolemTyVar :: TcTyVar -> SDoc
276 = ASSERT( isSkolemTyVar tv )
277 quotes (ppr tv) <+> ptext SLIT("is bound by") <+> ppr (skolemTvInfo tv)
279 instance Outputable SkolemInfo where
280 ppr (SigSkol id) = ptext SLIT("the type signature for") <+> quotes (ppr id)
281 ppr (ClsSkol cls) = ptext SLIT("the class declaration for") <+> quotes (ppr cls)
282 ppr (InstSkol df) = ptext SLIT("the instance declaration at") <+> ppr (getSrcLoc df)
283 ppr (ArrowSkol loc) = ptext SLIT("the arrow form at") <+> ppr loc
284 ppr (PatSkol dc loc) = sep [ptext SLIT("the pattern for") <+> quotes (ppr dc),
285 nest 2 (ptext SLIT("at") <+> ppr loc)]
286 ppr (GenSkol ty loc) = sep [ptext SLIT("the polymorphic type") <+> quotes (ppr ty),
287 nest 2 (ptext SLIT("at") <+> ppr loc)]
289 instance Outputable MetaDetails where
290 ppr Flexi = ptext SLIT("Flexi")
291 ppr (Indirect ty) = ptext SLIT("Indirect") <+> ppr ty
293 isImmutableTyVar, isSkolemTyVar, isMetaTyVar :: TyVar -> Bool
295 | isTcTyVar tv = isSkolemTyVar tv
299 = ASSERT( isTcTyVar tv )
300 case tcTyVarDetails tv of
305 = ASSERT( isTcTyVar tv )
306 case tcTyVarDetails tv of
310 skolemTvInfo :: TyVar -> SkolemInfo
312 = ASSERT( isTcTyVar tv )
313 case tcTyVarDetails tv of
314 SkolemTv info -> info
316 metaTvRef :: TyVar -> IORef MetaDetails
318 = ASSERT( isTcTyVar tv )
319 case tcTyVarDetails tv of
322 isFlexi, isIndirect :: MetaDetails -> Bool
324 isFlexi other = False
326 isIndirect (Indirect _) = True
327 isIndirect other = False
331 %************************************************************************
333 \subsection{Tau, sigma and rho}
335 %************************************************************************
338 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau)
340 mkPhiTy :: [PredType] -> Type -> Type
341 mkPhiTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
344 @isTauTy@ tests for nested for-alls.
347 isTauTy :: Type -> Bool
348 isTauTy (TyVarTy v) = True
349 isTauTy (TyConApp _ tys) = all isTauTy tys
350 isTauTy (NewTcApp _ tys) = all isTauTy tys
351 isTauTy (AppTy a b) = isTauTy a && isTauTy b
352 isTauTy (FunTy a b) = isTauTy a && isTauTy b
353 isTauTy (PredTy p) = True -- Don't look through source types
354 isTauTy (NoteTy _ ty) = isTauTy ty
355 isTauTy other = False
359 getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
360 -- construct a dictionary function name
361 getDFunTyKey (TyVarTy tv) = getOccName tv
362 getDFunTyKey (TyConApp tc _) = getOccName tc
363 getDFunTyKey (NewTcApp tc _) = getOccName tc
364 getDFunTyKey (AppTy fun _) = getDFunTyKey fun
365 getDFunTyKey (NoteTy _ t) = getDFunTyKey t
366 getDFunTyKey (FunTy arg _) = getOccName funTyCon
367 getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
368 getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty)
369 -- PredTy shouldn't happen
373 %************************************************************************
375 \subsection{Expanding and splitting}
377 %************************************************************************
379 These tcSplit functions are like their non-Tc analogues, but
380 a) they do not look through newtypes
381 b) they do not look through PredTys
382 c) [future] they ignore usage-type annotations
384 However, they are non-monadic and do not follow through mutable type
385 variables. It's up to you to make sure this doesn't matter.
388 tcSplitForAllTys :: Type -> ([TyVar], Type)
389 tcSplitForAllTys ty = split ty ty []
391 split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
392 split orig_ty (NoteTy n ty) tvs = split orig_ty ty tvs
393 split orig_ty t tvs = (reverse tvs, orig_ty)
395 tcIsForAllTy (ForAllTy tv ty) = True
396 tcIsForAllTy (NoteTy n ty) = tcIsForAllTy ty
397 tcIsForAllTy t = False
399 tcSplitPhiTy :: Type -> ([PredType], Type)
400 tcSplitPhiTy ty = split ty ty []
402 split orig_ty (FunTy arg res) ts = case tcSplitPredTy_maybe arg of
403 Just p -> split res res (p:ts)
404 Nothing -> (reverse ts, orig_ty)
405 split orig_ty (NoteTy n ty) ts = split orig_ty ty ts
406 split orig_ty ty ts = (reverse ts, orig_ty)
408 tcSplitSigmaTy ty = case tcSplitForAllTys ty of
409 (tvs, rho) -> case tcSplitPhiTy rho of
410 (theta, tau) -> (tvs, theta, tau)
412 tcTyConAppTyCon :: Type -> TyCon
413 tcTyConAppTyCon ty = fst (tcSplitTyConApp ty)
415 tcTyConAppArgs :: Type -> [Type]
416 tcTyConAppArgs ty = snd (tcSplitTyConApp ty)
418 tcSplitTyConApp :: Type -> (TyCon, [Type])
419 tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of
421 Nothing -> pprPanic "tcSplitTyConApp" (pprType ty)
423 tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
424 tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
425 tcSplitTyConApp_maybe (NewTcApp tc tys) = Just (tc, tys)
426 tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
427 tcSplitTyConApp_maybe (NoteTy n ty) = tcSplitTyConApp_maybe ty
428 -- Newtypes are opaque, so they may be split
429 -- However, predicates are not treated
430 -- as tycon applications by the type checker
431 tcSplitTyConApp_maybe other = Nothing
433 tcSplitFunTys :: Type -> ([Type], Type)
434 tcSplitFunTys ty = case tcSplitFunTy_maybe ty of
436 Just (arg,res) -> (arg:args, res')
438 (args,res') = tcSplitFunTys res
440 tcSplitFunTy_maybe :: Type -> Maybe (Type, Type)
441 tcSplitFunTy_maybe (FunTy arg res) = Just (arg, res)
442 tcSplitFunTy_maybe (NoteTy n ty) = tcSplitFunTy_maybe ty
443 tcSplitFunTy_maybe other = Nothing
445 tcFunArgTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> arg }
446 tcFunResultTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> res }
449 tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
450 tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
451 tcSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
452 tcSplitAppTy_maybe (NoteTy n ty) = tcSplitAppTy_maybe ty
453 tcSplitAppTy_maybe (TyConApp tc tys) = case snocView tys of
454 Just (tys', ty') -> Just (TyConApp tc tys', ty')
456 tcSplitAppTy_maybe (NewTcApp tc tys) = case snocView tys of
457 Just (tys', ty') -> Just (NewTcApp tc tys', ty')
459 tcSplitAppTy_maybe other = Nothing
461 tcSplitAppTy ty = case tcSplitAppTy_maybe ty of
463 Nothing -> pprPanic "tcSplitAppTy" (pprType ty)
465 tcSplitAppTys :: Type -> (Type, [Type])
469 go ty args = case tcSplitAppTy_maybe ty of
470 Just (ty', arg) -> go ty' (arg:args)
473 tcGetTyVar_maybe :: Type -> Maybe TyVar
474 tcGetTyVar_maybe (TyVarTy tv) = Just tv
475 tcGetTyVar_maybe (NoteTy _ t) = tcGetTyVar_maybe t
476 tcGetTyVar_maybe other = Nothing
478 tcGetTyVar :: String -> Type -> TyVar
479 tcGetTyVar msg ty = expectJust msg (tcGetTyVar_maybe ty)
481 tcIsTyVarTy :: Type -> Bool
482 tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty)
485 The type of a method for class C is always of the form:
486 Forall a1..an. C a1..an => sig_ty
487 where sig_ty is the type given by the method's signature, and thus in general
488 is a ForallTy. At the point that splitMethodTy is called, it is expected
489 that the outer Forall has already been stripped off. splitMethodTy then
490 returns (C a1..an, sig_ty') where sig_ty' is sig_ty with any Notes stripped off.
493 tcSplitMethodTy :: Type -> (PredType, Type)
494 tcSplitMethodTy ty = split ty
496 split (FunTy arg res) = case tcSplitPredTy_maybe arg of
498 Nothing -> panic "splitMethodTy"
499 split (NoteTy n ty) = split ty
500 split _ = panic "splitMethodTy"
502 tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
503 -- Split the type of a dictionary function
505 = case tcSplitSigmaTy ty of { (tvs, theta, tau) ->
506 case tcSplitPredTy_maybe tau of { Just (ClassP clas tys) ->
507 (tvs, theta, clas, tys) }}
512 %************************************************************************
514 \subsection{Predicate types}
516 %************************************************************************
519 tcSplitPredTy_maybe :: Type -> Maybe PredType
520 -- Returns Just for predicates only
521 tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty
522 tcSplitPredTy_maybe (PredTy p) = Just p
523 tcSplitPredTy_maybe other = Nothing
525 predTyUnique :: PredType -> Unique
526 predTyUnique (IParam n _) = getUnique (ipNameName n)
527 predTyUnique (ClassP clas tys) = getUnique clas
529 mkPredName :: Unique -> SrcLoc -> PredType -> Name
530 mkPredName uniq loc (ClassP cls tys) = mkInternalName uniq (mkDictOcc (getOccName cls)) loc
531 mkPredName uniq loc (IParam ip ty) = mkInternalName uniq (getOccName (ipNameName ip)) loc
535 --------------------- Dictionary types ---------------------------------
538 mkClassPred clas tys = ClassP clas tys
540 isClassPred :: PredType -> Bool
541 isClassPred (ClassP clas tys) = True
542 isClassPred other = False
544 isTyVarClassPred (ClassP clas tys) = all tcIsTyVarTy tys
545 isTyVarClassPred other = False
547 getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
548 getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
549 getClassPredTys_maybe _ = Nothing
551 getClassPredTys :: PredType -> (Class, [Type])
552 getClassPredTys (ClassP clas tys) = (clas, tys)
554 mkDictTy :: Class -> [Type] -> Type
555 mkDictTy clas tys = mkPredTy (ClassP clas tys)
557 isDictTy :: Type -> Bool
558 isDictTy (PredTy p) = isClassPred p
559 isDictTy (NoteTy _ ty) = isDictTy ty
560 isDictTy other = False
563 --------------------- Implicit parameters ---------------------------------
566 isIPPred :: PredType -> Bool
567 isIPPred (IParam _ _) = True
568 isIPPred other = False
570 isInheritablePred :: PredType -> Bool
571 -- Can be inherited by a context. For example, consider
572 -- f x = let g y = (?v, y+x)
573 -- in (g 3 with ?v = 8,
575 -- The point is that g's type must be quantifed over ?v:
576 -- g :: (?v :: a) => a -> a
577 -- but it doesn't need to be quantified over the Num a dictionary
578 -- which can be free in g's rhs, and shared by both calls to g
579 isInheritablePred (ClassP _ _) = True
580 isInheritablePred other = False
582 isLinearPred :: TcPredType -> Bool
583 isLinearPred (IParam (Linear n) _) = True
584 isLinearPred other = False
588 %************************************************************************
590 \subsection{Comparison}
592 %************************************************************************
594 Comparison, taking note of newtypes, predicates, etc,
597 tcEqType :: Type -> Type -> Bool
598 tcEqType ty1 ty2 = case ty1 `tcCmpType` ty2 of { EQ -> True; other -> False }
600 tcEqTypes :: [Type] -> [Type] -> Bool
601 tcEqTypes ty1 ty2 = case ty1 `tcCmpTypes` ty2 of { EQ -> True; other -> False }
603 tcEqPred :: PredType -> PredType -> Bool
604 tcEqPred p1 p2 = case p1 `tcCmpPred` p2 of { EQ -> True; other -> False }
607 tcCmpType :: Type -> Type -> Ordering
608 tcCmpType ty1 ty2 = cmpTy emptyVarEnv ty1 ty2
610 tcCmpTypes tys1 tys2 = cmpTys emptyVarEnv tys1 tys2
612 tcCmpPred p1 p2 = cmpPredTy emptyVarEnv p1 p2
614 cmpTys env tys1 tys2 = cmpList (cmpTy env) tys1 tys2
617 cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering
618 -- The "env" maps type variables in ty1 to type variables in ty2
619 -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
620 -- we in effect substitute tv2 for tv1 in t1 before continuing
622 -- Look through NoteTy
623 cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2
624 cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2
626 -- Deal with equal constructors
627 cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
628 Just tv1a -> tv1a `compare` tv2
629 Nothing -> tv1 `compare` tv2
631 cmpTy env (PredTy p1) (PredTy p2) = cmpPredTy env p1 p2
632 cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
633 cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
634 cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
635 cmpTy env (NewTcApp tc1 tys1) (NewTcApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
636 cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2
638 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < NewTcApp < ForAllTy < PredTy
639 cmpTy env (AppTy _ _) (TyVarTy _) = GT
641 cmpTy env (FunTy _ _) (TyVarTy _) = GT
642 cmpTy env (FunTy _ _) (AppTy _ _) = GT
644 cmpTy env (TyConApp _ _) (TyVarTy _) = GT
645 cmpTy env (TyConApp _ _) (AppTy _ _) = GT
646 cmpTy env (TyConApp _ _) (FunTy _ _) = GT
648 cmpTy env (NewTcApp _ _) (TyVarTy _) = GT
649 cmpTy env (NewTcApp _ _) (AppTy _ _) = GT
650 cmpTy env (NewTcApp _ _) (FunTy _ _) = GT
651 cmpTy env (NewTcApp _ _) (TyConApp _ _) = GT
653 cmpTy env (ForAllTy _ _) (TyVarTy _) = GT
654 cmpTy env (ForAllTy _ _) (AppTy _ _) = GT
655 cmpTy env (ForAllTy _ _) (FunTy _ _) = GT
656 cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT
657 cmpTy env (ForAllTy _ _) (NewTcApp _ _) = GT
659 cmpTy env (PredTy _) t2 = GT
665 cmpPredTy :: TyVarEnv TyVar -> PredType -> PredType -> Ordering
666 cmpPredTy env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2)
667 -- Compare types as well as names for implicit parameters
668 -- This comparison is used exclusively (I think) for the
669 -- finite map built in TcSimplify
670 cmpPredTy env (IParam _ _) (ClassP _ _) = LT
671 cmpPredTy env (ClassP _ _) (IParam _ _) = GT
672 cmpPredTy env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
675 PredTypes are used as a FM key in TcSimplify,
676 so we take the easy path and make them an instance of Ord
679 instance Eq PredType where { (==) = tcEqPred }
680 instance Ord PredType where { compare = tcCmpPred }
684 %************************************************************************
686 \subsection{Predicates}
688 %************************************************************************
690 isSigmaTy returns true of any qualified type. It doesn't *necessarily* have
692 f :: (?x::Int) => Int -> Int
695 isSigmaTy :: Type -> Bool
696 isSigmaTy (ForAllTy tyvar ty) = True
697 isSigmaTy (FunTy a b) = isPredTy a
698 isSigmaTy (NoteTy n ty) = isSigmaTy ty
701 isOverloadedTy :: Type -> Bool
702 isOverloadedTy (ForAllTy tyvar ty) = isOverloadedTy ty
703 isOverloadedTy (FunTy a b) = isPredTy a
704 isOverloadedTy (NoteTy n ty) = isOverloadedTy ty
705 isOverloadedTy _ = False
707 isPredTy :: Type -> Bool -- Belongs in TcType because it does
708 -- not look through newtypes, or predtypes (of course)
709 isPredTy (NoteTy _ ty) = isPredTy ty
710 isPredTy (PredTy sty) = True
715 isFloatTy = is_tc floatTyConKey
716 isDoubleTy = is_tc doubleTyConKey
717 isIntegerTy = is_tc integerTyConKey
718 isIntTy = is_tc intTyConKey
719 isAddrTy = is_tc addrTyConKey
720 isBoolTy = is_tc boolTyConKey
721 isUnitTy = is_tc unitTyConKey
723 is_tc :: Unique -> Type -> Bool
724 -- Newtypes are opaque to this
725 is_tc uniq ty = case tcSplitTyConApp_maybe ty of
726 Just (tc, _) -> uniq == getUnique tc
731 %************************************************************************
735 %************************************************************************
738 deNoteType :: Type -> Type
739 -- Remove synonyms, but not predicate types
740 deNoteType ty@(TyVarTy tyvar) = ty
741 deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
742 deNoteType (NewTcApp tycon tys) = NewTcApp tycon (map deNoteType tys)
743 deNoteType (PredTy p) = PredTy (deNotePredType p)
744 deNoteType (NoteTy _ ty) = deNoteType ty
745 deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg)
746 deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg)
747 deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty)
749 deNotePredType :: PredType -> PredType
750 deNotePredType (ClassP c tys) = ClassP c (map deNoteType tys)
751 deNotePredType (IParam n ty) = IParam n (deNoteType ty)
754 Find the free tycons and classes of a type. This is used in the front
758 tyClsNamesOfType :: Type -> NameSet
759 tyClsNamesOfType (TyVarTy tv) = emptyNameSet
760 tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
761 tyClsNamesOfType (NewTcApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
762 tyClsNamesOfType (NoteTy (SynNote ty1) ty2) = tyClsNamesOfType ty1
763 tyClsNamesOfType (NoteTy other_note ty2) = tyClsNamesOfType ty2
764 tyClsNamesOfType (PredTy (IParam n ty)) = tyClsNamesOfType ty
765 tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
766 tyClsNamesOfType (FunTy arg res) = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res
767 tyClsNamesOfType (AppTy fun arg) = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg
768 tyClsNamesOfType (ForAllTy tyvar ty) = tyClsNamesOfType ty
770 tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys
772 tyClsNamesOfDFunHead :: Type -> NameSet
773 -- Find the free type constructors and classes
774 -- of the head of the dfun instance type
775 -- The 'dfun_head_type' is because of
776 -- instance Foo a => Baz T where ...
777 -- The decl is an orphan if Baz and T are both not locally defined,
778 -- even if Foo *is* locally defined
779 tyClsNamesOfDFunHead dfun_ty
780 = case tcSplitSigmaTy dfun_ty of
781 (tvs,_,head_ty) -> tyClsNamesOfType head_ty
783 classesOfTheta :: ThetaType -> [Class]
784 -- Looks just for ClassP things; maybe it should check
785 classesOfTheta preds = [ c | ClassP c _ <- preds ]
789 %************************************************************************
791 \subsection[TysWiredIn-ext-type]{External types}
793 %************************************************************************
795 The compiler's foreign function interface supports the passing of a
796 restricted set of types as arguments and results (the restricting factor
800 isFFITy :: Type -> Bool
801 -- True for any TyCon that can possibly be an arg or result of an FFI call
802 isFFITy ty = checkRepTyCon legalFFITyCon ty
804 isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
805 -- Checks for valid argument type for a 'foreign import'
806 isFFIArgumentTy dflags safety ty
807 = checkRepTyCon (legalOutgoingTyCon dflags safety) ty
809 isFFIExternalTy :: Type -> Bool
810 -- Types that are allowed as arguments of a 'foreign export'
811 isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty
813 isFFIImportResultTy :: DynFlags -> Type -> Bool
814 isFFIImportResultTy dflags ty
815 = checkRepTyCon (legalFIResultTyCon dflags) ty
817 isFFIExportResultTy :: Type -> Bool
818 isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
820 isFFIDynArgumentTy :: Type -> Bool
821 -- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr,
822 -- or a newtype of either.
823 isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
825 isFFIDynResultTy :: Type -> Bool
826 -- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr,
827 -- or a newtype of either.
828 isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
830 isFFILabelTy :: Type -> Bool
831 -- The type of a foreign label must be Ptr, FunPtr, Addr,
832 -- or a newtype of either.
833 isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
835 isFFIDotnetTy :: DynFlags -> Type -> Bool
836 isFFIDotnetTy dflags ty
837 = checkRepTyCon (\ tc -> not (isByteArrayLikeTyCon tc) &&
838 (legalFIResultTyCon dflags tc ||
839 isFFIDotnetObjTy ty || isStringTy ty)) ty
841 -- Support String as an argument or result from a .NET FFI call.
843 case tcSplitTyConApp_maybe (repType ty) of
846 case tcSplitTyConApp_maybe (repType arg_ty) of
847 Just (cc,[]) -> cc == charTyCon
851 -- Support String as an argument or result from a .NET FFI call.
852 isFFIDotnetObjTy ty =
854 (_, t_ty) = tcSplitForAllTys ty
856 case tcSplitTyConApp_maybe (repType t_ty) of
857 Just (tc, [arg_ty]) | getName tc == objectTyConName -> True
860 toDNType :: Type -> DNType
862 | isStringTy ty = DNString
863 | isFFIDotnetObjTy ty = DNObject
864 | Just (tc,argTys) <- tcSplitTyConApp_maybe ty =
865 case lookup (getUnique tc) dn_assoc of
868 | tc `hasKey` ioTyConKey -> toDNType (head argTys)
869 | otherwise -> pprPanic ("toDNType: unsupported .NET type") (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc)
871 dn_assoc :: [ (Unique, DNType) ]
872 dn_assoc = [ (unitTyConKey, DNUnit)
873 , (intTyConKey, DNInt)
874 , (int8TyConKey, DNInt8)
875 , (int16TyConKey, DNInt16)
876 , (int32TyConKey, DNInt32)
877 , (int64TyConKey, DNInt64)
878 , (wordTyConKey, DNInt)
879 , (word8TyConKey, DNWord8)
880 , (word16TyConKey, DNWord16)
881 , (word32TyConKey, DNWord32)
882 , (word64TyConKey, DNWord64)
883 , (floatTyConKey, DNFloat)
884 , (doubleTyConKey, DNDouble)
885 , (addrTyConKey, DNPtr)
886 , (ptrTyConKey, DNPtr)
887 , (funPtrTyConKey, DNPtr)
888 , (charTyConKey, DNChar)
889 , (boolTyConKey, DNBool)
892 checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
893 -- Look through newtypes
894 -- Non-recursive ones are transparent to splitTyConApp,
895 -- but recursive ones aren't. Manuel had:
896 -- newtype T = MkT (Ptr T)
897 -- and wanted it to work...
898 checkRepTyCon check_tc ty
899 | Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc
902 checkRepTyConKey :: [Unique] -> Type -> Bool
903 -- Like checkRepTyCon, but just looks at the TyCon key
904 checkRepTyConKey keys
905 = checkRepTyCon (\tc -> tyConUnique tc `elem` keys)
908 ----------------------------------------------
909 These chaps do the work; they are not exported
910 ----------------------------------------------
913 legalFEArgTyCon :: TyCon -> Bool
914 -- It's illegal to return foreign objects and (mutable)
915 -- bytearrays from a _ccall_ / foreign declaration
916 -- (or be passed them as arguments in foreign exported functions).
918 | isByteArrayLikeTyCon tc
920 -- It's also illegal to make foreign exports that take unboxed
921 -- arguments. The RTS API currently can't invoke such things. --SDM 7/2000
923 = boxedMarshalableTyCon tc
925 legalFIResultTyCon :: DynFlags -> TyCon -> Bool
926 legalFIResultTyCon dflags tc
927 | isByteArrayLikeTyCon tc = False
928 | tc == unitTyCon = True
929 | otherwise = marshalableTyCon dflags tc
931 legalFEResultTyCon :: TyCon -> Bool
932 legalFEResultTyCon tc
933 | isByteArrayLikeTyCon tc = False
934 | tc == unitTyCon = True
935 | otherwise = boxedMarshalableTyCon tc
937 legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
938 -- Checks validity of types going from Haskell -> external world
939 legalOutgoingTyCon dflags safety tc
940 | playSafe safety && isByteArrayLikeTyCon tc
943 = marshalableTyCon dflags tc
945 legalFFITyCon :: TyCon -> Bool
946 -- True for any TyCon that can possibly be an arg or result of an FFI call
948 = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon
950 marshalableTyCon dflags tc
951 = (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
952 || boxedMarshalableTyCon tc
954 boxedMarshalableTyCon tc
955 = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
956 , int32TyConKey, int64TyConKey
957 , wordTyConKey, word8TyConKey, word16TyConKey
958 , word32TyConKey, word64TyConKey
959 , floatTyConKey, doubleTyConKey
960 , addrTyConKey, ptrTyConKey, funPtrTyConKey
963 , byteArrayTyConKey, mutableByteArrayTyConKey
967 isByteArrayLikeTyCon :: TyCon -> Bool
968 isByteArrayLikeTyCon tc =
969 getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]