compiler/typecheck/TcType.lhs

   1
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcType]{Types used in the typechecker}
   5
   6 This module provides the Type interface for front-end parts of the
   7 compiler.  These parts
   8
   9         * treat "source types" as opaque:
  10                 newtypes, and predicates are meaningful.
  11         * look through usage types
  12
  13 The "tc" prefix is for "typechechecker", because the type checker
  14 is the principal client.
  15
  16 \begin{code}
  17 module TcType (
  18   --------------------------------
  19   -- Types
  20   TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
  21   TcTyVar, TcTyVarSet, TcKind,
  22
  23   BoxyTyVar, BoxySigmaType, BoxyRhoType, BoxyThetaType, BoxyType,
  24
  25   --------------------------------
  26   -- MetaDetails
  27   UserTypeCtxt(..), pprUserTypeCtxt,
  28   TcTyVarDetails(..), BoxInfo(..), pprTcTyVarDetails,
  29   MetaDetails(Flexi, Indirect), SkolemInfo(..), pprSkolTvBinding, pprSkolInfo,
  30   isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isBoxyTyVar, isSigTyVar, isExistentialTyVar,
  31   metaTvRef,
  32   isFlexi, isIndirect,
  33
  34   --------------------------------
  35   -- Builders
  36   mkPhiTy, mkSigmaTy,
  37
  38   --------------------------------
  39   -- Splitters
  40   -- These are important because they do not look through newtypes
  41   tcView,
  42   tcSplitForAllTys, tcSplitPhiTy,
  43   tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN,
  44   tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
  45   tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys,
  46   tcValidInstHeadTy, tcGetTyVar_maybe, tcGetTyVar,
  47   tcSplitSigmaTy, tcMultiSplitSigmaTy,
  48
  49   ---------------------------------
  50   -- Predicates.
  51   -- Again, newtypes are opaque
  52   tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX,
  53   isSigmaTy, isOverloadedTy, isRigidTy, isBoxyTy,
  54   isDoubleTy, isFloatTy, isIntTy, isStringTy,
  55   isIntegerTy, isAddrTy, isBoolTy, isUnitTy,
  56   isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
  57
  58   ---------------------------------
  59   -- Misc type manipulators
  60   deNoteType, classesOfTheta,
  61   tyClsNamesOfType, tyClsNamesOfDFunHead,
  62   getDFunTyKey,
  63
  64   ---------------------------------
  65   -- Predicate types
  66   getClassPredTys_maybe, getClassPredTys,
  67   isClassPred, isTyVarClassPred,
  68   mkDictTy, tcSplitPredTy_maybe,
  69   isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique,
  70   mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName,
  71   dataConsStupidTheta, isRefineableTy,
  72
  73   ---------------------------------
  74   -- Foreign import and export
  75   isFFIArgumentTy,     -- :: DynFlags -> Safety -> Type -> Bool
  76   isFFIImportResultTy, -- :: DynFlags -> Type -> Bool
  77   isFFIExportResultTy, -- :: Type -> Bool
  78   isFFIExternalTy,     -- :: Type -> Bool
  79   isFFIDynArgumentTy,  -- :: Type -> Bool
  80   isFFIDynResultTy,    -- :: Type -> Bool
  81   isFFILabelTy,        -- :: Type -> Bool
  82   isFFIDotnetTy,       -- :: DynFlags -> Type -> Bool
  83   isFFIDotnetObjTy,    -- :: Type -> Bool
  84   isFFITy,             -- :: Type -> Bool
  85
  86   toDNType,            -- :: Type -> DNType
  87
  88   --------------------------------
  89   -- Rexported from Type
  90   Kind,         -- Stuff to do with kinds is insensitive to pre/post Tc
  91   unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
  92   isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
  93   isArgTypeKind, isSubKind, defaultKind,
  94
  95   Type, PredType(..), ThetaType,
  96   mkForAllTy, mkForAllTys,
  97   mkFunTy, mkFunTys, zipFunTys,
  98   mkTyConApp, mkAppTy, mkAppTys, applyTy, applyTys,
  99   mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
 100
 101   -- Type substitutions
 102   TvSubst(..),  -- Representation visible to a few friends
 103   TvSubstEnv, emptyTvSubst,
 104   mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst,
 105   getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, lookupTyVar,
 106   extendTvSubst, extendTvSubstList, isInScope, mkTvSubst, zipTyEnv,
 107   substTy, substTys, substTyWith, substTheta, substTyVar, substTyVarBndr,
 108
 109   isUnLiftedType,       -- Source types are always lifted
 110   isUnboxedTupleType,   -- Ditto
 111   isPrimitiveType,
 112
 113   tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
 114   tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars, tidySkolemTyVar,
 115   typeKind, tidyKind,
 116
 117   tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
 118   tcTyVarsOfType, tcTyVarsOfTypes, exactTyVarsOfType, exactTyVarsOfTypes,
 119
 120   pprKind, pprParendKind,
 121   pprType, pprParendType, pprTyThingCategory,
 122   pprPred, pprTheta, pprThetaArrow, pprClassPred
 123
 124   ) where
 125
 126 #include "HsVersions.h"
 127
 128 -- friends:
 129 import TypeRep          ( Type(..), funTyCon )  -- friend
 130
 131 import Type             (       -- Re-exports
 132                           tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
 133                           tyVarsOfTheta, Kind, PredType(..),
 134                           ThetaType, unliftedTypeKind,
 135                           liftedTypeKind, openTypeKind, mkArrowKind,
 136                           isLiftedTypeKind, isUnliftedTypeKind,
 137                           mkArrowKinds, mkForAllTy, mkForAllTys,
 138                           defaultKind, isArgTypeKind, isOpenTypeKind,
 139                           mkFunTy, mkFunTys, zipFunTys,
 140                           mkTyConApp, mkAppTy,
 141                           mkAppTys, applyTy, applyTys,
 142                           mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy,
 143                           mkPredTys, isUnLiftedType,
 144                           isUnboxedTupleType, isPrimitiveType,
 145                           splitTyConApp_maybe,
 146                           tidyTopType, tidyType, tidyPred, tidyTypes,
 147                           tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
 148                           tidyTyVarBndr, tidyOpenTyVar,
 149                           tidyOpenTyVars, tidyKind,
 150                           isSubKind, tcView,
 151
 152                           tcEqType, tcEqTypes, tcCmpType, tcCmpTypes,
 153                           tcEqPred, tcCmpPred, tcEqTypeX,
 154
 155                           TvSubst(..),
 156                           TvSubstEnv, emptyTvSubst, mkTvSubst, zipTyEnv,
 157                           mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst,
 158                           getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
 159                           extendTvSubst, extendTvSubstList, isInScope, notElemTvSubst,
 160                           substTy, substTys, substTyWith, substTheta,
 161                           substTyVar, substTyVarBndr, substPred, lookupTyVar,
 162
 163                           typeKind, repType,
 164                           pprKind, pprParendKind,
 165                           pprType, pprParendType, pprTyThingCategory,
 166                           pprPred, pprTheta, pprThetaArrow, pprClassPred
 167                         )
 168 import TyCon            ( TyCon, isUnLiftedTyCon, isSynTyCon, synTyConDefn, tyConUnique )
 169 import DataCon          ( DataCon, dataConStupidTheta, dataConResTys )
 170 import Class            ( Class )
 171 import Var              ( TyVar, Id, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails )
 172 import ForeignCall      ( Safety, playSafe, DNType(..) )
 173 import Unify            ( tcMatchTys )
 174 import VarSet
 175
 176 -- others:
 177 import DynFlags         ( DynFlags, DynFlag( Opt_GlasgowExts ), dopt )
 178 import Name             ( Name, NamedThing(..), mkInternalName, getSrcLoc )
 179 import NameSet
 180 import VarEnv           ( TidyEnv )
 181 import OccName          ( OccName, mkDictOcc )
 182 import PrelNames        -- Lots (e.g. in isFFIArgumentTy)
 183 import TysWiredIn       ( unitTyCon, charTyCon, listTyCon )
 184 import BasicTypes       ( IPName(..), Arity, ipNameName )
 185 import SrcLoc           ( SrcLoc, SrcSpan )
 186 import Util             ( snocView, equalLength )
 187 import Maybes           ( maybeToBool, expectJust, mapCatMaybes )
 188 import ListSetOps       ( hasNoDups )
 189 import List             ( nubBy )
 190 import Outputable
 191 import DATA_IOREF
 192 \end{code}
 193
 194
 195 %************************************************************************
 196 %*                                                                      *
 197 \subsection{Types}
 198 %*                                                                      *
 199 %************************************************************************
 200
 201 The type checker divides the generic Type world into the
 202 following more structured beasts:
 203
 204 sigma ::= forall tyvars. phi
 205         -- A sigma type is a qualified type
 206         --
 207         -- Note that even if 'tyvars' is empty, theta
 208         -- may not be: e.g.   (?x::Int) => Int
 209
 210         -- Note that 'sigma' is in prenex form:
 211         -- all the foralls are at the front.
 212         -- A 'phi' type has no foralls to the right of
 213         -- an arrow
 214
 215 phi :: theta => rho
 216
 217 rho ::= sigma -> rho
 218      |  tau
 219
 220 -- A 'tau' type has no quantification anywhere
 221 -- Note that the args of a type constructor must be taus
 222 tau ::= tyvar
 223      |  tycon tau_1 .. tau_n
 224      |  tau_1 tau_2
 225      |  tau_1 -> tau_2
 226
 227 -- In all cases, a (saturated) type synonym application is legal,
 228 -- provided it expands to the required form.
 229
 230 \begin{code}
 231 type TcTyVar = TyVar    -- Used only during type inference
 232 type TcType = Type      -- A TcType can have mutable type variables
 233         -- Invariant on ForAllTy in TcTypes:
 234         --      forall a. T
 235         -- a cannot occur inside a MutTyVar in T; that is,
 236         -- T is "flattened" before quantifying over a
 237
 238 -- These types do not have boxy type variables in them
 239 type TcPredType     = PredType
 240 type TcThetaType    = ThetaType
 241 type TcSigmaType    = TcType
 242 type TcRhoType      = TcType
 243 type TcTauType      = TcType
 244 type TcKind         = Kind
 245 type TcTyVarSet     = TyVarSet
 246
 247 -- These types may have boxy type variables in them
 248 type BoxyTyVar      = TcTyVar
 249 type BoxyRhoType    = TcType
 250 type BoxyThetaType  = TcThetaType
 251 type BoxySigmaType  = TcType
 252 type BoxyType       = TcType
 253 \end{code}
 254
 255
 256 %************************************************************************
 257 %*                                                                      *
 258 \subsection{TyVarDetails}
 259 %*                                                                      *
 260 %************************************************************************
 261
 262 TyVarDetails gives extra info about type variables, used during type
 263 checking.  It's attached to mutable type variables only.
 264 It's knot-tied back to Var.lhs.  There is no reason in principle
 265 why Var.lhs shouldn't actually have the definition, but it "belongs" here.
 266
 267
 268 Note [Signature skolems]
 269 ~~~~~~~~~~~~~~~~~~~~~~~~
 270 Consider this
 271
 272   x :: [a]
 273   y :: b
 274   (x,y,z) = ([y,z], z, head x)
 275
 276 Here, x and y have type sigs, which go into the environment.  We used to
 277 instantiate their types with skolem constants, and push those types into
 278 the RHS, so we'd typecheck the RHS with type
 279         ( [a*], b*, c )
 280 where a*, b* are skolem constants, and c is an ordinary meta type varible.
 281
 282 The trouble is that the occurrences of z in the RHS force a* and b* to
 283 be the *same*, so we can't make them into skolem constants that don't unify
 284 with each other.  Alas.
 285
 286 On the other hand, we *must* use skolems for signature type variables,
 287 becuase GADT type refinement refines skolems only.
 288
 289 One solution would be insist that in the above defn the programmer uses
 290 the same type variable in both type signatures.  But that takes explanation.
 291
 292 The alternative (currently implemented) is to have a special kind of skolem
 293 constant, SigSkokTv, which can unify with other SigSkolTvs.
 294
 295
 296 \begin{code}
 297 -- A TyVarDetails is inside a TyVar
 298 data TcTyVarDetails
 299   = SkolemTv SkolemInfo                 -- A skolem constant
 300
 301   | MetaTv BoxInfo (IORef MetaDetails)
 302
 303 data BoxInfo
 304    = BoxTv      -- The contents is a (non-boxy) sigma-type
 305                 -- That is, this MetaTv is a "box"
 306
 307    | TauTv      -- The contents is a (non-boxy) tau-type
 308                 -- That is, this MetaTv is an ordinary unification variable
 309
 310    | SigTv SkolemInfo   -- A variant of TauTv, except that it should not be
 311                         -- unified with a type, only with a type variable
 312                         -- SigTvs are only distinguished to improve error messages
 313                         --      see Note [Signature skolems]
 314                         --      The MetaDetails, if filled in, will
 315                         --      always be another SigTv or a SkolemTv
 316
 317 -- INVARIANTS:
 318 --      A TauTv is always filled in with a tau-type, which
 319 --      never contains any BoxTvs, nor any ForAlls
 320 --
 321 --      However, a BoxTv can contain a type that contains further BoxTvs
 322 --      Notably, when typechecking an explicit list, say [e1,e2], with
 323 --      expected type being a box b1, we fill in b1 with (List b2), where
 324 --      b2 is another (currently empty) box.
 325
 326 data MetaDetails
 327   = Flexi          -- Flexi type variables unify to become
 328                    -- Indirects.
 329
 330   | Indirect TcType  -- INVARIANT:
 331                      --   For a BoxTv, this type must be non-boxy
 332                      --   For a TauTv, this type must be a tau-type
 333
 334 data SkolemInfo
 335   = SigSkol UserTypeCtxt        -- A skolem that is created by instantiating
 336                                 -- a programmer-supplied type signature
 337                                 -- Location of the binding site is on the TyVar
 338
 339         -- The rest are for non-scoped skolems
 340   | ClsSkol Class       -- Bound at a class decl
 341   | InstSkol Id         -- Bound at an instance decl
 342   | PatSkol DataCon     -- An existential type variable bound by a pattern for
 343             SrcSpan     -- a data constructor with an existential type. E.g.
 344                         --      data T = forall a. Eq a => MkT a
 345                         --      f (MkT x) = ...
 346                         -- The pattern MkT x will allocate an existential type
 347                         -- variable for 'a'.
 348   | ArrowSkol SrcSpan   -- An arrow form (see TcArrows)
 349
 350   | GenSkol [TcTyVar]   -- Bound when doing a subsumption check for
 351             TcType      --      (forall tvs. ty)
 352             SrcSpan
 353
 354   | UnkSkol             -- Unhelpful info (until I improve it)
 355
 356 -------------------------------------
 357 -- UserTypeCtxt describes the places where a
 358 -- programmer-written type signature can occur
 359 data UserTypeCtxt
 360   = FunSigCtxt Name     -- Function type signature
 361                         -- Also used for types in SPECIALISE pragmas
 362   | ExprSigCtxt         -- Expression type signature
 363   | ConArgCtxt Name     -- Data constructor argument
 364   | TySynCtxt Name      -- RHS of a type synonym decl
 365   | GenPatCtxt          -- Pattern in generic decl
 366                         --      f{| a+b |} (Inl x) = ...
 367   | LamPatSigCtxt               -- Type sig in lambda pattern
 368                         --      f (x::t) = ...
 369   | BindPatSigCtxt      -- Type sig in pattern binding pattern
 370                         --      (x::t, y) = e
 371   | ResSigCtxt          -- Result type sig
 372                         --      f x :: t = ....
 373   | ForSigCtxt Name     -- Foreign inport or export signature
 374   | RuleSigCtxt Name    -- Signature on a forall'd variable in a RULE
 375   | DefaultDeclCtxt     -- Types in a default declaration
 376   | SpecInstCtxt        -- SPECIALISE instance pragma
 377
 378 -- Notes re TySynCtxt
 379 -- We allow type synonyms that aren't types; e.g.  type List = []
 380 --
 381 -- If the RHS mentions tyvars that aren't in scope, we'll
 382 -- quantify over them:
 383 --      e.g.    type T = a->a
 384 -- will become  type T = forall a. a->a
 385 --
 386 -- With gla-exts that's right, but for H98 we should complain.
 387 \end{code}
 388
 389 %************************************************************************
 390 %*                                                                      *
 391                 Pretty-printing
 392 %*                                                                      *
 393 %************************************************************************
 394
 395 \begin{code}
 396 pprTcTyVarDetails :: TcTyVarDetails -> SDoc
 397 -- For debugging
 398 pprTcTyVarDetails (SkolemTv _)         = ptext SLIT("sk")
 399 pprTcTyVarDetails (MetaTv BoxTv _)     = ptext SLIT("box")
 400 pprTcTyVarDetails (MetaTv TauTv _)     = ptext SLIT("tau")
 401 pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext SLIT("sig")
 402
 403 pprUserTypeCtxt :: UserTypeCtxt -> SDoc
 404 pprUserTypeCtxt (FunSigCtxt n)  = ptext SLIT("the type signature for") <+> quotes (ppr n)
 405 pprUserTypeCtxt ExprSigCtxt     = ptext SLIT("an expression type signature")
 406 pprUserTypeCtxt (ConArgCtxt c)  = ptext SLIT("the type of the constructor") <+> quotes (ppr c)
 407 pprUserTypeCtxt (TySynCtxt c)   = ptext SLIT("the RHS of the type synonym") <+> quotes (ppr c)
 408 pprUserTypeCtxt GenPatCtxt      = ptext SLIT("the type pattern of a generic definition")
 409 pprUserTypeCtxt LamPatSigCtxt   = ptext SLIT("a pattern type signature")
 410 pprUserTypeCtxt BindPatSigCtxt  = ptext SLIT("a pattern type signature")
 411 pprUserTypeCtxt ResSigCtxt      = ptext SLIT("a result type signature")
 412 pprUserTypeCtxt (ForSigCtxt n)  = ptext SLIT("the foreign declaration for") <+> quotes (ppr n)
 413 pprUserTypeCtxt (RuleSigCtxt n) = ptext SLIT("the type signature for") <+> quotes (ppr n)
 414 pprUserTypeCtxt DefaultDeclCtxt = ptext SLIT("a type in a `default' declaration")
 415 pprUserTypeCtxt SpecInstCtxt    = ptext SLIT("a SPECIALISE instance pragma")
 416
 417
 418 --------------------------------
 419 tidySkolemTyVar :: TidyEnv -> TcTyVar -> (TidyEnv, TcTyVar)
 420 -- Tidy the type inside a GenSkol, preparatory to printing it
 421 tidySkolemTyVar env tv
 422   = ASSERT( isSkolemTyVar tv )
 423     (env1, mkTcTyVar (tyVarName tv) (tyVarKind tv) info1)
 424   where
 425     (env1, info1) = case tcTyVarDetails tv of
 426                       SkolemTv (GenSkol tvs ty loc) -> (env2, SkolemTv (GenSkol tvs1 ty1 loc))
 427                             where
 428                               (env1, tvs1) = tidyOpenTyVars env tvs
 429                               (env2, ty1)  = tidyOpenType env1 ty
 430                       info -> (env, info)
 431
 432 pprSkolTvBinding :: TcTyVar -> SDoc
 433 -- Print info about the binding of a skolem tyvar,
 434 -- or nothing if we don't have anything useful to say
 435 pprSkolTvBinding tv
 436   = ppr_details (tcTyVarDetails tv)
 437   where
 438     ppr_details (MetaTv TauTv _)   = quotes (ppr tv) <+> ptext SLIT("is a meta type variable")
 439     ppr_details (MetaTv BoxTv _)   = quotes (ppr tv) <+> ptext SLIT("is a boxy type variable")
 440     ppr_details (MetaTv (SigTv info) _) = ppr_skol info
 441     ppr_details (SkolemTv info)         = ppr_skol info
 442
 443     ppr_skol UnkSkol         = empty    -- Unhelpful; omit
 444     ppr_skol (SigSkol ctxt)  = sep [quotes (ppr tv) <+> ptext SLIT("is bound by") <+> pprUserTypeCtxt ctxt,
 445                                     nest 2 (ptext SLIT("at") <+> ppr (getSrcLoc tv))]
 446     ppr_skol info            = quotes (ppr tv) <+> pprSkolInfo info
 447
 448 pprSkolInfo :: SkolemInfo -> SDoc
 449 pprSkolInfo (SigSkol ctxt)   = ptext SLIT("is bound by") <+> pprUserTypeCtxt ctxt
 450 pprSkolInfo (ClsSkol cls)    = ptext SLIT("is bound by the class declaration for") <+> quotes (ppr cls)
 451 pprSkolInfo (InstSkol df)    = ptext SLIT("is bound by the instance declaration at") <+> ppr (getSrcLoc df)
 452 pprSkolInfo (ArrowSkol loc)  = ptext SLIT("is bound by the arrow form at") <+> ppr loc
 453 pprSkolInfo (PatSkol dc loc) = sep [ptext SLIT("is bound by the pattern for") <+> quotes (ppr dc),
 454                                     nest 2 (ptext SLIT("at") <+> ppr loc)]
 455 pprSkolInfo (GenSkol tvs ty loc) = sep [sep [ptext SLIT("is bound by the polymorphic type"),
 456                                              nest 2 (quotes (ppr (mkForAllTys tvs ty)))],
 457                                         nest 2 (ptext SLIT("at") <+> ppr loc)]
 458 -- UnkSkol, SigSkol
 459 -- For type variables the others are dealt with by pprSkolTvBinding.
 460 -- For Insts, these cases should not happen
 461 pprSkolInfo UnkSkol = panic "UnkSkol"
 462
 463 instance Outputable MetaDetails where
 464   ppr Flexi         = ptext SLIT("Flexi")
 465   ppr (Indirect ty) = ptext SLIT("Indirect") <+> ppr ty
 466 \end{code}
 467
 468
 469 %************************************************************************
 470 %*                                                                      *
 471                 Predicates
 472 %*                                                                      *
 473 %************************************************************************
 474
 475 \begin{code}
 476 isImmutableTyVar, isSkolemTyVar, isExistentialTyVar, isBoxyTyVar, isMetaTyVar :: TyVar -> Bool
 477 isImmutableTyVar tv
 478   | isTcTyVar tv = isSkolemTyVar tv
 479   | otherwise    = True
 480
 481 isSkolemTyVar tv
 482   = ASSERT( isTcTyVar tv )
 483     case tcTyVarDetails tv of
 484         SkolemTv _         -> True
 485         MetaTv _ _         -> False
 486
 487 isExistentialTyVar tv   -- Existential type variable, bound by a pattern
 488   = ASSERT( isTcTyVar tv )
 489     case tcTyVarDetails tv of
 490         SkolemTv (PatSkol _ _) -> True
 491         other                  -> False
 492
 493 isMetaTyVar tv
 494   = ASSERT2( isTcTyVar tv, ppr tv )
 495     case tcTyVarDetails tv of
 496         MetaTv _ _ -> True
 497         other      -> False
 498
 499 isBoxyTyVar tv
 500   = ASSERT( isTcTyVar tv )
 501     case tcTyVarDetails tv of
 502         MetaTv BoxTv _ -> True
 503         other          -> False
 504
 505 isSigTyVar tv
 506   = ASSERT( isTcTyVar tv )
 507     case tcTyVarDetails tv of
 508         MetaTv (SigTv _) _ -> True
 509         other              -> False
 510
 511 metaTvRef :: TyVar -> IORef MetaDetails
 512 metaTvRef tv
 513   = ASSERT( isTcTyVar tv )
 514     case tcTyVarDetails tv of
 515         MetaTv _ ref -> ref
 516         other      -> pprPanic "metaTvRef" (ppr tv)
 517
 518 isFlexi, isIndirect :: MetaDetails -> Bool
 519 isFlexi Flexi = True
 520 isFlexi other = False
 521
 522 isIndirect (Indirect _) = True
 523 isIndirect other        = False
 524 \end{code}
 525
 526
 527 %************************************************************************
 528 %*                                                                      *
 529 \subsection{Tau, sigma and rho}
 530 %*                                                                      *
 531 %************************************************************************
 532
 533 \begin{code}
 534 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau)
 535
 536 mkPhiTy :: [PredType] -> Type -> Type
 537 mkPhiTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
 538 \end{code}
 539
 540 @isTauTy@ tests for nested for-alls.  It should not be called on a boxy type.
 541
 542 \begin{code}
 543 isTauTy :: Type -> Bool
 544 isTauTy ty | Just ty' <- tcView ty = isTauTy ty'
 545 isTauTy (TyVarTy tv)     = ASSERT( not (isTcTyVar tv && isBoxyTyVar tv) )
 546                            True
 547 isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc
 548 isTauTy (AppTy a b)       = isTauTy a && isTauTy b
 549 isTauTy (FunTy a b)       = isTauTy a && isTauTy b
 550 isTauTy (PredTy p)        = True                -- Don't look through source types
 551 isTauTy other             = False
 552
 553
 554 isTauTyCon :: TyCon -> Bool
 555 -- Returns False for type synonyms whose expansion is a polytype
 556 isTauTyCon tc | isSynTyCon tc = isTauTy (snd (synTyConDefn tc))
 557               | otherwise     = True
 558
 559 ---------------
 560 isBoxyTy :: TcType -> Bool
 561 isBoxyTy ty = any isBoxyTyVar (varSetElems (tcTyVarsOfType ty))
 562
 563 isRigidTy :: TcType -> Bool
 564 -- A type is rigid if it has no meta type variables in it
 565 isRigidTy ty = all isSkolemTyVar (varSetElems (tcTyVarsOfType ty))
 566
 567 isRefineableTy :: TcType -> Bool
 568 -- A type should have type refinements applied to it if it has
 569 -- free type variables, and they are all rigid
 570 isRefineableTy ty = not (null tc_tvs) && all isSkolemTyVar tc_tvs
 571                     where
 572                       tc_tvs = varSetElems (tcTyVarsOfType ty)
 573
 574 ---------------
 575 getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
 576                                 -- construct a dictionary function name
 577 getDFunTyKey ty | Just ty' <- tcView ty = getDFunTyKey ty'
 578 getDFunTyKey (TyVarTy tv)    = getOccName tv
 579 getDFunTyKey (TyConApp tc _) = getOccName tc
 580 getDFunTyKey (AppTy fun _)   = getDFunTyKey fun
 581 getDFunTyKey (FunTy arg _)   = getOccName funTyCon
 582 getDFunTyKey (ForAllTy _ t)  = getDFunTyKey t
 583 getDFunTyKey ty              = pprPanic "getDFunTyKey" (pprType ty)
 584 -- PredTy shouldn't happen
 585 \end{code}
 586
 587
 588 %************************************************************************
 589 %*                                                                      *
 590 \subsection{Expanding and splitting}
 591 %*                                                                      *
 592 %************************************************************************
 593
 594 These tcSplit functions are like their non-Tc analogues, but
 595         a) they do not look through newtypes
 596         b) they do not look through PredTys
 597         c) [future] they ignore usage-type annotations
 598
 599 However, they are non-monadic and do not follow through mutable type
 600 variables.  It's up to you to make sure this doesn't matter.
 601
 602 \begin{code}
 603 tcSplitForAllTys :: Type -> ([TyVar], Type)
 604 tcSplitForAllTys ty = split ty ty []
 605    where
 606      split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
 607      split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
 608      split orig_ty t                tvs = (reverse tvs, orig_ty)
 609
 610 tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty'
 611 tcIsForAllTy (ForAllTy tv ty) = True
 612 tcIsForAllTy t                = False
 613
 614 tcSplitPhiTy :: Type -> ([PredType], Type)
 615 tcSplitPhiTy ty = split ty ty []
 616  where
 617   split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
 618   split orig_ty (FunTy arg res) ts = case tcSplitPredTy_maybe arg of
 619                                         Just p  -> split res res (p:ts)
 620                                         Nothing -> (reverse ts, orig_ty)
 621   split orig_ty ty              ts = (reverse ts, orig_ty)
 622
 623 tcSplitSigmaTy ty = case tcSplitForAllTys ty of
 624                         (tvs, rho) -> case tcSplitPhiTy rho of
 625                                         (theta, tau) -> (tvs, theta, tau)
 626
 627 -----------------------
 628 tcMultiSplitSigmaTy
 629         :: TcSigmaType
 630         -> ( [([TyVar], ThetaType)],    -- forall as.C => forall bs.D
 631              TcSigmaType)               -- The rest of the type
 632
 633 -- We need a loop here because we are now prepared to entertain
 634 -- types like
 635 --      f:: forall a. Eq a => forall b. Baz b => tau
 636 -- We want to instantiate this to
 637 --      f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 638
 639 tcMultiSplitSigmaTy sigma
 640   = case (tcSplitSigmaTy sigma) of
 641         ([],[],ty) -> ([], sigma)
 642         (tvs, theta, ty) -> case tcMultiSplitSigmaTy ty of
 643                                 (pairs, rest) -> ((tvs,theta):pairs, rest)
 644
 645 -----------------------
 646 tcTyConAppTyCon :: Type -> TyCon
 647 tcTyConAppTyCon ty = fst (tcSplitTyConApp ty)
 648
 649 tcTyConAppArgs :: Type -> [Type]
 650 tcTyConAppArgs ty = snd (tcSplitTyConApp ty)
 651
 652 tcSplitTyConApp :: Type -> (TyCon, [Type])
 653 tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of
 654                         Just stuff -> stuff
 655                         Nothing    -> pprPanic "tcSplitTyConApp" (pprType ty)
 656
 657 tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
 658 tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty'
 659 tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
 660 tcSplitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
 661         -- Newtypes are opaque, so they may be split
 662         -- However, predicates are not treated
 663         -- as tycon applications by the type checker
 664 tcSplitTyConApp_maybe other             = Nothing
 665
 666 -----------------------
 667 tcSplitFunTys :: Type -> ([Type], Type)
 668 tcSplitFunTys ty = case tcSplitFunTy_maybe ty of
 669                         Nothing        -> ([], ty)
 670                         Just (arg,res) -> (arg:args, res')
 671                                        where
 672                                           (args,res') = tcSplitFunTys res
 673
 674 tcSplitFunTy_maybe :: Type -> Maybe (Type, Type)
 675 tcSplitFunTy_maybe ty | Just ty' <- tcView ty = tcSplitFunTy_maybe ty'
 676 tcSplitFunTy_maybe (FunTy arg res)  = Just (arg, res)
 677 tcSplitFunTy_maybe other            = Nothing
 678
 679 tcSplitFunTysN
 680         :: TcRhoType
 681         -> Arity                -- N: Number of desired args
 682         -> ([TcSigmaType],      -- Arg types (N or fewer)
 683             TcSigmaType)        -- The rest of the type
 684
 685 tcSplitFunTysN ty n_args
 686   | n_args == 0
 687   = ([], ty)
 688   | Just (arg,res) <- tcSplitFunTy_maybe ty
 689   = case tcSplitFunTysN res (n_args - 1) of
 690         (args, res) -> (arg:args, res)
 691   | otherwise
 692   = ([], ty)
 693
 694 tcFunArgTy    ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> arg }
 695 tcFunResultTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> res }
 696
 697
 698 -----------------------
 699 tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
 700 tcSplitAppTy_maybe ty | Just ty' <- tcView ty = tcSplitAppTy_maybe ty'
 701 tcSplitAppTy_maybe (FunTy ty1 ty2)   = Just (TyConApp funTyCon [ty1], ty2)
 702 tcSplitAppTy_maybe (AppTy ty1 ty2)   = Just (ty1, ty2)
 703 tcSplitAppTy_maybe (TyConApp tc tys) = case snocView tys of
 704                                         Just (tys', ty') -> Just (TyConApp tc tys', ty')
 705                                         Nothing          -> Nothing
 706 tcSplitAppTy_maybe other             = Nothing
 707
 708 tcSplitAppTy ty = case tcSplitAppTy_maybe ty of
 709                     Just stuff -> stuff
 710                     Nothing    -> pprPanic "tcSplitAppTy" (pprType ty)
 711
 712 tcSplitAppTys :: Type -> (Type, [Type])
 713 tcSplitAppTys ty
 714   = go ty []
 715   where
 716     go ty args = case tcSplitAppTy_maybe ty of
 717                    Just (ty', arg) -> go ty' (arg:args)
 718                    Nothing         -> (ty,args)
 719
 720 -----------------------
 721 tcGetTyVar_maybe :: Type -> Maybe TyVar
 722 tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty'
 723 tcGetTyVar_maybe (TyVarTy tv)   = Just tv
 724 tcGetTyVar_maybe other          = Nothing
 725
 726 tcGetTyVar :: String -> Type -> TyVar
 727 tcGetTyVar msg ty = expectJust msg (tcGetTyVar_maybe ty)
 728
 729 tcIsTyVarTy :: Type -> Bool
 730 tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty)
 731
 732 -----------------------
 733 tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
 734 -- Split the type of a dictionary function
 735 tcSplitDFunTy ty
 736   = case tcSplitSigmaTy ty   of { (tvs, theta, tau) ->
 737     case tcSplitDFunHead tau of { (clas, tys) ->
 738     (tvs, theta, clas, tys) }}
 739
 740 tcSplitDFunHead :: Type -> (Class, [Type])
 741 tcSplitDFunHead tau
 742   = case tcSplitPredTy_maybe tau of
 743         Just (ClassP clas tys) -> (clas, tys)
 744
 745 tcValidInstHeadTy :: Type -> Bool
 746 -- Used in Haskell-98 mode, for the argument types of an instance head
 747 -- These must not be type synonyms, but everywhere else type synonyms
 748 -- are transparent, so we need a special function here
 749 tcValidInstHeadTy ty
 750   = case ty of
 751         NoteTy _ ty     -> tcValidInstHeadTy ty
 752         TyConApp tc tys -> not (isSynTyCon tc) && ok tys
 753         FunTy arg res   -> ok [arg, res]
 754         other           -> False
 755   where
 756         -- Check that all the types are type variables,
 757         -- and that each is distinct
 758     ok tys = equalLength tvs tys && hasNoDups tvs
 759            where
 760              tvs = mapCatMaybes get_tv tys
 761
 762     get_tv (NoteTy _ ty) = get_tv ty    -- Again, do not look
 763     get_tv (TyVarTy tv)  = Just tv      -- through synonyms
 764     get_tv other         = Nothing
 765 \end{code}
 766
 767
 768
 769 %************************************************************************
 770 %*                                                                      *
 771 \subsection{Predicate types}
 772 %*                                                                      *
 773 %************************************************************************
 774
 775 \begin{code}
 776 tcSplitPredTy_maybe :: Type -> Maybe PredType
 777    -- Returns Just for predicates only
 778 tcSplitPredTy_maybe ty | Just ty' <- tcView ty = tcSplitPredTy_maybe ty'
 779 tcSplitPredTy_maybe (PredTy p)    = Just p
 780 tcSplitPredTy_maybe other         = Nothing
 781
 782 predTyUnique :: PredType -> Unique
 783 predTyUnique (IParam n _)      = getUnique (ipNameName n)
 784 predTyUnique (ClassP clas tys) = getUnique clas
 785
 786 mkPredName :: Unique -> SrcLoc -> PredType -> Name
 787 mkPredName uniq loc (ClassP cls tys) = mkInternalName uniq (mkDictOcc (getOccName cls)) loc
 788 mkPredName uniq loc (IParam ip ty)   = mkInternalName uniq (getOccName (ipNameName ip)) loc
 789 \end{code}
 790
 791
 792 --------------------- Dictionary types ---------------------------------
 793
 794 \begin{code}
 795 mkClassPred clas tys = ClassP clas tys
 796
 797 isClassPred :: PredType -> Bool
 798 isClassPred (ClassP clas tys) = True
 799 isClassPred other             = False
 800
 801 isTyVarClassPred (ClassP clas tys) = all tcIsTyVarTy tys
 802 isTyVarClassPred other             = False
 803
 804 getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
 805 getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
 806 getClassPredTys_maybe _                 = Nothing
 807
 808 getClassPredTys :: PredType -> (Class, [Type])
 809 getClassPredTys (ClassP clas tys) = (clas, tys)
 810
 811 mkDictTy :: Class -> [Type] -> Type
 812 mkDictTy clas tys = mkPredTy (ClassP clas tys)
 813
 814 isDictTy :: Type -> Bool
 815 isDictTy ty | Just ty' <- tcView ty = isDictTy ty'
 816 isDictTy (PredTy p)   = isClassPred p
 817 isDictTy other          = False
 818 \end{code}
 819
 820 --------------------- Implicit parameters ---------------------------------
 821
 822 \begin{code}
 823 isIPPred :: PredType -> Bool
 824 isIPPred (IParam _ _) = True
 825 isIPPred other        = False
 826
 827 isInheritablePred :: PredType -> Bool
 828 -- Can be inherited by a context.  For example, consider
 829 --      f x = let g y = (?v, y+x)
 830 --            in (g 3 with ?v = 8,
 831 --                g 4 with ?v = 9)
 832 -- The point is that g's type must be quantifed over ?v:
 833 --      g :: (?v :: a) => a -> a
 834 -- but it doesn't need to be quantified over the Num a dictionary
 835 -- which can be free in g's rhs, and shared by both calls to g
 836 isInheritablePred (ClassP _ _) = True
 837 isInheritablePred other      = False
 838
 839 isLinearPred :: TcPredType -> Bool
 840 isLinearPred (IParam (Linear n) _) = True
 841 isLinearPred other                 = False
 842 \end{code}
 843
 844 --------------------- The stupid theta (sigh) ---------------------------------
 845
 846 \begin{code}
 847 dataConsStupidTheta :: [DataCon] -> ThetaType
 848 -- Union the stupid thetas from all the specified constructors (non-empty)
 849 -- All the constructors should have the same result type, modulo alpha conversion
 850 -- The resulting ThetaType uses type variables from the *first* constructor in the list
 851 --
 852 -- It's here because it's used in MkId.mkRecordSelId, and in TcExpr
 853 dataConsStupidTheta (con1:cons)
 854   = nubBy tcEqPred all_preds
 855   where
 856     all_preds     = dataConStupidTheta con1 ++ other_stupids
 857     res_tys1      = dataConResTys con1
 858     tvs1          = tyVarsOfTypes res_tys1
 859     other_stupids = [ substPred subst pred
 860                     | con <- cons
 861                     , let Just subst = tcMatchTys tvs1 res_tys1 (dataConResTys con)
 862                     , pred <- dataConStupidTheta con ]
 863 \end{code}
 864
 865
 866 %************************************************************************
 867 %*                                                                      *
 868 \subsection{Predicates}
 869 %*                                                                      *
 870 %************************************************************************
 871
 872 isSigmaTy returns true of any qualified type.  It doesn't *necessarily* have
 873 any foralls.  E.g.
 874         f :: (?x::Int) => Int -> Int
 875
 876 \begin{code}
 877 isSigmaTy :: Type -> Bool
 878 isSigmaTy ty | Just ty' <- tcView ty = isSigmaTy ty'
 879 isSigmaTy (ForAllTy tyvar ty) = True
 880 isSigmaTy (FunTy a b)         = isPredTy a
 881 isSigmaTy _                   = False
 882
 883 isOverloadedTy :: Type -> Bool
 884 isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty'
 885 isOverloadedTy (ForAllTy tyvar ty) = isOverloadedTy ty
 886 isOverloadedTy (FunTy a b)         = isPredTy a
 887 isOverloadedTy _                   = False
 888
 889 isPredTy :: Type -> Bool        -- Belongs in TcType because it does
 890                                 -- not look through newtypes, or predtypes (of course)
 891 isPredTy ty | Just ty' <- tcView ty = isPredTy ty'
 892 isPredTy (PredTy sty)  = True
 893 isPredTy _             = False
 894 \end{code}
 895
 896 \begin{code}
 897 isFloatTy      = is_tc floatTyConKey
 898 isDoubleTy     = is_tc doubleTyConKey
 899 isIntegerTy    = is_tc integerTyConKey
 900 isIntTy        = is_tc intTyConKey
 901 isAddrTy       = is_tc addrTyConKey
 902 isBoolTy       = is_tc boolTyConKey
 903 isUnitTy       = is_tc unitTyConKey
 904
 905 is_tc :: Unique -> Type -> Bool
 906 -- Newtypes are opaque to this
 907 is_tc uniq ty = case tcSplitTyConApp_maybe ty of
 908                         Just (tc, _) -> uniq == getUnique tc
 909                         Nothing      -> False
 910 \end{code}
 911
 912
 913 %************************************************************************
 914 %*                                                                      *
 915 \subsection{Misc}
 916 %*                                                                      *
 917 %************************************************************************
 918
 919 \begin{code}
 920 deNoteType :: Type -> Type
 921 -- Remove all *outermost* type synonyms and other notes
 922 deNoteType ty | Just ty' <- tcView ty = deNoteType ty'
 923 deNoteType ty = ty
 924 \end{code}
 925
 926 \begin{code}
 927 tcTyVarsOfType :: Type -> TcTyVarSet
 928 -- Just the tc type variables free in the type
 929 tcTyVarsOfType (TyVarTy tv)         = if isTcTyVar tv then unitVarSet tv
 930                                                       else emptyVarSet
 931 tcTyVarsOfType (TyConApp tycon tys) = tcTyVarsOfTypes tys
 932 tcTyVarsOfType (NoteTy _ ty)        = tcTyVarsOfType ty
 933 tcTyVarsOfType (PredTy sty)         = tcTyVarsOfPred sty
 934 tcTyVarsOfType (FunTy arg res)      = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res
 935 tcTyVarsOfType (AppTy fun arg)      = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg
 936 tcTyVarsOfType (ForAllTy tyvar ty)  = tcTyVarsOfType ty `delVarSet` tyvar
 937         -- We do sometimes quantify over skolem TcTyVars
 938
 939 tcTyVarsOfTypes :: [Type] -> TyVarSet
 940 tcTyVarsOfTypes tys = foldr (unionVarSet.tcTyVarsOfType) emptyVarSet tys
 941
 942 tcTyVarsOfPred :: PredType -> TyVarSet
 943 tcTyVarsOfPred (IParam _ ty)  = tcTyVarsOfType ty
 944 tcTyVarsOfPred (ClassP _ tys) = tcTyVarsOfTypes tys
 945 \end{code}
 946
 947 Note [Silly type synonym]
 948 ~~~~~~~~~~~~~~~~~~~~~~~~~
 949 Consider
 950         type T a = Int
 951 What are the free tyvars of (T x)?  Empty, of course!
 952 Here's the example that Ralf Laemmel showed me:
 953         foo :: (forall a. C u a -> C u a) -> u
 954         mappend :: Monoid u => u -> u -> u
 955
 956         bar :: Monoid u => u
 957         bar = foo (\t -> t `mappend` t)
 958 We have to generalise at the arg to f, and we don't
 959 want to capture the constraint (Monad (C u a)) because
 960 it appears to mention a.  Pretty silly, but it was useful to him.
 961
 962 exactTyVarsOfType is used by the type checker to figure out exactly
 963 which type variables are mentioned in a type.  It's also used in the
 964 smart-app checking code --- see TcExpr.tcIdApp
 965
 966 \begin{code}
 967 exactTyVarsOfType :: TcType -> TyVarSet
 968 -- Find the free type variables (of any kind)
 969 -- but *expand* type synonyms.  See Note [Silly type synonym] belos.
 970 exactTyVarsOfType ty
 971   = go ty
 972   where
 973     go ty | Just ty' <- tcView ty = go ty'      -- This is the key line
 974     go (TyVarTy tv)               = unitVarSet tv
 975     go (TyConApp tycon tys)       = exactTyVarsOfTypes tys
 976     go (PredTy ty)                = go_pred ty
 977     go (FunTy arg res)            = go arg `unionVarSet` go res
 978     go (AppTy fun arg)            = go fun `unionVarSet` go arg
 979     go (ForAllTy tyvar ty)        = delVarSet (go ty) tyvar
 980
 981     go_pred (IParam _ ty)  = go ty
 982     go_pred (ClassP _ tys) = exactTyVarsOfTypes tys
 983
 984 exactTyVarsOfTypes :: [TcType] -> TyVarSet
 985 exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys
 986 \end{code}
 987
 988 Find the free tycons and classes of a type.  This is used in the front
 989 end of the compiler.
 990
 991 \begin{code}
 992 tyClsNamesOfType :: Type -> NameSet
 993 tyClsNamesOfType (TyVarTy tv)               = emptyNameSet
 994 tyClsNamesOfType (TyConApp tycon tys)       = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
 995 tyClsNamesOfType (NoteTy _ ty2)             = tyClsNamesOfType ty2
 996 tyClsNamesOfType (PredTy (IParam n ty))     = tyClsNamesOfType ty
 997 tyClsNamesOfType (PredTy (ClassP cl tys))   = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
 998 tyClsNamesOfType (FunTy arg res)            = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res
 999 tyClsNamesOfType (AppTy fun arg)            = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg
1000 tyClsNamesOfType (ForAllTy tyvar ty)        = tyClsNamesOfType ty
1001
1002 tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys
1003
1004 tyClsNamesOfDFunHead :: Type -> NameSet
1005 -- Find the free type constructors and classes
1006 -- of the head of the dfun instance type
1007 -- The 'dfun_head_type' is because of
1008 --      instance Foo a => Baz T where ...
1009 -- The decl is an orphan if Baz and T are both not locally defined,
1010 --      even if Foo *is* locally defined
1011 tyClsNamesOfDFunHead dfun_ty
1012   = case tcSplitSigmaTy dfun_ty of
1013         (tvs,_,head_ty) -> tyClsNamesOfType head_ty
1014
1015 classesOfTheta :: ThetaType -> [Class]
1016 -- Looks just for ClassP things; maybe it should check
1017 classesOfTheta preds = [ c | ClassP c _ <- preds ]
1018 \end{code}
1019
1020
1021 %************************************************************************
1022 %*                                                                      *
1023 \subsection[TysWiredIn-ext-type]{External types}
1024 %*                                                                      *
1025 %************************************************************************
1026
1027 The compiler's foreign function interface supports the passing of a
1028 restricted set of types as arguments and results (the restricting factor
1029 being the )
1030
1031 \begin{code}
1032 isFFITy :: Type -> Bool
1033 -- True for any TyCon that can possibly be an arg or result of an FFI call
1034 isFFITy ty = checkRepTyCon legalFFITyCon ty
1035
1036 isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
1037 -- Checks for valid argument type for a 'foreign import'
1038 isFFIArgumentTy dflags safety ty
1039    = checkRepTyCon (legalOutgoingTyCon dflags safety) ty
1040
1041 isFFIExternalTy :: Type -> Bool
1042 -- Types that are allowed as arguments of a 'foreign export'
1043 isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty
1044
1045 isFFIImportResultTy :: DynFlags -> Type -> Bool
1046 isFFIImportResultTy dflags ty
1047   = checkRepTyCon (legalFIResultTyCon dflags) ty
1048
1049 isFFIExportResultTy :: Type -> Bool
1050 isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
1051
1052 isFFIDynArgumentTy :: Type -> Bool
1053 -- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr,
1054 -- or a newtype of either.
1055 isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
1056
1057 isFFIDynResultTy :: Type -> Bool
1058 -- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr,
1059 -- or a newtype of either.
1060 isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
1061
1062 isFFILabelTy :: Type -> Bool
1063 -- The type of a foreign label must be Ptr, FunPtr, Addr,
1064 -- or a newtype of either.
1065 isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
1066
1067 isFFIDotnetTy :: DynFlags -> Type -> Bool
1068 isFFIDotnetTy dflags ty
1069   = checkRepTyCon (\ tc -> not (isByteArrayLikeTyCon tc) &&
1070                            (legalFIResultTyCon dflags tc ||
1071                            isFFIDotnetObjTy ty || isStringTy ty)) ty
1072
1073 -- Support String as an argument or result from a .NET FFI call.
1074 isStringTy ty =
1075   case tcSplitTyConApp_maybe (repType ty) of
1076     Just (tc, [arg_ty])
1077       | tc == listTyCon ->
1078         case tcSplitTyConApp_maybe (repType arg_ty) of
1079           Just (cc,[]) -> cc == charTyCon
1080           _ -> False
1081     _ -> False
1082
1083 -- Support String as an argument or result from a .NET FFI call.
1084 isFFIDotnetObjTy ty =
1085   let
1086    (_, t_ty) = tcSplitForAllTys ty
1087   in
1088   case tcSplitTyConApp_maybe (repType t_ty) of
1089     Just (tc, [arg_ty]) | getName tc == objectTyConName -> True
1090     _ -> False
1091
1092 toDNType :: Type -> DNType
1093 toDNType ty
1094   | isStringTy ty = DNString
1095   | isFFIDotnetObjTy ty = DNObject
1096   | Just (tc,argTys) <- tcSplitTyConApp_maybe ty =
1097      case lookup (getUnique tc) dn_assoc of
1098        Just x  -> x
1099        Nothing
1100          | tc `hasKey` ioTyConKey -> toDNType (head argTys)
1101          | otherwise -> pprPanic ("toDNType: unsupported .NET type") (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc)
1102     where
1103       dn_assoc :: [ (Unique, DNType) ]
1104       dn_assoc = [ (unitTyConKey,   DNUnit)
1105                  , (intTyConKey,    DNInt)
1106                  , (int8TyConKey,   DNInt8)
1107                  , (int16TyConKey,  DNInt16)
1108                  , (int32TyConKey,  DNInt32)
1109                  , (int64TyConKey,  DNInt64)
1110                  , (wordTyConKey,   DNInt)
1111                  , (word8TyConKey,  DNWord8)
1112                  , (word16TyConKey, DNWord16)
1113                  , (word32TyConKey, DNWord32)
1114                  , (word64TyConKey, DNWord64)
1115                  , (floatTyConKey,  DNFloat)
1116                  , (doubleTyConKey, DNDouble)
1117                  , (addrTyConKey,   DNPtr)
1118                  , (ptrTyConKey,    DNPtr)
1119                  , (funPtrTyConKey, DNPtr)
1120                  , (charTyConKey,   DNChar)
1121                  , (boolTyConKey,   DNBool)
1122                  ]
1123
1124 checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
1125         -- Look through newtypes
1126         -- Non-recursive ones are transparent to splitTyConApp,
1127         -- but recursive ones aren't.  Manuel had:
1128         --      newtype T = MkT (Ptr T)
1129         -- and wanted it to work...
1130 checkRepTyCon check_tc ty
1131   | Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc
1132   | otherwise                                       = False
1133
1134 checkRepTyConKey :: [Unique] -> Type -> Bool
1135 -- Like checkRepTyCon, but just looks at the TyCon key
1136 checkRepTyConKey keys
1137   = checkRepTyCon (\tc -> tyConUnique tc `elem` keys)
1138 \end{code}
1139
1140 ----------------------------------------------
1141 These chaps do the work; they are not exported
1142 ----------------------------------------------
1143
1144 \begin{code}
1145 legalFEArgTyCon :: TyCon -> Bool
1146 -- It's illegal to return foreign objects and (mutable)
1147 -- bytearrays from a _ccall_ / foreign declaration
1148 -- (or be passed them as arguments in foreign exported functions).
1149 legalFEArgTyCon tc
1150   | isByteArrayLikeTyCon tc
1151   = False
1152   -- It's also illegal to make foreign exports that take unboxed
1153   -- arguments.  The RTS API currently can't invoke such things.  --SDM 7/2000
1154   | otherwise
1155   = boxedMarshalableTyCon tc
1156
1157 legalFIResultTyCon :: DynFlags -> TyCon -> Bool
1158 legalFIResultTyCon dflags tc
1159   | isByteArrayLikeTyCon tc = False
1160   | tc == unitTyCon         = True
1161   | otherwise               = marshalableTyCon dflags tc
1162
1163 legalFEResultTyCon :: TyCon -> Bool
1164 legalFEResultTyCon tc
1165   | isByteArrayLikeTyCon tc = False
1166   | tc == unitTyCon         = True
1167   | otherwise               = boxedMarshalableTyCon tc
1168
1169 legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
1170 -- Checks validity of types going from Haskell -> external world
1171 legalOutgoingTyCon dflags safety tc
1172   | playSafe safety && isByteArrayLikeTyCon tc
1173   = False
1174   | otherwise
1175   = marshalableTyCon dflags tc
1176
1177 legalFFITyCon :: TyCon -> Bool
1178 -- True for any TyCon that can possibly be an arg or result of an FFI call
1179 legalFFITyCon tc
1180   = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon
1181
1182 marshalableTyCon dflags tc
1183   =  (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
1184   || boxedMarshalableTyCon tc
1185
1186 boxedMarshalableTyCon tc
1187    = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
1188                          , int32TyConKey, int64TyConKey
1189                          , wordTyConKey, word8TyConKey, word16TyConKey
1190                          , word32TyConKey, word64TyConKey
1191                          , floatTyConKey, doubleTyConKey
1192                          , addrTyConKey, ptrTyConKey, funPtrTyConKey
1193                          , charTyConKey
1194                          , stablePtrTyConKey
1195                          , byteArrayTyConKey, mutableByteArrayTyConKey
1196                          , boolTyConKey
1197                          ]
1198
1199 isByteArrayLikeTyCon :: TyCon -> Bool
1200 isByteArrayLikeTyCon tc =
1201   getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
1202 \end{code}