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, argTypeKind,
  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, argTypeKind,
 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 :: [TyVar] -> [PredType] -> Type -> Type
 544 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau)
 545
 546 mkPhiTy :: [PredType] -> Type -> Type
 547 mkPhiTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
 548 \end{code}
 549
 550 @isTauTy@ tests for nested for-alls.  It should not be called on a boxy type.
 551
 552 \begin{code}
 553 isTauTy :: Type -> Bool
 554 isTauTy ty | Just ty' <- tcView ty = isTauTy ty'
 555 isTauTy (TyVarTy tv)     = ASSERT( not (isTcTyVar tv && isBoxyTyVar tv) )
 556                            True
 557 isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc
 558 isTauTy (AppTy a b)       = isTauTy a && isTauTy b
 559 isTauTy (FunTy a b)       = isTauTy a && isTauTy b
 560 isTauTy (PredTy p)        = True                -- Don't look through source types
 561 isTauTy other             = False
 562
 563
 564 isTauTyCon :: TyCon -> Bool
 565 -- Returns False for type synonyms whose expansion is a polytype
 566 isTauTyCon tc | isSynTyCon tc = isTauTy (snd (synTyConDefn tc))
 567               | otherwise     = True
 568
 569 ---------------
 570 isBoxyTy :: TcType -> Bool
 571 isBoxyTy ty = any isBoxyTyVar (varSetElems (tcTyVarsOfType ty))
 572
 573 isRigidTy :: TcType -> Bool
 574 -- A type is rigid if it has no meta type variables in it
 575 isRigidTy ty = all isSkolemTyVar (varSetElems (tcTyVarsOfType ty))
 576
 577 isRefineableTy :: TcType -> Bool
 578 -- A type should have type refinements applied to it if it has
 579 -- free type variables, and they are all rigid
 580 isRefineableTy ty = not (null tc_tvs) && all isSkolemTyVar tc_tvs
 581                     where
 582                       tc_tvs = varSetElems (tcTyVarsOfType ty)
 583
 584 ---------------
 585 getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
 586                                 -- construct a dictionary function name
 587 getDFunTyKey ty | Just ty' <- tcView ty = getDFunTyKey ty'
 588 getDFunTyKey (TyVarTy tv)    = getOccName tv
 589 getDFunTyKey (TyConApp tc _) = getOccName tc
 590 getDFunTyKey (AppTy fun _)   = getDFunTyKey fun
 591 getDFunTyKey (FunTy arg _)   = getOccName funTyCon
 592 getDFunTyKey (ForAllTy _ t)  = getDFunTyKey t
 593 getDFunTyKey ty              = pprPanic "getDFunTyKey" (pprType ty)
 594 -- PredTy shouldn't happen
 595 \end{code}
 596
 597
 598 %************************************************************************
 599 %*                                                                      *
 600 \subsection{Expanding and splitting}
 601 %*                                                                      *
 602 %************************************************************************
 603
 604 These tcSplit functions are like their non-Tc analogues, but
 605         a) they do not look through newtypes
 606         b) they do not look through PredTys
 607         c) [future] they ignore usage-type annotations
 608
 609 However, they are non-monadic and do not follow through mutable type
 610 variables.  It's up to you to make sure this doesn't matter.
 611
 612 \begin{code}
 613 tcSplitForAllTys :: Type -> ([TyVar], Type)
 614 tcSplitForAllTys ty = split ty ty []
 615    where
 616      split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
 617      split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
 618      split orig_ty t                tvs = (reverse tvs, orig_ty)
 619
 620 tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty'
 621 tcIsForAllTy (ForAllTy tv ty) = True
 622 tcIsForAllTy t                = False
 623
 624 tcSplitPhiTy :: Type -> (ThetaType, Type)
 625 tcSplitPhiTy ty = split ty ty []
 626  where
 627   split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
 628   split orig_ty (FunTy arg res) ts
 629         | Just p <- tcSplitPredTy_maybe arg = split res res (p:ts)
 630   split orig_ty ty              ts = (reverse ts, orig_ty)
 631
 632 tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)
 633 tcSplitSigmaTy ty = case tcSplitForAllTys ty of
 634                         (tvs, rho) -> case tcSplitPhiTy rho of
 635                                         (theta, tau) -> (tvs, theta, tau)
 636
 637 -----------------------
 638 tcMultiSplitSigmaTy
 639         :: TcSigmaType
 640         -> ( [([TyVar], ThetaType)],    -- forall as.C => forall bs.D
 641              TcSigmaType)               -- The rest of the type
 642
 643 -- We need a loop here because we are now prepared to entertain
 644 -- types like
 645 --      f:: forall a. Eq a => forall b. Baz b => tau
 646 -- We want to instantiate this to
 647 --      f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 648
 649 tcMultiSplitSigmaTy sigma
 650   = case (tcSplitSigmaTy sigma) of
 651         ([],[],ty) -> ([], sigma)
 652         (tvs, theta, ty) -> case tcMultiSplitSigmaTy ty of
 653                                 (pairs, rest) -> ((tvs,theta):pairs, rest)
 654
 655 -----------------------
 656 tcTyConAppTyCon :: Type -> TyCon
 657 tcTyConAppTyCon ty = fst (tcSplitTyConApp ty)
 658
 659 tcTyConAppArgs :: Type -> [Type]
 660 tcTyConAppArgs ty = snd (tcSplitTyConApp ty)
 661
 662 tcSplitTyConApp :: Type -> (TyCon, [Type])
 663 tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of
 664                         Just stuff -> stuff
 665                         Nothing    -> pprPanic "tcSplitTyConApp" (pprType ty)
 666
 667 tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
 668 tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty'
 669 tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
 670 tcSplitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
 671         -- Newtypes are opaque, so they may be split
 672         -- However, predicates are not treated
 673         -- as tycon applications by the type checker
 674 tcSplitTyConApp_maybe other             = Nothing
 675
 676 -----------------------
 677 tcSplitFunTys :: Type -> ([Type], Type)
 678 tcSplitFunTys ty = case tcSplitFunTy_maybe ty of
 679                         Nothing        -> ([], ty)
 680                         Just (arg,res) -> (arg:args, res')
 681                                        where
 682                                           (args,res') = tcSplitFunTys res
 683
 684 tcSplitFunTy_maybe :: Type -> Maybe (Type, Type)
 685 tcSplitFunTy_maybe ty | Just ty' <- tcView ty = tcSplitFunTy_maybe ty'
 686 tcSplitFunTy_maybe (FunTy arg res)  = Just (arg, res)
 687 tcSplitFunTy_maybe other            = Nothing
 688
 689 tcSplitFunTysN
 690         :: TcRhoType
 691         -> Arity                -- N: Number of desired args
 692         -> ([TcSigmaType],      -- Arg types (N or fewer)
 693             TcSigmaType)        -- The rest of the type
 694
 695 tcSplitFunTysN ty n_args
 696   | n_args == 0
 697   = ([], ty)
 698   | Just (arg,res) <- tcSplitFunTy_maybe ty
 699   = case tcSplitFunTysN res (n_args - 1) of
 700         (args, res) -> (arg:args, res)
 701   | otherwise
 702   = ([], ty)
 703
 704 tcSplitFunTy  ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty)
 705 tcFunArgTy    ty = fst (tcSplitFunTy ty)
 706 tcFunResultTy ty = snd (tcSplitFunTy ty)
 707
 708 -----------------------
 709 tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
 710 tcSplitAppTy_maybe ty | Just ty' <- tcView ty = tcSplitAppTy_maybe ty'
 711 tcSplitAppTy_maybe (FunTy ty1 ty2)   = Just (TyConApp funTyCon [ty1], ty2)
 712 tcSplitAppTy_maybe (AppTy ty1 ty2)   = Just (ty1, ty2)
 713 tcSplitAppTy_maybe (TyConApp tc tys) = case snocView tys of
 714                                         Just (tys', ty') -> Just (TyConApp tc tys', ty')
 715                                         Nothing          -> Nothing
 716 tcSplitAppTy_maybe other             = Nothing
 717
 718 tcSplitAppTy ty = case tcSplitAppTy_maybe ty of
 719                     Just stuff -> stuff
 720                     Nothing    -> pprPanic "tcSplitAppTy" (pprType ty)
 721
 722 tcSplitAppTys :: Type -> (Type, [Type])
 723 tcSplitAppTys ty
 724   = go ty []
 725   where
 726     go ty args = case tcSplitAppTy_maybe ty of
 727                    Just (ty', arg) -> go ty' (arg:args)
 728                    Nothing         -> (ty,args)
 729
 730 -----------------------
 731 tcGetTyVar_maybe :: Type -> Maybe TyVar
 732 tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty'
 733 tcGetTyVar_maybe (TyVarTy tv)   = Just tv
 734 tcGetTyVar_maybe other          = Nothing
 735
 736 tcGetTyVar :: String -> Type -> TyVar
 737 tcGetTyVar msg ty = expectJust msg (tcGetTyVar_maybe ty)
 738
 739 tcIsTyVarTy :: Type -> Bool
 740 tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty)
 741
 742 -----------------------
 743 tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
 744 -- Split the type of a dictionary function
 745 tcSplitDFunTy ty
 746   = case tcSplitSigmaTy ty   of { (tvs, theta, tau) ->
 747     case tcSplitDFunHead tau of { (clas, tys) ->
 748     (tvs, theta, clas, tys) }}
 749
 750 tcSplitDFunHead :: Type -> (Class, [Type])
 751 tcSplitDFunHead tau
 752   = case tcSplitPredTy_maybe tau of
 753         Just (ClassP clas tys) -> (clas, tys)
 754         other -> panic "tcSplitDFunHead"
 755
 756 tcValidInstHeadTy :: Type -> Bool
 757 -- Used in Haskell-98 mode, for the argument types of an instance head
 758 -- These must not be type synonyms, but everywhere else type synonyms
 759 -- are transparent, so we need a special function here
 760 tcValidInstHeadTy ty
 761   = case ty of
 762         NoteTy _ ty     -> tcValidInstHeadTy ty
 763         TyConApp tc tys -> not (isSynTyCon tc) && ok tys
 764         FunTy arg res   -> ok [arg, res]
 765         other           -> False
 766   where
 767         -- Check that all the types are type variables,
 768         -- and that each is distinct
 769     ok tys = equalLength tvs tys && hasNoDups tvs
 770            where
 771              tvs = mapCatMaybes get_tv tys
 772
 773     get_tv (NoteTy _ ty) = get_tv ty    -- Again, do not look
 774     get_tv (TyVarTy tv)  = Just tv      -- through synonyms
 775     get_tv other         = Nothing
 776 \end{code}
 777
 778
 779
 780 %************************************************************************
 781 %*                                                                      *
 782 \subsection{Predicate types}
 783 %*                                                                      *
 784 %************************************************************************
 785
 786 \begin{code}
 787 tcSplitPredTy_maybe :: Type -> Maybe PredType
 788    -- Returns Just for predicates only
 789 tcSplitPredTy_maybe ty | Just ty' <- tcView ty = tcSplitPredTy_maybe ty'
 790 tcSplitPredTy_maybe (PredTy p)    = Just p
 791 tcSplitPredTy_maybe other         = Nothing
 792
 793 predTyUnique :: PredType -> Unique
 794 predTyUnique (IParam n _)      = getUnique (ipNameName n)
 795 predTyUnique (ClassP clas tys) = getUnique clas
 796
 797 mkPredName :: Unique -> SrcLoc -> PredType -> Name
 798 mkPredName uniq loc (ClassP cls tys) = mkInternalName uniq (mkDictOcc (getOccName cls)) loc
 799 mkPredName uniq loc (IParam ip ty)   = mkInternalName uniq (getOccName (ipNameName ip)) loc
 800 \end{code}
 801
 802
 803 --------------------- Dictionary types ---------------------------------
 804
 805 \begin{code}
 806 mkClassPred clas tys = ClassP clas tys
 807
 808 isClassPred :: PredType -> Bool
 809 isClassPred (ClassP clas tys) = True
 810 isClassPred other             = False
 811
 812 isTyVarClassPred (ClassP clas tys) = all tcIsTyVarTy tys
 813 isTyVarClassPred other             = False
 814
 815 getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
 816 getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
 817 getClassPredTys_maybe _                 = Nothing
 818
 819 getClassPredTys :: PredType -> (Class, [Type])
 820 getClassPredTys (ClassP clas tys) = (clas, tys)
 821 getClassPredTys other = panic "getClassPredTys"
 822
 823 mkDictTy :: Class -> [Type] -> Type
 824 mkDictTy clas tys = mkPredTy (ClassP clas tys)
 825
 826 isDictTy :: Type -> Bool
 827 isDictTy ty | Just ty' <- tcView ty = isDictTy ty'
 828 isDictTy (PredTy p) = isClassPred p
 829 isDictTy other      = False
 830 \end{code}
 831
 832 --------------------- Implicit parameters ---------------------------------
 833
 834 \begin{code}
 835 isIPPred :: PredType -> Bool
 836 isIPPred (IParam _ _) = True
 837 isIPPred other        = False
 838
 839 isInheritablePred :: PredType -> Bool
 840 -- Can be inherited by a context.  For example, consider
 841 --      f x = let g y = (?v, y+x)
 842 --            in (g 3 with ?v = 8,
 843 --                g 4 with ?v = 9)
 844 -- The point is that g's type must be quantifed over ?v:
 845 --      g :: (?v :: a) => a -> a
 846 -- but it doesn't need to be quantified over the Num a dictionary
 847 -- which can be free in g's rhs, and shared by both calls to g
 848 isInheritablePred (ClassP _ _) = True
 849 isInheritablePred other      = False
 850
 851 isLinearPred :: TcPredType -> Bool
 852 isLinearPred (IParam (Linear n) _) = True
 853 isLinearPred other                 = False
 854 \end{code}
 855
 856 --------------------- The stupid theta (sigh) ---------------------------------
 857
 858 \begin{code}
 859 dataConsStupidTheta :: [DataCon] -> ThetaType
 860 -- Union the stupid thetas from all the specified constructors (non-empty)
 861 -- All the constructors should have the same result type, modulo alpha conversion
 862 -- The resulting ThetaType uses type variables from the *first* constructor in the list
 863 --
 864 -- It's here because it's used in MkId.mkRecordSelId, and in TcExpr
 865 dataConsStupidTheta (con1:cons)
 866   = nubBy tcEqPred all_preds
 867   where
 868     all_preds     = dataConStupidTheta con1 ++ other_stupids
 869     res_tys1      = dataConResTys con1
 870     tvs1          = tyVarsOfTypes res_tys1
 871     other_stupids = [ substPred subst pred
 872                     | con <- cons
 873                     , let Just subst = tcMatchTys tvs1 res_tys1 (dataConResTys con)
 874                     , pred <- dataConStupidTheta con ]
 875 dataConsStupidTheta [] = panic "dataConsStupidTheta"
 876 \end{code}
 877
 878
 879 %************************************************************************
 880 %*                                                                      *
 881 \subsection{Predicates}
 882 %*                                                                      *
 883 %************************************************************************
 884
 885 isSigmaTy returns true of any qualified type.  It doesn't *necessarily* have
 886 any foralls.  E.g.
 887         f :: (?x::Int) => Int -> Int
 888
 889 \begin{code}
 890 isSigmaTy :: Type -> Bool
 891 isSigmaTy ty | Just ty' <- tcView ty = isSigmaTy ty'
 892 isSigmaTy (ForAllTy tyvar ty) = True
 893 isSigmaTy (FunTy a b)         = isPredTy a
 894 isSigmaTy _                   = False
 895
 896 isOverloadedTy :: Type -> Bool
 897 isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty'
 898 isOverloadedTy (ForAllTy tyvar ty) = isOverloadedTy ty
 899 isOverloadedTy (FunTy a b)         = isPredTy a
 900 isOverloadedTy _                   = False
 901
 902 isPredTy :: Type -> Bool        -- Belongs in TcType because it does
 903                                 -- not look through newtypes, or predtypes (of course)
 904 isPredTy ty | Just ty' <- tcView ty = isPredTy ty'
 905 isPredTy (PredTy sty)  = True
 906 isPredTy _             = False
 907 \end{code}
 908
 909 \begin{code}
 910 isFloatTy      = is_tc floatTyConKey
 911 isDoubleTy     = is_tc doubleTyConKey
 912 isIntegerTy    = is_tc integerTyConKey
 913 isIntTy        = is_tc intTyConKey
 914 isBoolTy       = is_tc boolTyConKey
 915 isUnitTy       = is_tc unitTyConKey
 916
 917 is_tc :: Unique -> Type -> Bool
 918 -- Newtypes are opaque to this
 919 is_tc uniq ty = case tcSplitTyConApp_maybe ty of
 920                         Just (tc, _) -> uniq == getUnique tc
 921                         Nothing      -> False
 922 \end{code}
 923
 924
 925 %************************************************************************
 926 %*                                                                      *
 927 \subsection{Misc}
 928 %*                                                                      *
 929 %************************************************************************
 930
 931 \begin{code}
 932 deNoteType :: Type -> Type
 933 -- Remove all *outermost* type synonyms and other notes
 934 deNoteType ty | Just ty' <- tcView ty = deNoteType ty'
 935 deNoteType ty = ty
 936 \end{code}
 937
 938 \begin{code}
 939 tcTyVarsOfType :: Type -> TcTyVarSet
 940 -- Just the tc type variables free in the type
 941 tcTyVarsOfType (TyVarTy tv)         = if isTcTyVar tv then unitVarSet tv
 942                                                       else emptyVarSet
 943 tcTyVarsOfType (TyConApp tycon tys) = tcTyVarsOfTypes tys
 944 tcTyVarsOfType (NoteTy _ ty)        = tcTyVarsOfType ty
 945 tcTyVarsOfType (PredTy sty)         = tcTyVarsOfPred sty
 946 tcTyVarsOfType (FunTy arg res)      = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res
 947 tcTyVarsOfType (AppTy fun arg)      = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg
 948 tcTyVarsOfType (ForAllTy tyvar ty)  = tcTyVarsOfType ty `delVarSet` tyvar
 949         -- We do sometimes quantify over skolem TcTyVars
 950
 951 tcTyVarsOfTypes :: [Type] -> TyVarSet
 952 tcTyVarsOfTypes tys = foldr (unionVarSet.tcTyVarsOfType) emptyVarSet tys
 953
 954 tcTyVarsOfPred :: PredType -> TyVarSet
 955 tcTyVarsOfPred (IParam _ ty)  = tcTyVarsOfType ty
 956 tcTyVarsOfPred (ClassP _ tys) = tcTyVarsOfTypes tys
 957 \end{code}
 958
 959 Note [Silly type synonym]
 960 ~~~~~~~~~~~~~~~~~~~~~~~~~
 961 Consider
 962         type T a = Int
 963 What are the free tyvars of (T x)?  Empty, of course!
 964 Here's the example that Ralf Laemmel showed me:
 965         foo :: (forall a. C u a -> C u a) -> u
 966         mappend :: Monoid u => u -> u -> u
 967
 968         bar :: Monoid u => u
 969         bar = foo (\t -> t `mappend` t)
 970 We have to generalise at the arg to f, and we don't
 971 want to capture the constraint (Monad (C u a)) because
 972 it appears to mention a.  Pretty silly, but it was useful to him.
 973
 974 exactTyVarsOfType is used by the type checker to figure out exactly
 975 which type variables are mentioned in a type.  It's also used in the
 976 smart-app checking code --- see TcExpr.tcIdApp
 977
 978 \begin{code}
 979 exactTyVarsOfType :: TcType -> TyVarSet
 980 -- Find the free type variables (of any kind)
 981 -- but *expand* type synonyms.  See Note [Silly type synonym] above.
 982 exactTyVarsOfType ty
 983   = go ty
 984   where
 985     go ty | Just ty' <- tcView ty = go ty'      -- This is the key line
 986     go (TyVarTy tv)               = unitVarSet tv
 987     go (TyConApp tycon tys)       = exactTyVarsOfTypes tys
 988     go (PredTy ty)                = go_pred ty
 989     go (FunTy arg res)            = go arg `unionVarSet` go res
 990     go (AppTy fun arg)            = go fun `unionVarSet` go arg
 991     go (ForAllTy tyvar ty)        = delVarSet (go ty) tyvar
 992
 993     go_pred (IParam _ ty)  = go ty
 994     go_pred (ClassP _ tys) = exactTyVarsOfTypes tys
 995
 996 exactTyVarsOfTypes :: [TcType] -> TyVarSet
 997 exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys
 998 \end{code}
 999
1000 Find the free tycons and classes of a type.  This is used in the front
1001 end of the compiler.
1002
1003 \begin{code}
1004 tyClsNamesOfType :: Type -> NameSet
1005 tyClsNamesOfType (TyVarTy tv)               = emptyNameSet
1006 tyClsNamesOfType (TyConApp tycon tys)       = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
1007 tyClsNamesOfType (NoteTy _ ty2)             = tyClsNamesOfType ty2
1008 tyClsNamesOfType (PredTy (IParam n ty))     = tyClsNamesOfType ty
1009 tyClsNamesOfType (PredTy (ClassP cl tys))   = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
1010 tyClsNamesOfType (FunTy arg res)            = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res
1011 tyClsNamesOfType (AppTy fun arg)            = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg
1012 tyClsNamesOfType (ForAllTy tyvar ty)        = tyClsNamesOfType ty
1013
1014 tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys
1015
1016 tyClsNamesOfDFunHead :: Type -> NameSet
1017 -- Find the free type constructors and classes
1018 -- of the head of the dfun instance type
1019 -- The 'dfun_head_type' is because of
1020 --      instance Foo a => Baz T where ...
1021 -- The decl is an orphan if Baz and T are both not locally defined,
1022 --      even if Foo *is* locally defined
1023 tyClsNamesOfDFunHead dfun_ty
1024   = case tcSplitSigmaTy dfun_ty of
1025         (tvs,_,head_ty) -> tyClsNamesOfType head_ty
1026
1027 classesOfTheta :: ThetaType -> [Class]
1028 -- Looks just for ClassP things; maybe it should check
1029 classesOfTheta preds = [ c | ClassP c _ <- preds ]
1030 \end{code}
1031
1032
1033 %************************************************************************
1034 %*                                                                      *
1035 \subsection[TysWiredIn-ext-type]{External types}
1036 %*                                                                      *
1037 %************************************************************************
1038
1039 The compiler's foreign function interface supports the passing of a
1040 restricted set of types as arguments and results (the restricting factor
1041 being the )
1042
1043 \begin{code}
1044 tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type)
1045 -- (isIOType t) returns (Just (IO,t')) if t is of the form (IO t'), or
1046 --                                     some newtype wrapping thereof
1047 --              returns Nothing otherwise
1048 tcSplitIOType_maybe ty
1049   | Just (io_tycon, [io_res_ty]) <- tcSplitTyConApp_maybe ty,
1050         -- This split absolutely has to be a tcSplit, because we must
1051         -- see the IO type; and it's a newtype which is transparent to splitTyConApp.
1052     io_tycon `hasKey` ioTyConKey
1053   = Just (io_tycon, io_res_ty)
1054
1055   | Just ty' <- coreView ty     -- Look through non-recursive newtypes
1056   = tcSplitIOType_maybe ty'
1057
1058   | otherwise
1059   = Nothing
1060
1061 isFFITy :: Type -> Bool
1062 -- True for any TyCon that can possibly be an arg or result of an FFI call
1063 isFFITy ty = checkRepTyCon legalFFITyCon ty
1064
1065 isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
1066 -- Checks for valid argument type for a 'foreign import'
1067 isFFIArgumentTy dflags safety ty
1068    = checkRepTyCon (legalOutgoingTyCon dflags safety) ty
1069
1070 isFFIExternalTy :: Type -> Bool
1071 -- Types that are allowed as arguments of a 'foreign export'
1072 isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty
1073
1074 isFFIImportResultTy :: DynFlags -> Type -> Bool
1075 isFFIImportResultTy dflags ty
1076   = checkRepTyCon (legalFIResultTyCon dflags) ty
1077
1078 isFFIExportResultTy :: Type -> Bool
1079 isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
1080
1081 isFFIDynArgumentTy :: Type -> Bool
1082 -- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr,
1083 -- or a newtype of either.
1084 isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
1085
1086 isFFIDynResultTy :: Type -> Bool
1087 -- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr,
1088 -- or a newtype of either.
1089 isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
1090
1091 isFFILabelTy :: Type -> Bool
1092 -- The type of a foreign label must be Ptr, FunPtr, Addr,
1093 -- or a newtype of either.
1094 isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
1095
1096 isFFIDotnetTy :: DynFlags -> Type -> Bool
1097 isFFIDotnetTy dflags ty
1098   = checkRepTyCon (\ tc -> (legalFIResultTyCon dflags tc ||
1099                            isFFIDotnetObjTy ty || isStringTy ty)) ty
1100
1101 -- Support String as an argument or result from a .NET FFI call.
1102 isStringTy ty =
1103   case tcSplitTyConApp_maybe (repType ty) of
1104     Just (tc, [arg_ty])
1105       | tc == listTyCon ->
1106         case tcSplitTyConApp_maybe (repType arg_ty) of
1107           Just (cc,[]) -> cc == charTyCon
1108           _ -> False
1109     _ -> False
1110
1111 -- Support String as an argument or result from a .NET FFI call.
1112 isFFIDotnetObjTy ty =
1113   let
1114    (_, t_ty) = tcSplitForAllTys ty
1115   in
1116   case tcSplitTyConApp_maybe (repType t_ty) of
1117     Just (tc, [arg_ty]) | getName tc == objectTyConName -> True
1118     _ -> False
1119
1120 toDNType :: Type -> DNType
1121 toDNType ty
1122   | isStringTy ty = DNString
1123   | isFFIDotnetObjTy ty = DNObject
1124   | Just (tc,argTys) <- tcSplitTyConApp_maybe ty
1125   =  case lookup (getUnique tc) dn_assoc of
1126        Just x  -> x
1127        Nothing
1128          | tc `hasKey` ioTyConKey -> toDNType (head argTys)
1129          | otherwise -> pprPanic ("toDNType: unsupported .NET type")
1130                           (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc)
1131   | otherwise = panic "toDNType"        -- Is this right?
1132     where
1133       dn_assoc :: [ (Unique, DNType) ]
1134       dn_assoc = [ (unitTyConKey,   DNUnit)
1135                  , (intTyConKey,    DNInt)
1136                  , (int8TyConKey,   DNInt8)
1137                  , (int16TyConKey,  DNInt16)
1138                  , (int32TyConKey,  DNInt32)
1139                  , (int64TyConKey,  DNInt64)
1140                  , (wordTyConKey,   DNInt)
1141                  , (word8TyConKey,  DNWord8)
1142                  , (word16TyConKey, DNWord16)
1143                  , (word32TyConKey, DNWord32)
1144                  , (word64TyConKey, DNWord64)
1145                  , (floatTyConKey,  DNFloat)
1146                  , (doubleTyConKey, DNDouble)
1147                  , (ptrTyConKey,    DNPtr)
1148                  , (funPtrTyConKey, DNPtr)
1149                  , (charTyConKey,   DNChar)
1150                  , (boolTyConKey,   DNBool)
1151                  ]
1152
1153 checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
1154         -- Look through newtypes
1155         -- Non-recursive ones are transparent to splitTyConApp,
1156         -- but recursive ones aren't.  Manuel had:
1157         --      newtype T = MkT (Ptr T)
1158         -- and wanted it to work...
1159 checkRepTyCon check_tc ty
1160   | Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc
1161   | otherwise                                       = False
1162
1163 checkRepTyConKey :: [Unique] -> Type -> Bool
1164 -- Like checkRepTyCon, but just looks at the TyCon key
1165 checkRepTyConKey keys
1166   = checkRepTyCon (\tc -> tyConUnique tc `elem` keys)
1167 \end{code}
1168
1169 ----------------------------------------------
1170 These chaps do the work; they are not exported
1171 ----------------------------------------------
1172
1173 \begin{code}
1174 legalFEArgTyCon :: TyCon -> Bool
1175 legalFEArgTyCon tc
1176   -- It's illegal to make foreign exports that take unboxed
1177   -- arguments.  The RTS API currently can't invoke such things.  --SDM 7/2000
1178   = boxedMarshalableTyCon tc
1179
1180 legalFIResultTyCon :: DynFlags -> TyCon -> Bool
1181 legalFIResultTyCon dflags tc
1182   | tc == unitTyCon         = True
1183   | otherwise               = marshalableTyCon dflags tc
1184
1185 legalFEResultTyCon :: TyCon -> Bool
1186 legalFEResultTyCon tc
1187   | tc == unitTyCon         = True
1188   | otherwise               = boxedMarshalableTyCon tc
1189
1190 legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
1191 -- Checks validity of types going from Haskell -> external world
1192 legalOutgoingTyCon dflags safety tc
1193   = marshalableTyCon dflags tc
1194
1195 legalFFITyCon :: TyCon -> Bool
1196 -- True for any TyCon that can possibly be an arg or result of an FFI call
1197 legalFFITyCon tc
1198   = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon
1199
1200 marshalableTyCon dflags tc
1201   =  (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
1202   || boxedMarshalableTyCon tc
1203
1204 boxedMarshalableTyCon tc
1205    = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
1206                          , int32TyConKey, int64TyConKey
1207                          , wordTyConKey, word8TyConKey, word16TyConKey
1208                          , word32TyConKey, word64TyConKey
1209                          , floatTyConKey, doubleTyConKey
1210                          , ptrTyConKey, funPtrTyConKey
1211                          , charTyConKey
1212                          , stablePtrTyConKey
1213                          , boolTyConKey
1214                          ]
1215 \end{code}