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