compiler/typecheck/TcType.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5 \section[TcType]{Types used in the typechecker}
   6
   7 This module provides the Type interface for front-end parts of the
   8 compiler.  These parts
   9
  10         * treat "source types" as opaque:
  11                 newtypes, and predicates are meaningful.
  12         * look through usage types
  13
  14 The "tc" prefix is for "TypeChecker", because the type checker
  15 is the principal client.
  16
  17 \begin{code}
  18 module TcType (
  19   --------------------------------
  20   -- Types
  21   TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
  22   TcCoercion, TcTyVar, TcTyVarSet, TcKind, TcCoVar,
  23
  24   --------------------------------
  25   -- MetaDetails
  26   UserTypeCtxt(..), pprUserTypeCtxt,
  27   TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv,
  28   MetaDetails(Flexi, Indirect), MetaInfo(..),
  29   isImmutableTyVar, isSkolemTyVar, isMetaTyVar,  isMetaTyVarTy,
  30   isSigTyVar, isOverlappableTyVar,  isTyConableTyVar,
  31   metaTvRef,
  32   isFlexi, isIndirect, isRuntimeUnkSkol,
  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, tcSplitPredFunTy_maybe,
  43   tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcSplitFunTysN,
  44   tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
  45   tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, repSplitAppTy_maybe,
  46   tcInstHeadTyNotSynonym, tcInstHeadTyAppAllTyVars,
  47   tcGetTyVar_maybe, tcGetTyVar,
  48   tcSplitSigmaTy, tcDeepSplitSigmaTy_maybe,
  49
  50   ---------------------------------
  51   -- Predicates.
  52   -- Again, newtypes are opaque
  53   eqType, eqTypes, eqPred, cmpType, cmpTypes, cmpPred, eqTypeX,
  54   eqKind,
  55   isSigmaTy, isOverloadedTy,
  56   isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,
  57   isIntegerTy, isBoolTy, isUnitTy, isCharTy,
  58   isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,
  59   isSynFamilyTyConApp,
  60
  61   ---------------------------------
  62   -- Misc type manipulators
  63   deNoteType,
  64   orphNamesOfType, orphNamesOfDFunHead, orphNamesOfCo,
  65   getDFunTyKey,
  66
  67   ---------------------------------
  68   -- Predicate types
  69   mkMinimalBySCs, transSuperClasses, immSuperClasses,
  70
  71   -- * Tidying type related things up for printing
  72   tidyType,      tidyTypes,
  73   tidyOpenType,  tidyOpenTypes,
  74   tidyTyVarBndr, tidyFreeTyVars,
  75   tidyOpenTyVar, tidyOpenTyVars,
  76   tidyTopType,   tidyPred,
  77   tidyKind,
  78   tidyCo, tidyCos,
  79
  80   ---------------------------------
  81   -- Foreign import and export
  82   isFFIArgumentTy,     -- :: DynFlags -> Safety -> Type -> Bool
  83   isFFIImportResultTy, -- :: DynFlags -> Type -> Bool
  84   isFFIExportResultTy, -- :: Type -> Bool
  85   isFFIExternalTy,     -- :: Type -> Bool
  86   isFFIDynArgumentTy,  -- :: Type -> Bool
  87   isFFIDynResultTy,    -- :: Type -> Bool
  88   isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool
  89   isFFIPrimResultTy,   -- :: DynFlags -> Type -> Bool
  90   isFFILabelTy,        -- :: Type -> Bool
  91   isFFIDotnetTy,       -- :: DynFlags -> Type -> Bool
  92   isFFIDotnetObjTy,    -- :: Type -> Bool
  93   isFFITy,             -- :: Type -> Bool
  94   isFunPtrTy,          -- :: Type -> Bool
  95   tcSplitIOType_maybe, -- :: Type -> Maybe Type
  96
  97   --------------------------------
  98   -- Rexported from Kind
  99   Kind, typeKind,
 100   unliftedTypeKind, liftedTypeKind, argTypeKind,
 101   openTypeKind, mkArrowKind, mkArrowKinds,
 102   isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind,
 103   isSubArgTypeKind, isSubKind, splitKindFunTys, defaultKind,
 104   kindVarRef, mkKindVar,
 105
 106   --------------------------------
 107   -- Rexported from Type
 108   Type, Pred(..), PredType, ThetaType,
 109   mkForAllTy, mkForAllTys,
 110   mkFunTy, mkFunTys, zipFunTys,
 111   mkTyConApp, mkAppTy, mkAppTys, applyTy, applyTys,
 112   mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
 113
 114   getClassPredTys_maybe, getClassPredTys,
 115   isClassPred, isTyVarClassPred, isEqPred,
 116   mkClassPred, mkIPPred, splitPredTy_maybe,
 117   mkDictTy, isPredTy, isDictTy, isDictLikeTy,
 118   tcSplitDFunTy, tcSplitDFunHead,
 119   isIPPred, mkEqPred,
 120
 121   -- Type substitutions
 122   TvSubst(..),  -- Representation visible to a few friends
 123   TvSubstEnv, emptyTvSubst,
 124   mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst,
 125   mkTopTvSubst, notElemTvSubst, unionTvSubst,
 126   getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
 127   Type.lookupTyVar, Type.extendTvSubst, Type.substTyVarBndr,
 128   extendTvSubstList, isInScope, mkTvSubst, zipTyEnv,
 129   Type.substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars,
 130
 131   isUnLiftedType,       -- Source types are always lifted
 132   isUnboxedTupleType,   -- Ditto
 133   isPrimitiveType,
 134
 135   tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
 136   tcTyVarsOfType, tcTyVarsOfTypes, tcTyVarsOfPred, exactTyVarsOfType,
 137   exactTyVarsOfTypes,
 138
 139   pprKind, pprParendKind,
 140   pprType, pprParendType, pprTypeApp, pprTyThingCategory,
 141   pprPred, pprTheta, pprThetaArrow, pprThetaArrowTy, pprClassPred
 142
 143   ) where
 144
 145 #include "HsVersions.h"
 146
 147 -- friends:
 148 import Kind
 149 import TypeRep
 150 import Class
 151 import Var
 152 import ForeignCall
 153 import VarSet
 154 import Type
 155 import Coercion
 156 import TyCon
 157
 158 -- others:
 159 import DynFlags
 160 import Name hiding (varName)
 161 import NameSet
 162 import VarEnv
 163 import PrelNames
 164 import TysWiredIn
 165 import BasicTypes
 166 import Util
 167 import Maybes
 168 import ListSetOps
 169 import Outputable
 170 import FastString
 171
 172 import qualified Data.Foldable as Foldable
 173 import Data.Functor( (<$>) )
 174 import Data.List( mapAccumL )
 175 import Data.IORef
 176 \end{code}
 177
 178 %************************************************************************
 179 %*                                                                      *
 180 \subsection{Types}
 181 %*                                                                      *
 182 %************************************************************************
 183
 184 The type checker divides the generic Type world into the
 185 following more structured beasts:
 186
 187 sigma ::= forall tyvars. phi
 188         -- A sigma type is a qualified type
 189         --
 190         -- Note that even if 'tyvars' is empty, theta
 191         -- may not be: e.g.   (?x::Int) => Int
 192
 193         -- Note that 'sigma' is in prenex form:
 194         -- all the foralls are at the front.
 195         -- A 'phi' type has no foralls to the right of
 196         -- an arrow
 197
 198 phi :: theta => rho
 199
 200 rho ::= sigma -> rho
 201      |  tau
 202
 203 -- A 'tau' type has no quantification anywhere
 204 -- Note that the args of a type constructor must be taus
 205 tau ::= tyvar
 206      |  tycon tau_1 .. tau_n
 207      |  tau_1 tau_2
 208      |  tau_1 -> tau_2
 209
 210 -- In all cases, a (saturated) type synonym application is legal,
 211 -- provided it expands to the required form.
 212
 213 \begin{code}
 214 type TcTyVar = TyVar    -- Used only during type inference
 215 type TcCoVar = CoVar    -- Used only during type inference; mutable
 216 type TcType = Type      -- A TcType can have mutable type variables
 217         -- Invariant on ForAllTy in TcTypes:
 218         --      forall a. T
 219         -- a cannot occur inside a MutTyVar in T; that is,
 220         -- T is "flattened" before quantifying over a
 221
 222 type TcCoercion = Coercion  -- A TcCoercion can contain TcTypes.
 223
 224 -- These types do not have boxy type variables in them
 225 type TcPredType     = PredType
 226 type TcThetaType    = ThetaType
 227 type TcSigmaType    = TcType
 228 type TcRhoType      = TcType
 229 type TcTauType      = TcType
 230 type TcKind         = Kind
 231 type TcTyVarSet     = TyVarSet
 232 \end{code}
 233
 234
 235 %************************************************************************
 236 %*                                                                      *
 237 \subsection{TyVarDetails}
 238 %*                                                                      *
 239 %************************************************************************
 240
 241 TyVarDetails gives extra info about type variables, used during type
 242 checking.  It's attached to mutable type variables only.
 243 It's knot-tied back to Var.lhs.  There is no reason in principle
 244 why Var.lhs shouldn't actually have the definition, but it "belongs" here.
 245
 246
 247 Note [Signature skolems]
 248 ~~~~~~~~~~~~~~~~~~~~~~~~
 249 Consider this
 250
 251   x :: [a]
 252   y :: b
 253   (x,y,z) = ([y,z], z, head x)
 254
 255 Here, x and y have type sigs, which go into the environment.  We used to
 256 instantiate their types with skolem constants, and push those types into
 257 the RHS, so we'd typecheck the RHS with type
 258         ( [a*], b*, c )
 259 where a*, b* are skolem constants, and c is an ordinary meta type varible.
 260
 261 The trouble is that the occurrences of z in the RHS force a* and b* to
 262 be the *same*, so we can't make them into skolem constants that don't unify
 263 with each other.  Alas.
 264
 265 One solution would be insist that in the above defn the programmer uses
 266 the same type variable in both type signatures.  But that takes explanation.
 267
 268 The alternative (currently implemented) is to have a special kind of skolem
 269 constant, SigTv, which can unify with other SigTvs.  These are *not* treated
 270 as rigid for the purposes of GADTs.  And they are used *only* for pattern
 271 bindings and mutually recursive function bindings.  See the function
 272 TcBinds.tcInstSig, and its use_skols parameter.
 273
 274
 275 \begin{code}
 276 -- A TyVarDetails is inside a TyVar
 277 data TcTyVarDetails
 278   = SkolemTv      -- A skolem
 279        Bool       -- True <=> this skolem type variable can be overlapped
 280                   --          when looking up instances
 281                   -- See Note [Binding when looking up instances] in InstEnv
 282
 283   | RuntimeUnk    -- Stands for an as-yet-unknown type in the GHCi
 284                   -- interactive context
 285
 286   | FlatSkol TcType
 287            -- The "skolem" obtained by flattening during
 288            -- constraint simplification
 289
 290            -- In comments we will use the notation alpha[flat = ty]
 291            -- to represent a flattening skolem variable alpha
 292            -- identified with type ty.
 293
 294   | MetaTv MetaInfo (IORef MetaDetails)
 295
 296 vanillaSkolemTv, superSkolemTv :: TcTyVarDetails
 297 -- See Note [Binding when looking up instances] in InstEnv
 298 vanillaSkolemTv = SkolemTv False  -- Might be instantiated
 299 superSkolemTv   = SkolemTv True   -- Treat this as a completely distinct type
 300
 301 data MetaDetails
 302   = Flexi  -- Flexi type variables unify to become Indirects
 303   | Indirect TcType
 304
 305 instance Outputable MetaDetails where
 306   ppr Flexi         = ptext (sLit "Flexi")
 307   ppr (Indirect ty) = ptext (sLit "Indirect") <+> ppr ty
 308
 309 data MetaInfo
 310    = TauTv         -- This MetaTv is an ordinary unification variable
 311                    -- A TauTv is always filled in with a tau-type, which
 312                    -- never contains any ForAlls
 313
 314    | SigTv         -- A variant of TauTv, except that it should not be
 315                    -- unified with a type, only with a type variable
 316                    -- SigTvs are only distinguished to improve error messages
 317                    --      see Note [Signature skolems]
 318                    --      The MetaDetails, if filled in, will
 319                    --      always be another SigTv or a SkolemTv
 320
 321    | TcsTv         -- A MetaTv allocated by the constraint solver
 322                    -- Its particular property is that it is always "touchable"
 323                    -- Nevertheless, the constraint solver has to try to guess
 324                    -- what type to instantiate it to
 325
 326 -------------------------------------
 327 -- UserTypeCtxt describes the origin of the polymorphic type
 328 -- in the places where we need to an expression has that type
 329
 330 data UserTypeCtxt
 331   = FunSigCtxt Name     -- Function type signature
 332                         -- Also used for types in SPECIALISE pragmas
 333   | ExprSigCtxt         -- Expression type signature
 334   | ConArgCtxt Name     -- Data constructor argument
 335   | TySynCtxt Name      -- RHS of a type synonym decl
 336   | GenPatCtxt          -- Pattern in generic decl
 337                         --      f{| a+b |} (Inl x) = ...
 338   | LamPatSigCtxt               -- Type sig in lambda pattern
 339                         --      f (x::t) = ...
 340   | BindPatSigCtxt      -- Type sig in pattern binding pattern
 341                         --      (x::t, y) = e
 342   | ResSigCtxt          -- Result type sig
 343                         --      f x :: t = ....
 344   | ForSigCtxt Name     -- Foreign inport or export signature
 345   | DefaultDeclCtxt     -- Types in a default declaration
 346   | SpecInstCtxt        -- SPECIALISE instance pragma
 347   | ThBrackCtxt         -- Template Haskell type brackets [t| ... |]
 348
 349   | GenSigCtxt          -- Higher-rank or impredicative situations
 350                         -- e.g. (f e) where f has a higher-rank type
 351                         -- We might want to elaborate this
 352
 353 -- Notes re TySynCtxt
 354 -- We allow type synonyms that aren't types; e.g.  type List = []
 355 --
 356 -- If the RHS mentions tyvars that aren't in scope, we'll
 357 -- quantify over them:
 358 --      e.g.    type T = a->a
 359 -- will become  type T = forall a. a->a
 360 --
 361 -- With gla-exts that's right, but for H98 we should complain.
 362
 363 ---------------------------------
 364 -- Kind variables:
 365
 366 mkKindName :: Unique -> Name
 367 mkKindName unique = mkSystemName unique kind_var_occ
 368
 369 kindVarRef :: KindVar -> IORef MetaDetails
 370 kindVarRef tc =
 371   ASSERT ( isTcTyVar tc )
 372   case tcTyVarDetails tc of
 373     MetaTv TauTv ref -> ref
 374     _                -> pprPanic "kindVarRef" (ppr tc)
 375
 376 mkKindVar :: Unique -> IORef MetaDetails -> KindVar
 377 mkKindVar u r
 378   = mkTcTyVar (mkKindName u)
 379               tySuperKind  -- not sure this is right,
 380                             -- do we need kind vars for
 381                             -- coercions?
 382               (MetaTv TauTv r)
 383
 384 kind_var_occ :: OccName -- Just one for all KindVars
 385                         -- They may be jiggled by tidying
 386 kind_var_occ = mkOccName tvName "k"
 387 \end{code}
 388
 389 %************************************************************************
 390 %*                                                                      *
 391                 Pretty-printing
 392 %*                                                                      *
 393 %************************************************************************
 394
 395 \begin{code}
 396 pprTcTyVarDetails :: TcTyVarDetails -> SDoc
 397 -- For debugging
 398 pprTcTyVarDetails (SkolemTv {})     = ptext (sLit "sk")
 399 pprTcTyVarDetails (RuntimeUnk {})  = ptext (sLit "rt")
 400 pprTcTyVarDetails (FlatSkol {})    = ptext (sLit "fsk")
 401 pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau")
 402 pprTcTyVarDetails (MetaTv TcsTv _) = ptext (sLit "tcs")
 403 pprTcTyVarDetails (MetaTv SigTv _) = ptext (sLit "sig")
 404
 405 pprUserTypeCtxt :: UserTypeCtxt -> SDoc
 406 pprUserTypeCtxt (FunSigCtxt n)  = ptext (sLit "the type signature for") <+> quotes (ppr n)
 407 pprUserTypeCtxt ExprSigCtxt     = ptext (sLit "an expression type signature")
 408 pprUserTypeCtxt (ConArgCtxt c)  = ptext (sLit "the type of the constructor") <+> quotes (ppr c)
 409 pprUserTypeCtxt (TySynCtxt c)   = ptext (sLit "the RHS of the type synonym") <+> quotes (ppr c)
 410 pprUserTypeCtxt GenPatCtxt      = ptext (sLit "the type pattern of a generic definition")
 411 pprUserTypeCtxt ThBrackCtxt     = ptext (sLit "a Template Haskell quotation [t|...|]")
 412 pprUserTypeCtxt LamPatSigCtxt   = ptext (sLit "a pattern type signature")
 413 pprUserTypeCtxt BindPatSigCtxt  = ptext (sLit "a pattern type signature")
 414 pprUserTypeCtxt ResSigCtxt      = ptext (sLit "a result type signature")
 415 pprUserTypeCtxt (ForSigCtxt n)  = ptext (sLit "the foreign declaration for") <+> quotes (ppr n)
 416 pprUserTypeCtxt DefaultDeclCtxt = ptext (sLit "a type in a `default' declaration")
 417 pprUserTypeCtxt SpecInstCtxt    = ptext (sLit "a SPECIALISE instance pragma")
 418 pprUserTypeCtxt GenSigCtxt      = ptext (sLit "a type expected by the context")
 419 \end{code}
 420
 421
 422 %************************************************************************
 423 %*                                                                      *
 424 \subsection{TidyType}
 425 %*                                                                      *
 426 %************************************************************************
 427
 428 \begin{code}
 429 -- | This tidies up a type for printing in an error message, or in
 430 -- an interface file.
 431 --
 432 -- It doesn't change the uniques at all, just the print names.
 433 tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
 434 tidyTyVarBndr (tidy_env, subst) tyvar
 435   = case tidyOccName tidy_env occ1 of
 436       (tidy', occ') -> ((tidy', subst'), tyvar')
 437         where
 438           subst' = extendVarEnv subst tyvar tyvar'
 439           tyvar' = setTyVarName tyvar name'
 440           name'  = tidyNameOcc name occ'
 441   where
 442     name = tyVarName tyvar
 443     occ  = getOccName name
 444     -- System Names are for unification variables;
 445     -- when we tidy them we give them a trailing "0" (or 1 etc)
 446     -- so that they don't take precedence for the un-modified name
 447     occ1 | isSystemName name = mkTyVarOcc (occNameString occ ++ "0")
 448          | otherwise         = occ
 449
 450
 451 ---------------
 452 tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
 453 -- ^ Add the free 'TyVar's to the env in tidy form,
 454 -- so that we can tidy the type they are free in
 455 tidyFreeTyVars env tyvars = fst (tidyOpenTyVars env (varSetElems tyvars))
 456
 457 ---------------
 458 tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
 459 tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars
 460
 461 ---------------
 462 tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
 463 -- ^ Treat a new 'TyVar' as a binder, and give it a fresh tidy name
 464 -- using the environment if one has not already been allocated. See
 465 -- also 'tidyTyVarBndr'
 466 tidyOpenTyVar env@(_, subst) tyvar
 467   = case lookupVarEnv subst tyvar of
 468         Just tyvar' -> (env, tyvar')            -- Already substituted
 469         Nothing     -> tidyTyVarBndr env tyvar  -- Treat it as a binder
 470
 471 ---------------
 472 tidyType :: TidyEnv -> Type -> Type
 473 tidyType env@(_, subst) ty
 474   = go ty
 475   where
 476     go (TyVarTy tv)         = case lookupVarEnv subst tv of
 477                                 Nothing  -> expand tv
 478                                 Just tv' -> expand tv'
 479     go (TyConApp tycon tys) = let args = map go tys
 480                               in args `seqList` TyConApp tycon args
 481     go (PredTy sty)         = PredTy (tidyPred env sty)
 482     go (AppTy fun arg)      = (AppTy $! (go fun)) $! (go arg)
 483     go (FunTy fun arg)      = (FunTy $! (go fun)) $! (go arg)
 484     go (ForAllTy tv ty)     = ForAllTy tvp $! (tidyType envp ty)
 485                               where
 486                                 (envp, tvp) = tidyTyVarBndr env tv
 487
 488     -- Expand FlatSkols, the skolems introduced by flattening process
 489     -- We don't want to show them in type error messages
 490     expand tv | isTcTyVar tv
 491               , FlatSkol ty <- tcTyVarDetails tv
 492               = go ty
 493               | otherwise
 494               = TyVarTy tv
 495
 496 ---------------
 497 tidyTypes :: TidyEnv -> [Type] -> [Type]
 498 tidyTypes env tys = map (tidyType env) tys
 499
 500 ---------------
 501 tidyPred :: TidyEnv -> PredType -> PredType
 502 tidyPred env (IParam n ty)     = IParam n (tidyType env ty)
 503 tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
 504 tidyPred env (EqPred ty1 ty2)  = EqPred (tidyType env ty1) (tidyType env ty2)
 505
 506 ---------------
 507 -- | Grabs the free type variables, tidies them
 508 -- and then uses 'tidyType' to work over the type itself
 509 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
 510 tidyOpenType env ty
 511   = (env', tidyType env' ty)
 512   where
 513     env' = tidyFreeTyVars env (tyVarsOfType ty)
 514
 515 ---------------
 516 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
 517 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
 518
 519 ---------------
 520 -- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment)
 521 tidyTopType :: Type -> Type
 522 tidyTopType ty = tidyType emptyTidyEnv ty
 523
 524 ---------------
 525 tidyKind :: TidyEnv -> Kind -> (TidyEnv, Kind)
 526 tidyKind env k = tidyOpenType env k
 527 \end{code}
 528
 529 %************************************************************************
 530 %*                                                                      *
 531                             Tidying coercions
 532 %*                                                                      *
 533 %************************************************************************
 534
 535 \begin{code}
 536
 537 tidyCo :: TidyEnv -> Coercion -> Coercion
 538 tidyCo env@(_, subst) co
 539   = go co
 540   where
 541     go (Refl ty)             = Refl (tidyType env ty)
 542     go (TyConAppCo tc cos)   = let args = map go cos
 543                                in args `seqList` TyConAppCo tc args
 544     go (AppCo co1 co2)       = (AppCo $! go co1) $! go co2
 545     go (ForAllCo tv co)      = ForAllCo tvp $! (tidyCo envp co)
 546                                where
 547                                  (envp, tvp) = tidyTyVarBndr env tv
 548     go (PredCo pco)          = PredCo $! (go <$> pco)
 549     go (CoVarCo cv)          = case lookupVarEnv subst cv of
 550                                  Nothing  -> CoVarCo cv
 551                                  Just cv' -> CoVarCo cv'
 552     go (AxiomInstCo con cos) = let args = tidyCos env cos
 553                                in  args `seqList` AxiomInstCo con args
 554     go (UnsafeCo ty1 ty2)    = (UnsafeCo $! tidyType env ty1) $! tidyType env ty2
 555     go (SymCo co)            = SymCo $! go co
 556     go (TransCo co1 co2)     = (TransCo $! go co1) $! go co2
 557     go (NthCo d co)          = NthCo d $! go co
 558     go (InstCo co ty)        = (InstCo $! go co) $! tidyType env ty
 559
 560 tidyCos :: TidyEnv -> [Coercion] -> [Coercion]
 561 tidyCos env = map (tidyCo env)
 562
 563 \end{code}
 564
 565 %************************************************************************
 566 %*                                                                      *
 567                 Predicates
 568 %*                                                                      *
 569 %************************************************************************
 570
 571 \begin{code}
 572 isImmutableTyVar :: TyVar -> Bool
 573
 574 isImmutableTyVar tv
 575   | isTcTyVar tv = isSkolemTyVar tv
 576   | otherwise    = True
 577
 578 isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar,
 579   isMetaTyVar :: TcTyVar -> Bool
 580
 581 isTyConableTyVar tv
 582         -- True of a meta-type variable that can be filled in
 583         -- with a type constructor application; in particular,
 584         -- not a SigTv
 585   = ASSERT( isTcTyVar tv)
 586     case tcTyVarDetails tv of
 587         MetaTv SigTv _ -> False
 588         _              -> True
 589
 590 isSkolemTyVar tv
 591   = ASSERT2( isTcTyVar tv, ppr tv )
 592     case tcTyVarDetails tv of
 593         SkolemTv {}   -> True
 594         FlatSkol {}   -> True
 595         RuntimeUnk {} -> True
 596         MetaTv {}     -> False
 597
 598 isOverlappableTyVar tv
 599   = ASSERT( isTcTyVar tv )
 600     case tcTyVarDetails tv of
 601         SkolemTv overlappable -> overlappable
 602         _                     -> False
 603
 604 isMetaTyVar tv
 605   = ASSERT2( isTcTyVar tv, ppr tv )
 606     case tcTyVarDetails tv of
 607         MetaTv _ _ -> True
 608         _          -> False
 609
 610 isMetaTyVarTy :: TcType -> Bool
 611 isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv
 612 isMetaTyVarTy _            = False
 613
 614 isSigTyVar :: Var -> Bool
 615 isSigTyVar tv
 616   = ASSERT( isTcTyVar tv )
 617     case tcTyVarDetails tv of
 618         MetaTv SigTv _ -> True
 619         _              -> False
 620
 621 metaTvRef :: TyVar -> IORef MetaDetails
 622 metaTvRef tv
 623   = ASSERT2( isTcTyVar tv, ppr tv )
 624     case tcTyVarDetails tv of
 625         MetaTv _ ref -> ref
 626         _          -> pprPanic "metaTvRef" (ppr tv)
 627
 628 isFlexi, isIndirect :: MetaDetails -> Bool
 629 isFlexi Flexi = True
 630 isFlexi _     = False
 631
 632 isIndirect (Indirect _) = True
 633 isIndirect _            = False
 634
 635 isRuntimeUnkSkol :: TyVar -> Bool
 636 -- Called only in TcErrors; see Note [Runtime skolems] there
 637 isRuntimeUnkSkol x
 638   | isTcTyVar x, RuntimeUnk <- tcTyVarDetails x = True
 639   | otherwise                                   = False
 640 \end{code}
 641
 642
 643 %************************************************************************
 644 %*                                                                      *
 645 \subsection{Tau, sigma and rho}
 646 %*                                                                      *
 647 %************************************************************************
 648
 649 \begin{code}
 650 mkSigmaTy :: [TyVar] -> [PredType] -> Type -> Type
 651 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau)
 652
 653 mkPhiTy :: [PredType] -> Type -> Type
 654 mkPhiTy theta ty = foldr (\p r -> mkFunTy (mkPredTy p) r) ty theta
 655 \end{code}
 656
 657 @isTauTy@ tests for nested for-alls.  It should not be called on a boxy type.
 658
 659 \begin{code}
 660 isTauTy :: Type -> Bool
 661 isTauTy ty | Just ty' <- tcView ty = isTauTy ty'
 662 isTauTy (TyVarTy _)       = True
 663 isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc
 664 isTauTy (AppTy a b)       = isTauTy a && isTauTy b
 665 isTauTy (FunTy a b)       = isTauTy a && isTauTy b
 666 isTauTy (PredTy _)        = True                -- Don't look through source types
 667 isTauTy _                 = False
 668
 669 isTauTyCon :: TyCon -> Bool
 670 -- Returns False for type synonyms whose expansion is a polytype
 671 isTauTyCon tc
 672   | isClosedSynTyCon tc = isTauTy (snd (synTyConDefn tc))
 673   | otherwise           = True
 674
 675 ---------------
 676 getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
 677                                 -- construct a dictionary function name
 678 getDFunTyKey ty | Just ty' <- tcView ty = getDFunTyKey ty'
 679 getDFunTyKey (TyVarTy tv)    = getOccName tv
 680 getDFunTyKey (TyConApp tc _) = getOccName tc
 681 getDFunTyKey (AppTy fun _)   = getDFunTyKey fun
 682 getDFunTyKey (FunTy _ _)     = getOccName funTyCon
 683 getDFunTyKey (ForAllTy _ t)  = getDFunTyKey t
 684 getDFunTyKey ty              = pprPanic "getDFunTyKey" (pprType ty)
 685 -- PredTy shouldn't happen
 686 \end{code}
 687
 688
 689 %************************************************************************
 690 %*                                                                      *
 691 \subsection{Expanding and splitting}
 692 %*                                                                      *
 693 %************************************************************************
 694
 695 These tcSplit functions are like their non-Tc analogues, but
 696         a) they do not look through newtypes
 697         b) they do not look through PredTys
 698
 699 However, they are non-monadic and do not follow through mutable type
 700 variables.  It's up to you to make sure this doesn't matter.
 701
 702 \begin{code}
 703 tcSplitForAllTys :: Type -> ([TyVar], Type)
 704 tcSplitForAllTys ty = split ty ty []
 705    where
 706      split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
 707      split _ (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
 708      split orig_ty _          tvs = (reverse tvs, orig_ty)
 709
 710 tcIsForAllTy :: Type -> Bool
 711 tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty'
 712 tcIsForAllTy (ForAllTy {}) = True
 713 tcIsForAllTy _             = False
 714
 715 tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type)
 716 -- Split off the first predicate argument from a type
 717 tcSplitPredFunTy_maybe ty | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty'
 718 tcSplitPredFunTy_maybe (FunTy arg res)
 719   | Just p <- splitPredTy_maybe arg = Just (p, res)
 720 tcSplitPredFunTy_maybe _
 721   = Nothing
 722
 723 tcSplitPhiTy :: Type -> (ThetaType, Type)
 724 tcSplitPhiTy ty
 725   = split ty []
 726   where
 727     split ty ts
 728       = case tcSplitPredFunTy_maybe ty of
 729           Just (pred, ty) -> split ty (pred:ts)
 730           Nothing         -> (reverse ts, ty)
 731
 732 tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)
 733 tcSplitSigmaTy ty = case tcSplitForAllTys ty of
 734                         (tvs, rho) -> case tcSplitPhiTy rho of
 735                                         (theta, tau) -> (tvs, theta, tau)
 736
 737 -----------------------
 738 tcDeepSplitSigmaTy_maybe
 739   :: TcSigmaType -> Maybe ([TcType], [TyVar], ThetaType, TcSigmaType)
 740 -- Looks for a *non-trivial* quantified type, under zero or more function arrows
 741 -- By "non-trivial" we mean either tyvars or constraints are non-empty
 742
 743 tcDeepSplitSigmaTy_maybe ty
 744   | Just (arg_ty, res_ty)           <- tcSplitFunTy_maybe ty
 745   , Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty
 746   = Just (arg_ty:arg_tys, tvs, theta, rho)
 747
 748   | (tvs, theta, rho) <- tcSplitSigmaTy ty
 749   , not (null tvs && null theta)
 750   = Just ([], tvs, theta, rho)
 751
 752   | otherwise = Nothing
 753
 754 -----------------------
 755 tcTyConAppTyCon :: Type -> TyCon
 756 tcTyConAppTyCon ty = case tcSplitTyConApp_maybe ty of
 757                         Just (tc, _) -> tc
 758                         Nothing      -> pprPanic "tcTyConAppTyCon" (pprType ty)
 759
 760 tcTyConAppArgs :: Type -> [Type]
 761 tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of
 762                         Just (_, args) -> args
 763                         Nothing        -> pprPanic "tcTyConAppArgs" (pprType ty)
 764
 765 tcSplitTyConApp :: Type -> (TyCon, [Type])
 766 tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of
 767                         Just stuff -> stuff
 768                         Nothing    -> pprPanic "tcSplitTyConApp" (pprType ty)
 769
 770 tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
 771 tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty'
 772 tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
 773 tcSplitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
 774         -- Newtypes are opaque, so they may be split
 775         -- However, predicates are not treated
 776         -- as tycon applications by the type checker
 777 tcSplitTyConApp_maybe _                 = Nothing
 778
 779 -----------------------
 780 tcSplitFunTys :: Type -> ([Type], Type)
 781 tcSplitFunTys ty = case tcSplitFunTy_maybe ty of
 782                         Nothing        -> ([], ty)
 783                         Just (arg,res) -> (arg:args, res')
 784                                        where
 785                                           (args,res') = tcSplitFunTys res
 786
 787 tcSplitFunTy_maybe :: Type -> Maybe (Type, Type)
 788 tcSplitFunTy_maybe ty | Just ty' <- tcView ty           = tcSplitFunTy_maybe ty'
 789 tcSplitFunTy_maybe (FunTy arg res) | not (isPredTy arg) = Just (arg, res)
 790 tcSplitFunTy_maybe _                                    = Nothing
 791         -- Note the (not (isPredTy arg)) guard
 792         -- Consider     (?x::Int) => Bool
 793         -- We don't want to treat this as a function type!
 794         -- A concrete example is test tc230:
 795         --      f :: () -> (?p :: ()) => () -> ()
 796         --
 797         --      g = f () ()
 798
 799 tcSplitFunTysN
 800         :: TcRhoType
 801         -> Arity                -- N: Number of desired args
 802         -> ([TcSigmaType],      -- Arg types (N or fewer)
 803             TcSigmaType)        -- The rest of the type
 804
 805 tcSplitFunTysN ty n_args
 806   | n_args == 0
 807   = ([], ty)
 808   | Just (arg,res) <- tcSplitFunTy_maybe ty
 809   = case tcSplitFunTysN res (n_args - 1) of
 810         (args, res) -> (arg:args, res)
 811   | otherwise
 812   = ([], ty)
 813
 814 tcSplitFunTy :: Type -> (Type, Type)
 815 tcSplitFunTy  ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty)
 816
 817 tcFunArgTy :: Type -> Type
 818 tcFunArgTy    ty = fst (tcSplitFunTy ty)
 819
 820 tcFunResultTy :: Type -> Type
 821 tcFunResultTy ty = snd (tcSplitFunTy ty)
 822
 823 -----------------------
 824 tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
 825 tcSplitAppTy_maybe ty | Just ty' <- tcView ty = tcSplitAppTy_maybe ty'
 826 tcSplitAppTy_maybe ty = repSplitAppTy_maybe ty
 827
 828 tcSplitAppTy :: Type -> (Type, Type)
 829 tcSplitAppTy ty = case tcSplitAppTy_maybe ty of
 830                     Just stuff -> stuff
 831                     Nothing    -> pprPanic "tcSplitAppTy" (pprType ty)
 832
 833 tcSplitAppTys :: Type -> (Type, [Type])
 834 tcSplitAppTys ty
 835   = go ty []
 836   where
 837     go ty args = case tcSplitAppTy_maybe ty of
 838                    Just (ty', arg) -> go ty' (arg:args)
 839                    Nothing         -> (ty,args)
 840
 841 -----------------------
 842 tcGetTyVar_maybe :: Type -> Maybe TyVar
 843 tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty'
 844 tcGetTyVar_maybe (TyVarTy tv)   = Just tv
 845 tcGetTyVar_maybe _              = Nothing
 846
 847 tcGetTyVar :: String -> Type -> TyVar
 848 tcGetTyVar msg ty = expectJust msg (tcGetTyVar_maybe ty)
 849
 850 tcIsTyVarTy :: Type -> Bool
 851 tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty)
 852
 853 -----------------------
 854 tcSplitDFunTy :: Type -> ([TyVar], Int, Class, [Type])
 855 -- Split the type of a dictionary function
 856 -- We don't use tcSplitSigmaTy,  because a DFun may (with NDP)
 857 -- have non-Pred arguments, such as
 858 --     df :: forall m. (forall b. Eq b => Eq (m b)) -> C m
 859 tcSplitDFunTy ty
 860   = case tcSplitForAllTys ty   of { (tvs, rho)  ->
 861     case split_dfun_args 0 rho of { (n_theta, tau) ->
 862     case tcSplitDFunHead tau   of { (clas, tys) ->
 863     (tvs, n_theta, clas, tys) }}}
 864   where
 865     -- Count the context of the dfun.  This can be a mix of
 866     -- coercion and class constraints; or (in the general NDP case)
 867     -- some other function argument
 868     split_dfun_args n ty | Just ty' <- tcView ty = split_dfun_args n ty'
 869     split_dfun_args n (FunTy _ ty)     = split_dfun_args (n+1) ty
 870     split_dfun_args n ty               = (n, ty)
 871
 872 tcSplitDFunHead :: Type -> (Class, [Type])
 873 tcSplitDFunHead tau
 874   = case splitPredTy_maybe tau of
 875         Just (ClassP clas tys) -> (clas, tys)
 876         _ -> pprPanic "tcSplitDFunHead" (ppr tau)
 877
 878 tcInstHeadTyNotSynonym :: Type -> Bool
 879 -- Used in Haskell-98 mode, for the argument types of an instance head
 880 -- These must not be type synonyms, but everywhere else type synonyms
 881 -- are transparent, so we need a special function here
 882 tcInstHeadTyNotSynonym ty
 883   = case ty of
 884         TyConApp tc _ -> not (isSynTyCon tc)
 885         _ -> True
 886
 887 tcInstHeadTyAppAllTyVars :: Type -> Bool
 888 -- Used in Haskell-98 mode, for the argument types of an instance head
 889 -- These must be a constructor applied to type variable arguments
 890 tcInstHeadTyAppAllTyVars ty
 891   | Just ty' <- tcView ty       -- Look through synonyms
 892   = tcInstHeadTyAppAllTyVars ty'
 893   | otherwise
 894   = case ty of
 895         TyConApp _ tys  -> ok tys
 896         FunTy arg res   -> ok [arg, res]
 897         _               -> False
 898   where
 899         -- Check that all the types are type variables,
 900         -- and that each is distinct
 901     ok tys = equalLength tvs tys && hasNoDups tvs
 902            where
 903              tvs = mapCatMaybes get_tv tys
 904
 905     get_tv (TyVarTy tv)  = Just tv      -- through synonyms
 906     get_tv _             = Nothing
 907 \end{code}
 908
 909
 910
 911 %************************************************************************
 912 %*                                                                      *
 913 \subsection{Predicate types}
 914 %*                                                                      *
 915 %************************************************************************
 916
 917 Superclasses
 918
 919 \begin{code}
 920 mkMinimalBySCs :: [PredType] -> [PredType]
 921 -- Remove predicates that can be deduced from others by superclasses
 922 mkMinimalBySCs ptys = [ ploc |  ploc <- ptys
 923                              ,  ploc `not_in_preds` rec_scs ]
 924  where
 925    rec_scs = concatMap trans_super_classes ptys
 926    not_in_preds p ps = null (filter (eqPred p) ps)
 927    trans_super_classes (ClassP cls tys) = transSuperClasses cls tys
 928    trans_super_classes _other_pty       = []
 929
 930 transSuperClasses :: Class -> [Type] -> [PredType]
 931 transSuperClasses cls tys
 932   = foldl (\pts p -> trans_sc p ++ pts) [] $
 933     immSuperClasses cls tys
 934   where trans_sc :: PredType -> [PredType]
 935         trans_sc this_pty@(ClassP cls tys)
 936           = foldl (\pts p -> trans_sc p ++ pts) [this_pty] $
 937             immSuperClasses cls tys
 938         trans_sc pty = [pty]
 939
 940 immSuperClasses :: Class -> [Type] -> [PredType]
 941 immSuperClasses cls tys
 942   = substTheta (zipTopTvSubst tyvars tys) sc_theta
 943   where (tyvars,sc_theta,_,_) = classBigSig cls
 944 \end{code}
 945
 946
 947 %************************************************************************
 948 %*                                                                      *
 949 \subsection{Predicates}
 950 %*                                                                      *
 951 %************************************************************************
 952
 953 isSigmaTy returns true of any qualified type.  It doesn't *necessarily* have
 954 any foralls.  E.g.
 955         f :: (?x::Int) => Int -> Int
 956
 957 \begin{code}
 958 isSigmaTy :: Type -> Bool
 959 isSigmaTy ty | Just ty' <- tcView ty = isSigmaTy ty'
 960 isSigmaTy (ForAllTy _ _) = True
 961 isSigmaTy (FunTy a _)    = isPredTy a
 962 isSigmaTy _              = False
 963
 964 isOverloadedTy :: Type -> Bool
 965 -- Yes for a type of a function that might require evidence-passing
 966 -- Used only by bindLocalMethods
 967 isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty'
 968 isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty
 969 isOverloadedTy (FunTy a _)     = isPredTy a
 970 isOverloadedTy _               = False
 971 \end{code}
 972
 973 \begin{code}
 974 isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy,
 975     isUnitTy, isCharTy :: Type -> Bool
 976 isFloatTy      = is_tc floatTyConKey
 977 isDoubleTy     = is_tc doubleTyConKey
 978 isIntegerTy    = is_tc integerTyConKey
 979 isIntTy        = is_tc intTyConKey
 980 isWordTy       = is_tc wordTyConKey
 981 isBoolTy       = is_tc boolTyConKey
 982 isUnitTy       = is_tc unitTyConKey
 983 isCharTy       = is_tc charTyConKey
 984
 985 isStringTy :: Type -> Bool
 986 isStringTy ty
 987   = case tcSplitTyConApp_maybe ty of
 988       Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty
 989       _                   -> False
 990
 991 is_tc :: Unique -> Type -> Bool
 992 -- Newtypes are opaque to this
 993 is_tc uniq ty = case tcSplitTyConApp_maybe ty of
 994                         Just (tc, _) -> uniq == getUnique tc
 995                         Nothing      -> False
 996 \end{code}
 997
 998 \begin{code}
 999 -- NB: Currently used in places where we have already expanded type synonyms;
1000 --     hence no 'coreView'.  This could, however, be changed without breaking
1001 --     any code.
1002 isSynFamilyTyConApp :: TcTauType -> Bool
1003 isSynFamilyTyConApp (TyConApp tc tys) = isSynFamilyTyCon tc &&
1004                                       length tys == tyConArity tc
1005 isSynFamilyTyConApp _other            = False
1006 \end{code}
1007
1008
1009 %************************************************************************
1010 %*                                                                      *
1011 \subsection{Misc}
1012 %*                                                                      *
1013 %************************************************************************
1014
1015 \begin{code}
1016 deNoteType :: Type -> Type
1017 -- Remove all *outermost* type synonyms and other notes
1018 deNoteType ty | Just ty' <- tcView ty = deNoteType ty'
1019 deNoteType ty = ty
1020 \end{code}
1021
1022 \begin{code}
1023 tcTyVarsOfType :: Type -> TcTyVarSet
1024 -- Just the *TcTyVars* free in the type
1025 -- (Types.tyVarsOfTypes finds all free TyVars)
1026 tcTyVarsOfType (TyVarTy tv)         = if isTcTyVar tv then unitVarSet tv
1027                                                       else emptyVarSet
1028 tcTyVarsOfType (TyConApp _ tys)     = tcTyVarsOfTypes tys
1029 tcTyVarsOfType (PredTy sty)         = tcTyVarsOfPred sty
1030 tcTyVarsOfType (FunTy arg res)      = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res
1031 tcTyVarsOfType (AppTy fun arg)      = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg
1032 tcTyVarsOfType (ForAllTy tyvar ty)  = tcTyVarsOfType ty `delVarSet` tyvar
1033         -- We do sometimes quantify over skolem TcTyVars
1034
1035 tcTyVarsOfTypes :: [Type] -> TyVarSet
1036 tcTyVarsOfTypes tys = foldr (unionVarSet.tcTyVarsOfType) emptyVarSet tys
1037
1038 tcTyVarsOfPred :: PredType -> TyVarSet
1039 tcTyVarsOfPred (IParam _ ty)    = tcTyVarsOfType ty
1040 tcTyVarsOfPred (ClassP _ tys)   = tcTyVarsOfTypes tys
1041 tcTyVarsOfPred (EqPred ty1 ty2) = tcTyVarsOfType ty1 `unionVarSet` tcTyVarsOfType ty2
1042 \end{code}
1043
1044 Find the free tycons and classes of a type.  This is used in the front
1045 end of the compiler.
1046
1047 \begin{code}
1048 orphNamesOfType :: Type -> NameSet
1049 orphNamesOfType ty | Just ty' <- tcView ty = orphNamesOfType ty'
1050                 -- Look through type synonyms (Trac #4912)
1051 orphNamesOfType (TyVarTy _)                = emptyNameSet
1052 orphNamesOfType (TyConApp tycon tys)       = unitNameSet (getName tycon)
1053                                              `unionNameSets` orphNamesOfTypes tys
1054 orphNamesOfType (PredTy (IParam _ ty))    = orphNamesOfType ty
1055 orphNamesOfType (PredTy (ClassP cl tys))  = unitNameSet (getName cl)
1056                                             `unionNameSets` orphNamesOfTypes tys
1057 orphNamesOfType (PredTy (EqPred ty1 ty2)) = orphNamesOfType ty1
1058                                             `unionNameSets` orphNamesOfType ty2
1059 orphNamesOfType (FunTy arg res)     = orphNamesOfType arg `unionNameSets` orphNamesOfType res
1060 orphNamesOfType (AppTy fun arg)     = orphNamesOfType fun `unionNameSets` orphNamesOfType arg
1061 orphNamesOfType (ForAllTy _ ty)     = orphNamesOfType ty
1062
1063 orphNamesOfTypes :: [Type] -> NameSet
1064 orphNamesOfTypes tys = foldr (unionNameSets . orphNamesOfType) emptyNameSet tys
1065
1066 orphNamesOfDFunHead :: Type -> NameSet
1067 -- Find the free type constructors and classes
1068 -- of the head of the dfun instance type
1069 -- The 'dfun_head_type' is because of
1070 --      instance Foo a => Baz T where ...
1071 -- The decl is an orphan if Baz and T are both not locally defined,
1072 --      even if Foo *is* locally defined
1073 orphNamesOfDFunHead dfun_ty
1074   = case tcSplitSigmaTy dfun_ty of
1075         (_, _, head_ty) -> orphNamesOfType head_ty
1076
1077 orphNamesOfCo :: Coercion -> NameSet
1078 orphNamesOfCo (Refl ty)             = orphNamesOfType ty
1079 orphNamesOfCo (TyConAppCo tc cos)   = unitNameSet (getName tc) `unionNameSets` orphNamesOfCos cos
1080 orphNamesOfCo (AppCo co1 co2)       = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2
1081 orphNamesOfCo (ForAllCo _ co)       = orphNamesOfCo co
1082 orphNamesOfCo (PredCo p)            = Foldable.foldr (unionNameSets . orphNamesOfCo)
1083                                                       emptyNameSet p
1084 orphNamesOfCo (CoVarCo _)           = emptyNameSet
1085 orphNamesOfCo (AxiomInstCo con cos) = orphNamesOfCoCon con `unionNameSets` orphNamesOfCos cos
1086 orphNamesOfCo (UnsafeCo ty1 ty2)    = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2
1087 orphNamesOfCo (SymCo co)            = orphNamesOfCo co
1088 orphNamesOfCo (TransCo co1 co2)     = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2
1089 orphNamesOfCo (NthCo _ co)          = orphNamesOfCo co
1090 orphNamesOfCo (InstCo co ty)        = orphNamesOfCo co `unionNameSets` orphNamesOfType ty
1091
1092 orphNamesOfCos :: [Coercion] -> NameSet
1093 orphNamesOfCos = foldr (unionNameSets . orphNamesOfCo) emptyNameSet
1094
1095 orphNamesOfCoCon :: CoAxiom -> NameSet
1096 orphNamesOfCoCon (CoAxiom { co_ax_lhs = ty1, co_ax_rhs = ty2 })
1097   = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2
1098 \end{code}
1099
1100
1101 %************************************************************************
1102 %*                                                                      *
1103 \subsection[TysWiredIn-ext-type]{External types}
1104 %*                                                                      *
1105 %************************************************************************
1106
1107 The compiler's foreign function interface supports the passing of a
1108 restricted set of types as arguments and results (the restricting factor
1109 being the )
1110
1111 \begin{code}
1112 tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, Coercion)
1113 -- (isIOType t) returns Just (IO,t',co)
1114 --                              if co : t ~ IO t'
1115 --              returns Nothing otherwise
1116 tcSplitIOType_maybe ty
1117   = case tcSplitTyConApp_maybe ty of
1118         -- This split absolutely has to be a tcSplit, because we must
1119         -- see the IO type; and it's a newtype which is transparent to splitTyConApp.
1120
1121         Just (io_tycon, [io_res_ty])
1122            |  io_tycon `hasKey` ioTyConKey
1123            -> Just (io_tycon, io_res_ty, mkReflCo ty)
1124
1125         Just (tc, tys)
1126            | not (isRecursiveTyCon tc)
1127            , Just (ty, co1) <- instNewTyCon_maybe tc tys
1128                   -- Newtypes that require a coercion are ok
1129            -> case tcSplitIOType_maybe ty of
1130                 Nothing             -> Nothing
1131                 Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCo` co2)
1132
1133         _ -> Nothing
1134
1135 isFFITy :: Type -> Bool
1136 -- True for any TyCon that can possibly be an arg or result of an FFI call
1137 isFFITy ty = checkRepTyCon legalFFITyCon ty
1138
1139 isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
1140 -- Checks for valid argument type for a 'foreign import'
1141 isFFIArgumentTy dflags safety ty
1142    = checkRepTyCon (legalOutgoingTyCon dflags safety) ty
1143
1144 isFFIExternalTy :: Type -> Bool
1145 -- Types that are allowed as arguments of a 'foreign export'
1146 isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty
1147
1148 isFFIImportResultTy :: DynFlags -> Type -> Bool
1149 isFFIImportResultTy dflags ty
1150   = checkRepTyCon (legalFIResultTyCon dflags) ty
1151
1152 isFFIExportResultTy :: Type -> Bool
1153 isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
1154
1155 isFFIDynArgumentTy :: Type -> Bool
1156 -- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr,
1157 -- or a newtype of either.
1158 isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
1159
1160 isFFIDynResultTy :: Type -> Bool
1161 -- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr,
1162 -- or a newtype of either.
1163 isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
1164
1165 isFFILabelTy :: Type -> Bool
1166 -- The type of a foreign label must be Ptr, FunPtr, Addr,
1167 -- or a newtype of either.
1168 isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
1169
1170 isFFIPrimArgumentTy :: DynFlags -> Type -> Bool
1171 -- Checks for valid argument type for a 'foreign import prim'
1172 -- Currently they must all be simple unlifted types.
1173 isFFIPrimArgumentTy dflags ty
1174    = checkRepTyCon (legalFIPrimArgTyCon dflags) ty
1175
1176 isFFIPrimResultTy :: DynFlags -> Type -> Bool
1177 -- Checks for valid result type for a 'foreign import prim'
1178 -- Currently it must be an unlifted type, including unboxed tuples.
1179 isFFIPrimResultTy dflags ty
1180    = checkRepTyCon (legalFIPrimResultTyCon dflags) ty
1181
1182 isFFIDotnetTy :: DynFlags -> Type -> Bool
1183 isFFIDotnetTy dflags ty
1184   = checkRepTyCon (\ tc -> (legalFIResultTyCon dflags tc ||
1185                            isFFIDotnetObjTy ty || isStringTy ty)) ty
1186         -- NB: isStringTy used to look through newtypes, but
1187         --     it no longer does so.  May need to adjust isFFIDotNetTy
1188         --     if we do want to look through newtypes.
1189
1190 isFFIDotnetObjTy :: Type -> Bool
1191 isFFIDotnetObjTy ty
1192   = checkRepTyCon check_tc t_ty
1193   where
1194    (_, t_ty) = tcSplitForAllTys ty
1195    check_tc tc = getName tc == objectTyConName
1196
1197 isFunPtrTy :: Type -> Bool
1198 isFunPtrTy = checkRepTyConKey [funPtrTyConKey]
1199
1200 checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
1201 -- Look through newtypes, but *not* foralls
1202 -- Should work even for recursive newtypes
1203 -- eg Manuel had:       newtype T = MkT (Ptr T)
1204 checkRepTyCon check_tc ty
1205   = go [] ty
1206   where
1207     go rec_nts ty
1208       | Just (tc,tys) <- splitTyConApp_maybe ty
1209       = case carefullySplitNewType_maybe rec_nts tc tys of
1210            Just (rec_nts', ty') -> go rec_nts' ty'
1211            Nothing              -> check_tc tc
1212       | otherwise
1213       = False
1214
1215 checkRepTyConKey :: [Unique] -> Type -> Bool
1216 -- Like checkRepTyCon, but just looks at the TyCon key
1217 checkRepTyConKey keys
1218   = checkRepTyCon (\tc -> tyConUnique tc `elem` keys)
1219 \end{code}
1220
1221 ----------------------------------------------
1222 These chaps do the work; they are not exported
1223 ----------------------------------------------
1224
1225 \begin{code}
1226 legalFEArgTyCon :: TyCon -> Bool
1227 legalFEArgTyCon tc
1228   -- It's illegal to make foreign exports that take unboxed
1229   -- arguments.  The RTS API currently can't invoke such things.  --SDM 7/2000
1230   = boxedMarshalableTyCon tc
1231
1232 legalFIResultTyCon :: DynFlags -> TyCon -> Bool
1233 legalFIResultTyCon dflags tc
1234   | tc == unitTyCon         = True
1235   | otherwise               = marshalableTyCon dflags tc
1236
1237 legalFEResultTyCon :: TyCon -> Bool
1238 legalFEResultTyCon tc
1239   | tc == unitTyCon         = True
1240   | otherwise               = boxedMarshalableTyCon tc
1241
1242 legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
1243 -- Checks validity of types going from Haskell -> external world
1244 legalOutgoingTyCon dflags _ tc
1245   = marshalableTyCon dflags tc
1246
1247 legalFFITyCon :: TyCon -> Bool
1248 -- True for any TyCon that can possibly be an arg or result of an FFI call
1249 legalFFITyCon tc
1250   = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon
1251
1252 marshalableTyCon :: DynFlags -> TyCon -> Bool
1253 marshalableTyCon dflags tc
1254   =  (xopt Opt_UnliftedFFITypes dflags
1255       && isUnLiftedTyCon tc
1256       && not (isUnboxedTupleTyCon tc)
1257       && case tyConPrimRep tc of        -- Note [Marshalling VoidRep]
1258            VoidRep -> False
1259            _       -> True)
1260   || boxedMarshalableTyCon tc
1261
1262 boxedMarshalableTyCon :: TyCon -> Bool
1263 boxedMarshalableTyCon tc
1264    = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
1265                          , int32TyConKey, int64TyConKey
1266                          , wordTyConKey, word8TyConKey, word16TyConKey
1267                          , word32TyConKey, word64TyConKey
1268                          , floatTyConKey, doubleTyConKey
1269                          , ptrTyConKey, funPtrTyConKey
1270                          , charTyConKey
1271                          , stablePtrTyConKey
1272                          , boolTyConKey
1273                          ]
1274
1275 legalFIPrimArgTyCon :: DynFlags -> TyCon -> Bool
1276 -- Check args of 'foreign import prim', only allow simple unlifted types.
1277 -- Strictly speaking it is unnecessary to ban unboxed tuples here since
1278 -- currently they're of the wrong kind to use in function args anyway.
1279 legalFIPrimArgTyCon dflags tc
1280   = xopt Opt_UnliftedFFITypes dflags
1281     && isUnLiftedTyCon tc
1282     && not (isUnboxedTupleTyCon tc)
1283
1284 legalFIPrimResultTyCon :: DynFlags -> TyCon -> Bool
1285 -- Check result type of 'foreign import prim'. Allow simple unlifted
1286 -- types and also unboxed tuple result types '... -> (# , , #)'
1287 legalFIPrimResultTyCon dflags tc
1288   = xopt Opt_UnliftedFFITypes dflags
1289     && isUnLiftedTyCon tc
1290     && (isUnboxedTupleTyCon tc
1291         || case tyConPrimRep tc of      -- Note [Marshalling VoidRep]
1292            VoidRep -> False
1293            _       -> True)
1294 \end{code}
1295
1296 Note [Marshalling VoidRep]
1297 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1298 We don't treat State# (whose PrimRep is VoidRep) as marshalable.
1299 In turn that means you can't write
1300         foreign import foo :: Int -> State# RealWorld
1301
1302 Reason: the back end falls over with panic "primRepHint:VoidRep";
1303         and there is no compelling reason to permit it