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 Name    -- 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                    -- The Name is the name of the function from whose
 321                    -- type signature we got this skolem
 322
 323    | TcsTv         -- A MetaTv allocated by the constraint solver
 324                    -- Its particular property is that it is always "touchable"
 325                    -- Nevertheless, the constraint solver has to try to guess
 326                    -- what type to instantiate it to
 327
 328 -------------------------------------
 329 -- UserTypeCtxt describes the origin of the polymorphic type
 330 -- in the places where we need to an expression has that type
 331
 332 data UserTypeCtxt
 333   = FunSigCtxt Name     -- Function type signature
 334                         -- Also used for types in SPECIALISE pragmas
 335   | ExprSigCtxt         -- Expression type signature
 336   | ConArgCtxt Name     -- Data constructor argument
 337   | TySynCtxt Name      -- RHS of a type synonym decl
 338   | GenPatCtxt          -- Pattern in generic decl
 339                         --      f{| a+b |} (Inl x) = ...
 340   | LamPatSigCtxt               -- Type sig in lambda pattern
 341                         --      f (x::t) = ...
 342   | BindPatSigCtxt      -- Type sig in pattern binding pattern
 343                         --      (x::t, y) = e
 344   | ResSigCtxt          -- Result type sig
 345                         --      f x :: t = ....
 346   | ForSigCtxt Name     -- Foreign inport or export signature
 347   | DefaultDeclCtxt     -- Types in a default declaration
 348   | SpecInstCtxt        -- SPECIALISE instance pragma
 349   | ThBrackCtxt         -- Template Haskell type brackets [t| ... |]
 350
 351   | GenSigCtxt          -- Higher-rank or impredicative situations
 352                         -- e.g. (f e) where f has a higher-rank type
 353                         -- We might want to elaborate this
 354
 355 -- Notes re TySynCtxt
 356 -- We allow type synonyms that aren't types; e.g.  type List = []
 357 --
 358 -- If the RHS mentions tyvars that aren't in scope, we'll
 359 -- quantify over them:
 360 --      e.g.    type T = a->a
 361 -- will become  type T = forall a. a->a
 362 --
 363 -- With gla-exts that's right, but for H98 we should complain.
 364
 365 ---------------------------------
 366 -- Kind variables:
 367
 368 mkKindName :: Unique -> Name
 369 mkKindName unique = mkSystemName unique kind_var_occ
 370
 371 kindVarRef :: KindVar -> IORef MetaDetails
 372 kindVarRef tc =
 373   ASSERT ( isTcTyVar tc )
 374   case tcTyVarDetails tc of
 375     MetaTv TauTv ref -> ref
 376     _                -> pprPanic "kindVarRef" (ppr tc)
 377
 378 mkKindVar :: Unique -> IORef MetaDetails -> KindVar
 379 mkKindVar u r
 380   = mkTcTyVar (mkKindName u)
 381               tySuperKind  -- not sure this is right,
 382                             -- do we need kind vars for
 383                             -- coercions?
 384               (MetaTv TauTv r)
 385
 386 kind_var_occ :: OccName -- Just one for all KindVars
 387                         -- They may be jiggled by tidying
 388 kind_var_occ = mkOccName tvName "k"
 389 \end{code}
 390
 391 %************************************************************************
 392 %*                                                                      *
 393                 Pretty-printing
 394 %*                                                                      *
 395 %************************************************************************
 396
 397 \begin{code}
 398 pprTcTyVarDetails :: TcTyVarDetails -> SDoc
 399 -- For debugging
 400 pprTcTyVarDetails (SkolemTv _)         = ptext (sLit "sk")
 401 pprTcTyVarDetails (RuntimeUnk {})      = ptext (sLit "rt")
 402 pprTcTyVarDetails (FlatSkol {})        = ptext (sLit "fsk")
 403 pprTcTyVarDetails (MetaTv TauTv _)     = ptext (sLit "tau")
 404 pprTcTyVarDetails (MetaTv TcsTv _)     = ptext (sLit "tcs")
 405 pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext (sLit "sig")
 406
 407 pprUserTypeCtxt :: UserTypeCtxt -> SDoc
 408 pprUserTypeCtxt (FunSigCtxt n)  = ptext (sLit "the type signature for") <+> quotes (ppr n)
 409 pprUserTypeCtxt ExprSigCtxt     = ptext (sLit "an expression type signature")
 410 pprUserTypeCtxt (ConArgCtxt c)  = ptext (sLit "the type of the constructor") <+> quotes (ppr c)
 411 pprUserTypeCtxt (TySynCtxt c)   = ptext (sLit "the RHS of the type synonym") <+> quotes (ppr c)
 412 pprUserTypeCtxt GenPatCtxt      = ptext (sLit "the type pattern of a generic definition")
 413 pprUserTypeCtxt ThBrackCtxt     = ptext (sLit "a Template Haskell quotation [t|...|]")
 414 pprUserTypeCtxt LamPatSigCtxt   = ptext (sLit "a pattern type signature")
 415 pprUserTypeCtxt BindPatSigCtxt  = ptext (sLit "a pattern type signature")
 416 pprUserTypeCtxt ResSigCtxt      = ptext (sLit "a result type signature")
 417 pprUserTypeCtxt (ForSigCtxt n)  = ptext (sLit "the foreign declaration for") <+> quotes (ppr n)
 418 pprUserTypeCtxt DefaultDeclCtxt = ptext (sLit "a type in a `default' declaration")
 419 pprUserTypeCtxt SpecInstCtxt    = ptext (sLit "a SPECIALISE instance pragma")
 420 pprUserTypeCtxt GenSigCtxt      = ptext (sLit "a type expected by the context")
 421 \end{code}
 422
 423
 424 %************************************************************************
 425 %*                                                                      *
 426 \subsection{TidyType}
 427 %*                                                                      *
 428 %************************************************************************
 429
 430 \begin{code}
 431 -- | This tidies up a type for printing in an error message, or in
 432 -- an interface file.
 433 --
 434 -- It doesn't change the uniques at all, just the print names.
 435 tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
 436 tidyTyVarBndr (tidy_env, subst) tyvar
 437   = case tidyOccName tidy_env occ1 of
 438       (tidy', occ') -> ((tidy', subst'), tyvar')
 439         where
 440           subst' = extendVarEnv subst tyvar tyvar'
 441           tyvar' = setTyVarName tyvar name'
 442           name'  = tidyNameOcc name occ'
 443   where
 444     name = tyVarName tyvar
 445     occ  = getOccName name
 446     -- System Names are for unification variables;
 447     -- when we tidy them we give them a trailing "0" (or 1 etc)
 448     -- so that they don't take precedence for the un-modified name
 449     occ1 | isSystemName name = mkTyVarOcc (occNameString occ ++ "0")
 450          | otherwise         = occ
 451
 452
 453 ---------------
 454 tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
 455 -- ^ Add the free 'TyVar's to the env in tidy form,
 456 -- so that we can tidy the type they are free in
 457 tidyFreeTyVars env tyvars = fst (tidyOpenTyVars env (varSetElems tyvars))
 458
 459 ---------------
 460 tidyOpenTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
 461 tidyOpenTyVars env tyvars = mapAccumL tidyOpenTyVar env tyvars
 462
 463 ---------------
 464 tidyOpenTyVar :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
 465 -- ^ Treat a new 'TyVar' as a binder, and give it a fresh tidy name
 466 -- using the environment if one has not already been allocated. See
 467 -- also 'tidyTyVarBndr'
 468 tidyOpenTyVar env@(_, subst) tyvar
 469   = case lookupVarEnv subst tyvar of
 470         Just tyvar' -> (env, tyvar')            -- Already substituted
 471         Nothing     -> tidyTyVarBndr env tyvar  -- Treat it as a binder
 472
 473 ---------------
 474 tidyType :: TidyEnv -> Type -> Type
 475 tidyType env@(_, subst) ty
 476   = go ty
 477   where
 478     go (TyVarTy tv)         = case lookupVarEnv subst tv of
 479                                 Nothing  -> expand tv
 480                                 Just tv' -> expand tv'
 481     go (TyConApp tycon tys) = let args = map go tys
 482                               in args `seqList` TyConApp tycon args
 483     go (PredTy sty)         = PredTy (tidyPred env sty)
 484     go (AppTy fun arg)      = (AppTy $! (go fun)) $! (go arg)
 485     go (FunTy fun arg)      = (FunTy $! (go fun)) $! (go arg)
 486     go (ForAllTy tv ty)     = ForAllTy tvp $! (tidyType envp ty)
 487                               where
 488                                 (envp, tvp) = tidyTyVarBndr env tv
 489
 490     -- Expand FlatSkols, the skolems introduced by flattening process
 491     -- We don't want to show them in type error messages
 492     expand tv | isTcTyVar tv
 493               , FlatSkol ty <- tcTyVarDetails tv
 494               = go ty
 495               | otherwise
 496               = TyVarTy tv
 497
 498 ---------------
 499 tidyTypes :: TidyEnv -> [Type] -> [Type]
 500 tidyTypes env tys = map (tidyType env) tys
 501
 502 ---------------
 503 tidyPred :: TidyEnv -> PredType -> PredType
 504 tidyPred env (IParam n ty)     = IParam n (tidyType env ty)
 505 tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
 506 tidyPred env (EqPred ty1 ty2)  = EqPred (tidyType env ty1) (tidyType env ty2)
 507
 508 ---------------
 509 -- | Grabs the free type variables, tidies them
 510 -- and then uses 'tidyType' to work over the type itself
 511 tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)
 512 tidyOpenType env ty
 513   = (env', tidyType env' ty)
 514   where
 515     env' = tidyFreeTyVars env (tyVarsOfType ty)
 516
 517 ---------------
 518 tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
 519 tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
 520
 521 ---------------
 522 -- | Calls 'tidyType' on a top-level type (i.e. with an empty tidying environment)
 523 tidyTopType :: Type -> Type
 524 tidyTopType ty = tidyType emptyTidyEnv ty
 525
 526 ---------------
 527 tidyKind :: TidyEnv -> Kind -> (TidyEnv, Kind)
 528 tidyKind env k = tidyOpenType env k
 529 \end{code}
 530
 531 %************************************************************************
 532 %*                                                                      *
 533                             Tidying coercions
 534 %*                                                                      *
 535 %************************************************************************
 536
 537 \begin{code}
 538
 539 tidyCo :: TidyEnv -> Coercion -> Coercion
 540 tidyCo env@(_, subst) co
 541   = go co
 542   where
 543     go (Refl ty)             = Refl (tidyType env ty)
 544     go (TyConAppCo tc cos)   = let args = map go cos
 545                                in args `seqList` TyConAppCo tc args
 546     go (AppCo co1 co2)       = (AppCo $! go co1) $! go co2
 547     go (ForAllCo tv co)      = ForAllCo tvp $! (tidyCo envp co)
 548                                where
 549                                  (envp, tvp) = tidyTyVarBndr env tv
 550     go (PredCo pco)          = PredCo $! (go <$> pco)
 551     go (CoVarCo cv)          = case lookupVarEnv subst cv of
 552                                  Nothing  -> CoVarCo cv
 553                                  Just cv' -> CoVarCo cv'
 554     go (AxiomInstCo con cos) = let args = tidyCos env cos
 555                                in  args `seqList` AxiomInstCo con args
 556     go (UnsafeCo ty1 ty2)    = (UnsafeCo $! tidyType env ty1) $! tidyType env ty2
 557     go (SymCo co)            = SymCo $! go co
 558     go (TransCo co1 co2)     = (TransCo $! go co1) $! go co2
 559     go (NthCo d co)          = NthCo d $! go co
 560     go (InstCo co ty)        = (InstCo $! go co) $! tidyType env ty
 561
 562 tidyCos :: TidyEnv -> [Coercion] -> [Coercion]
 563 tidyCos env = map (tidyCo env)
 564
 565 \end{code}
 566
 567 %************************************************************************
 568 %*                                                                      *
 569                 Predicates
 570 %*                                                                      *
 571 %************************************************************************
 572
 573 \begin{code}
 574 isImmutableTyVar :: TyVar -> Bool
 575
 576 isImmutableTyVar tv
 577   | isTcTyVar tv = isSkolemTyVar tv
 578   | otherwise    = True
 579
 580 isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar,
 581   isMetaTyVar :: TcTyVar -> Bool
 582
 583 isTyConableTyVar tv
 584         -- True of a meta-type variable that can be filled in
 585         -- with a type constructor application; in particular,
 586         -- not a SigTv
 587   = ASSERT( isTcTyVar tv)
 588     case tcTyVarDetails tv of
 589         MetaTv (SigTv _) _ -> False
 590         _                  -> True
 591
 592 isSkolemTyVar tv
 593   = ASSERT2( isTcTyVar tv, ppr tv )
 594     case tcTyVarDetails tv of
 595         SkolemTv {}   -> True
 596         FlatSkol {}   -> True
 597         RuntimeUnk {} -> True
 598         MetaTv {}     -> False
 599
 600 isOverlappableTyVar tv
 601   = ASSERT( isTcTyVar tv )
 602     case tcTyVarDetails tv of
 603         SkolemTv overlappable -> overlappable
 604         _                     -> False
 605
 606 isMetaTyVar tv
 607   = ASSERT2( isTcTyVar tv, ppr tv )
 608     case tcTyVarDetails tv of
 609         MetaTv _ _ -> True
 610         _          -> False
 611
 612 isMetaTyVarTy :: TcType -> Bool
 613 isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv
 614 isMetaTyVarTy _            = False
 615
 616 isSigTyVar :: Var -> Bool
 617 isSigTyVar tv
 618   = ASSERT( isTcTyVar tv )
 619     case tcTyVarDetails tv of
 620         MetaTv (SigTv _) _ -> True
 621         _                  -> False
 622
 623 metaTvRef :: TyVar -> IORef MetaDetails
 624 metaTvRef tv
 625   = ASSERT2( isTcTyVar tv, ppr tv )
 626     case tcTyVarDetails tv of
 627         MetaTv _ ref -> ref
 628         _          -> pprPanic "metaTvRef" (ppr tv)
 629
 630 isFlexi, isIndirect :: MetaDetails -> Bool
 631 isFlexi Flexi = True
 632 isFlexi _     = False
 633
 634 isIndirect (Indirect _) = True
 635 isIndirect _            = False
 636
 637 isRuntimeUnkSkol :: TyVar -> Bool
 638 -- Called only in TcErrors; see Note [Runtime skolems] there
 639 isRuntimeUnkSkol x
 640   | isTcTyVar x, RuntimeUnk <- tcTyVarDetails x = True
 641   | otherwise                                   = False
 642 \end{code}
 643
 644
 645 %************************************************************************
 646 %*                                                                      *
 647 \subsection{Tau, sigma and rho}
 648 %*                                                                      *
 649 %************************************************************************
 650
 651 \begin{code}
 652 mkSigmaTy :: [TyVar] -> [PredType] -> Type -> Type
 653 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau)
 654
 655 mkPhiTy :: [PredType] -> Type -> Type
 656 mkPhiTy theta ty = foldr (\p r -> mkFunTy (mkPredTy p) r) ty theta
 657 \end{code}
 658
 659 @isTauTy@ tests for nested for-alls.  It should not be called on a boxy type.
 660
 661 \begin{code}
 662 isTauTy :: Type -> Bool
 663 isTauTy ty | Just ty' <- tcView ty = isTauTy ty'
 664 isTauTy (TyVarTy _)       = True
 665 isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc
 666 isTauTy (AppTy a b)       = isTauTy a && isTauTy b
 667 isTauTy (FunTy a b)       = isTauTy a && isTauTy b
 668 isTauTy (PredTy _)        = True                -- Don't look through source types
 669 isTauTy _                 = False
 670
 671 isTauTyCon :: TyCon -> Bool
 672 -- Returns False for type synonyms whose expansion is a polytype
 673 isTauTyCon tc
 674   | isClosedSynTyCon tc = isTauTy (snd (synTyConDefn tc))
 675   | otherwise           = True
 676
 677 ---------------
 678 getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
 679                                 -- construct a dictionary function name
 680 getDFunTyKey ty | Just ty' <- tcView ty = getDFunTyKey ty'
 681 getDFunTyKey (TyVarTy tv)    = getOccName tv
 682 getDFunTyKey (TyConApp tc _) = getOccName tc
 683 getDFunTyKey (AppTy fun _)   = getDFunTyKey fun
 684 getDFunTyKey (FunTy _ _)     = getOccName funTyCon
 685 getDFunTyKey (ForAllTy _ t)  = getDFunTyKey t
 686 getDFunTyKey ty              = pprPanic "getDFunTyKey" (pprType ty)
 687 -- PredTy shouldn't happen
 688 \end{code}
 689
 690
 691 %************************************************************************
 692 %*                                                                      *
 693 \subsection{Expanding and splitting}
 694 %*                                                                      *
 695 %************************************************************************
 696
 697 These tcSplit functions are like their non-Tc analogues, but
 698         a) they do not look through newtypes
 699         b) they do not look through PredTys
 700
 701 However, they are non-monadic and do not follow through mutable type
 702 variables.  It's up to you to make sure this doesn't matter.
 703
 704 \begin{code}
 705 tcSplitForAllTys :: Type -> ([TyVar], Type)
 706 tcSplitForAllTys ty = split ty ty []
 707    where
 708      split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
 709      split _ (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
 710      split orig_ty _          tvs = (reverse tvs, orig_ty)
 711
 712 tcIsForAllTy :: Type -> Bool
 713 tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty'
 714 tcIsForAllTy (ForAllTy {}) = True
 715 tcIsForAllTy _             = False
 716
 717 tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type)
 718 -- Split off the first predicate argument from a type
 719 tcSplitPredFunTy_maybe ty | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty'
 720 tcSplitPredFunTy_maybe (FunTy arg res)
 721   | Just p <- splitPredTy_maybe arg = Just (p, res)
 722 tcSplitPredFunTy_maybe _
 723   = Nothing
 724
 725 tcSplitPhiTy :: Type -> (ThetaType, Type)
 726 tcSplitPhiTy ty
 727   = split ty []
 728   where
 729     split ty ts
 730       = case tcSplitPredFunTy_maybe ty of
 731           Just (pred, ty) -> split ty (pred:ts)
 732           Nothing         -> (reverse ts, ty)
 733
 734 tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)
 735 tcSplitSigmaTy ty = case tcSplitForAllTys ty of
 736                         (tvs, rho) -> case tcSplitPhiTy rho of
 737                                         (theta, tau) -> (tvs, theta, tau)
 738
 739 -----------------------
 740 tcDeepSplitSigmaTy_maybe
 741   :: TcSigmaType -> Maybe ([TcType], [TyVar], ThetaType, TcSigmaType)
 742 -- Looks for a *non-trivial* quantified type, under zero or more function arrows
 743 -- By "non-trivial" we mean either tyvars or constraints are non-empty
 744
 745 tcDeepSplitSigmaTy_maybe ty
 746   | Just (arg_ty, res_ty)           <- tcSplitFunTy_maybe ty
 747   , Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty
 748   = Just (arg_ty:arg_tys, tvs, theta, rho)
 749
 750   | (tvs, theta, rho) <- tcSplitSigmaTy ty
 751   , not (null tvs && null theta)
 752   = Just ([], tvs, theta, rho)
 753
 754   | otherwise = Nothing
 755
 756 -----------------------
 757 tcTyConAppTyCon :: Type -> TyCon
 758 tcTyConAppTyCon ty = case tcSplitTyConApp_maybe ty of
 759                         Just (tc, _) -> tc
 760                         Nothing      -> pprPanic "tcTyConAppTyCon" (pprType ty)
 761
 762 tcTyConAppArgs :: Type -> [Type]
 763 tcTyConAppArgs ty = case tcSplitTyConApp_maybe ty of
 764                         Just (_, args) -> args
 765                         Nothing        -> pprPanic "tcTyConAppArgs" (pprType ty)
 766
 767 tcSplitTyConApp :: Type -> (TyCon, [Type])
 768 tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of
 769                         Just stuff -> stuff
 770                         Nothing    -> pprPanic "tcSplitTyConApp" (pprType ty)
 771
 772 tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
 773 tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty'
 774 tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
 775 tcSplitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
 776         -- Newtypes are opaque, so they may be split
 777         -- However, predicates are not treated
 778         -- as tycon applications by the type checker
 779 tcSplitTyConApp_maybe _                 = Nothing
 780
 781 -----------------------
 782 tcSplitFunTys :: Type -> ([Type], Type)
 783 tcSplitFunTys ty = case tcSplitFunTy_maybe ty of
 784                         Nothing        -> ([], ty)
 785                         Just (arg,res) -> (arg:args, res')
 786                                        where
 787                                           (args,res') = tcSplitFunTys res
 788
 789 tcSplitFunTy_maybe :: Type -> Maybe (Type, Type)
 790 tcSplitFunTy_maybe ty | Just ty' <- tcView ty           = tcSplitFunTy_maybe ty'
 791 tcSplitFunTy_maybe (FunTy arg res) | not (isPredTy arg) = Just (arg, res)
 792 tcSplitFunTy_maybe _                                    = Nothing
 793         -- Note the (not (isPredTy arg)) guard
 794         -- Consider     (?x::Int) => Bool
 795         -- We don't want to treat this as a function type!
 796         -- A concrete example is test tc230:
 797         --      f :: () -> (?p :: ()) => () -> ()
 798         --
 799         --      g = f () ()
 800
 801 tcSplitFunTysN
 802         :: TcRhoType
 803         -> Arity                -- N: Number of desired args
 804         -> ([TcSigmaType],      -- Arg types (N or fewer)
 805             TcSigmaType)        -- The rest of the type
 806
 807 tcSplitFunTysN ty n_args
 808   | n_args == 0
 809   = ([], ty)
 810   | Just (arg,res) <- tcSplitFunTy_maybe ty
 811   = case tcSplitFunTysN res (n_args - 1) of
 812         (args, res) -> (arg:args, res)
 813   | otherwise
 814   = ([], ty)
 815
 816 tcSplitFunTy :: Type -> (Type, Type)
 817 tcSplitFunTy  ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty)
 818
 819 tcFunArgTy :: Type -> Type
 820 tcFunArgTy    ty = fst (tcSplitFunTy ty)
 821
 822 tcFunResultTy :: Type -> Type
 823 tcFunResultTy ty = snd (tcSplitFunTy ty)
 824
 825 -----------------------
 826 tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
 827 tcSplitAppTy_maybe ty | Just ty' <- tcView ty = tcSplitAppTy_maybe ty'
 828 tcSplitAppTy_maybe ty = repSplitAppTy_maybe ty
 829
 830 tcSplitAppTy :: Type -> (Type, Type)
 831 tcSplitAppTy ty = case tcSplitAppTy_maybe ty of
 832                     Just stuff -> stuff
 833                     Nothing    -> pprPanic "tcSplitAppTy" (pprType ty)
 834
 835 tcSplitAppTys :: Type -> (Type, [Type])
 836 tcSplitAppTys ty
 837   = go ty []
 838   where
 839     go ty args = case tcSplitAppTy_maybe ty of
 840                    Just (ty', arg) -> go ty' (arg:args)
 841                    Nothing         -> (ty,args)
 842
 843 -----------------------
 844 tcGetTyVar_maybe :: Type -> Maybe TyVar
 845 tcGetTyVar_maybe ty | Just ty' <- tcView ty = tcGetTyVar_maybe ty'
 846 tcGetTyVar_maybe (TyVarTy tv)   = Just tv
 847 tcGetTyVar_maybe _              = Nothing
 848
 849 tcGetTyVar :: String -> Type -> TyVar
 850 tcGetTyVar msg ty = expectJust msg (tcGetTyVar_maybe ty)
 851
 852 tcIsTyVarTy :: Type -> Bool
 853 tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty)
 854
 855 -----------------------
 856 tcSplitDFunTy :: Type -> ([TyVar], Int, Class, [Type])
 857 -- Split the type of a dictionary function
 858 -- We don't use tcSplitSigmaTy,  because a DFun may (with NDP)
 859 -- have non-Pred arguments, such as
 860 --     df :: forall m. (forall b. Eq b => Eq (m b)) -> C m
 861 tcSplitDFunTy ty
 862   = case tcSplitForAllTys ty   of { (tvs, rho)  ->
 863     case split_dfun_args 0 rho of { (n_theta, tau) ->
 864     case tcSplitDFunHead tau   of { (clas, tys) ->
 865     (tvs, n_theta, clas, tys) }}}
 866   where
 867     -- Count the context of the dfun.  This can be a mix of
 868     -- coercion and class constraints; or (in the general NDP case)
 869     -- some other function argument
 870     split_dfun_args n ty | Just ty' <- tcView ty = split_dfun_args n ty'
 871     split_dfun_args n (FunTy _ ty)     = split_dfun_args (n+1) ty
 872     split_dfun_args n ty               = (n, ty)
 873
 874 tcSplitDFunHead :: Type -> (Class, [Type])
 875 tcSplitDFunHead tau
 876   = case splitPredTy_maybe tau of
 877         Just (ClassP clas tys) -> (clas, tys)
 878         _ -> pprPanic "tcSplitDFunHead" (ppr tau)
 879
 880 tcInstHeadTyNotSynonym :: Type -> Bool
 881 -- Used in Haskell-98 mode, for the argument types of an instance head
 882 -- These must not be type synonyms, but everywhere else type synonyms
 883 -- are transparent, so we need a special function here
 884 tcInstHeadTyNotSynonym ty
 885   = case ty of
 886         TyConApp tc _ -> not (isSynTyCon tc)
 887         _ -> True
 888
 889 tcInstHeadTyAppAllTyVars :: Type -> Bool
 890 -- Used in Haskell-98 mode, for the argument types of an instance head
 891 -- These must be a constructor applied to type variable arguments
 892 tcInstHeadTyAppAllTyVars ty
 893   | Just ty' <- tcView ty       -- Look through synonyms
 894   = tcInstHeadTyAppAllTyVars ty'
 895   | otherwise
 896   = case ty of
 897         TyConApp _ tys  -> ok tys
 898         FunTy arg res   -> ok [arg, res]
 899         _               -> False
 900   where
 901         -- Check that all the types are type variables,
 902         -- and that each is distinct
 903     ok tys = equalLength tvs tys && hasNoDups tvs
 904            where
 905              tvs = mapCatMaybes get_tv tys
 906
 907     get_tv (TyVarTy tv)  = Just tv      -- through synonyms
 908     get_tv _             = Nothing
 909 \end{code}
 910
 911
 912
 913 %************************************************************************
 914 %*                                                                      *
 915 \subsection{Predicate types}
 916 %*                                                                      *
 917 %************************************************************************
 918
 919 Superclasses
 920
 921 \begin{code}
 922 mkMinimalBySCs :: [PredType] -> [PredType]
 923 -- Remove predicates that can be deduced from others by superclasses
 924 mkMinimalBySCs ptys = [ ploc |  ploc <- ptys
 925                              ,  ploc `not_in_preds` rec_scs ]
 926  where
 927    rec_scs = concatMap trans_super_classes ptys
 928    not_in_preds p ps = null (filter (eqPred p) ps)
 929    trans_super_classes (ClassP cls tys) = transSuperClasses cls tys
 930    trans_super_classes _other_pty       = []
 931
 932 transSuperClasses :: Class -> [Type] -> [PredType]
 933 transSuperClasses cls tys
 934   = foldl (\pts p -> trans_sc p ++ pts) [] $
 935     immSuperClasses cls tys
 936   where trans_sc :: PredType -> [PredType]
 937         trans_sc this_pty@(ClassP cls tys)
 938           = foldl (\pts p -> trans_sc p ++ pts) [this_pty] $
 939             immSuperClasses cls tys
 940         trans_sc pty = [pty]
 941
 942 immSuperClasses :: Class -> [Type] -> [PredType]
 943 immSuperClasses cls tys
 944   = substTheta (zipTopTvSubst tyvars tys) sc_theta
 945   where (tyvars,sc_theta,_,_) = classBigSig cls
 946 \end{code}
 947
 948
 949 %************************************************************************
 950 %*                                                                      *
 951 \subsection{Predicates}
 952 %*                                                                      *
 953 %************************************************************************
 954
 955 isSigmaTy returns true of any qualified type.  It doesn't *necessarily* have
 956 any foralls.  E.g.
 957         f :: (?x::Int) => Int -> Int
 958
 959 \begin{code}
 960 isSigmaTy :: Type -> Bool
 961 isSigmaTy ty | Just ty' <- tcView ty = isSigmaTy ty'
 962 isSigmaTy (ForAllTy _ _) = True
 963 isSigmaTy (FunTy a _)    = isPredTy a
 964 isSigmaTy _              = False
 965
 966 isOverloadedTy :: Type -> Bool
 967 -- Yes for a type of a function that might require evidence-passing
 968 -- Used only by bindLocalMethods
 969 isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty'
 970 isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty
 971 isOverloadedTy (FunTy a _)     = isPredTy a
 972 isOverloadedTy _               = False
 973 \end{code}
 974
 975 \begin{code}
 976 isFloatTy, isDoubleTy, isIntegerTy, isIntTy, isWordTy, isBoolTy,
 977     isUnitTy, isCharTy :: Type -> Bool
 978 isFloatTy      = is_tc floatTyConKey
 979 isDoubleTy     = is_tc doubleTyConKey
 980 isIntegerTy    = is_tc integerTyConKey
 981 isIntTy        = is_tc intTyConKey
 982 isWordTy       = is_tc wordTyConKey
 983 isBoolTy       = is_tc boolTyConKey
 984 isUnitTy       = is_tc unitTyConKey
 985 isCharTy       = is_tc charTyConKey
 986
 987 isStringTy :: Type -> Bool
 988 isStringTy ty
 989   = case tcSplitTyConApp_maybe ty of
 990       Just (tc, [arg_ty]) -> tc == listTyCon && isCharTy arg_ty
 991       _                   -> False
 992
 993 is_tc :: Unique -> Type -> Bool
 994 -- Newtypes are opaque to this
 995 is_tc uniq ty = case tcSplitTyConApp_maybe ty of
 996                         Just (tc, _) -> uniq == getUnique tc
 997                         Nothing      -> False
 998 \end{code}
 999
1000 \begin{code}
1001 -- NB: Currently used in places where we have already expanded type synonyms;
1002 --     hence no 'coreView'.  This could, however, be changed without breaking
1003 --     any code.
1004 isSynFamilyTyConApp :: TcTauType -> Bool
1005 isSynFamilyTyConApp (TyConApp tc tys) = isSynFamilyTyCon tc &&
1006                                       length tys == tyConArity tc
1007 isSynFamilyTyConApp _other            = False
1008 \end{code}
1009
1010
1011 %************************************************************************
1012 %*                                                                      *
1013 \subsection{Misc}
1014 %*                                                                      *
1015 %************************************************************************
1016
1017 \begin{code}
1018 deNoteType :: Type -> Type
1019 -- Remove all *outermost* type synonyms and other notes
1020 deNoteType ty | Just ty' <- tcView ty = deNoteType ty'
1021 deNoteType ty = ty
1022 \end{code}
1023
1024 \begin{code}
1025 tcTyVarsOfType :: Type -> TcTyVarSet
1026 -- Just the *TcTyVars* free in the type
1027 -- (Types.tyVarsOfTypes finds all free TyVars)
1028 tcTyVarsOfType (TyVarTy tv)         = if isTcTyVar tv then unitVarSet tv
1029                                                       else emptyVarSet
1030 tcTyVarsOfType (TyConApp _ tys)     = tcTyVarsOfTypes tys
1031 tcTyVarsOfType (PredTy sty)         = tcTyVarsOfPred sty
1032 tcTyVarsOfType (FunTy arg res)      = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res
1033 tcTyVarsOfType (AppTy fun arg)      = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg
1034 tcTyVarsOfType (ForAllTy tyvar ty)  = tcTyVarsOfType ty `delVarSet` tyvar
1035         -- We do sometimes quantify over skolem TcTyVars
1036
1037 tcTyVarsOfTypes :: [Type] -> TyVarSet
1038 tcTyVarsOfTypes tys = foldr (unionVarSet.tcTyVarsOfType) emptyVarSet tys
1039
1040 tcTyVarsOfPred :: PredType -> TyVarSet
1041 tcTyVarsOfPred (IParam _ ty)    = tcTyVarsOfType ty
1042 tcTyVarsOfPred (ClassP _ tys)   = tcTyVarsOfTypes tys
1043 tcTyVarsOfPred (EqPred ty1 ty2) = tcTyVarsOfType ty1 `unionVarSet` tcTyVarsOfType ty2
1044 \end{code}
1045
1046 Find the free tycons and classes of a type.  This is used in the front
1047 end of the compiler.
1048
1049 \begin{code}
1050 orphNamesOfType :: Type -> NameSet
1051 orphNamesOfType ty | Just ty' <- tcView ty = orphNamesOfType ty'
1052                 -- Look through type synonyms (Trac #4912)
1053 orphNamesOfType (TyVarTy _)                = emptyNameSet
1054 orphNamesOfType (TyConApp tycon tys)       = unitNameSet (getName tycon)
1055                                              `unionNameSets` orphNamesOfTypes tys
1056 orphNamesOfType (PredTy (IParam _ ty))    = orphNamesOfType ty
1057 orphNamesOfType (PredTy (ClassP cl tys))  = unitNameSet (getName cl)
1058                                             `unionNameSets` orphNamesOfTypes tys
1059 orphNamesOfType (PredTy (EqPred ty1 ty2)) = orphNamesOfType ty1
1060                                             `unionNameSets` orphNamesOfType ty2
1061 orphNamesOfType (FunTy arg res)     = orphNamesOfType arg `unionNameSets` orphNamesOfType res
1062 orphNamesOfType (AppTy fun arg)     = orphNamesOfType fun `unionNameSets` orphNamesOfType arg
1063 orphNamesOfType (ForAllTy _ ty)     = orphNamesOfType ty
1064
1065 orphNamesOfTypes :: [Type] -> NameSet
1066 orphNamesOfTypes tys = foldr (unionNameSets . orphNamesOfType) emptyNameSet tys
1067
1068 orphNamesOfDFunHead :: Type -> NameSet
1069 -- Find the free type constructors and classes
1070 -- of the head of the dfun instance type
1071 -- The 'dfun_head_type' is because of
1072 --      instance Foo a => Baz T where ...
1073 -- The decl is an orphan if Baz and T are both not locally defined,
1074 --      even if Foo *is* locally defined
1075 orphNamesOfDFunHead dfun_ty
1076   = case tcSplitSigmaTy dfun_ty of
1077         (_, _, head_ty) -> orphNamesOfType head_ty
1078
1079 orphNamesOfCo :: Coercion -> NameSet
1080 orphNamesOfCo (Refl ty)             = orphNamesOfType ty
1081 orphNamesOfCo (TyConAppCo tc cos)   = unitNameSet (getName tc) `unionNameSets` orphNamesOfCos cos
1082 orphNamesOfCo (AppCo co1 co2)       = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2
1083 orphNamesOfCo (ForAllCo _ co)       = orphNamesOfCo co
1084 orphNamesOfCo (PredCo p)            = Foldable.foldr (unionNameSets . orphNamesOfCo)
1085                                                       emptyNameSet p
1086 orphNamesOfCo (CoVarCo _)           = emptyNameSet
1087 orphNamesOfCo (AxiomInstCo con cos) = orphNamesOfCoCon con `unionNameSets` orphNamesOfCos cos
1088 orphNamesOfCo (UnsafeCo ty1 ty2)    = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2
1089 orphNamesOfCo (SymCo co)            = orphNamesOfCo co
1090 orphNamesOfCo (TransCo co1 co2)     = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2
1091 orphNamesOfCo (NthCo _ co)          = orphNamesOfCo co
1092 orphNamesOfCo (InstCo co ty)        = orphNamesOfCo co `unionNameSets` orphNamesOfType ty
1093
1094 orphNamesOfCos :: [Coercion] -> NameSet
1095 orphNamesOfCos = foldr (unionNameSets . orphNamesOfCo) emptyNameSet
1096
1097 orphNamesOfCoCon :: CoAxiom -> NameSet
1098 orphNamesOfCoCon (CoAxiom { co_ax_lhs = ty1, co_ax_rhs = ty2 })
1099   = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2
1100 \end{code}
1101
1102
1103 %************************************************************************
1104 %*                                                                      *
1105 \subsection[TysWiredIn-ext-type]{External types}
1106 %*                                                                      *
1107 %************************************************************************
1108
1109 The compiler's foreign function interface supports the passing of a
1110 restricted set of types as arguments and results (the restricting factor
1111 being the )
1112
1113 \begin{code}
1114 tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, Coercion)
1115 -- (isIOType t) returns Just (IO,t',co)
1116 --                              if co : t ~ IO t'
1117 --              returns Nothing otherwise
1118 tcSplitIOType_maybe ty
1119   = case tcSplitTyConApp_maybe ty of
1120         -- This split absolutely has to be a tcSplit, because we must
1121         -- see the IO type; and it's a newtype which is transparent to splitTyConApp.
1122
1123         Just (io_tycon, [io_res_ty])
1124            |  io_tycon `hasKey` ioTyConKey
1125            -> Just (io_tycon, io_res_ty, mkReflCo ty)
1126
1127         Just (tc, tys)
1128            | not (isRecursiveTyCon tc)
1129            , Just (ty, co1) <- instNewTyCon_maybe tc tys
1130                   -- Newtypes that require a coercion are ok
1131            -> case tcSplitIOType_maybe ty of
1132                 Nothing             -> Nothing
1133                 Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCo` co2)
1134
1135         _ -> Nothing
1136
1137 isFFITy :: Type -> Bool
1138 -- True for any TyCon that can possibly be an arg or result of an FFI call
1139 isFFITy ty = checkRepTyCon legalFFITyCon ty
1140
1141 isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
1142 -- Checks for valid argument type for a 'foreign import'
1143 isFFIArgumentTy dflags safety ty
1144    = checkRepTyCon (legalOutgoingTyCon dflags safety) ty
1145
1146 isFFIExternalTy :: Type -> Bool
1147 -- Types that are allowed as arguments of a 'foreign export'
1148 isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty
1149
1150 isFFIImportResultTy :: DynFlags -> Type -> Bool
1151 isFFIImportResultTy dflags ty
1152   = checkRepTyCon (legalFIResultTyCon dflags) ty
1153
1154 isFFIExportResultTy :: Type -> Bool
1155 isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
1156
1157 isFFIDynArgumentTy :: Type -> Bool
1158 -- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr,
1159 -- or a newtype of either.
1160 isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
1161
1162 isFFIDynResultTy :: Type -> Bool
1163 -- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr,
1164 -- or a newtype of either.
1165 isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
1166
1167 isFFILabelTy :: Type -> Bool
1168 -- The type of a foreign label must be Ptr, FunPtr, Addr,
1169 -- or a newtype of either.
1170 isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
1171
1172 isFFIPrimArgumentTy :: DynFlags -> Type -> Bool
1173 -- Checks for valid argument type for a 'foreign import prim'
1174 -- Currently they must all be simple unlifted types.
1175 isFFIPrimArgumentTy dflags ty
1176    = checkRepTyCon (legalFIPrimArgTyCon dflags) ty
1177
1178 isFFIPrimResultTy :: DynFlags -> Type -> Bool
1179 -- Checks for valid result type for a 'foreign import prim'
1180 -- Currently it must be an unlifted type, including unboxed tuples.
1181 isFFIPrimResultTy dflags ty
1182    = checkRepTyCon (legalFIPrimResultTyCon dflags) ty
1183
1184 isFFIDotnetTy :: DynFlags -> Type -> Bool
1185 isFFIDotnetTy dflags ty
1186   = checkRepTyCon (\ tc -> (legalFIResultTyCon dflags tc ||
1187                            isFFIDotnetObjTy ty || isStringTy ty)) ty
1188         -- NB: isStringTy used to look through newtypes, but
1189         --     it no longer does so.  May need to adjust isFFIDotNetTy
1190         --     if we do want to look through newtypes.
1191
1192 isFFIDotnetObjTy :: Type -> Bool
1193 isFFIDotnetObjTy ty
1194   = checkRepTyCon check_tc t_ty
1195   where
1196    (_, t_ty) = tcSplitForAllTys ty
1197    check_tc tc = getName tc == objectTyConName
1198
1199 isFunPtrTy :: Type -> Bool
1200 isFunPtrTy = checkRepTyConKey [funPtrTyConKey]
1201
1202 checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
1203 -- Look through newtypes, but *not* foralls
1204 -- Should work even for recursive newtypes
1205 -- eg Manuel had:       newtype T = MkT (Ptr T)
1206 checkRepTyCon check_tc ty
1207   = go [] ty
1208   where
1209     go rec_nts ty
1210       | Just (tc,tys) <- splitTyConApp_maybe ty
1211       = case carefullySplitNewType_maybe rec_nts tc tys of
1212            Just (rec_nts', ty') -> go rec_nts' ty'
1213            Nothing              -> check_tc tc
1214       | otherwise
1215       = False
1216
1217 checkRepTyConKey :: [Unique] -> Type -> Bool
1218 -- Like checkRepTyCon, but just looks at the TyCon key
1219 checkRepTyConKey keys
1220   = checkRepTyCon (\tc -> tyConUnique tc `elem` keys)
1221 \end{code}
1222
1223 ----------------------------------------------
1224 These chaps do the work; they are not exported
1225 ----------------------------------------------
1226
1227 \begin{code}
1228 legalFEArgTyCon :: TyCon -> Bool
1229 legalFEArgTyCon tc
1230   -- It's illegal to make foreign exports that take unboxed
1231   -- arguments.  The RTS API currently can't invoke such things.  --SDM 7/2000
1232   = boxedMarshalableTyCon tc
1233
1234 legalFIResultTyCon :: DynFlags -> TyCon -> Bool
1235 legalFIResultTyCon dflags tc
1236   | tc == unitTyCon         = True
1237   | otherwise               = marshalableTyCon dflags tc
1238
1239 legalFEResultTyCon :: TyCon -> Bool
1240 legalFEResultTyCon tc
1241   | tc == unitTyCon         = True
1242   | otherwise               = boxedMarshalableTyCon tc
1243
1244 legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
1245 -- Checks validity of types going from Haskell -> external world
1246 legalOutgoingTyCon dflags _ tc
1247   = marshalableTyCon dflags tc
1248
1249 legalFFITyCon :: TyCon -> Bool
1250 -- True for any TyCon that can possibly be an arg or result of an FFI call
1251 legalFFITyCon tc
1252   = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon
1253
1254 marshalableTyCon :: DynFlags -> TyCon -> Bool
1255 marshalableTyCon dflags tc
1256   =  (xopt Opt_UnliftedFFITypes dflags
1257       && isUnLiftedTyCon tc
1258       && not (isUnboxedTupleTyCon tc)
1259       && case tyConPrimRep tc of        -- Note [Marshalling VoidRep]
1260            VoidRep -> False
1261            _       -> True)
1262   || boxedMarshalableTyCon tc
1263
1264 boxedMarshalableTyCon :: TyCon -> Bool
1265 boxedMarshalableTyCon tc
1266    = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
1267                          , int32TyConKey, int64TyConKey
1268                          , wordTyConKey, word8TyConKey, word16TyConKey
1269                          , word32TyConKey, word64TyConKey
1270                          , floatTyConKey, doubleTyConKey
1271                          , ptrTyConKey, funPtrTyConKey
1272                          , charTyConKey
1273                          , stablePtrTyConKey
1274                          , boolTyConKey
1275                          ]
1276
1277 legalFIPrimArgTyCon :: DynFlags -> TyCon -> Bool
1278 -- Check args of 'foreign import prim', only allow simple unlifted types.
1279 -- Strictly speaking it is unnecessary to ban unboxed tuples here since
1280 -- currently they're of the wrong kind to use in function args anyway.
1281 legalFIPrimArgTyCon dflags tc
1282   = xopt Opt_UnliftedFFITypes dflags
1283     && isUnLiftedTyCon tc
1284     && not (isUnboxedTupleTyCon tc)
1285
1286 legalFIPrimResultTyCon :: DynFlags -> TyCon -> Bool
1287 -- Check result type of 'foreign import prim'. Allow simple unlifted
1288 -- types and also unboxed tuple result types '... -> (# , , #)'
1289 legalFIPrimResultTyCon dflags tc
1290   = xopt Opt_UnliftedFFITypes dflags
1291     && isUnLiftedTyCon tc
1292     && (isUnboxedTupleTyCon tc
1293         || case tyConPrimRep tc of      -- Note [Marshalling VoidRep]
1294            VoidRep -> False
1295            _       -> True)
1296 \end{code}
1297
1298 Note [Marshalling VoidRep]
1299 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1300 We don't treat State# (whose PrimRep is VoidRep) as marshalable.
1301 In turn that means you can't write
1302         foreign import foo :: Int -> State# RealWorld
1303
1304 Reason: the back end falls over with panic "primRepHint:VoidRep";
1305         and there is no compelling reason to permit it