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