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