ghc/compiler/typecheck/TcType.lhs

   1
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcType]{Types used in the typechecker}
   5
   6 This module provides the Type interface for front-end parts of the
   7 compiler.  These parts
   8
   9         * treat "source types" as opaque:
  10                 newtypes, and predicates are meaningful.
  11         * look through usage types
  12
  13 The "tc" prefix is for "typechechecker", because the type checker
  14 is the principal client.
  15
  16 \begin{code}
  17 module TcType (
  18   --------------------------------
  19   -- Types
  20   TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
  21   TcTyVar, TcTyVarSet, TcKind,
  22
  23   --------------------------------
  24   -- MetaDetails
  25   TcTyVarDetails(..),
  26   MetaDetails(Flexi, Indirect), SkolemInfo(..), pprSkolemTyVar,
  27   isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isExistentialTyVar, skolemTvInfo, metaTvRef,
  28   isFlexi, isIndirect,
  29
  30   --------------------------------
  31   -- Builders
  32   mkPhiTy, mkSigmaTy,
  33
  34   --------------------------------
  35   -- Splitters
  36   -- These are important because they do not look through newtypes
  37   tcSplitForAllTys, tcSplitPhiTy,
  38   tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy,
  39   tcSplitTyConApp, tcSplitTyConApp_maybe, tcTyConAppTyCon, tcTyConAppArgs,
  40   tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitSigmaTy,
  41   tcSplitMethodTy, tcGetTyVar_maybe, tcGetTyVar,
  42
  43   ---------------------------------
  44   -- Predicates.
  45   -- Again, newtypes are opaque
  46   tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred,
  47   isSigmaTy, isOverloadedTy,
  48   isDoubleTy, isFloatTy, isIntTy,
  49   isIntegerTy, isAddrTy, isBoolTy, isUnitTy,
  50   isTauTy, tcIsTyVarTy, tcIsForAllTy,
  51
  52   ---------------------------------
  53   -- Misc type manipulators
  54   deNoteType, classesOfTheta,
  55   tyClsNamesOfType, tyClsNamesOfDFunHead,
  56   getDFunTyKey,
  57
  58   ---------------------------------
  59   -- Predicate types
  60   getClassPredTys_maybe, getClassPredTys,
  61   isClassPred, isTyVarClassPred,
  62   mkDictTy, tcSplitPredTy_maybe,
  63   isPredTy, isDictTy, tcSplitDFunTy, predTyUnique,
  64   mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName,
  65
  66   ---------------------------------
  67   -- Foreign import and export
  68   isFFIArgumentTy,     -- :: DynFlags -> Safety -> Type -> Bool
  69   isFFIImportResultTy, -- :: DynFlags -> Type -> Bool
  70   isFFIExportResultTy, -- :: Type -> Bool
  71   isFFIExternalTy,     -- :: Type -> Bool
  72   isFFIDynArgumentTy,  -- :: Type -> Bool
  73   isFFIDynResultTy,    -- :: Type -> Bool
  74   isFFILabelTy,        -- :: Type -> Bool
  75   isFFIDotnetTy,       -- :: DynFlags -> Type -> Bool
  76   isFFIDotnetObjTy,    -- :: Type -> Bool
  77   isFFITy,             -- :: Type -> Bool
  78
  79   toDNType,            -- :: Type -> DNType
  80
  81   --------------------------------
  82   -- Rexported from Type
  83   Kind,         -- Stuff to do with kinds is insensitive to pre/post Tc
  84   unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKind, mkArrowKinds,
  85   isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
  86   isArgTypeKind, isSubKind, defaultKind,
  87
  88   Type, PredType(..), ThetaType,
  89   mkForAllTy, mkForAllTys,
  90   mkFunTy, mkFunTys, zipFunTys,
  91   mkTyConApp, mkGenTyConApp, mkAppTy, mkAppTys, mkSynTy, applyTy, applyTys,
  92   mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys,
  93
  94   -- Type substitutions
  95   TvSubst(..),  -- Representation visible to a few friends
  96   TvSubstEnv, emptyTvSubst,
  97   mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst,
  98   getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
  99   extendTvSubst, extendTvSubstList, isInScope,
 100   substTy, substTys, substTyWith, substTheta, substTyVar,
 101
 102   isUnLiftedType,       -- Source types are always lifted
 103   isUnboxedTupleType,   -- Ditto
 104   isPrimitiveType,
 105
 106   tidyTopType, tidyType, tidyPred, tidyTypes, tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
 107   tidyTyVarBndr, tidyOpenTyVar, tidyOpenTyVars,
 108   typeKind,
 109
 110   tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta,
 111
 112   pprKind, pprParendKind,
 113   pprType, pprParendType, pprTyThingCategory,
 114   pprPred, pprTheta, pprThetaArrow, pprClassPred
 115
 116   ) where
 117
 118 #include "HsVersions.h"
 119
 120 -- friends:
 121 import TypeRep          ( Type(..), TyNote(..), funTyCon )  -- friend
 122
 123 import Type             (       -- Re-exports
 124                           tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
 125                           tyVarsOfTheta, Kind, Type, PredType(..),
 126                           ThetaType, unliftedTypeKind,
 127                           liftedTypeKind, openTypeKind, mkArrowKind,
 128                           isLiftedTypeKind, isUnliftedTypeKind,
 129                           isOpenTypeKind,
 130                           mkArrowKinds, mkForAllTy, mkForAllTys,
 131                           defaultKind, isArgTypeKind, isOpenTypeKind,
 132                           mkFunTy, mkFunTys, zipFunTys,
 133                           mkTyConApp, mkGenTyConApp, mkAppTy,
 134                           mkAppTys, mkSynTy, applyTy, applyTys,
 135                           mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy,
 136                           mkPredTys, isUnLiftedType,
 137                           isUnboxedTupleType, isPrimitiveType,
 138                           splitTyConApp_maybe,
 139                           tidyTopType, tidyType, tidyPred, tidyTypes,
 140                           tidyFreeTyVars, tidyOpenType, tidyOpenTypes,
 141                           tidyTyVarBndr, tidyOpenTyVar,
 142                           tidyOpenTyVars,
 143                           isSubKind,
 144                           TvSubst(..),
 145                           TvSubstEnv, emptyTvSubst,
 146                           mkTvSubst, zipTvSubst, zipTopTvSubst, mkTopTvSubst,
 147                           getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope,
 148                           extendTvSubst, extendTvSubstList, isInScope,
 149                           substTy, substTys, substTyWith, substTheta, substTyVar,
 150
 151                           typeKind, repType,
 152                           pprKind, pprParendKind,
 153                           pprType, pprParendType, pprTyThingCategory,
 154                           pprPred, pprTheta, pprThetaArrow, pprClassPred
 155                         )
 156 import TyCon            ( TyCon, isUnLiftedTyCon, tyConUnique )
 157 import DataCon          ( DataCon )
 158 import Class            ( Class )
 159 import Var              ( TyVar, Id, isTcTyVar, tcTyVarDetails )
 160 import ForeignCall      ( Safety, playSafe, DNType(..) )
 161 import VarEnv
 162 import VarSet
 163
 164 -- others:
 165 import CmdLineOpts      ( DynFlags, DynFlag( Opt_GlasgowExts ), dopt )
 166 import Name             ( Name, NamedThing(..), mkInternalName, getSrcLoc )
 167 import NameSet
 168 import OccName          ( OccName, mkDictOcc )
 169 import PrelNames        -- Lots (e.g. in isFFIArgumentTy)
 170 import TysWiredIn       ( unitTyCon, charTyCon, listTyCon )
 171 import BasicTypes       ( IPName(..), ipNameName )
 172 import Unique           ( Unique, Uniquable(..) )
 173 import SrcLoc           ( SrcLoc, SrcSpan )
 174 import Util             ( cmpList, thenCmp, snocView )
 175 import Maybes           ( maybeToBool, expectJust )
 176 import Outputable
 177 import DATA_IOREF
 178 \end{code}
 179
 180
 181 %************************************************************************
 182 %*                                                                      *
 183 \subsection{Types}
 184 %*                                                                      *
 185 %************************************************************************
 186
 187 The type checker divides the generic Type world into the
 188 following more structured beasts:
 189
 190 sigma ::= forall tyvars. phi
 191         -- A sigma type is a qualified type
 192         --
 193         -- Note that even if 'tyvars' is empty, theta
 194         -- may not be: e.g.   (?x::Int) => Int
 195
 196         -- Note that 'sigma' is in prenex form:
 197         -- all the foralls are at the front.
 198         -- A 'phi' type has no foralls to the right of
 199         -- an arrow
 200
 201 phi :: theta => rho
 202
 203 rho ::= sigma -> rho
 204      |  tau
 205
 206 -- A 'tau' type has no quantification anywhere
 207 -- Note that the args of a type constructor must be taus
 208 tau ::= tyvar
 209      |  tycon tau_1 .. tau_n
 210      |  tau_1 tau_2
 211      |  tau_1 -> tau_2
 212
 213 -- In all cases, a (saturated) type synonym application is legal,
 214 -- provided it expands to the required form.
 215
 216 \begin{code}
 217 type TcType = Type              -- A TcType can have mutable type variables
 218         -- Invariant on ForAllTy in TcTypes:
 219         --      forall a. T
 220         -- a cannot occur inside a MutTyVar in T; that is,
 221         -- T is "flattened" before quantifying over a
 222
 223 type TcPredType     = PredType
 224 type TcThetaType    = ThetaType
 225 type TcSigmaType    = TcType
 226 type TcRhoType      = TcType
 227 type TcTauType      = TcType
 228 type TcKind         = Kind
 229 type TcTyVarSet     = TyVarSet
 230 \end{code}
 231
 232
 233 %************************************************************************
 234 %*                                                                      *
 235 \subsection{TyVarDetails}
 236 %*                                                                      *
 237 %************************************************************************
 238
 239 TyVarDetails gives extra info about type variables, used during type
 240 checking.  It's attached to mutable type variables only.
 241 It's knot-tied back to Var.lhs.  There is no reason in principle
 242 why Var.lhs shouldn't actually have the definition, but it "belongs" here.
 243
 244 \begin{code}
 245 type TcTyVar = TyVar    -- Used only during type inference
 246
 247 -- A TyVarDetails is inside a TyVar
 248 data TcTyVarDetails
 249   = SkolemTv SkolemInfo         -- A skolem constant
 250   | MetaTv (IORef MetaDetails)  -- A meta type variable stands for a tau-type
 251
 252 data SkolemInfo
 253   = SigSkol Name        -- Bound at a type signature
 254   | ClsSkol Class       -- Bound at a class decl
 255   | InstSkol Id         -- Bound at an instance decl
 256   | PatSkol DataCon     -- An existential type variable bound by a pattern for
 257             SrcSpan     -- a data constructor with an existential type. E.g.
 258                         --      data T = forall a. Eq a => MkT a
 259                         --      f (MkT x) = ...
 260                         -- The pattern MkT x will allocate an existential type
 261                         -- variable for 'a'.
 262   | ArrowSkol SrcSpan   -- An arrow form (see TcArrows)
 263
 264   | GenSkol TcType      -- Bound when doing a subsumption check for this type
 265             SrcSpan
 266
 267 data MetaDetails
 268   = Flexi          -- Flexi type variables unify to become
 269                    -- Indirects.
 270
 271   | Indirect TcType  -- Type indirections, treated as wobbly
 272                      -- for the purpose of GADT unification.
 273
 274 pprSkolemTyVar :: TcTyVar -> SDoc
 275 pprSkolemTyVar tv
 276   = ASSERT( isSkolemTyVar tv )
 277     quotes (ppr tv) <+> ptext SLIT("is bound by") <+> ppr (skolemTvInfo tv)
 278
 279 instance Outputable SkolemInfo where
 280   ppr (SigSkol id)  = ptext SLIT("the type signature for") <+> quotes (ppr id)
 281   ppr (ClsSkol cls) = ptext SLIT("the class declaration for") <+> quotes (ppr cls)
 282   ppr (InstSkol df) = ptext SLIT("the instance declaration at") <+> ppr (getSrcLoc df)
 283   ppr (ArrowSkol loc)  = ptext SLIT("the arrow form at") <+> ppr loc
 284   ppr (PatSkol dc loc) = sep [ptext SLIT("the pattern for") <+> quotes (ppr dc),
 285                             nest 2 (ptext SLIT("at") <+> ppr loc)]
 286   ppr (GenSkol ty loc) = sep [ptext SLIT("the polymorphic type") <+> quotes (ppr ty),
 287                             nest 2 (ptext SLIT("at") <+> ppr loc)]
 288
 289 instance Outputable MetaDetails where
 290   ppr Flexi         = ptext SLIT("Flexi")
 291   ppr (Indirect ty) = ptext SLIT("Indirect") <+> ppr ty
 292
 293 isImmutableTyVar, isSkolemTyVar, isExistentialTyVar, isMetaTyVar :: TyVar -> Bool
 294 isImmutableTyVar tv
 295   | isTcTyVar tv = isSkolemTyVar tv
 296   | otherwise    = True
 297
 298 isSkolemTyVar tv
 299   = ASSERT( isTcTyVar tv )
 300     case tcTyVarDetails tv of
 301         SkolemTv _ -> True
 302         MetaTv _   -> False
 303
 304 isExistentialTyVar tv   -- Existential type variable, bound by a pattern
 305   = ASSERT( isTcTyVar tv )
 306     case tcTyVarDetails tv of
 307         SkolemTv (PatSkol _ _) -> True
 308         other                  -> False
 309
 310 isMetaTyVar tv
 311   = ASSERT( isTcTyVar tv )
 312     case tcTyVarDetails tv of
 313         SkolemTv _ -> False
 314         MetaTv _   -> True
 315
 316 skolemTvInfo :: TyVar -> SkolemInfo
 317 skolemTvInfo tv
 318   = ASSERT( isTcTyVar tv )
 319     case tcTyVarDetails tv of
 320         SkolemTv info -> info
 321
 322 metaTvRef :: TyVar -> IORef MetaDetails
 323 metaTvRef tv
 324   = ASSERT( isTcTyVar tv )
 325     case tcTyVarDetails tv of
 326          MetaTv ref -> ref
 327
 328 isFlexi, isIndirect :: MetaDetails -> Bool
 329 isFlexi Flexi = True
 330 isFlexi other = False
 331
 332 isIndirect (Indirect _) = True
 333 isIndirect other        = False
 334 \end{code}
 335
 336
 337 %************************************************************************
 338 %*                                                                      *
 339 \subsection{Tau, sigma and rho}
 340 %*                                                                      *
 341 %************************************************************************
 342
 343 \begin{code}
 344 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau)
 345
 346 mkPhiTy :: [PredType] -> Type -> Type
 347 mkPhiTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
 348 \end{code}
 349
 350 @isTauTy@ tests for nested for-alls.
 351
 352 \begin{code}
 353 isTauTy :: Type -> Bool
 354 isTauTy (TyVarTy v)      = True
 355 isTauTy (TyConApp _ tys) = all isTauTy tys
 356 isTauTy (AppTy a b)      = isTauTy a && isTauTy b
 357 isTauTy (FunTy a b)      = isTauTy a && isTauTy b
 358 isTauTy (PredTy p)       = True         -- Don't look through source types
 359 isTauTy (NoteTy _ ty)    = isTauTy ty
 360 isTauTy other            = False
 361 \end{code}
 362
 363 \begin{code}
 364 getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
 365                                 -- construct a dictionary function name
 366 getDFunTyKey (TyVarTy tv)    = getOccName tv
 367 getDFunTyKey (TyConApp tc _) = getOccName tc
 368 getDFunTyKey (AppTy fun _)   = getDFunTyKey fun
 369 getDFunTyKey (NoteTy _ t)    = getDFunTyKey t
 370 getDFunTyKey (FunTy arg _)   = getOccName funTyCon
 371 getDFunTyKey (ForAllTy _ t)  = getDFunTyKey t
 372 getDFunTyKey ty              = pprPanic "getDFunTyKey" (pprType ty)
 373 -- PredTy shouldn't happen
 374 \end{code}
 375
 376
 377 %************************************************************************
 378 %*                                                                      *
 379 \subsection{Expanding and splitting}
 380 %*                                                                      *
 381 %************************************************************************
 382
 383 These tcSplit functions are like their non-Tc analogues, but
 384         a) they do not look through newtypes
 385         b) they do not look through PredTys
 386         c) [future] they ignore usage-type annotations
 387
 388 However, they are non-monadic and do not follow through mutable type
 389 variables.  It's up to you to make sure this doesn't matter.
 390
 391 \begin{code}
 392 tcSplitForAllTys :: Type -> ([TyVar], Type)
 393 tcSplitForAllTys ty = split ty ty []
 394    where
 395      split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
 396      split orig_ty (NoteTy n  ty)   tvs = split orig_ty ty tvs
 397      split orig_ty t                tvs = (reverse tvs, orig_ty)
 398
 399 tcIsForAllTy (ForAllTy tv ty) = True
 400 tcIsForAllTy (NoteTy n ty)    = tcIsForAllTy ty
 401 tcIsForAllTy t                = False
 402
 403 tcSplitPhiTy :: Type -> ([PredType], Type)
 404 tcSplitPhiTy ty = split ty ty []
 405  where
 406   split orig_ty (FunTy arg res) ts = case tcSplitPredTy_maybe arg of
 407                                         Just p  -> split res res (p:ts)
 408                                         Nothing -> (reverse ts, orig_ty)
 409   split orig_ty (NoteTy n ty)   ts = split orig_ty ty ts
 410   split orig_ty ty              ts = (reverse ts, orig_ty)
 411
 412 tcSplitSigmaTy ty = case tcSplitForAllTys ty of
 413                         (tvs, rho) -> case tcSplitPhiTy rho of
 414                                         (theta, tau) -> (tvs, theta, tau)
 415
 416 tcTyConAppTyCon :: Type -> TyCon
 417 tcTyConAppTyCon ty = fst (tcSplitTyConApp ty)
 418
 419 tcTyConAppArgs :: Type -> [Type]
 420 tcTyConAppArgs ty = snd (tcSplitTyConApp ty)
 421
 422 tcSplitTyConApp :: Type -> (TyCon, [Type])
 423 tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of
 424                         Just stuff -> stuff
 425                         Nothing    -> pprPanic "tcSplitTyConApp" (pprType ty)
 426
 427 tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
 428 tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
 429 tcSplitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
 430 tcSplitTyConApp_maybe (NoteTy n ty)     = tcSplitTyConApp_maybe ty
 431         -- Newtypes are opaque, so they may be split
 432         -- However, predicates are not treated
 433         -- as tycon applications by the type checker
 434 tcSplitTyConApp_maybe other                     = Nothing
 435
 436 tcSplitFunTys :: Type -> ([Type], Type)
 437 tcSplitFunTys ty = case tcSplitFunTy_maybe ty of
 438                         Nothing        -> ([], ty)
 439                         Just (arg,res) -> (arg:args, res')
 440                                        where
 441                                           (args,res') = tcSplitFunTys res
 442
 443 tcSplitFunTy_maybe :: Type -> Maybe (Type, Type)
 444 tcSplitFunTy_maybe (FunTy arg res)  = Just (arg, res)
 445 tcSplitFunTy_maybe (NoteTy n ty)    = tcSplitFunTy_maybe ty
 446 tcSplitFunTy_maybe other            = Nothing
 447
 448 tcFunArgTy    ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> arg }
 449 tcFunResultTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> res }
 450
 451
 452 tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
 453 tcSplitAppTy_maybe (FunTy ty1 ty2)   = Just (TyConApp funTyCon [ty1], ty2)
 454 tcSplitAppTy_maybe (AppTy ty1 ty2)   = Just (ty1, ty2)
 455 tcSplitAppTy_maybe (NoteTy n ty)     = tcSplitAppTy_maybe ty
 456 tcSplitAppTy_maybe (TyConApp tc tys) = case snocView tys of
 457                                         Just (tys', ty') -> Just (TyConApp tc tys', ty')
 458                                         Nothing          -> Nothing
 459 tcSplitAppTy_maybe other             = Nothing
 460
 461 tcSplitAppTy ty = case tcSplitAppTy_maybe ty of
 462                     Just stuff -> stuff
 463                     Nothing    -> pprPanic "tcSplitAppTy" (pprType ty)
 464
 465 tcSplitAppTys :: Type -> (Type, [Type])
 466 tcSplitAppTys ty
 467   = go ty []
 468   where
 469     go ty args = case tcSplitAppTy_maybe ty of
 470                    Just (ty', arg) -> go ty' (arg:args)
 471                    Nothing         -> (ty,args)
 472
 473 tcGetTyVar_maybe :: Type -> Maybe TyVar
 474 tcGetTyVar_maybe (TyVarTy tv)   = Just tv
 475 tcGetTyVar_maybe (NoteTy _ t)   = tcGetTyVar_maybe t
 476 tcGetTyVar_maybe other          = Nothing
 477
 478 tcGetTyVar :: String -> Type -> TyVar
 479 tcGetTyVar msg ty = expectJust msg (tcGetTyVar_maybe ty)
 480
 481 tcIsTyVarTy :: Type -> Bool
 482 tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty)
 483 \end{code}
 484
 485 The type of a method for class C is always of the form:
 486         Forall a1..an. C a1..an => sig_ty
 487 where sig_ty is the type given by the method's signature, and thus in general
 488 is a ForallTy.  At the point that splitMethodTy is called, it is expected
 489 that the outer Forall has already been stripped off.  splitMethodTy then
 490 returns (C a1..an, sig_ty') where sig_ty' is sig_ty with any Notes stripped off.
 491
 492 \begin{code}
 493 tcSplitMethodTy :: Type -> (PredType, Type)
 494 tcSplitMethodTy ty = split ty
 495  where
 496   split (FunTy arg res) = case tcSplitPredTy_maybe arg of
 497                             Just p  -> (p, res)
 498                             Nothing -> panic "splitMethodTy"
 499   split (NoteTy n ty)   = split ty
 500   split _               = panic "splitMethodTy"
 501
 502 tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
 503 -- Split the type of a dictionary function
 504 tcSplitDFunTy ty
 505   = case tcSplitSigmaTy ty       of { (tvs, theta, tau) ->
 506     case tcSplitPredTy_maybe tau of { Just (ClassP clas tys) ->
 507     (tvs, theta, clas, tys) }}
 508 \end{code}
 509
 510
 511
 512 %************************************************************************
 513 %*                                                                      *
 514 \subsection{Predicate types}
 515 %*                                                                      *
 516 %************************************************************************
 517
 518 \begin{code}
 519 tcSplitPredTy_maybe :: Type -> Maybe PredType
 520    -- Returns Just for predicates only
 521 tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty
 522 tcSplitPredTy_maybe (PredTy p)    = Just p
 523 tcSplitPredTy_maybe other         = Nothing
 524
 525 predTyUnique :: PredType -> Unique
 526 predTyUnique (IParam n _)      = getUnique (ipNameName n)
 527 predTyUnique (ClassP clas tys) = getUnique clas
 528
 529 mkPredName :: Unique -> SrcLoc -> PredType -> Name
 530 mkPredName uniq loc (ClassP cls tys) = mkInternalName uniq (mkDictOcc (getOccName cls)) loc
 531 mkPredName uniq loc (IParam ip ty)   = mkInternalName uniq (getOccName (ipNameName ip)) loc
 532 \end{code}
 533
 534
 535 --------------------- Dictionary types ---------------------------------
 536
 537 \begin{code}
 538 mkClassPred clas tys = ClassP clas tys
 539
 540 isClassPred :: PredType -> Bool
 541 isClassPred (ClassP clas tys) = True
 542 isClassPred other             = False
 543
 544 isTyVarClassPred (ClassP clas tys) = all tcIsTyVarTy tys
 545 isTyVarClassPred other             = False
 546
 547 getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
 548 getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
 549 getClassPredTys_maybe _                 = Nothing
 550
 551 getClassPredTys :: PredType -> (Class, [Type])
 552 getClassPredTys (ClassP clas tys) = (clas, tys)
 553
 554 mkDictTy :: Class -> [Type] -> Type
 555 mkDictTy clas tys = mkPredTy (ClassP clas tys)
 556
 557 isDictTy :: Type -> Bool
 558 isDictTy (PredTy p)   = isClassPred p
 559 isDictTy (NoteTy _ ty)  = isDictTy ty
 560 isDictTy other          = False
 561 \end{code}
 562
 563 --------------------- Implicit parameters ---------------------------------
 564
 565 \begin{code}
 566 isIPPred :: PredType -> Bool
 567 isIPPred (IParam _ _) = True
 568 isIPPred other        = False
 569
 570 isInheritablePred :: PredType -> Bool
 571 -- Can be inherited by a context.  For example, consider
 572 --      f x = let g y = (?v, y+x)
 573 --            in (g 3 with ?v = 8,
 574 --                g 4 with ?v = 9)
 575 -- The point is that g's type must be quantifed over ?v:
 576 --      g :: (?v :: a) => a -> a
 577 -- but it doesn't need to be quantified over the Num a dictionary
 578 -- which can be free in g's rhs, and shared by both calls to g
 579 isInheritablePred (ClassP _ _) = True
 580 isInheritablePred other      = False
 581
 582 isLinearPred :: TcPredType -> Bool
 583 isLinearPred (IParam (Linear n) _) = True
 584 isLinearPred other                 = False
 585 \end{code}
 586
 587
 588 %************************************************************************
 589 %*                                                                      *
 590 \subsection{Comparison}
 591 %*                                                                      *
 592 %************************************************************************
 593
 594 Comparison, taking note of newtypes, predicates, etc,
 595
 596 \begin{code}
 597 tcEqType :: Type -> Type -> Bool
 598 tcEqType ty1 ty2 = case ty1 `tcCmpType` ty2 of { EQ -> True; other -> False }
 599
 600 tcEqTypes :: [Type] -> [Type] -> Bool
 601 tcEqTypes ty1 ty2 = case ty1 `tcCmpTypes` ty2 of { EQ -> True; other -> False }
 602
 603 tcEqPred :: PredType -> PredType -> Bool
 604 tcEqPred p1 p2 = case p1 `tcCmpPred` p2 of { EQ -> True; other -> False }
 605
 606 -------------
 607 tcCmpType :: Type -> Type -> Ordering
 608 tcCmpType ty1 ty2 = cmpTy emptyVarEnv ty1 ty2
 609
 610 tcCmpTypes tys1 tys2 = cmpTys emptyVarEnv tys1 tys2
 611
 612 tcCmpPred p1 p2 = cmpPredTy emptyVarEnv p1 p2
 613 -------------
 614 cmpTys env tys1 tys2 = cmpList (cmpTy env) tys1 tys2
 615
 616 -------------
 617 cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering
 618   -- The "env" maps type variables in ty1 to type variables in ty2
 619   -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
 620   -- we in effect substitute tv2 for tv1 in t1 before continuing
 621
 622     -- Look through NoteTy
 623 cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2
 624 cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2
 625
 626     -- Deal with equal constructors
 627 cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
 628                                           Just tv1a -> tv1a `compare` tv2
 629                                           Nothing   -> tv1  `compare` tv2
 630
 631 cmpTy env (PredTy p1) (PredTy p2) = cmpPredTy env p1 p2
 632 cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
 633 cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
 634 cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
 635 cmpTy env (ForAllTy tv1 t1)   (ForAllTy tv2 t2)   = cmpTy (extendVarEnv env tv1 tv2) t1 t2
 636
 637     -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < PredTy
 638 cmpTy env (AppTy _ _) (TyVarTy _) = GT
 639
 640 cmpTy env (FunTy _ _) (TyVarTy _) = GT
 641 cmpTy env (FunTy _ _) (AppTy _ _) = GT
 642
 643 cmpTy env (TyConApp _ _) (TyVarTy _) = GT
 644 cmpTy env (TyConApp _ _) (AppTy _ _) = GT
 645 cmpTy env (TyConApp _ _) (FunTy _ _) = GT
 646
 647 cmpTy env (ForAllTy _ _) (TyVarTy _)    = GT
 648 cmpTy env (ForAllTy _ _) (AppTy _ _)    = GT
 649 cmpTy env (ForAllTy _ _) (FunTy _ _)    = GT
 650 cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT
 651
 652 cmpTy env (PredTy _)   t2               = GT
 653
 654 cmpTy env _ _ = LT
 655 \end{code}
 656
 657 \begin{code}
 658 cmpPredTy :: TyVarEnv TyVar -> PredType -> PredType -> Ordering
 659 cmpPredTy env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2)
 660         -- Compare types as well as names for implicit parameters
 661         -- This comparison is used exclusively (I think) for the
 662         -- finite map built in TcSimplify
 663 cmpPredTy env (IParam _ _)     (ClassP _ _)       = LT
 664 cmpPredTy env (ClassP _ _)     (IParam _ _)     = GT
 665 cmpPredTy env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
 666 \end{code}
 667
 668 PredTypes are used as a FM key in TcSimplify,
 669 so we take the easy path and make them an instance of Ord
 670
 671 \begin{code}
 672 instance Eq  PredType where { (==)    = tcEqPred }
 673 instance Ord PredType where { compare = tcCmpPred }
 674 \end{code}
 675
 676
 677 %************************************************************************
 678 %*                                                                      *
 679 \subsection{Predicates}
 680 %*                                                                      *
 681 %************************************************************************
 682
 683 isSigmaTy returns true of any qualified type.  It doesn't *necessarily* have
 684 any foralls.  E.g.
 685         f :: (?x::Int) => Int -> Int
 686
 687 \begin{code}
 688 isSigmaTy :: Type -> Bool
 689 isSigmaTy (ForAllTy tyvar ty) = True
 690 isSigmaTy (FunTy a b)         = isPredTy a
 691 isSigmaTy (NoteTy n ty)       = isSigmaTy ty
 692 isSigmaTy _                   = False
 693
 694 isOverloadedTy :: Type -> Bool
 695 isOverloadedTy (ForAllTy tyvar ty) = isOverloadedTy ty
 696 isOverloadedTy (FunTy a b)         = isPredTy a
 697 isOverloadedTy (NoteTy n ty)       = isOverloadedTy ty
 698 isOverloadedTy _                   = False
 699
 700 isPredTy :: Type -> Bool        -- Belongs in TcType because it does
 701                                 -- not look through newtypes, or predtypes (of course)
 702 isPredTy (NoteTy _ ty) = isPredTy ty
 703 isPredTy (PredTy sty)  = True
 704 isPredTy _             = False
 705 \end{code}
 706
 707 \begin{code}
 708 isFloatTy      = is_tc floatTyConKey
 709 isDoubleTy     = is_tc doubleTyConKey
 710 isIntegerTy    = is_tc integerTyConKey
 711 isIntTy        = is_tc intTyConKey
 712 isAddrTy       = is_tc addrTyConKey
 713 isBoolTy       = is_tc boolTyConKey
 714 isUnitTy       = is_tc unitTyConKey
 715
 716 is_tc :: Unique -> Type -> Bool
 717 -- Newtypes are opaque to this
 718 is_tc uniq ty = case tcSplitTyConApp_maybe ty of
 719                         Just (tc, _) -> uniq == getUnique tc
 720                         Nothing      -> False
 721 \end{code}
 722
 723
 724 %************************************************************************
 725 %*                                                                      *
 726 \subsection{Misc}
 727 %*                                                                      *
 728 %************************************************************************
 729
 730 \begin{code}
 731 deNoteType :: Type -> Type
 732         -- Remove synonyms, but not predicate types
 733 deNoteType ty@(TyVarTy tyvar)   = ty
 734 deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
 735 deNoteType (PredTy p)           = PredTy (deNotePredType p)
 736 deNoteType (NoteTy _ ty)        = deNoteType ty
 737 deNoteType (AppTy fun arg)      = AppTy (deNoteType fun) (deNoteType arg)
 738 deNoteType (FunTy fun arg)      = FunTy (deNoteType fun) (deNoteType arg)
 739 deNoteType (ForAllTy tv ty)     = ForAllTy tv (deNoteType ty)
 740
 741 deNotePredType :: PredType -> PredType
 742 deNotePredType (ClassP c tys)   = ClassP c (map deNoteType tys)
 743 deNotePredType (IParam n ty)    = IParam n (deNoteType ty)
 744 \end{code}
 745
 746 Find the free tycons and classes of a type.  This is used in the front
 747 end of the compiler.
 748
 749 \begin{code}
 750 tyClsNamesOfType :: Type -> NameSet
 751 tyClsNamesOfType (TyVarTy tv)               = emptyNameSet
 752 tyClsNamesOfType (TyConApp tycon tys)       = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
 753 tyClsNamesOfType (NoteTy (SynNote ty1) ty2) = tyClsNamesOfType ty1
 754 tyClsNamesOfType (NoteTy other_note    ty2) = tyClsNamesOfType ty2
 755 tyClsNamesOfType (PredTy (IParam n ty))   = tyClsNamesOfType ty
 756 tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
 757 tyClsNamesOfType (FunTy arg res)            = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res
 758 tyClsNamesOfType (AppTy fun arg)            = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg
 759 tyClsNamesOfType (ForAllTy tyvar ty)        = tyClsNamesOfType ty
 760
 761 tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys
 762
 763 tyClsNamesOfDFunHead :: Type -> NameSet
 764 -- Find the free type constructors and classes
 765 -- of the head of the dfun instance type
 766 -- The 'dfun_head_type' is because of
 767 --      instance Foo a => Baz T where ...
 768 -- The decl is an orphan if Baz and T are both not locally defined,
 769 --      even if Foo *is* locally defined
 770 tyClsNamesOfDFunHead dfun_ty
 771   = case tcSplitSigmaTy dfun_ty of
 772         (tvs,_,head_ty) -> tyClsNamesOfType head_ty
 773
 774 classesOfTheta :: ThetaType -> [Class]
 775 -- Looks just for ClassP things; maybe it should check
 776 classesOfTheta preds = [ c | ClassP c _ <- preds ]
 777 \end{code}
 778
 779
 780 %************************************************************************
 781 %*                                                                      *
 782 \subsection[TysWiredIn-ext-type]{External types}
 783 %*                                                                      *
 784 %************************************************************************
 785
 786 The compiler's foreign function interface supports the passing of a
 787 restricted set of types as arguments and results (the restricting factor
 788 being the )
 789
 790 \begin{code}
 791 isFFITy :: Type -> Bool
 792 -- True for any TyCon that can possibly be an arg or result of an FFI call
 793 isFFITy ty = checkRepTyCon legalFFITyCon ty
 794
 795 isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
 796 -- Checks for valid argument type for a 'foreign import'
 797 isFFIArgumentTy dflags safety ty
 798    = checkRepTyCon (legalOutgoingTyCon dflags safety) ty
 799
 800 isFFIExternalTy :: Type -> Bool
 801 -- Types that are allowed as arguments of a 'foreign export'
 802 isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty
 803
 804 isFFIImportResultTy :: DynFlags -> Type -> Bool
 805 isFFIImportResultTy dflags ty
 806   = checkRepTyCon (legalFIResultTyCon dflags) ty
 807
 808 isFFIExportResultTy :: Type -> Bool
 809 isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
 810
 811 isFFIDynArgumentTy :: Type -> Bool
 812 -- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr,
 813 -- or a newtype of either.
 814 isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
 815
 816 isFFIDynResultTy :: Type -> Bool
 817 -- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr,
 818 -- or a newtype of either.
 819 isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
 820
 821 isFFILabelTy :: Type -> Bool
 822 -- The type of a foreign label must be Ptr, FunPtr, Addr,
 823 -- or a newtype of either.
 824 isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
 825
 826 isFFIDotnetTy :: DynFlags -> Type -> Bool
 827 isFFIDotnetTy dflags ty
 828   = checkRepTyCon (\ tc -> not (isByteArrayLikeTyCon tc) &&
 829                            (legalFIResultTyCon dflags tc ||
 830                            isFFIDotnetObjTy ty || isStringTy ty)) ty
 831
 832 -- Support String as an argument or result from a .NET FFI call.
 833 isStringTy ty =
 834   case tcSplitTyConApp_maybe (repType ty) of
 835     Just (tc, [arg_ty])
 836       | tc == listTyCon ->
 837         case tcSplitTyConApp_maybe (repType arg_ty) of
 838           Just (cc,[]) -> cc == charTyCon
 839           _ -> False
 840     _ -> False
 841
 842 -- Support String as an argument or result from a .NET FFI call.
 843 isFFIDotnetObjTy ty =
 844   let
 845    (_, t_ty) = tcSplitForAllTys ty
 846   in
 847   case tcSplitTyConApp_maybe (repType t_ty) of
 848     Just (tc, [arg_ty]) | getName tc == objectTyConName -> True
 849     _ -> False
 850
 851 toDNType :: Type -> DNType
 852 toDNType ty
 853   | isStringTy ty = DNString
 854   | isFFIDotnetObjTy ty = DNObject
 855   | Just (tc,argTys) <- tcSplitTyConApp_maybe ty =
 856      case lookup (getUnique tc) dn_assoc of
 857        Just x  -> x
 858        Nothing
 859          | tc `hasKey` ioTyConKey -> toDNType (head argTys)
 860          | otherwise -> pprPanic ("toDNType: unsupported .NET type") (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc)
 861     where
 862       dn_assoc :: [ (Unique, DNType) ]
 863       dn_assoc = [ (unitTyConKey,   DNUnit)
 864                  , (intTyConKey,    DNInt)
 865                  , (int8TyConKey,   DNInt8)
 866                  , (int16TyConKey,  DNInt16)
 867                  , (int32TyConKey,  DNInt32)
 868                  , (int64TyConKey,  DNInt64)
 869                  , (wordTyConKey,   DNInt)
 870                  , (word8TyConKey,  DNWord8)
 871                  , (word16TyConKey, DNWord16)
 872                  , (word32TyConKey, DNWord32)
 873                  , (word64TyConKey, DNWord64)
 874                  , (floatTyConKey,  DNFloat)
 875                  , (doubleTyConKey, DNDouble)
 876                  , (addrTyConKey,   DNPtr)
 877                  , (ptrTyConKey,    DNPtr)
 878                  , (funPtrTyConKey, DNPtr)
 879                  , (charTyConKey,   DNChar)
 880                  , (boolTyConKey,   DNBool)
 881                  ]
 882
 883 checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
 884         -- Look through newtypes
 885         -- Non-recursive ones are transparent to splitTyConApp,
 886         -- but recursive ones aren't.  Manuel had:
 887         --      newtype T = MkT (Ptr T)
 888         -- and wanted it to work...
 889 checkRepTyCon check_tc ty
 890   | Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc
 891   | otherwise                                       = False
 892
 893 checkRepTyConKey :: [Unique] -> Type -> Bool
 894 -- Like checkRepTyCon, but just looks at the TyCon key
 895 checkRepTyConKey keys
 896   = checkRepTyCon (\tc -> tyConUnique tc `elem` keys)
 897 \end{code}
 898
 899 ----------------------------------------------
 900 These chaps do the work; they are not exported
 901 ----------------------------------------------
 902
 903 \begin{code}
 904 legalFEArgTyCon :: TyCon -> Bool
 905 -- It's illegal to return foreign objects and (mutable)
 906 -- bytearrays from a _ccall_ / foreign declaration
 907 -- (or be passed them as arguments in foreign exported functions).
 908 legalFEArgTyCon tc
 909   | isByteArrayLikeTyCon tc
 910   = False
 911   -- It's also illegal to make foreign exports that take unboxed
 912   -- arguments.  The RTS API currently can't invoke such things.  --SDM 7/2000
 913   | otherwise
 914   = boxedMarshalableTyCon tc
 915
 916 legalFIResultTyCon :: DynFlags -> TyCon -> Bool
 917 legalFIResultTyCon dflags tc
 918   | isByteArrayLikeTyCon tc = False
 919   | tc == unitTyCon         = True
 920   | otherwise               = marshalableTyCon dflags tc
 921
 922 legalFEResultTyCon :: TyCon -> Bool
 923 legalFEResultTyCon tc
 924   | isByteArrayLikeTyCon tc = False
 925   | tc == unitTyCon         = True
 926   | otherwise               = boxedMarshalableTyCon tc
 927
 928 legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
 929 -- Checks validity of types going from Haskell -> external world
 930 legalOutgoingTyCon dflags safety tc
 931   | playSafe safety && isByteArrayLikeTyCon tc
 932   = False
 933   | otherwise
 934   = marshalableTyCon dflags tc
 935
 936 legalFFITyCon :: TyCon -> Bool
 937 -- True for any TyCon that can possibly be an arg or result of an FFI call
 938 legalFFITyCon tc
 939   = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon
 940
 941 marshalableTyCon dflags tc
 942   =  (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
 943   || boxedMarshalableTyCon tc
 944
 945 boxedMarshalableTyCon tc
 946    = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
 947                          , int32TyConKey, int64TyConKey
 948                          , wordTyConKey, word8TyConKey, word16TyConKey
 949                          , word32TyConKey, word64TyConKey
 950                          , floatTyConKey, doubleTyConKey
 951                          , addrTyConKey, ptrTyConKey, funPtrTyConKey
 952                          , charTyConKey
 953                          , stablePtrTyConKey
 954                          , byteArrayTyConKey, mutableByteArrayTyConKey
 955                          , boolTyConKey
 956                          ]
 957
 958 isByteArrayLikeTyCon :: TyCon -> Bool
 959 isByteArrayLikeTyCon tc =
 960   getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
 961 \end{code}
 962
 963