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