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, isExistentialTyVar, 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 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, isExistentialTyVar, isMetaTyVar :: TyVar -> Bool
295 | isTcTyVar tv = isSkolemTyVar tv
299 = ASSERT( isTcTyVar tv )
300 case tcTyVarDetails tv of
304 isExistentialTyVar tv -- Existential type variable, bound by a pattern
305 = ASSERT( isTcTyVar tv )
306 case tcTyVarDetails tv of
307 SkolemTv (PatSkol _ _) -> True
311 = ASSERT( isTcTyVar tv )
312 case tcTyVarDetails tv of
316 skolemTvInfo :: TyVar -> SkolemInfo
318 = ASSERT( isTcTyVar tv )
319 case tcTyVarDetails tv of
320 SkolemTv info -> info
322 metaTvRef :: TyVar -> IORef MetaDetails
324 = ASSERT( isTcTyVar tv )
325 case tcTyVarDetails tv of
328 isFlexi, isIndirect :: MetaDetails -> Bool
330 isFlexi other = False
332 isIndirect (Indirect _) = True
333 isIndirect other = False
337 %************************************************************************
339 \subsection{Tau, sigma and rho}
341 %************************************************************************
344 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau)
346 mkPhiTy :: [PredType] -> Type -> Type
347 mkPhiTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
350 @isTauTy@ tests for nested for-alls.
353 isTauTy :: Type -> Bool
354 isTauTy (TyVarTy v) = True
355 isTauTy (TyConApp _ tys) = all isTauTy tys
356 isTauTy (AppTy a b) = isTauTy a && isTauTy b
357 isTauTy (FunTy a b) = isTauTy a && isTauTy b
358 isTauTy (PredTy p) = True -- Don't look through source types
359 isTauTy (NoteTy _ ty) = isTauTy ty
360 isTauTy other = False
364 getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
365 -- construct a dictionary function name
366 getDFunTyKey (TyVarTy tv) = getOccName tv
367 getDFunTyKey (TyConApp tc _) = getOccName tc
368 getDFunTyKey (AppTy fun _) = getDFunTyKey fun
369 getDFunTyKey (NoteTy _ t) = getDFunTyKey t
370 getDFunTyKey (FunTy arg _) = getOccName funTyCon
371 getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
372 getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty)
373 -- PredTy shouldn't happen
377 %************************************************************************
379 \subsection{Expanding and splitting}
381 %************************************************************************
383 These tcSplit functions are like their non-Tc analogues, but
384 a) they do not look through newtypes
385 b) they do not look through PredTys
386 c) [future] they ignore usage-type annotations
388 However, they are non-monadic and do not follow through mutable type
389 variables. It's up to you to make sure this doesn't matter.
392 tcSplitForAllTys :: Type -> ([TyVar], Type)
393 tcSplitForAllTys ty = split ty ty []
395 split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
396 split orig_ty (NoteTy n ty) tvs = split orig_ty ty tvs
397 split orig_ty t tvs = (reverse tvs, orig_ty)
399 tcIsForAllTy (ForAllTy tv ty) = True
400 tcIsForAllTy (NoteTy n ty) = tcIsForAllTy ty
401 tcIsForAllTy t = False
403 tcSplitPhiTy :: Type -> ([PredType], Type)
404 tcSplitPhiTy ty = split ty ty []
406 split orig_ty (FunTy arg res) ts = case tcSplitPredTy_maybe arg of
407 Just p -> split res res (p:ts)
408 Nothing -> (reverse ts, orig_ty)
409 split orig_ty (NoteTy n ty) ts = split orig_ty ty ts
410 split orig_ty ty ts = (reverse ts, orig_ty)
412 tcSplitSigmaTy ty = case tcSplitForAllTys ty of
413 (tvs, rho) -> case tcSplitPhiTy rho of
414 (theta, tau) -> (tvs, theta, tau)
416 tcTyConAppTyCon :: Type -> TyCon
417 tcTyConAppTyCon ty = fst (tcSplitTyConApp ty)
419 tcTyConAppArgs :: Type -> [Type]
420 tcTyConAppArgs ty = snd (tcSplitTyConApp ty)
422 tcSplitTyConApp :: Type -> (TyCon, [Type])
423 tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of
425 Nothing -> pprPanic "tcSplitTyConApp" (pprType ty)
427 tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
428 tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
429 tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
430 tcSplitTyConApp_maybe (NoteTy n ty) = tcSplitTyConApp_maybe ty
431 -- Newtypes are opaque, so they may be split
432 -- However, predicates are not treated
433 -- as tycon applications by the type checker
434 tcSplitTyConApp_maybe other = Nothing
436 tcSplitFunTys :: Type -> ([Type], Type)
437 tcSplitFunTys ty = case tcSplitFunTy_maybe ty of
439 Just (arg,res) -> (arg:args, res')
441 (args,res') = tcSplitFunTys res
443 tcSplitFunTy_maybe :: Type -> Maybe (Type, Type)
444 tcSplitFunTy_maybe (FunTy arg res) = Just (arg, res)
445 tcSplitFunTy_maybe (NoteTy n ty) = tcSplitFunTy_maybe ty
446 tcSplitFunTy_maybe other = Nothing
448 tcFunArgTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> arg }
449 tcFunResultTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> res }
452 tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
453 tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
454 tcSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
455 tcSplitAppTy_maybe (NoteTy n ty) = tcSplitAppTy_maybe ty
456 tcSplitAppTy_maybe (TyConApp tc tys) = case snocView tys of
457 Just (tys', ty') -> Just (TyConApp 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)
484 tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
485 -- Split the type of a dictionary function
487 = case tcSplitSigmaTy ty of { (tvs, theta, tau) ->
488 case tcSplitPredTy_maybe tau of { Just (ClassP clas tys) ->
489 (tvs, theta, clas, tys) }}
494 %************************************************************************
496 \subsection{Predicate types}
498 %************************************************************************
501 tcSplitPredTy_maybe :: Type -> Maybe PredType
502 -- Returns Just for predicates only
503 tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty
504 tcSplitPredTy_maybe (PredTy p) = Just p
505 tcSplitPredTy_maybe other = Nothing
507 predTyUnique :: PredType -> Unique
508 predTyUnique (IParam n _) = getUnique (ipNameName n)
509 predTyUnique (ClassP clas tys) = getUnique clas
511 mkPredName :: Unique -> SrcLoc -> PredType -> Name
512 mkPredName uniq loc (ClassP cls tys) = mkInternalName uniq (mkDictOcc (getOccName cls)) loc
513 mkPredName uniq loc (IParam ip ty) = mkInternalName uniq (getOccName (ipNameName ip)) loc
517 --------------------- Dictionary types ---------------------------------
520 mkClassPred clas tys = ClassP clas tys
522 isClassPred :: PredType -> Bool
523 isClassPred (ClassP clas tys) = True
524 isClassPred other = False
526 isTyVarClassPred (ClassP clas tys) = all tcIsTyVarTy tys
527 isTyVarClassPred other = False
529 getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
530 getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
531 getClassPredTys_maybe _ = Nothing
533 getClassPredTys :: PredType -> (Class, [Type])
534 getClassPredTys (ClassP clas tys) = (clas, tys)
536 mkDictTy :: Class -> [Type] -> Type
537 mkDictTy clas tys = mkPredTy (ClassP clas tys)
539 isDictTy :: Type -> Bool
540 isDictTy (PredTy p) = isClassPred p
541 isDictTy (NoteTy _ ty) = isDictTy ty
542 isDictTy other = False
545 --------------------- Implicit parameters ---------------------------------
548 isIPPred :: PredType -> Bool
549 isIPPred (IParam _ _) = True
550 isIPPred other = False
552 isInheritablePred :: PredType -> Bool
553 -- Can be inherited by a context. For example, consider
554 -- f x = let g y = (?v, y+x)
555 -- in (g 3 with ?v = 8,
557 -- The point is that g's type must be quantifed over ?v:
558 -- g :: (?v :: a) => a -> a
559 -- but it doesn't need to be quantified over the Num a dictionary
560 -- which can be free in g's rhs, and shared by both calls to g
561 isInheritablePred (ClassP _ _) = True
562 isInheritablePred other = False
564 isLinearPred :: TcPredType -> Bool
565 isLinearPred (IParam (Linear n) _) = True
566 isLinearPred other = False
570 %************************************************************************
572 \subsection{Comparison}
574 %************************************************************************
576 Comparison, taking note of newtypes, predicates, etc,
579 tcEqType :: Type -> Type -> Bool
580 tcEqType ty1 ty2 = case ty1 `tcCmpType` ty2 of { EQ -> True; other -> False }
582 tcEqTypes :: [Type] -> [Type] -> Bool
583 tcEqTypes ty1 ty2 = case ty1 `tcCmpTypes` ty2 of { EQ -> True; other -> False }
585 tcEqPred :: PredType -> PredType -> Bool
586 tcEqPred p1 p2 = case p1 `tcCmpPred` p2 of { EQ -> True; other -> False }
589 tcCmpType :: Type -> Type -> Ordering
590 tcCmpType ty1 ty2 = cmpTy emptyVarEnv ty1 ty2
592 tcCmpTypes tys1 tys2 = cmpTys emptyVarEnv tys1 tys2
594 tcCmpPred p1 p2 = cmpPredTy emptyVarEnv p1 p2
596 cmpTys env tys1 tys2 = cmpList (cmpTy env) tys1 tys2
599 cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering
600 -- The "env" maps type variables in ty1 to type variables in ty2
601 -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
602 -- we in effect substitute tv2 for tv1 in t1 before continuing
604 -- Look through NoteTy
605 cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2
606 cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2
608 -- Deal with equal constructors
609 cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
610 Just tv1a -> tv1a `compare` tv2
611 Nothing -> tv1 `compare` tv2
613 cmpTy env (PredTy p1) (PredTy p2) = cmpPredTy env p1 p2
614 cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
615 cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
616 cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
617 cmpTy env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTy (extendVarEnv env tv1 tv2) t1 t2
619 -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < PredTy
620 cmpTy env (AppTy _ _) (TyVarTy _) = GT
622 cmpTy env (FunTy _ _) (TyVarTy _) = GT
623 cmpTy env (FunTy _ _) (AppTy _ _) = GT
625 cmpTy env (TyConApp _ _) (TyVarTy _) = GT
626 cmpTy env (TyConApp _ _) (AppTy _ _) = GT
627 cmpTy env (TyConApp _ _) (FunTy _ _) = GT
629 cmpTy env (ForAllTy _ _) (TyVarTy _) = GT
630 cmpTy env (ForAllTy _ _) (AppTy _ _) = GT
631 cmpTy env (ForAllTy _ _) (FunTy _ _) = GT
632 cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT
634 cmpTy env (PredTy _) t2 = GT
640 cmpPredTy :: TyVarEnv TyVar -> PredType -> PredType -> Ordering
641 cmpPredTy env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2)
642 -- Compare types as well as names for implicit parameters
643 -- This comparison is used exclusively (I think) for the
644 -- finite map built in TcSimplify
645 cmpPredTy env (IParam _ _) (ClassP _ _) = LT
646 cmpPredTy env (ClassP _ _) (IParam _ _) = GT
647 cmpPredTy env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
650 PredTypes are used as a FM key in TcSimplify,
651 so we take the easy path and make them an instance of Ord
654 instance Eq PredType where { (==) = tcEqPred }
655 instance Ord PredType where { compare = tcCmpPred }
659 %************************************************************************
661 \subsection{Predicates}
663 %************************************************************************
665 isSigmaTy returns true of any qualified type. It doesn't *necessarily* have
667 f :: (?x::Int) => Int -> Int
670 isSigmaTy :: Type -> Bool
671 isSigmaTy (ForAllTy tyvar ty) = True
672 isSigmaTy (FunTy a b) = isPredTy a
673 isSigmaTy (NoteTy n ty) = isSigmaTy ty
676 isOverloadedTy :: Type -> Bool
677 isOverloadedTy (ForAllTy tyvar ty) = isOverloadedTy ty
678 isOverloadedTy (FunTy a b) = isPredTy a
679 isOverloadedTy (NoteTy n ty) = isOverloadedTy ty
680 isOverloadedTy _ = False
682 isPredTy :: Type -> Bool -- Belongs in TcType because it does
683 -- not look through newtypes, or predtypes (of course)
684 isPredTy (NoteTy _ ty) = isPredTy ty
685 isPredTy (PredTy sty) = True
690 isFloatTy = is_tc floatTyConKey
691 isDoubleTy = is_tc doubleTyConKey
692 isIntegerTy = is_tc integerTyConKey
693 isIntTy = is_tc intTyConKey
694 isAddrTy = is_tc addrTyConKey
695 isBoolTy = is_tc boolTyConKey
696 isUnitTy = is_tc unitTyConKey
698 is_tc :: Unique -> Type -> Bool
699 -- Newtypes are opaque to this
700 is_tc uniq ty = case tcSplitTyConApp_maybe ty of
701 Just (tc, _) -> uniq == getUnique tc
706 %************************************************************************
710 %************************************************************************
713 deNoteType :: Type -> Type
714 -- Remove synonyms, but not predicate types
715 deNoteType ty@(TyVarTy tyvar) = ty
716 deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
717 deNoteType (PredTy p) = PredTy (deNotePredType p)
718 deNoteType (NoteTy _ ty) = deNoteType ty
719 deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg)
720 deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg)
721 deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty)
723 deNotePredType :: PredType -> PredType
724 deNotePredType (ClassP c tys) = ClassP c (map deNoteType tys)
725 deNotePredType (IParam n ty) = IParam n (deNoteType ty)
728 Find the free tycons and classes of a type. This is used in the front
732 tyClsNamesOfType :: Type -> NameSet
733 tyClsNamesOfType (TyVarTy tv) = emptyNameSet
734 tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
735 tyClsNamesOfType (NoteTy (SynNote ty1) ty2) = tyClsNamesOfType ty1
736 tyClsNamesOfType (NoteTy other_note ty2) = tyClsNamesOfType ty2
737 tyClsNamesOfType (PredTy (IParam n ty)) = tyClsNamesOfType ty
738 tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
739 tyClsNamesOfType (FunTy arg res) = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res
740 tyClsNamesOfType (AppTy fun arg) = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg
741 tyClsNamesOfType (ForAllTy tyvar ty) = tyClsNamesOfType ty
743 tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys
745 tyClsNamesOfDFunHead :: Type -> NameSet
746 -- Find the free type constructors and classes
747 -- of the head of the dfun instance type
748 -- The 'dfun_head_type' is because of
749 -- instance Foo a => Baz T where ...
750 -- The decl is an orphan if Baz and T are both not locally defined,
751 -- even if Foo *is* locally defined
752 tyClsNamesOfDFunHead dfun_ty
753 = case tcSplitSigmaTy dfun_ty of
754 (tvs,_,head_ty) -> tyClsNamesOfType head_ty
756 classesOfTheta :: ThetaType -> [Class]
757 -- Looks just for ClassP things; maybe it should check
758 classesOfTheta preds = [ c | ClassP c _ <- preds ]
762 %************************************************************************
764 \subsection[TysWiredIn-ext-type]{External types}
766 %************************************************************************
768 The compiler's foreign function interface supports the passing of a
769 restricted set of types as arguments and results (the restricting factor
773 isFFITy :: Type -> Bool
774 -- True for any TyCon that can possibly be an arg or result of an FFI call
775 isFFITy ty = checkRepTyCon legalFFITyCon ty
777 isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
778 -- Checks for valid argument type for a 'foreign import'
779 isFFIArgumentTy dflags safety ty
780 = checkRepTyCon (legalOutgoingTyCon dflags safety) ty
782 isFFIExternalTy :: Type -> Bool
783 -- Types that are allowed as arguments of a 'foreign export'
784 isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty
786 isFFIImportResultTy :: DynFlags -> Type -> Bool
787 isFFIImportResultTy dflags ty
788 = checkRepTyCon (legalFIResultTyCon dflags) ty
790 isFFIExportResultTy :: Type -> Bool
791 isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
793 isFFIDynArgumentTy :: Type -> Bool
794 -- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr,
795 -- or a newtype of either.
796 isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
798 isFFIDynResultTy :: Type -> Bool
799 -- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr,
800 -- or a newtype of either.
801 isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
803 isFFILabelTy :: Type -> Bool
804 -- The type of a foreign label must be Ptr, FunPtr, Addr,
805 -- or a newtype of either.
806 isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
808 isFFIDotnetTy :: DynFlags -> Type -> Bool
809 isFFIDotnetTy dflags ty
810 = checkRepTyCon (\ tc -> not (isByteArrayLikeTyCon tc) &&
811 (legalFIResultTyCon dflags tc ||
812 isFFIDotnetObjTy ty || isStringTy ty)) ty
814 -- Support String as an argument or result from a .NET FFI call.
816 case tcSplitTyConApp_maybe (repType ty) of
819 case tcSplitTyConApp_maybe (repType arg_ty) of
820 Just (cc,[]) -> cc == charTyCon
824 -- Support String as an argument or result from a .NET FFI call.
825 isFFIDotnetObjTy ty =
827 (_, t_ty) = tcSplitForAllTys ty
829 case tcSplitTyConApp_maybe (repType t_ty) of
830 Just (tc, [arg_ty]) | getName tc == objectTyConName -> True
833 toDNType :: Type -> DNType
835 | isStringTy ty = DNString
836 | isFFIDotnetObjTy ty = DNObject
837 | Just (tc,argTys) <- tcSplitTyConApp_maybe ty =
838 case lookup (getUnique tc) dn_assoc of
841 | tc `hasKey` ioTyConKey -> toDNType (head argTys)
842 | otherwise -> pprPanic ("toDNType: unsupported .NET type") (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc)
844 dn_assoc :: [ (Unique, DNType) ]
845 dn_assoc = [ (unitTyConKey, DNUnit)
846 , (intTyConKey, DNInt)
847 , (int8TyConKey, DNInt8)
848 , (int16TyConKey, DNInt16)
849 , (int32TyConKey, DNInt32)
850 , (int64TyConKey, DNInt64)
851 , (wordTyConKey, DNInt)
852 , (word8TyConKey, DNWord8)
853 , (word16TyConKey, DNWord16)
854 , (word32TyConKey, DNWord32)
855 , (word64TyConKey, DNWord64)
856 , (floatTyConKey, DNFloat)
857 , (doubleTyConKey, DNDouble)
858 , (addrTyConKey, DNPtr)
859 , (ptrTyConKey, DNPtr)
860 , (funPtrTyConKey, DNPtr)
861 , (charTyConKey, DNChar)
862 , (boolTyConKey, DNBool)
865 checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
866 -- Look through newtypes
867 -- Non-recursive ones are transparent to splitTyConApp,
868 -- but recursive ones aren't. Manuel had:
869 -- newtype T = MkT (Ptr T)
870 -- and wanted it to work...
871 checkRepTyCon check_tc ty
872 | Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc
875 checkRepTyConKey :: [Unique] -> Type -> Bool
876 -- Like checkRepTyCon, but just looks at the TyCon key
877 checkRepTyConKey keys
878 = checkRepTyCon (\tc -> tyConUnique tc `elem` keys)
881 ----------------------------------------------
882 These chaps do the work; they are not exported
883 ----------------------------------------------
886 legalFEArgTyCon :: TyCon -> Bool
887 -- It's illegal to return foreign objects and (mutable)
888 -- bytearrays from a _ccall_ / foreign declaration
889 -- (or be passed them as arguments in foreign exported functions).
891 | isByteArrayLikeTyCon tc
893 -- It's also illegal to make foreign exports that take unboxed
894 -- arguments. The RTS API currently can't invoke such things. --SDM 7/2000
896 = boxedMarshalableTyCon tc
898 legalFIResultTyCon :: DynFlags -> TyCon -> Bool
899 legalFIResultTyCon dflags tc
900 | isByteArrayLikeTyCon tc = False
901 | tc == unitTyCon = True
902 | otherwise = marshalableTyCon dflags tc
904 legalFEResultTyCon :: TyCon -> Bool
905 legalFEResultTyCon tc
906 | isByteArrayLikeTyCon tc = False
907 | tc == unitTyCon = True
908 | otherwise = boxedMarshalableTyCon tc
910 legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
911 -- Checks validity of types going from Haskell -> external world
912 legalOutgoingTyCon dflags safety tc
913 | playSafe safety && isByteArrayLikeTyCon tc
916 = marshalableTyCon dflags tc
918 legalFFITyCon :: TyCon -> Bool
919 -- True for any TyCon that can possibly be an arg or result of an FFI call
921 = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon
923 marshalableTyCon dflags tc
924 = (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
925 || boxedMarshalableTyCon tc
927 boxedMarshalableTyCon tc
928 = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
929 , int32TyConKey, int64TyConKey
930 , wordTyConKey, word8TyConKey, word16TyConKey
931 , word32TyConKey, word64TyConKey
932 , floatTyConKey, doubleTyConKey
933 , addrTyConKey, ptrTyConKey, funPtrTyConKey
936 , byteArrayTyConKey, mutableByteArrayTyConKey
940 isByteArrayLikeTyCon :: TyCon -> Bool
941 isByteArrayLikeTyCon tc =
942 getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]