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, 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
 484 tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
 485 -- Split the type of a dictionary function
 486 tcSplitDFunTy ty
 487   = case tcSplitSigmaTy ty       of { (tvs, theta, tau) ->
 488     case tcSplitPredTy_maybe tau of { Just (ClassP clas tys) ->
 489     (tvs, theta, clas, tys) }}
 490 \end{code}
 491
 492
 493
 494 %************************************************************************
 495 %*                                                                      *
 496 \subsection{Predicate types}
 497 %*                                                                      *
 498 %************************************************************************
 499
 500 \begin{code}
 501 tcSplitPredTy_maybe :: Type -> Maybe PredType
 502    -- Returns Just for predicates only
 503 tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty
 504 tcSplitPredTy_maybe (PredTy p)    = Just p
 505 tcSplitPredTy_maybe other         = Nothing
 506
 507 predTyUnique :: PredType -> Unique
 508 predTyUnique (IParam n _)      = getUnique (ipNameName n)
 509 predTyUnique (ClassP clas tys) = getUnique clas
 510
 511 mkPredName :: Unique -> SrcLoc -> PredType -> Name
 512 mkPredName uniq loc (ClassP cls tys) = mkInternalName uniq (mkDictOcc (getOccName cls)) loc
 513 mkPredName uniq loc (IParam ip ty)   = mkInternalName uniq (getOccName (ipNameName ip)) loc
 514 \end{code}
 515
 516
 517 --------------------- Dictionary types ---------------------------------
 518
 519 \begin{code}
 520 mkClassPred clas tys = ClassP clas tys
 521
 522 isClassPred :: PredType -> Bool
 523 isClassPred (ClassP clas tys) = True
 524 isClassPred other             = False
 525
 526 isTyVarClassPred (ClassP clas tys) = all tcIsTyVarTy tys
 527 isTyVarClassPred other             = False
 528
 529 getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
 530 getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
 531 getClassPredTys_maybe _                 = Nothing
 532
 533 getClassPredTys :: PredType -> (Class, [Type])
 534 getClassPredTys (ClassP clas tys) = (clas, tys)
 535
 536 mkDictTy :: Class -> [Type] -> Type
 537 mkDictTy clas tys = mkPredTy (ClassP clas tys)
 538
 539 isDictTy :: Type -> Bool
 540 isDictTy (PredTy p)   = isClassPred p
 541 isDictTy (NoteTy _ ty)  = isDictTy ty
 542 isDictTy other          = False
 543 \end{code}
 544
 545 --------------------- Implicit parameters ---------------------------------
 546
 547 \begin{code}
 548 isIPPred :: PredType -> Bool
 549 isIPPred (IParam _ _) = True
 550 isIPPred other        = False
 551
 552 isInheritablePred :: PredType -> Bool
 553 -- Can be inherited by a context.  For example, consider
 554 --      f x = let g y = (?v, y+x)
 555 --            in (g 3 with ?v = 8,
 556 --                g 4 with ?v = 9)
 557 -- The point is that g's type must be quantifed over ?v:
 558 --      g :: (?v :: a) => a -> a
 559 -- but it doesn't need to be quantified over the Num a dictionary
 560 -- which can be free in g's rhs, and shared by both calls to g
 561 isInheritablePred (ClassP _ _) = True
 562 isInheritablePred other      = False
 563
 564 isLinearPred :: TcPredType -> Bool
 565 isLinearPred (IParam (Linear n) _) = True
 566 isLinearPred other                 = False
 567 \end{code}
 568
 569
 570 %************************************************************************
 571 %*                                                                      *
 572 \subsection{Comparison}
 573 %*                                                                      *
 574 %************************************************************************
 575
 576 Comparison, taking note of newtypes, predicates, etc,
 577
 578 \begin{code}
 579 tcEqType :: Type -> Type -> Bool
 580 tcEqType ty1 ty2 = case ty1 `tcCmpType` ty2 of { EQ -> True; other -> False }
 581
 582 tcEqTypes :: [Type] -> [Type] -> Bool
 583 tcEqTypes ty1 ty2 = case ty1 `tcCmpTypes` ty2 of { EQ -> True; other -> False }
 584
 585 tcEqPred :: PredType -> PredType -> Bool
 586 tcEqPred p1 p2 = case p1 `tcCmpPred` p2 of { EQ -> True; other -> False }
 587
 588 -------------
 589 tcCmpType :: Type -> Type -> Ordering
 590 tcCmpType ty1 ty2 = cmpTy emptyVarEnv ty1 ty2
 591
 592 tcCmpTypes tys1 tys2 = cmpTys emptyVarEnv tys1 tys2
 593
 594 tcCmpPred p1 p2 = cmpPredTy emptyVarEnv p1 p2
 595 -------------
 596 cmpTys env tys1 tys2 = cmpList (cmpTy env) tys1 tys2
 597
 598 -------------
 599 cmpTy :: TyVarEnv TyVar -> Type -> Type -> Ordering
 600   -- The "env" maps type variables in ty1 to type variables in ty2
 601   -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
 602   -- we in effect substitute tv2 for tv1 in t1 before continuing
 603
 604     -- Look through NoteTy
 605 cmpTy env (NoteTy _ ty1) ty2 = cmpTy env ty1 ty2
 606 cmpTy env ty1 (NoteTy _ ty2) = cmpTy env ty1 ty2
 607
 608     -- Deal with equal constructors
 609 cmpTy env (TyVarTy tv1) (TyVarTy tv2) = case lookupVarEnv env tv1 of
 610                                           Just tv1a -> tv1a `compare` tv2
 611                                           Nothing   -> tv1  `compare` tv2
 612
 613 cmpTy env (PredTy p1) (PredTy p2) = cmpPredTy env p1 p2
 614 cmpTy env (AppTy f1 a1) (AppTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
 615 cmpTy env (FunTy f1 a1) (FunTy f2 a2) = cmpTy env f1 f2 `thenCmp` cmpTy env a1 a2
 616 cmpTy env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmpTys env tys1 tys2)
 617 cmpTy env (ForAllTy tv1 t1)   (ForAllTy tv2 t2)   = cmpTy (extendVarEnv env tv1 tv2) t1 t2
 618
 619     -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < PredTy
 620 cmpTy env (AppTy _ _) (TyVarTy _) = GT
 621
 622 cmpTy env (FunTy _ _) (TyVarTy _) = GT
 623 cmpTy env (FunTy _ _) (AppTy _ _) = GT
 624
 625 cmpTy env (TyConApp _ _) (TyVarTy _) = GT
 626 cmpTy env (TyConApp _ _) (AppTy _ _) = GT
 627 cmpTy env (TyConApp _ _) (FunTy _ _) = GT
 628
 629 cmpTy env (ForAllTy _ _) (TyVarTy _)    = GT
 630 cmpTy env (ForAllTy _ _) (AppTy _ _)    = GT
 631 cmpTy env (ForAllTy _ _) (FunTy _ _)    = GT
 632 cmpTy env (ForAllTy _ _) (TyConApp _ _) = GT
 633
 634 cmpTy env (PredTy _)   t2               = GT
 635
 636 cmpTy env _ _ = LT
 637 \end{code}
 638
 639 \begin{code}
 640 cmpPredTy :: TyVarEnv TyVar -> PredType -> PredType -> Ordering
 641 cmpPredTy env (IParam n1 ty1) (IParam n2 ty2) = (n1 `compare` n2) `thenCmp` (cmpTy env ty1 ty2)
 642         -- Compare types as well as names for implicit parameters
 643         -- This comparison is used exclusively (I think) for the
 644         -- finite map built in TcSimplify
 645 cmpPredTy env (IParam _ _)     (ClassP _ _)       = LT
 646 cmpPredTy env (ClassP _ _)     (IParam _ _)     = GT
 647 cmpPredTy env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
 648 \end{code}
 649
 650 PredTypes are used as a FM key in TcSimplify,
 651 so we take the easy path and make them an instance of Ord
 652
 653 \begin{code}
 654 instance Eq  PredType where { (==)    = tcEqPred }
 655 instance Ord PredType where { compare = tcCmpPred }
 656 \end{code}
 657
 658
 659 %************************************************************************
 660 %*                                                                      *
 661 \subsection{Predicates}
 662 %*                                                                      *
 663 %************************************************************************
 664
 665 isSigmaTy returns true of any qualified type.  It doesn't *necessarily* have
 666 any foralls.  E.g.
 667         f :: (?x::Int) => Int -> Int
 668
 669 \begin{code}
 670 isSigmaTy :: Type -> Bool
 671 isSigmaTy (ForAllTy tyvar ty) = True
 672 isSigmaTy (FunTy a b)         = isPredTy a
 673 isSigmaTy (NoteTy n ty)       = isSigmaTy ty
 674 isSigmaTy _                   = False
 675
 676 isOverloadedTy :: Type -> Bool
 677 isOverloadedTy (ForAllTy tyvar ty) = isOverloadedTy ty
 678 isOverloadedTy (FunTy a b)         = isPredTy a
 679 isOverloadedTy (NoteTy n ty)       = isOverloadedTy ty
 680 isOverloadedTy _                   = False
 681
 682 isPredTy :: Type -> Bool        -- Belongs in TcType because it does
 683                                 -- not look through newtypes, or predtypes (of course)
 684 isPredTy (NoteTy _ ty) = isPredTy ty
 685 isPredTy (PredTy sty)  = True
 686 isPredTy _             = False
 687 \end{code}
 688
 689 \begin{code}
 690 isFloatTy      = is_tc floatTyConKey
 691 isDoubleTy     = is_tc doubleTyConKey
 692 isIntegerTy    = is_tc integerTyConKey
 693 isIntTy        = is_tc intTyConKey
 694 isAddrTy       = is_tc addrTyConKey
 695 isBoolTy       = is_tc boolTyConKey
 696 isUnitTy       = is_tc unitTyConKey
 697
 698 is_tc :: Unique -> Type -> Bool
 699 -- Newtypes are opaque to this
 700 is_tc uniq ty = case tcSplitTyConApp_maybe ty of
 701                         Just (tc, _) -> uniq == getUnique tc
 702                         Nothing      -> False
 703 \end{code}
 704
 705
 706 %************************************************************************
 707 %*                                                                      *
 708 \subsection{Misc}
 709 %*                                                                      *
 710 %************************************************************************
 711
 712 \begin{code}
 713 deNoteType :: Type -> Type
 714         -- Remove synonyms, but not predicate types
 715 deNoteType ty@(TyVarTy tyvar)   = ty
 716 deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
 717 deNoteType (PredTy p)           = PredTy (deNotePredType p)
 718 deNoteType (NoteTy _ ty)        = deNoteType ty
 719 deNoteType (AppTy fun arg)      = AppTy (deNoteType fun) (deNoteType arg)
 720 deNoteType (FunTy fun arg)      = FunTy (deNoteType fun) (deNoteType arg)
 721 deNoteType (ForAllTy tv ty)     = ForAllTy tv (deNoteType ty)
 722
 723 deNotePredType :: PredType -> PredType
 724 deNotePredType (ClassP c tys)   = ClassP c (map deNoteType tys)
 725 deNotePredType (IParam n ty)    = IParam n (deNoteType ty)
 726 \end{code}
 727
 728 Find the free tycons and classes of a type.  This is used in the front
 729 end of the compiler.
 730
 731 \begin{code}
 732 tyClsNamesOfType :: Type -> NameSet
 733 tyClsNamesOfType (TyVarTy tv)               = emptyNameSet
 734 tyClsNamesOfType (TyConApp tycon tys)       = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
 735 tyClsNamesOfType (NoteTy (SynNote ty1) ty2) = tyClsNamesOfType ty1
 736 tyClsNamesOfType (NoteTy other_note    ty2) = tyClsNamesOfType ty2
 737 tyClsNamesOfType (PredTy (IParam n ty))   = tyClsNamesOfType ty
 738 tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
 739 tyClsNamesOfType (FunTy arg res)            = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res
 740 tyClsNamesOfType (AppTy fun arg)            = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg
 741 tyClsNamesOfType (ForAllTy tyvar ty)        = tyClsNamesOfType ty
 742
 743 tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys
 744
 745 tyClsNamesOfDFunHead :: Type -> NameSet
 746 -- Find the free type constructors and classes
 747 -- of the head of the dfun instance type
 748 -- The 'dfun_head_type' is because of
 749 --      instance Foo a => Baz T where ...
 750 -- The decl is an orphan if Baz and T are both not locally defined,
 751 --      even if Foo *is* locally defined
 752 tyClsNamesOfDFunHead dfun_ty
 753   = case tcSplitSigmaTy dfun_ty of
 754         (tvs,_,head_ty) -> tyClsNamesOfType head_ty
 755
 756 classesOfTheta :: ThetaType -> [Class]
 757 -- Looks just for ClassP things; maybe it should check
 758 classesOfTheta preds = [ c | ClassP c _ <- preds ]
 759 \end{code}
 760
 761
 762 %************************************************************************
 763 %*                                                                      *
 764 \subsection[TysWiredIn-ext-type]{External types}
 765 %*                                                                      *
 766 %************************************************************************
 767
 768 The compiler's foreign function interface supports the passing of a
 769 restricted set of types as arguments and results (the restricting factor
 770 being the )
 771
 772 \begin{code}
 773 isFFITy :: Type -> Bool
 774 -- True for any TyCon that can possibly be an arg or result of an FFI call
 775 isFFITy ty = checkRepTyCon legalFFITyCon ty
 776
 777 isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
 778 -- Checks for valid argument type for a 'foreign import'
 779 isFFIArgumentTy dflags safety ty
 780    = checkRepTyCon (legalOutgoingTyCon dflags safety) ty
 781
 782 isFFIExternalTy :: Type -> Bool
 783 -- Types that are allowed as arguments of a 'foreign export'
 784 isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty
 785
 786 isFFIImportResultTy :: DynFlags -> Type -> Bool
 787 isFFIImportResultTy dflags ty
 788   = checkRepTyCon (legalFIResultTyCon dflags) ty
 789
 790 isFFIExportResultTy :: Type -> Bool
 791 isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
 792
 793 isFFIDynArgumentTy :: Type -> Bool
 794 -- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr,
 795 -- or a newtype of either.
 796 isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
 797
 798 isFFIDynResultTy :: Type -> Bool
 799 -- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr,
 800 -- or a newtype of either.
 801 isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
 802
 803 isFFILabelTy :: Type -> Bool
 804 -- The type of a foreign label must be Ptr, FunPtr, Addr,
 805 -- or a newtype of either.
 806 isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
 807
 808 isFFIDotnetTy :: DynFlags -> Type -> Bool
 809 isFFIDotnetTy dflags ty
 810   = checkRepTyCon (\ tc -> not (isByteArrayLikeTyCon tc) &&
 811                            (legalFIResultTyCon dflags tc ||
 812                            isFFIDotnetObjTy ty || isStringTy ty)) ty
 813
 814 -- Support String as an argument or result from a .NET FFI call.
 815 isStringTy ty =
 816   case tcSplitTyConApp_maybe (repType ty) of
 817     Just (tc, [arg_ty])
 818       | tc == listTyCon ->
 819         case tcSplitTyConApp_maybe (repType arg_ty) of
 820           Just (cc,[]) -> cc == charTyCon
 821           _ -> False
 822     _ -> False
 823
 824 -- Support String as an argument or result from a .NET FFI call.
 825 isFFIDotnetObjTy ty =
 826   let
 827    (_, t_ty) = tcSplitForAllTys ty
 828   in
 829   case tcSplitTyConApp_maybe (repType t_ty) of
 830     Just (tc, [arg_ty]) | getName tc == objectTyConName -> True
 831     _ -> False
 832
 833 toDNType :: Type -> DNType
 834 toDNType ty
 835   | isStringTy ty = DNString
 836   | isFFIDotnetObjTy ty = DNObject
 837   | Just (tc,argTys) <- tcSplitTyConApp_maybe ty =
 838      case lookup (getUnique tc) dn_assoc of
 839        Just x  -> x
 840        Nothing
 841          | tc `hasKey` ioTyConKey -> toDNType (head argTys)
 842          | otherwise -> pprPanic ("toDNType: unsupported .NET type") (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc)
 843     where
 844       dn_assoc :: [ (Unique, DNType) ]
 845       dn_assoc = [ (unitTyConKey,   DNUnit)
 846                  , (intTyConKey,    DNInt)
 847                  , (int8TyConKey,   DNInt8)
 848                  , (int16TyConKey,  DNInt16)
 849                  , (int32TyConKey,  DNInt32)
 850                  , (int64TyConKey,  DNInt64)
 851                  , (wordTyConKey,   DNInt)
 852                  , (word8TyConKey,  DNWord8)
 853                  , (word16TyConKey, DNWord16)
 854                  , (word32TyConKey, DNWord32)
 855                  , (word64TyConKey, DNWord64)
 856                  , (floatTyConKey,  DNFloat)
 857                  , (doubleTyConKey, DNDouble)
 858                  , (addrTyConKey,   DNPtr)
 859                  , (ptrTyConKey,    DNPtr)
 860                  , (funPtrTyConKey, DNPtr)
 861                  , (charTyConKey,   DNChar)
 862                  , (boolTyConKey,   DNBool)
 863                  ]
 864
 865 checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
 866         -- Look through newtypes
 867         -- Non-recursive ones are transparent to splitTyConApp,
 868         -- but recursive ones aren't.  Manuel had:
 869         --      newtype T = MkT (Ptr T)
 870         -- and wanted it to work...
 871 checkRepTyCon check_tc ty
 872   | Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc
 873   | otherwise                                       = False
 874
 875 checkRepTyConKey :: [Unique] -> Type -> Bool
 876 -- Like checkRepTyCon, but just looks at the TyCon key
 877 checkRepTyConKey keys
 878   = checkRepTyCon (\tc -> tyConUnique tc `elem` keys)
 879 \end{code}
 880
 881 ----------------------------------------------
 882 These chaps do the work; they are not exported
 883 ----------------------------------------------
 884
 885 \begin{code}
 886 legalFEArgTyCon :: TyCon -> Bool
 887 -- It's illegal to return foreign objects and (mutable)
 888 -- bytearrays from a _ccall_ / foreign declaration
 889 -- (or be passed them as arguments in foreign exported functions).
 890 legalFEArgTyCon tc
 891   | isByteArrayLikeTyCon tc
 892   = False
 893   -- It's also illegal to make foreign exports that take unboxed
 894   -- arguments.  The RTS API currently can't invoke such things.  --SDM 7/2000
 895   | otherwise
 896   = boxedMarshalableTyCon tc
 897
 898 legalFIResultTyCon :: DynFlags -> TyCon -> Bool
 899 legalFIResultTyCon dflags tc
 900   | isByteArrayLikeTyCon tc = False
 901   | tc == unitTyCon         = True
 902   | otherwise               = marshalableTyCon dflags tc
 903
 904 legalFEResultTyCon :: TyCon -> Bool
 905 legalFEResultTyCon tc
 906   | isByteArrayLikeTyCon tc = False
 907   | tc == unitTyCon         = True
 908   | otherwise               = boxedMarshalableTyCon tc
 909
 910 legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
 911 -- Checks validity of types going from Haskell -> external world
 912 legalOutgoingTyCon dflags safety tc
 913   | playSafe safety && isByteArrayLikeTyCon tc
 914   = False
 915   | otherwise
 916   = marshalableTyCon dflags tc
 917
 918 legalFFITyCon :: TyCon -> Bool
 919 -- True for any TyCon that can possibly be an arg or result of an FFI call
 920 legalFFITyCon tc
 921   = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon
 922
 923 marshalableTyCon dflags tc
 924   =  (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
 925   || boxedMarshalableTyCon tc
 926
 927 boxedMarshalableTyCon tc
 928    = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
 929                          , int32TyConKey, int64TyConKey
 930                          , wordTyConKey, word8TyConKey, word16TyConKey
 931                          , word32TyConKey, word64TyConKey
 932                          , floatTyConKey, doubleTyConKey
 933                          , addrTyConKey, ptrTyConKey, funPtrTyConKey
 934                          , charTyConKey
 935                          , stablePtrTyConKey
 936                          , byteArrayTyConKey, mutableByteArrayTyConKey
 937                          , boolTyConKey
 938                          ]
 939
 940 isByteArrayLikeTyCon :: TyCon -> Bool
 941 isByteArrayLikeTyCon tc =
 942   getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
 943 \end{code}
 944
 945