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, tcEqTypeX,
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, PredType(..),
126 ThetaType, unliftedTypeKind,
127 liftedTypeKind, openTypeKind, mkArrowKind,
128 isLiftedTypeKind, isUnliftedTypeKind,
129 mkArrowKinds, mkForAllTy, mkForAllTys,
130 defaultKind, isArgTypeKind, isOpenTypeKind,
131 mkFunTy, mkFunTys, zipFunTys,
132 mkTyConApp, mkGenTyConApp, mkAppTy,
133 mkAppTys, mkSynTy, applyTy, applyTys,
134 mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy,
135 mkPredTys, isUnLiftedType,
136 isUnboxedTupleType, isPrimitiveType,
138 tidyTopType, tidyType, tidyPred, tidyTypes,
139 tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
140 tidyTyVarBndr, tidyOpenTyVar,
144 tcEqType, tcEqTypes, tcCmpType, tcCmpTypes,
145 tcEqPred, tcCmpPred, tcEqTypeX,
148 TvSubstEnv, emptyTvSubst,
149 mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst,
150 getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
151 extendTvSubst, extendTvSubstList, isInScope,
152 substTy, substTys, substTyWith, substTheta, substTyVar,
155 pprKind, pprParendKind,
156 pprType, pprParendType, pprTyThingCategory,
157 pprPred, pprTheta, pprThetaArrow, pprClassPred
159 import TyCon ( TyCon, isUnLiftedTyCon, tyConUnique )
160 import DataCon ( DataCon )
161 import Class ( Class )
162 import Var ( TyVar, Id, isTcTyVar, tcTyVarDetails )
163 import ForeignCall ( Safety, playSafe, DNType(..) )
167 import CmdLineOpts ( DynFlags, DynFlag( Opt_GlasgowExts ), dopt )
168 import Name ( Name, NamedThing(..), mkInternalName, getSrcLoc )
170 import OccName ( OccName, mkDictOcc )
171 import PrelNames -- Lots (e.g. in isFFIArgumentTy)
172 import TysWiredIn ( unitTyCon, charTyCon, listTyCon )
173 import BasicTypes ( IPName(..), ipNameName )
174 import SrcLoc ( SrcLoc, SrcSpan )
175 import Util ( snocView )
176 import Maybes ( maybeToBool, expectJust )
182 %************************************************************************
186 %************************************************************************
188 The type checker divides the generic Type world into the
189 following more structured beasts:
191 sigma ::= forall tyvars. phi
192 -- A sigma type is a qualified type
194 -- Note that even if 'tyvars' is empty, theta
195 -- may not be: e.g. (?x::Int) => Int
197 -- Note that 'sigma' is in prenex form:
198 -- all the foralls are at the front.
199 -- A 'phi' type has no foralls to the right of
207 -- A 'tau' type has no quantification anywhere
208 -- Note that the args of a type constructor must be taus
210 | tycon tau_1 .. tau_n
214 -- In all cases, a (saturated) type synonym application is legal,
215 -- provided it expands to the required form.
218 type TcType = Type -- A TcType can have mutable type variables
219 -- Invariant on ForAllTy in TcTypes:
221 -- a cannot occur inside a MutTyVar in T; that is,
222 -- T is "flattened" before quantifying over a
224 type TcPredType = PredType
225 type TcThetaType = ThetaType
226 type TcSigmaType = TcType
227 type TcRhoType = TcType
228 type TcTauType = TcType
230 type TcTyVarSet = TyVarSet
234 %************************************************************************
236 \subsection{TyVarDetails}
238 %************************************************************************
240 TyVarDetails gives extra info about type variables, used during type
241 checking. It's attached to mutable type variables only.
242 It's knot-tied back to Var.lhs. There is no reason in principle
243 why Var.lhs shouldn't actually have the definition, but it "belongs" here.
246 type TcTyVar = TyVar -- Used only during type inference
248 -- A TyVarDetails is inside a TyVar
250 = SkolemTv SkolemInfo -- A skolem constant
251 | MetaTv (IORef MetaDetails) -- A meta type variable stands for a tau-type
254 = SigSkol Name -- Bound at a type signature
255 | ClsSkol Class -- Bound at a class decl
256 | InstSkol Id -- Bound at an instance decl
257 | PatSkol DataCon -- An existential type variable bound by a pattern for
258 SrcSpan -- a data constructor with an existential type. E.g.
259 -- data T = forall a. Eq a => MkT a
261 -- The pattern MkT x will allocate an existential type
263 | ArrowSkol SrcSpan -- An arrow form (see TcArrows)
265 | GenSkol TcType -- Bound when doing a subsumption check for this type
269 = Flexi -- Flexi type variables unify to become
272 | Indirect TcType -- Type indirections, treated as wobbly
273 -- for the purpose of GADT unification.
275 pprSkolemTyVar :: TcTyVar -> SDoc
277 = ASSERT( isSkolemTyVar tv )
278 quotes (ppr tv) <+> ptext SLIT("is bound by") <+> ppr (skolemTvInfo tv)
280 instance Outputable SkolemInfo where
281 ppr (SigSkol id) = ptext SLIT("the type signature for") <+> quotes (ppr id)
282 ppr (ClsSkol cls) = ptext SLIT("the class declaration for") <+> quotes (ppr cls)
283 ppr (InstSkol df) = ptext SLIT("the instance declaration at") <+> ppr (getSrcLoc df)
284 ppr (ArrowSkol loc) = ptext SLIT("the arrow form at") <+> ppr loc
285 ppr (PatSkol dc loc) = sep [ptext SLIT("the pattern for") <+> quotes (ppr dc),
286 nest 2 (ptext SLIT("at") <+> ppr loc)]
287 ppr (GenSkol ty loc) = sep [ptext SLIT("the polymorphic type") <+> quotes (ppr ty),
288 nest 2 (ptext SLIT("at") <+> ppr loc)]
290 instance Outputable MetaDetails where
291 ppr Flexi = ptext SLIT("Flexi")
292 ppr (Indirect ty) = ptext SLIT("Indirect") <+> ppr ty
294 isImmutableTyVar, isSkolemTyVar, isExistentialTyVar, isMetaTyVar :: TyVar -> Bool
296 | isTcTyVar tv = isSkolemTyVar tv
300 = ASSERT( isTcTyVar tv )
301 case tcTyVarDetails tv of
305 isExistentialTyVar tv -- Existential type variable, bound by a pattern
306 = ASSERT( isTcTyVar tv )
307 case tcTyVarDetails tv of
308 SkolemTv (PatSkol _ _) -> True
312 = ASSERT( isTcTyVar tv )
313 case tcTyVarDetails tv of
317 skolemTvInfo :: TyVar -> SkolemInfo
319 = ASSERT( isTcTyVar tv )
320 case tcTyVarDetails tv of
321 SkolemTv info -> info
323 metaTvRef :: TyVar -> IORef MetaDetails
325 = ASSERT( isTcTyVar tv )
326 case tcTyVarDetails tv of
329 isFlexi, isIndirect :: MetaDetails -> Bool
331 isFlexi other = False
333 isIndirect (Indirect _) = True
334 isIndirect other = False
338 %************************************************************************
340 \subsection{Tau, sigma and rho}
342 %************************************************************************
345 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau)
347 mkPhiTy :: [PredType] -> Type -> Type
348 mkPhiTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
351 @isTauTy@ tests for nested for-alls.
354 isTauTy :: Type -> Bool
355 isTauTy (TyVarTy v) = True
356 isTauTy (TyConApp _ tys) = all isTauTy tys
357 isTauTy (AppTy a b) = isTauTy a && isTauTy b
358 isTauTy (FunTy a b) = isTauTy a && isTauTy b
359 isTauTy (PredTy p) = True -- Don't look through source types
360 isTauTy (NoteTy _ ty) = isTauTy ty
361 isTauTy other = False
365 getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
366 -- construct a dictionary function name
367 getDFunTyKey (TyVarTy tv) = getOccName tv
368 getDFunTyKey (TyConApp tc _) = getOccName tc
369 getDFunTyKey (AppTy fun _) = getDFunTyKey fun
370 getDFunTyKey (NoteTy _ t) = getDFunTyKey t
371 getDFunTyKey (FunTy arg _) = getOccName funTyCon
372 getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
373 getDFunTyKey ty = pprPanic "getDFunTyKey" (pprType ty)
374 -- PredTy shouldn't happen
378 %************************************************************************
380 \subsection{Expanding and splitting}
382 %************************************************************************
384 These tcSplit functions are like their non-Tc analogues, but
385 a) they do not look through newtypes
386 b) they do not look through PredTys
387 c) [future] they ignore usage-type annotations
389 However, they are non-monadic and do not follow through mutable type
390 variables. It's up to you to make sure this doesn't matter.
393 tcSplitForAllTys :: Type -> ([TyVar], Type)
394 tcSplitForAllTys ty = split ty ty []
396 split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
397 split orig_ty (NoteTy n ty) tvs = split orig_ty ty tvs
398 split orig_ty t tvs = (reverse tvs, orig_ty)
400 tcIsForAllTy (ForAllTy tv ty) = True
401 tcIsForAllTy (NoteTy n ty) = tcIsForAllTy ty
402 tcIsForAllTy t = False
404 tcSplitPhiTy :: Type -> ([PredType], Type)
405 tcSplitPhiTy ty = split ty ty []
407 split orig_ty (FunTy arg res) ts = case tcSplitPredTy_maybe arg of
408 Just p -> split res res (p:ts)
409 Nothing -> (reverse ts, orig_ty)
410 split orig_ty (NoteTy n ty) ts = split orig_ty ty ts
411 split orig_ty ty ts = (reverse ts, orig_ty)
413 tcSplitSigmaTy ty = case tcSplitForAllTys ty of
414 (tvs, rho) -> case tcSplitPhiTy rho of
415 (theta, tau) -> (tvs, theta, tau)
417 tcTyConAppTyCon :: Type -> TyCon
418 tcTyConAppTyCon ty = fst (tcSplitTyConApp ty)
420 tcTyConAppArgs :: Type -> [Type]
421 tcTyConAppArgs ty = snd (tcSplitTyConApp ty)
423 tcSplitTyConApp :: Type -> (TyCon, [Type])
424 tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of
426 Nothing -> pprPanic "tcSplitTyConApp" (pprType ty)
428 tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
429 tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
430 tcSplitTyConApp_maybe (FunTy arg res) = Just (funTyCon, [arg,res])
431 tcSplitTyConApp_maybe (NoteTy n ty) = tcSplitTyConApp_maybe ty
432 -- Newtypes are opaque, so they may be split
433 -- However, predicates are not treated
434 -- as tycon applications by the type checker
435 tcSplitTyConApp_maybe other = Nothing
437 tcSplitFunTys :: Type -> ([Type], Type)
438 tcSplitFunTys ty = case tcSplitFunTy_maybe ty of
440 Just (arg,res) -> (arg:args, res')
442 (args,res') = tcSplitFunTys res
444 tcSplitFunTy_maybe :: Type -> Maybe (Type, Type)
445 tcSplitFunTy_maybe (FunTy arg res) = Just (arg, res)
446 tcSplitFunTy_maybe (NoteTy n ty) = tcSplitFunTy_maybe ty
447 tcSplitFunTy_maybe other = Nothing
449 tcFunArgTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> arg }
450 tcFunResultTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> res }
453 tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
454 tcSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2)
455 tcSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2)
456 tcSplitAppTy_maybe (NoteTy n ty) = tcSplitAppTy_maybe ty
457 tcSplitAppTy_maybe (TyConApp tc tys) = case snocView tys of
458 Just (tys', ty') -> Just (TyConApp tc tys', ty')
460 tcSplitAppTy_maybe other = Nothing
462 tcSplitAppTy ty = case tcSplitAppTy_maybe ty of
464 Nothing -> pprPanic "tcSplitAppTy" (pprType ty)
466 tcSplitAppTys :: Type -> (Type, [Type])
470 go ty args = case tcSplitAppTy_maybe ty of
471 Just (ty', arg) -> go ty' (arg:args)
474 tcGetTyVar_maybe :: Type -> Maybe TyVar
475 tcGetTyVar_maybe (TyVarTy tv) = Just tv
476 tcGetTyVar_maybe (NoteTy _ t) = tcGetTyVar_maybe t
477 tcGetTyVar_maybe other = Nothing
479 tcGetTyVar :: String -> Type -> TyVar
480 tcGetTyVar msg ty = expectJust msg (tcGetTyVar_maybe ty)
482 tcIsTyVarTy :: Type -> Bool
483 tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty)
485 tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
486 -- Split the type of a dictionary function
488 = case tcSplitSigmaTy ty of { (tvs, theta, tau) ->
489 case tcSplitPredTy_maybe tau of { Just (ClassP clas tys) ->
490 (tvs, theta, clas, tys) }}
495 %************************************************************************
497 \subsection{Predicate types}
499 %************************************************************************
502 tcSplitPredTy_maybe :: Type -> Maybe PredType
503 -- Returns Just for predicates only
504 tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty
505 tcSplitPredTy_maybe (PredTy p) = Just p
506 tcSplitPredTy_maybe other = Nothing
508 predTyUnique :: PredType -> Unique
509 predTyUnique (IParam n _) = getUnique (ipNameName n)
510 predTyUnique (ClassP clas tys) = getUnique clas
512 mkPredName :: Unique -> SrcLoc -> PredType -> Name
513 mkPredName uniq loc (ClassP cls tys) = mkInternalName uniq (mkDictOcc (getOccName cls)) loc
514 mkPredName uniq loc (IParam ip ty) = mkInternalName uniq (getOccName (ipNameName ip)) loc
518 --------------------- Dictionary types ---------------------------------
521 mkClassPred clas tys = ClassP clas tys
523 isClassPred :: PredType -> Bool
524 isClassPred (ClassP clas tys) = True
525 isClassPred other = False
527 isTyVarClassPred (ClassP clas tys) = all tcIsTyVarTy tys
528 isTyVarClassPred other = False
530 getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
531 getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
532 getClassPredTys_maybe _ = Nothing
534 getClassPredTys :: PredType -> (Class, [Type])
535 getClassPredTys (ClassP clas tys) = (clas, tys)
537 mkDictTy :: Class -> [Type] -> Type
538 mkDictTy clas tys = mkPredTy (ClassP clas tys)
540 isDictTy :: Type -> Bool
541 isDictTy (PredTy p) = isClassPred p
542 isDictTy (NoteTy _ ty) = isDictTy ty
543 isDictTy other = False
546 --------------------- Implicit parameters ---------------------------------
549 isIPPred :: PredType -> Bool
550 isIPPred (IParam _ _) = True
551 isIPPred other = False
553 isInheritablePred :: PredType -> Bool
554 -- Can be inherited by a context. For example, consider
555 -- f x = let g y = (?v, y+x)
556 -- in (g 3 with ?v = 8,
558 -- The point is that g's type must be quantifed over ?v:
559 -- g :: (?v :: a) => a -> a
560 -- but it doesn't need to be quantified over the Num a dictionary
561 -- which can be free in g's rhs, and shared by both calls to g
562 isInheritablePred (ClassP _ _) = True
563 isInheritablePred other = False
565 isLinearPred :: TcPredType -> Bool
566 isLinearPred (IParam (Linear n) _) = True
567 isLinearPred other = False
571 %************************************************************************
573 \subsection{Predicates}
575 %************************************************************************
577 isSigmaTy returns true of any qualified type. It doesn't *necessarily* have
579 f :: (?x::Int) => Int -> Int
582 isSigmaTy :: Type -> Bool
583 isSigmaTy (ForAllTy tyvar ty) = True
584 isSigmaTy (FunTy a b) = isPredTy a
585 isSigmaTy (NoteTy n ty) = isSigmaTy ty
588 isOverloadedTy :: Type -> Bool
589 isOverloadedTy (ForAllTy tyvar ty) = isOverloadedTy ty
590 isOverloadedTy (FunTy a b) = isPredTy a
591 isOverloadedTy (NoteTy n ty) = isOverloadedTy ty
592 isOverloadedTy _ = False
594 isPredTy :: Type -> Bool -- Belongs in TcType because it does
595 -- not look through newtypes, or predtypes (of course)
596 isPredTy (NoteTy _ ty) = isPredTy ty
597 isPredTy (PredTy sty) = True
602 isFloatTy = is_tc floatTyConKey
603 isDoubleTy = is_tc doubleTyConKey
604 isIntegerTy = is_tc integerTyConKey
605 isIntTy = is_tc intTyConKey
606 isAddrTy = is_tc addrTyConKey
607 isBoolTy = is_tc boolTyConKey
608 isUnitTy = is_tc unitTyConKey
610 is_tc :: Unique -> Type -> Bool
611 -- Newtypes are opaque to this
612 is_tc uniq ty = case tcSplitTyConApp_maybe ty of
613 Just (tc, _) -> uniq == getUnique tc
618 %************************************************************************
622 %************************************************************************
625 deNoteType :: Type -> Type
626 -- Remove synonyms, but not predicate types
627 deNoteType ty@(TyVarTy tyvar) = ty
628 deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
629 deNoteType (PredTy p) = PredTy (deNotePredType p)
630 deNoteType (NoteTy _ ty) = deNoteType ty
631 deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg)
632 deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg)
633 deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty)
635 deNotePredType :: PredType -> PredType
636 deNotePredType (ClassP c tys) = ClassP c (map deNoteType tys)
637 deNotePredType (IParam n ty) = IParam n (deNoteType ty)
640 Find the free tycons and classes of a type. This is used in the front
644 tyClsNamesOfType :: Type -> NameSet
645 tyClsNamesOfType (TyVarTy tv) = emptyNameSet
646 tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
647 tyClsNamesOfType (NoteTy (SynNote ty1) ty2) = tyClsNamesOfType ty1
648 tyClsNamesOfType (NoteTy other_note ty2) = tyClsNamesOfType ty2
649 tyClsNamesOfType (PredTy (IParam n ty)) = tyClsNamesOfType ty
650 tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
651 tyClsNamesOfType (FunTy arg res) = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res
652 tyClsNamesOfType (AppTy fun arg) = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg
653 tyClsNamesOfType (ForAllTy tyvar ty) = tyClsNamesOfType ty
655 tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys
657 tyClsNamesOfDFunHead :: Type -> NameSet
658 -- Find the free type constructors and classes
659 -- of the head of the dfun instance type
660 -- The 'dfun_head_type' is because of
661 -- instance Foo a => Baz T where ...
662 -- The decl is an orphan if Baz and T are both not locally defined,
663 -- even if Foo *is* locally defined
664 tyClsNamesOfDFunHead dfun_ty
665 = case tcSplitSigmaTy dfun_ty of
666 (tvs,_,head_ty) -> tyClsNamesOfType head_ty
668 classesOfTheta :: ThetaType -> [Class]
669 -- Looks just for ClassP things; maybe it should check
670 classesOfTheta preds = [ c | ClassP c _ <- preds ]
674 %************************************************************************
676 \subsection[TysWiredIn-ext-type]{External types}
678 %************************************************************************
680 The compiler's foreign function interface supports the passing of a
681 restricted set of types as arguments and results (the restricting factor
685 isFFITy :: Type -> Bool
686 -- True for any TyCon that can possibly be an arg or result of an FFI call
687 isFFITy ty = checkRepTyCon legalFFITyCon ty
689 isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
690 -- Checks for valid argument type for a 'foreign import'
691 isFFIArgumentTy dflags safety ty
692 = checkRepTyCon (legalOutgoingTyCon dflags safety) ty
694 isFFIExternalTy :: Type -> Bool
695 -- Types that are allowed as arguments of a 'foreign export'
696 isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty
698 isFFIImportResultTy :: DynFlags -> Type -> Bool
699 isFFIImportResultTy dflags ty
700 = checkRepTyCon (legalFIResultTyCon dflags) ty
702 isFFIExportResultTy :: Type -> Bool
703 isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
705 isFFIDynArgumentTy :: Type -> Bool
706 -- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr,
707 -- or a newtype of either.
708 isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
710 isFFIDynResultTy :: Type -> Bool
711 -- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr,
712 -- or a newtype of either.
713 isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
715 isFFILabelTy :: Type -> Bool
716 -- The type of a foreign label must be Ptr, FunPtr, Addr,
717 -- or a newtype of either.
718 isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
720 isFFIDotnetTy :: DynFlags -> Type -> Bool
721 isFFIDotnetTy dflags ty
722 = checkRepTyCon (\ tc -> not (isByteArrayLikeTyCon tc) &&
723 (legalFIResultTyCon dflags tc ||
724 isFFIDotnetObjTy ty || isStringTy ty)) ty
726 -- Support String as an argument or result from a .NET FFI call.
728 case tcSplitTyConApp_maybe (repType ty) of
731 case tcSplitTyConApp_maybe (repType arg_ty) of
732 Just (cc,[]) -> cc == charTyCon
736 -- Support String as an argument or result from a .NET FFI call.
737 isFFIDotnetObjTy ty =
739 (_, t_ty) = tcSplitForAllTys ty
741 case tcSplitTyConApp_maybe (repType t_ty) of
742 Just (tc, [arg_ty]) | getName tc == objectTyConName -> True
745 toDNType :: Type -> DNType
747 | isStringTy ty = DNString
748 | isFFIDotnetObjTy ty = DNObject
749 | Just (tc,argTys) <- tcSplitTyConApp_maybe ty =
750 case lookup (getUnique tc) dn_assoc of
753 | tc `hasKey` ioTyConKey -> toDNType (head argTys)
754 | otherwise -> pprPanic ("toDNType: unsupported .NET type") (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc)
756 dn_assoc :: [ (Unique, DNType) ]
757 dn_assoc = [ (unitTyConKey, DNUnit)
758 , (intTyConKey, DNInt)
759 , (int8TyConKey, DNInt8)
760 , (int16TyConKey, DNInt16)
761 , (int32TyConKey, DNInt32)
762 , (int64TyConKey, DNInt64)
763 , (wordTyConKey, DNInt)
764 , (word8TyConKey, DNWord8)
765 , (word16TyConKey, DNWord16)
766 , (word32TyConKey, DNWord32)
767 , (word64TyConKey, DNWord64)
768 , (floatTyConKey, DNFloat)
769 , (doubleTyConKey, DNDouble)
770 , (addrTyConKey, DNPtr)
771 , (ptrTyConKey, DNPtr)
772 , (funPtrTyConKey, DNPtr)
773 , (charTyConKey, DNChar)
774 , (boolTyConKey, DNBool)
777 checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
778 -- Look through newtypes
779 -- Non-recursive ones are transparent to splitTyConApp,
780 -- but recursive ones aren't. Manuel had:
781 -- newtype T = MkT (Ptr T)
782 -- and wanted it to work...
783 checkRepTyCon check_tc ty
784 | Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc
787 checkRepTyConKey :: [Unique] -> Type -> Bool
788 -- Like checkRepTyCon, but just looks at the TyCon key
789 checkRepTyConKey keys
790 = checkRepTyCon (\tc -> tyConUnique tc `elem` keys)
793 ----------------------------------------------
794 These chaps do the work; they are not exported
795 ----------------------------------------------
798 legalFEArgTyCon :: TyCon -> Bool
799 -- It's illegal to return foreign objects and (mutable)
800 -- bytearrays from a _ccall_ / foreign declaration
801 -- (or be passed them as arguments in foreign exported functions).
803 | isByteArrayLikeTyCon tc
805 -- It's also illegal to make foreign exports that take unboxed
806 -- arguments. The RTS API currently can't invoke such things. --SDM 7/2000
808 = boxedMarshalableTyCon tc
810 legalFIResultTyCon :: DynFlags -> TyCon -> Bool
811 legalFIResultTyCon dflags tc
812 | isByteArrayLikeTyCon tc = False
813 | tc == unitTyCon = True
814 | otherwise = marshalableTyCon dflags tc
816 legalFEResultTyCon :: TyCon -> Bool
817 legalFEResultTyCon tc
818 | isByteArrayLikeTyCon tc = False
819 | tc == unitTyCon = True
820 | otherwise = boxedMarshalableTyCon tc
822 legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
823 -- Checks validity of types going from Haskell -> external world
824 legalOutgoingTyCon dflags safety tc
825 | playSafe safety && isByteArrayLikeTyCon tc
828 = marshalableTyCon dflags tc
830 legalFFITyCon :: TyCon -> Bool
831 -- True for any TyCon that can possibly be an arg or result of an FFI call
833 = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon
835 marshalableTyCon dflags tc
836 = (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
837 || boxedMarshalableTyCon tc
839 boxedMarshalableTyCon tc
840 = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
841 , int32TyConKey, int64TyConKey
842 , wordTyConKey, word8TyConKey, word16TyConKey
843 , word32TyConKey, word64TyConKey
844 , floatTyConKey, doubleTyConKey
845 , addrTyConKey, ptrTyConKey, funPtrTyConKey
848 , byteArrayTyConKey, mutableByteArrayTyConKey
852 isByteArrayLikeTyCon :: TyCon -> Bool
853 isByteArrayLikeTyCon tc =
854 getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]