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, hoistForAllTys,
  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, deShadowTy,
 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 %************************************************************************
 626 %*                                                                      *
 627                 Hoisting for-alls
 628 %*                                                                      *
 629 %************************************************************************
 630
 631 hoistForAllTys is used for user-written type signatures only
 632 We want to 'look through' type synonyms when doing this
 633 so it's better done on the Type than the HsType
 634
 635 It moves all the foralls and constraints to the top
 636 e.g.    T -> forall a. a        ==>   forall a. T -> a
 637         T -> (?x::Int) -> Int   ==>   (?x::Int) -> T -> Int
 638
 639 Also: it eliminates duplicate constraints.  These can show up
 640 when hoisting constraints, notably implicit parameters.
 641
 642 It tries hard to retain type synonyms if hoisting does not break one
 643 up.  Not only does this improve error messages, but there's a tricky
 644 interaction with Haskell 98.  H98 requires no unsaturated type
 645 synonyms, which is checked by checkValidType.  This runs after
 646 hoisting, so we don't want hoisting to remove the SynNotes!  (We can't
 647 run validity checking before hoisting because in mutually-recursive
 648 type definitions we postpone validity checking until after the knot is
 649 tied.)
 650
 651 \begin{code}
 652 hoistForAllTys :: Type -> Type
 653 hoistForAllTys ty
 654   = go (deShadowTy ty)
 655         -- Running over ty with an empty substitution gives it the
 656         -- no-shadowing property.  This is important.  For example:
 657         --      type Foo r = forall a. a -> r
 658         --      foo :: Foo (Foo ())
 659         -- Here the hoisting should give
 660         --      foo :: forall a a1. a -> a1 -> ()
 661         --
 662         -- What about type vars that are lexically in scope in the envt?
 663         -- We simply rely on them having a different unique to any
 664         -- binder in 'ty'.  Otherwise we'd have to slurp the in-scope-tyvars
 665         -- out of the envt, which is boring and (I think) not necessary.
 666
 667   where
 668     go (TyVarTy tv)                = TyVarTy tv
 669     go (TyConApp tc tys)           = TyConApp tc (map go tys)
 670     go (PredTy pred)               = PredTy pred    -- No nested foralls
 671     go (NoteTy (SynNote ty1) ty2)  = NoteTy (SynNote (go ty1)) (go ty2)
 672     go (NoteTy (FTVNote _) ty2)    = go ty2         -- Discard the free tyvar note
 673     go (FunTy arg res)             = mk_fun_ty (go arg) (go res)
 674     go (AppTy fun arg)             = AppTy (go fun) (go arg)
 675     go (ForAllTy tv ty)            = ForAllTy tv (go ty)
 676
 677         -- mk_fun_ty does all the work.
 678         -- It's building t1 -> t2:
 679         --      if t2 is a for-all type, push t1 inside it
 680         --      if t2 is (pred -> t3), check for duplicates
 681     mk_fun_ty ty1 ty2
 682         | not (isOverloadedTy ty2)      -- No forall's, or context =>
 683         = FunTy ty1 ty2
 684         | PredTy p1 <- ty1              -- ty1 is a predicate
 685         = if p1 `elem` theta then       -- so check for duplicates
 686                 ty2
 687           else
 688                 mkSigmaTy tvs (p1:theta) tau
 689         | otherwise
 690         = mkSigmaTy tvs theta (FunTy ty1 tau)
 691         where
 692           (tvs, theta, tau) = tcSplitSigmaTy ty2
 693 \end{code}
 694
 695
 696 %************************************************************************
 697 %*                                                                      *
 698 \subsection{Misc}
 699 %*                                                                      *
 700 %************************************************************************
 701
 702 \begin{code}
 703 deNoteType :: Type -> Type
 704         -- Remove synonyms, but not predicate types
 705 deNoteType ty@(TyVarTy tyvar)   = ty
 706 deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
 707 deNoteType (PredTy p)           = PredTy (deNotePredType p)
 708 deNoteType (NoteTy _ ty)        = deNoteType ty
 709 deNoteType (AppTy fun arg)      = AppTy (deNoteType fun) (deNoteType arg)
 710 deNoteType (FunTy fun arg)      = FunTy (deNoteType fun) (deNoteType arg)
 711 deNoteType (ForAllTy tv ty)     = ForAllTy tv (deNoteType ty)
 712
 713 deNotePredType :: PredType -> PredType
 714 deNotePredType (ClassP c tys)   = ClassP c (map deNoteType tys)
 715 deNotePredType (IParam n ty)    = IParam n (deNoteType ty)
 716 \end{code}
 717
 718 Find the free tycons and classes of a type.  This is used in the front
 719 end of the compiler.
 720
 721 \begin{code}
 722 tyClsNamesOfType :: Type -> NameSet
 723 tyClsNamesOfType (TyVarTy tv)               = emptyNameSet
 724 tyClsNamesOfType (TyConApp tycon tys)       = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
 725 tyClsNamesOfType (NoteTy (SynNote ty1) ty2) = tyClsNamesOfType ty1
 726 tyClsNamesOfType (NoteTy other_note    ty2) = tyClsNamesOfType ty2
 727 tyClsNamesOfType (PredTy (IParam n ty))   = tyClsNamesOfType ty
 728 tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
 729 tyClsNamesOfType (FunTy arg res)            = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res
 730 tyClsNamesOfType (AppTy fun arg)            = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg
 731 tyClsNamesOfType (ForAllTy tyvar ty)        = tyClsNamesOfType ty
 732
 733 tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys
 734
 735 tyClsNamesOfDFunHead :: Type -> NameSet
 736 -- Find the free type constructors and classes
 737 -- of the head of the dfun instance type
 738 -- The 'dfun_head_type' is because of
 739 --      instance Foo a => Baz T where ...
 740 -- The decl is an orphan if Baz and T are both not locally defined,
 741 --      even if Foo *is* locally defined
 742 tyClsNamesOfDFunHead dfun_ty
 743   = case tcSplitSigmaTy dfun_ty of
 744         (tvs,_,head_ty) -> tyClsNamesOfType head_ty
 745
 746 classesOfTheta :: ThetaType -> [Class]
 747 -- Looks just for ClassP things; maybe it should check
 748 classesOfTheta preds = [ c | ClassP c _ <- preds ]
 749 \end{code}
 750
 751
 752 %************************************************************************
 753 %*                                                                      *
 754 \subsection[TysWiredIn-ext-type]{External types}
 755 %*                                                                      *
 756 %************************************************************************
 757
 758 The compiler's foreign function interface supports the passing of a
 759 restricted set of types as arguments and results (the restricting factor
 760 being the )
 761
 762 \begin{code}
 763 isFFITy :: Type -> Bool
 764 -- True for any TyCon that can possibly be an arg or result of an FFI call
 765 isFFITy ty = checkRepTyCon legalFFITyCon ty
 766
 767 isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
 768 -- Checks for valid argument type for a 'foreign import'
 769 isFFIArgumentTy dflags safety ty
 770    = checkRepTyCon (legalOutgoingTyCon dflags safety) ty
 771
 772 isFFIExternalTy :: Type -> Bool
 773 -- Types that are allowed as arguments of a 'foreign export'
 774 isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty
 775
 776 isFFIImportResultTy :: DynFlags -> Type -> Bool
 777 isFFIImportResultTy dflags ty
 778   = checkRepTyCon (legalFIResultTyCon dflags) ty
 779
 780 isFFIExportResultTy :: Type -> Bool
 781 isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
 782
 783 isFFIDynArgumentTy :: Type -> Bool
 784 -- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr,
 785 -- or a newtype of either.
 786 isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
 787
 788 isFFIDynResultTy :: Type -> Bool
 789 -- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr,
 790 -- or a newtype of either.
 791 isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
 792
 793 isFFILabelTy :: Type -> Bool
 794 -- The type of a foreign label must be Ptr, FunPtr, Addr,
 795 -- or a newtype of either.
 796 isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
 797
 798 isFFIDotnetTy :: DynFlags -> Type -> Bool
 799 isFFIDotnetTy dflags ty
 800   = checkRepTyCon (\ tc -> not (isByteArrayLikeTyCon tc) &&
 801                            (legalFIResultTyCon dflags tc ||
 802                            isFFIDotnetObjTy ty || isStringTy ty)) ty
 803
 804 -- Support String as an argument or result from a .NET FFI call.
 805 isStringTy ty =
 806   case tcSplitTyConApp_maybe (repType ty) of
 807     Just (tc, [arg_ty])
 808       | tc == listTyCon ->
 809         case tcSplitTyConApp_maybe (repType arg_ty) of
 810           Just (cc,[]) -> cc == charTyCon
 811           _ -> False
 812     _ -> False
 813
 814 -- Support String as an argument or result from a .NET FFI call.
 815 isFFIDotnetObjTy ty =
 816   let
 817    (_, t_ty) = tcSplitForAllTys ty
 818   in
 819   case tcSplitTyConApp_maybe (repType t_ty) of
 820     Just (tc, [arg_ty]) | getName tc == objectTyConName -> True
 821     _ -> False
 822
 823 toDNType :: Type -> DNType
 824 toDNType ty
 825   | isStringTy ty = DNString
 826   | isFFIDotnetObjTy ty = DNObject
 827   | Just (tc,argTys) <- tcSplitTyConApp_maybe ty =
 828      case lookup (getUnique tc) dn_assoc of
 829        Just x  -> x
 830        Nothing
 831          | tc `hasKey` ioTyConKey -> toDNType (head argTys)
 832          | otherwise -> pprPanic ("toDNType: unsupported .NET type") (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc)
 833     where
 834       dn_assoc :: [ (Unique, DNType) ]
 835       dn_assoc = [ (unitTyConKey,   DNUnit)
 836                  , (intTyConKey,    DNInt)
 837                  , (int8TyConKey,   DNInt8)
 838                  , (int16TyConKey,  DNInt16)
 839                  , (int32TyConKey,  DNInt32)
 840                  , (int64TyConKey,  DNInt64)
 841                  , (wordTyConKey,   DNInt)
 842                  , (word8TyConKey,  DNWord8)
 843                  , (word16TyConKey, DNWord16)
 844                  , (word32TyConKey, DNWord32)
 845                  , (word64TyConKey, DNWord64)
 846                  , (floatTyConKey,  DNFloat)
 847                  , (doubleTyConKey, DNDouble)
 848                  , (addrTyConKey,   DNPtr)
 849                  , (ptrTyConKey,    DNPtr)
 850                  , (funPtrTyConKey, DNPtr)
 851                  , (charTyConKey,   DNChar)
 852                  , (boolTyConKey,   DNBool)
 853                  ]
 854
 855 checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
 856         -- Look through newtypes
 857         -- Non-recursive ones are transparent to splitTyConApp,
 858         -- but recursive ones aren't.  Manuel had:
 859         --      newtype T = MkT (Ptr T)
 860         -- and wanted it to work...
 861 checkRepTyCon check_tc ty
 862   | Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc
 863   | otherwise                                       = False
 864
 865 checkRepTyConKey :: [Unique] -> Type -> Bool
 866 -- Like checkRepTyCon, but just looks at the TyCon key
 867 checkRepTyConKey keys
 868   = checkRepTyCon (\tc -> tyConUnique tc `elem` keys)
 869 \end{code}
 870
 871 ----------------------------------------------
 872 These chaps do the work; they are not exported
 873 ----------------------------------------------
 874
 875 \begin{code}
 876 legalFEArgTyCon :: TyCon -> Bool
 877 -- It's illegal to return foreign objects and (mutable)
 878 -- bytearrays from a _ccall_ / foreign declaration
 879 -- (or be passed them as arguments in foreign exported functions).
 880 legalFEArgTyCon tc
 881   | isByteArrayLikeTyCon tc
 882   = False
 883   -- It's also illegal to make foreign exports that take unboxed
 884   -- arguments.  The RTS API currently can't invoke such things.  --SDM 7/2000
 885   | otherwise
 886   = boxedMarshalableTyCon tc
 887
 888 legalFIResultTyCon :: DynFlags -> TyCon -> Bool
 889 legalFIResultTyCon dflags tc
 890   | isByteArrayLikeTyCon tc = False
 891   | tc == unitTyCon         = True
 892   | otherwise               = marshalableTyCon dflags tc
 893
 894 legalFEResultTyCon :: TyCon -> Bool
 895 legalFEResultTyCon tc
 896   | isByteArrayLikeTyCon tc = False
 897   | tc == unitTyCon         = True
 898   | otherwise               = boxedMarshalableTyCon tc
 899
 900 legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
 901 -- Checks validity of types going from Haskell -> external world
 902 legalOutgoingTyCon dflags safety tc
 903   | playSafe safety && isByteArrayLikeTyCon tc
 904   = False
 905   | otherwise
 906   = marshalableTyCon dflags tc
 907
 908 legalFFITyCon :: TyCon -> Bool
 909 -- True for any TyCon that can possibly be an arg or result of an FFI call
 910 legalFFITyCon tc
 911   = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon
 912
 913 marshalableTyCon dflags tc
 914   =  (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
 915   || boxedMarshalableTyCon tc
 916
 917 boxedMarshalableTyCon tc
 918    = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
 919                          , int32TyConKey, int64TyConKey
 920                          , wordTyConKey, word8TyConKey, word16TyConKey
 921                          , word32TyConKey, word64TyConKey
 922                          , floatTyConKey, doubleTyConKey
 923                          , addrTyConKey, ptrTyConKey, funPtrTyConKey
 924                          , charTyConKey
 925                          , stablePtrTyConKey
 926                          , byteArrayTyConKey, mutableByteArrayTyConKey
 927                          , boolTyConKey
 928                          ]
 929
 930 isByteArrayLikeTyCon :: TyCon -> Bool
 931 isByteArrayLikeTyCon tc =
 932   getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
 933 \end{code}
 934
 935