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   Expected(..), TcRef, 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
 232 type TcRef a     = IORef a
 233 data Expected ty = Infer (TcRef ty)     -- The hole to fill in for type inference
 234                  | Check ty             -- The type to check during type checking
 235 \end{code}
 236
 237
 238 %************************************************************************
 239 %*                                                                      *
 240 \subsection{TyVarDetails}
 241 %*                                                                      *
 242 %************************************************************************
 243
 244 TyVarDetails gives extra info about type variables, used during type
 245 checking.  It's attached to mutable type variables only.
 246 It's knot-tied back to Var.lhs.  There is no reason in principle
 247 why Var.lhs shouldn't actually have the definition, but it "belongs" here.
 248
 249 \begin{code}
 250 type TcTyVar = TyVar    -- Used only during type inference
 251
 252 -- A TyVarDetails is inside a TyVar
 253 data TcTyVarDetails
 254   = SkolemTv SkolemInfo         -- A skolem constant
 255   | MetaTv (IORef MetaDetails)  -- A meta type variable stands for a tau-type
 256
 257 data SkolemInfo
 258   = SigSkol Name        -- Bound at a type signature
 259   | ClsSkol Class       -- Bound at a class decl
 260   | InstSkol Id         -- Bound at an instance decl
 261   | PatSkol DataCon     -- An existential type variable bound by a pattern for
 262             SrcSpan     -- a data constructor with an existential type. E.g.
 263                         --      data T = forall a. Eq a => MkT a
 264                         --      f (MkT x) = ...
 265                         -- The pattern MkT x will allocate an existential type
 266                         -- variable for 'a'.
 267   | ArrowSkol SrcSpan   -- An arrow form (see TcArrows)
 268
 269   | GenSkol TcType      -- Bound when doing a subsumption check for this type
 270             SrcSpan
 271
 272 data MetaDetails
 273   = Flexi          -- Flexi type variables unify to become
 274                    -- Indirects.
 275
 276   | Indirect TcType  -- Type indirections, treated as wobbly
 277                      -- for the purpose of GADT unification.
 278
 279 pprSkolemTyVar :: TcTyVar -> SDoc
 280 pprSkolemTyVar tv
 281   = ASSERT( isSkolemTyVar tv )
 282     quotes (ppr tv) <+> ptext SLIT("is bound by") <+> ppr (skolemTvInfo tv)
 283
 284 instance Outputable SkolemInfo where
 285   ppr (SigSkol id)  = ptext SLIT("the type signature for") <+> quotes (ppr id)
 286   ppr (ClsSkol cls) = ptext SLIT("the class declaration for") <+> quotes (ppr cls)
 287   ppr (InstSkol df) = ptext SLIT("the instance declaration at") <+> ppr (getSrcLoc df)
 288   ppr (ArrowSkol loc)  = ptext SLIT("the arrow form at") <+> ppr loc
 289   ppr (PatSkol dc loc) = sep [ptext SLIT("the pattern for") <+> quotes (ppr dc),
 290                             nest 2 (ptext SLIT("at") <+> ppr loc)]
 291   ppr (GenSkol ty loc) = sep [ptext SLIT("the polymorphic type") <+> quotes (ppr ty),
 292                             nest 2 (ptext SLIT("at") <+> ppr loc)]
 293
 294 instance Outputable MetaDetails where
 295   ppr Flexi         = ptext SLIT("Flexi")
 296   ppr (Indirect ty) = ptext SLIT("Indirect") <+> ppr ty
 297
 298 isImmutableTyVar, isSkolemTyVar, isExistentialTyVar, isMetaTyVar :: TyVar -> Bool
 299 isImmutableTyVar tv
 300   | isTcTyVar tv = isSkolemTyVar tv
 301   | otherwise    = True
 302
 303 isSkolemTyVar tv
 304   = ASSERT( isTcTyVar tv )
 305     case tcTyVarDetails tv of
 306         SkolemTv _ -> True
 307         MetaTv _   -> False
 308
 309 isExistentialTyVar tv   -- Existential type variable, bound by a pattern
 310   = ASSERT( isTcTyVar tv )
 311     case tcTyVarDetails tv of
 312         SkolemTv (PatSkol _ _) -> True
 313         other                  -> False
 314
 315 isMetaTyVar tv
 316   = ASSERT( isTcTyVar tv )
 317     case tcTyVarDetails tv of
 318         SkolemTv _ -> False
 319         MetaTv _   -> True
 320
 321 skolemTvInfo :: TyVar -> SkolemInfo
 322 skolemTvInfo tv
 323   = ASSERT( isTcTyVar tv )
 324     case tcTyVarDetails tv of
 325         SkolemTv info -> info
 326
 327 metaTvRef :: TyVar -> IORef MetaDetails
 328 metaTvRef tv
 329   = ASSERT( isTcTyVar tv )
 330     case tcTyVarDetails tv of
 331          MetaTv ref -> ref
 332
 333 isFlexi, isIndirect :: MetaDetails -> Bool
 334 isFlexi Flexi = True
 335 isFlexi other = False
 336
 337 isIndirect (Indirect _) = True
 338 isIndirect other        = False
 339 \end{code}
 340
 341
 342 %************************************************************************
 343 %*                                                                      *
 344 \subsection{Tau, sigma and rho}
 345 %*                                                                      *
 346 %************************************************************************
 347
 348 \begin{code}
 349 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau)
 350
 351 mkPhiTy :: [PredType] -> Type -> Type
 352 mkPhiTy theta ty = foldr (\p r -> FunTy (mkPredTy p) r) ty theta
 353 \end{code}
 354
 355 @isTauTy@ tests for nested for-alls.
 356
 357 \begin{code}
 358 isTauTy :: Type -> Bool
 359 isTauTy (TyVarTy v)      = True
 360 isTauTy (TyConApp _ tys) = all isTauTy tys
 361 isTauTy (AppTy a b)      = isTauTy a && isTauTy b
 362 isTauTy (FunTy a b)      = isTauTy a && isTauTy b
 363 isTauTy (PredTy p)       = True         -- Don't look through source types
 364 isTauTy (NoteTy _ ty)    = isTauTy ty
 365 isTauTy other            = False
 366 \end{code}
 367
 368 \begin{code}
 369 getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
 370                                 -- construct a dictionary function name
 371 getDFunTyKey (TyVarTy tv)    = getOccName tv
 372 getDFunTyKey (TyConApp tc _) = getOccName tc
 373 getDFunTyKey (AppTy fun _)   = getDFunTyKey fun
 374 getDFunTyKey (NoteTy _ t)    = getDFunTyKey t
 375 getDFunTyKey (FunTy arg _)   = getOccName funTyCon
 376 getDFunTyKey (ForAllTy _ t)  = getDFunTyKey t
 377 getDFunTyKey ty              = pprPanic "getDFunTyKey" (pprType ty)
 378 -- PredTy shouldn't happen
 379 \end{code}
 380
 381
 382 %************************************************************************
 383 %*                                                                      *
 384 \subsection{Expanding and splitting}
 385 %*                                                                      *
 386 %************************************************************************
 387
 388 These tcSplit functions are like their non-Tc analogues, but
 389         a) they do not look through newtypes
 390         b) they do not look through PredTys
 391         c) [future] they ignore usage-type annotations
 392
 393 However, they are non-monadic and do not follow through mutable type
 394 variables.  It's up to you to make sure this doesn't matter.
 395
 396 \begin{code}
 397 tcSplitForAllTys :: Type -> ([TyVar], Type)
 398 tcSplitForAllTys ty = split ty ty []
 399    where
 400      split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
 401      split orig_ty (NoteTy n  ty)   tvs = split orig_ty ty tvs
 402      split orig_ty t                tvs = (reverse tvs, orig_ty)
 403
 404 tcIsForAllTy (ForAllTy tv ty) = True
 405 tcIsForAllTy (NoteTy n ty)    = tcIsForAllTy ty
 406 tcIsForAllTy t                = False
 407
 408 tcSplitPhiTy :: Type -> ([PredType], Type)
 409 tcSplitPhiTy ty = split ty ty []
 410  where
 411   split orig_ty (FunTy arg res) ts = case tcSplitPredTy_maybe arg of
 412                                         Just p  -> split res res (p:ts)
 413                                         Nothing -> (reverse ts, orig_ty)
 414   split orig_ty (NoteTy n ty)   ts = split orig_ty ty ts
 415   split orig_ty ty              ts = (reverse ts, orig_ty)
 416
 417 tcSplitSigmaTy ty = case tcSplitForAllTys ty of
 418                         (tvs, rho) -> case tcSplitPhiTy rho of
 419                                         (theta, tau) -> (tvs, theta, tau)
 420
 421 tcTyConAppTyCon :: Type -> TyCon
 422 tcTyConAppTyCon ty = fst (tcSplitTyConApp ty)
 423
 424 tcTyConAppArgs :: Type -> [Type]
 425 tcTyConAppArgs ty = snd (tcSplitTyConApp ty)
 426
 427 tcSplitTyConApp :: Type -> (TyCon, [Type])
 428 tcSplitTyConApp ty = case tcSplitTyConApp_maybe ty of
 429                         Just stuff -> stuff
 430                         Nothing    -> pprPanic "tcSplitTyConApp" (pprType ty)
 431
 432 tcSplitTyConApp_maybe :: Type -> Maybe (TyCon, [Type])
 433 tcSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
 434 tcSplitTyConApp_maybe (FunTy arg res)   = Just (funTyCon, [arg,res])
 435 tcSplitTyConApp_maybe (NoteTy n ty)     = tcSplitTyConApp_maybe ty
 436         -- Newtypes are opaque, so they may be split
 437         -- However, predicates are not treated
 438         -- as tycon applications by the type checker
 439 tcSplitTyConApp_maybe other                     = Nothing
 440
 441 tcSplitFunTys :: Type -> ([Type], Type)
 442 tcSplitFunTys ty = case tcSplitFunTy_maybe ty of
 443                         Nothing        -> ([], ty)
 444                         Just (arg,res) -> (arg:args, res')
 445                                        where
 446                                           (args,res') = tcSplitFunTys res
 447
 448 tcSplitFunTy_maybe :: Type -> Maybe (Type, Type)
 449 tcSplitFunTy_maybe (FunTy arg res)  = Just (arg, res)
 450 tcSplitFunTy_maybe (NoteTy n ty)    = tcSplitFunTy_maybe ty
 451 tcSplitFunTy_maybe other            = Nothing
 452
 453 tcFunArgTy    ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> arg }
 454 tcFunResultTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> res }
 455
 456
 457 tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
 458 tcSplitAppTy_maybe (FunTy ty1 ty2)   = Just (TyConApp funTyCon [ty1], ty2)
 459 tcSplitAppTy_maybe (AppTy ty1 ty2)   = Just (ty1, ty2)
 460 tcSplitAppTy_maybe (NoteTy n ty)     = tcSplitAppTy_maybe ty
 461 tcSplitAppTy_maybe (TyConApp tc tys) = case snocView tys of
 462                                         Just (tys', ty') -> Just (TyConApp tc tys', ty')
 463                                         Nothing          -> Nothing
 464 tcSplitAppTy_maybe other             = Nothing
 465
 466 tcSplitAppTy ty = case tcSplitAppTy_maybe ty of
 467                     Just stuff -> stuff
 468                     Nothing    -> pprPanic "tcSplitAppTy" (pprType ty)
 469
 470 tcSplitAppTys :: Type -> (Type, [Type])
 471 tcSplitAppTys ty
 472   = go ty []
 473   where
 474     go ty args = case tcSplitAppTy_maybe ty of
 475                    Just (ty', arg) -> go ty' (arg:args)
 476                    Nothing         -> (ty,args)
 477
 478 tcGetTyVar_maybe :: Type -> Maybe TyVar
 479 tcGetTyVar_maybe (TyVarTy tv)   = Just tv
 480 tcGetTyVar_maybe (NoteTy _ t)   = tcGetTyVar_maybe t
 481 tcGetTyVar_maybe other          = Nothing
 482
 483 tcGetTyVar :: String -> Type -> TyVar
 484 tcGetTyVar msg ty = expectJust msg (tcGetTyVar_maybe ty)
 485
 486 tcIsTyVarTy :: Type -> Bool
 487 tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty)
 488
 489 tcSplitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
 490 -- Split the type of a dictionary function
 491 tcSplitDFunTy ty
 492   = case tcSplitSigmaTy ty   of { (tvs, theta, tau) ->
 493     case tcSplitDFunHead tau of { (clas, tys) ->
 494     (tvs, theta, clas, tys) }}
 495
 496 tcSplitDFunHead :: Type -> (Class, [Type])
 497 tcSplitDFunHead tau
 498   = case tcSplitPredTy_maybe tau of
 499         Just (ClassP clas tys) -> (clas, tys)
 500 \end{code}
 501
 502
 503
 504 %************************************************************************
 505 %*                                                                      *
 506 \subsection{Predicate types}
 507 %*                                                                      *
 508 %************************************************************************
 509
 510 \begin{code}
 511 tcSplitPredTy_maybe :: Type -> Maybe PredType
 512    -- Returns Just for predicates only
 513 tcSplitPredTy_maybe (NoteTy _ ty) = tcSplitPredTy_maybe ty
 514 tcSplitPredTy_maybe (PredTy p)    = Just p
 515 tcSplitPredTy_maybe other         = Nothing
 516
 517 predTyUnique :: PredType -> Unique
 518 predTyUnique (IParam n _)      = getUnique (ipNameName n)
 519 predTyUnique (ClassP clas tys) = getUnique clas
 520
 521 mkPredName :: Unique -> SrcLoc -> PredType -> Name
 522 mkPredName uniq loc (ClassP cls tys) = mkInternalName uniq (mkDictOcc (getOccName cls)) loc
 523 mkPredName uniq loc (IParam ip ty)   = mkInternalName uniq (getOccName (ipNameName ip)) loc
 524 \end{code}
 525
 526
 527 --------------------- Dictionary types ---------------------------------
 528
 529 \begin{code}
 530 mkClassPred clas tys = ClassP clas tys
 531
 532 isClassPred :: PredType -> Bool
 533 isClassPred (ClassP clas tys) = True
 534 isClassPred other             = False
 535
 536 isTyVarClassPred (ClassP clas tys) = all tcIsTyVarTy tys
 537 isTyVarClassPred other             = False
 538
 539 getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
 540 getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
 541 getClassPredTys_maybe _                 = Nothing
 542
 543 getClassPredTys :: PredType -> (Class, [Type])
 544 getClassPredTys (ClassP clas tys) = (clas, tys)
 545
 546 mkDictTy :: Class -> [Type] -> Type
 547 mkDictTy clas tys = mkPredTy (ClassP clas tys)
 548
 549 isDictTy :: Type -> Bool
 550 isDictTy (PredTy p)   = isClassPred p
 551 isDictTy (NoteTy _ ty)  = isDictTy ty
 552 isDictTy other          = False
 553 \end{code}
 554
 555 --------------------- Implicit parameters ---------------------------------
 556
 557 \begin{code}
 558 isIPPred :: PredType -> Bool
 559 isIPPred (IParam _ _) = True
 560 isIPPred other        = False
 561
 562 isInheritablePred :: PredType -> Bool
 563 -- Can be inherited by a context.  For example, consider
 564 --      f x = let g y = (?v, y+x)
 565 --            in (g 3 with ?v = 8,
 566 --                g 4 with ?v = 9)
 567 -- The point is that g's type must be quantifed over ?v:
 568 --      g :: (?v :: a) => a -> a
 569 -- but it doesn't need to be quantified over the Num a dictionary
 570 -- which can be free in g's rhs, and shared by both calls to g
 571 isInheritablePred (ClassP _ _) = True
 572 isInheritablePred other      = False
 573
 574 isLinearPred :: TcPredType -> Bool
 575 isLinearPred (IParam (Linear n) _) = True
 576 isLinearPred other                 = False
 577 \end{code}
 578
 579
 580 %************************************************************************
 581 %*                                                                      *
 582 \subsection{Predicates}
 583 %*                                                                      *
 584 %************************************************************************
 585
 586 isSigmaTy returns true of any qualified type.  It doesn't *necessarily* have
 587 any foralls.  E.g.
 588         f :: (?x::Int) => Int -> Int
 589
 590 \begin{code}
 591 isSigmaTy :: Type -> Bool
 592 isSigmaTy (ForAllTy tyvar ty) = True
 593 isSigmaTy (FunTy a b)         = isPredTy a
 594 isSigmaTy (NoteTy n ty)       = isSigmaTy ty
 595 isSigmaTy _                   = False
 596
 597 isOverloadedTy :: Type -> Bool
 598 isOverloadedTy (ForAllTy tyvar ty) = isOverloadedTy ty
 599 isOverloadedTy (FunTy a b)         = isPredTy a
 600 isOverloadedTy (NoteTy n ty)       = isOverloadedTy ty
 601 isOverloadedTy _                   = False
 602
 603 isPredTy :: Type -> Bool        -- Belongs in TcType because it does
 604                                 -- not look through newtypes, or predtypes (of course)
 605 isPredTy (NoteTy _ ty) = isPredTy ty
 606 isPredTy (PredTy sty)  = True
 607 isPredTy _             = False
 608 \end{code}
 609
 610 \begin{code}
 611 isFloatTy      = is_tc floatTyConKey
 612 isDoubleTy     = is_tc doubleTyConKey
 613 isIntegerTy    = is_tc integerTyConKey
 614 isIntTy        = is_tc intTyConKey
 615 isAddrTy       = is_tc addrTyConKey
 616 isBoolTy       = is_tc boolTyConKey
 617 isUnitTy       = is_tc unitTyConKey
 618
 619 is_tc :: Unique -> Type -> Bool
 620 -- Newtypes are opaque to this
 621 is_tc uniq ty = case tcSplitTyConApp_maybe ty of
 622                         Just (tc, _) -> uniq == getUnique tc
 623                         Nothing      -> False
 624 \end{code}
 625
 626
 627
 628
 629 %************************************************************************
 630 %*                                                                      *
 631                 Hoisting for-alls
 632 %*                                                                      *
 633 %************************************************************************
 634
 635 hoistForAllTys is used for user-written type signatures only
 636 We want to 'look through' type synonyms when doing this
 637 so it's better done on the Type than the HsType
 638
 639 It moves all the foralls and constraints to the top
 640 e.g.    T -> forall a. a        ==>   forall a. T -> a
 641         T -> (?x::Int) -> Int   ==>   (?x::Int) -> T -> Int
 642
 643 Also: it eliminates duplicate constraints.  These can show up
 644 when hoisting constraints, notably implicit parameters.
 645
 646 It tries hard to retain type synonyms if hoisting does not break one
 647 up.  Not only does this improve error messages, but there's a tricky
 648 interaction with Haskell 98.  H98 requires no unsaturated type
 649 synonyms, which is checked by checkValidType.  This runs after
 650 hoisting, so we don't want hoisting to remove the SynNotes!  (We can't
 651 run validity checking before hoisting because in mutually-recursive
 652 type definitions we postpone validity checking until after the knot is
 653 tied.)
 654
 655 \begin{code}
 656 hoistForAllTys :: Type -> Type
 657 hoistForAllTys ty
 658   = go (deShadowTy ty)
 659         -- Running over ty with an empty substitution gives it the
 660         -- no-shadowing property.  This is important.  For example:
 661         --      type Foo r = forall a. a -> r
 662         --      foo :: Foo (Foo ())
 663         -- Here the hoisting should give
 664         --      foo :: forall a a1. a -> a1 -> ()
 665         --
 666         -- What about type vars that are lexically in scope in the envt?
 667         -- We simply rely on them having a different unique to any
 668         -- binder in 'ty'.  Otherwise we'd have to slurp the in-scope-tyvars
 669         -- out of the envt, which is boring and (I think) not necessary.
 670
 671   where
 672     go (TyVarTy tv)                = TyVarTy tv
 673     go (TyConApp tc tys)           = TyConApp tc (map go tys)
 674     go (PredTy pred)               = PredTy pred    -- No nested foralls
 675     go (NoteTy (SynNote ty1) ty2)  = NoteTy (SynNote (go ty1)) (go ty2)
 676     go (NoteTy (FTVNote _) ty2)    = go ty2         -- Discard the free tyvar note
 677     go (FunTy arg res)             = mk_fun_ty (go arg) (go res)
 678     go (AppTy fun arg)             = AppTy (go fun) (go arg)
 679     go (ForAllTy tv ty)            = ForAllTy tv (go ty)
 680
 681         -- mk_fun_ty does all the work.
 682         -- It's building t1 -> t2:
 683         --      if t2 is a for-all type, push t1 inside it
 684         --      if t2 is (pred -> t3), check for duplicates
 685     mk_fun_ty ty1 ty2
 686         | not (isOverloadedTy ty2)      -- No forall's, or context =>
 687         = FunTy ty1 ty2
 688         | PredTy p1 <- ty1              -- ty1 is a predicate
 689         = if p1 `elem` theta then       -- so check for duplicates
 690                 ty2
 691           else
 692                 mkSigmaTy tvs (p1:theta) tau
 693         | otherwise
 694         = mkSigmaTy tvs theta (FunTy ty1 tau)
 695         where
 696           (tvs, theta, tau) = tcSplitSigmaTy ty2
 697 \end{code}
 698
 699
 700 %************************************************************************
 701 %*                                                                      *
 702 \subsection{Misc}
 703 %*                                                                      *
 704 %************************************************************************
 705
 706 \begin{code}
 707 deNoteType :: Type -> Type
 708         -- Remove synonyms, but not predicate types
 709 deNoteType ty@(TyVarTy tyvar)   = ty
 710 deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys)
 711 deNoteType (PredTy p)           = PredTy (deNotePredType p)
 712 deNoteType (NoteTy _ ty)        = deNoteType ty
 713 deNoteType (AppTy fun arg)      = AppTy (deNoteType fun) (deNoteType arg)
 714 deNoteType (FunTy fun arg)      = FunTy (deNoteType fun) (deNoteType arg)
 715 deNoteType (ForAllTy tv ty)     = ForAllTy tv (deNoteType ty)
 716
 717 deNotePredType :: PredType -> PredType
 718 deNotePredType (ClassP c tys)   = ClassP c (map deNoteType tys)
 719 deNotePredType (IParam n ty)    = IParam n (deNoteType ty)
 720 \end{code}
 721
 722 Find the free tycons and classes of a type.  This is used in the front
 723 end of the compiler.
 724
 725 \begin{code}
 726 tyClsNamesOfType :: Type -> NameSet
 727 tyClsNamesOfType (TyVarTy tv)               = emptyNameSet
 728 tyClsNamesOfType (TyConApp tycon tys)       = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
 729 tyClsNamesOfType (NoteTy (SynNote ty1) ty2) = tyClsNamesOfType ty1
 730 tyClsNamesOfType (NoteTy other_note    ty2) = tyClsNamesOfType ty2
 731 tyClsNamesOfType (PredTy (IParam n ty))   = tyClsNamesOfType ty
 732 tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
 733 tyClsNamesOfType (FunTy arg res)            = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res
 734 tyClsNamesOfType (AppTy fun arg)            = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg
 735 tyClsNamesOfType (ForAllTy tyvar ty)        = tyClsNamesOfType ty
 736
 737 tyClsNamesOfTypes tys = foldr (unionNameSets . tyClsNamesOfType) emptyNameSet tys
 738
 739 tyClsNamesOfDFunHead :: Type -> NameSet
 740 -- Find the free type constructors and classes
 741 -- of the head of the dfun instance type
 742 -- The 'dfun_head_type' is because of
 743 --      instance Foo a => Baz T where ...
 744 -- The decl is an orphan if Baz and T are both not locally defined,
 745 --      even if Foo *is* locally defined
 746 tyClsNamesOfDFunHead dfun_ty
 747   = case tcSplitSigmaTy dfun_ty of
 748         (tvs,_,head_ty) -> tyClsNamesOfType head_ty
 749
 750 classesOfTheta :: ThetaType -> [Class]
 751 -- Looks just for ClassP things; maybe it should check
 752 classesOfTheta preds = [ c | ClassP c _ <- preds ]
 753 \end{code}
 754
 755
 756 %************************************************************************
 757 %*                                                                      *
 758 \subsection[TysWiredIn-ext-type]{External types}
 759 %*                                                                      *
 760 %************************************************************************
 761
 762 The compiler's foreign function interface supports the passing of a
 763 restricted set of types as arguments and results (the restricting factor
 764 being the )
 765
 766 \begin{code}
 767 isFFITy :: Type -> Bool
 768 -- True for any TyCon that can possibly be an arg or result of an FFI call
 769 isFFITy ty = checkRepTyCon legalFFITyCon ty
 770
 771 isFFIArgumentTy :: DynFlags -> Safety -> Type -> Bool
 772 -- Checks for valid argument type for a 'foreign import'
 773 isFFIArgumentTy dflags safety ty
 774    = checkRepTyCon (legalOutgoingTyCon dflags safety) ty
 775
 776 isFFIExternalTy :: Type -> Bool
 777 -- Types that are allowed as arguments of a 'foreign export'
 778 isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty
 779
 780 isFFIImportResultTy :: DynFlags -> Type -> Bool
 781 isFFIImportResultTy dflags ty
 782   = checkRepTyCon (legalFIResultTyCon dflags) ty
 783
 784 isFFIExportResultTy :: Type -> Bool
 785 isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
 786
 787 isFFIDynArgumentTy :: Type -> Bool
 788 -- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr,
 789 -- or a newtype of either.
 790 isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
 791
 792 isFFIDynResultTy :: Type -> Bool
 793 -- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr,
 794 -- or a newtype of either.
 795 isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
 796
 797 isFFILabelTy :: Type -> Bool
 798 -- The type of a foreign label must be Ptr, FunPtr, Addr,
 799 -- or a newtype of either.
 800 isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey, addrTyConKey]
 801
 802 isFFIDotnetTy :: DynFlags -> Type -> Bool
 803 isFFIDotnetTy dflags ty
 804   = checkRepTyCon (\ tc -> not (isByteArrayLikeTyCon tc) &&
 805                            (legalFIResultTyCon dflags tc ||
 806                            isFFIDotnetObjTy ty || isStringTy ty)) ty
 807
 808 -- Support String as an argument or result from a .NET FFI call.
 809 isStringTy ty =
 810   case tcSplitTyConApp_maybe (repType ty) of
 811     Just (tc, [arg_ty])
 812       | tc == listTyCon ->
 813         case tcSplitTyConApp_maybe (repType arg_ty) of
 814           Just (cc,[]) -> cc == charTyCon
 815           _ -> False
 816     _ -> False
 817
 818 -- Support String as an argument or result from a .NET FFI call.
 819 isFFIDotnetObjTy ty =
 820   let
 821    (_, t_ty) = tcSplitForAllTys ty
 822   in
 823   case tcSplitTyConApp_maybe (repType t_ty) of
 824     Just (tc, [arg_ty]) | getName tc == objectTyConName -> True
 825     _ -> False
 826
 827 toDNType :: Type -> DNType
 828 toDNType ty
 829   | isStringTy ty = DNString
 830   | isFFIDotnetObjTy ty = DNObject
 831   | Just (tc,argTys) <- tcSplitTyConApp_maybe ty =
 832      case lookup (getUnique tc) dn_assoc of
 833        Just x  -> x
 834        Nothing
 835          | tc `hasKey` ioTyConKey -> toDNType (head argTys)
 836          | otherwise -> pprPanic ("toDNType: unsupported .NET type") (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc)
 837     where
 838       dn_assoc :: [ (Unique, DNType) ]
 839       dn_assoc = [ (unitTyConKey,   DNUnit)
 840                  , (intTyConKey,    DNInt)
 841                  , (int8TyConKey,   DNInt8)
 842                  , (int16TyConKey,  DNInt16)
 843                  , (int32TyConKey,  DNInt32)
 844                  , (int64TyConKey,  DNInt64)
 845                  , (wordTyConKey,   DNInt)
 846                  , (word8TyConKey,  DNWord8)
 847                  , (word16TyConKey, DNWord16)
 848                  , (word32TyConKey, DNWord32)
 849                  , (word64TyConKey, DNWord64)
 850                  , (floatTyConKey,  DNFloat)
 851                  , (doubleTyConKey, DNDouble)
 852                  , (addrTyConKey,   DNPtr)
 853                  , (ptrTyConKey,    DNPtr)
 854                  , (funPtrTyConKey, DNPtr)
 855                  , (charTyConKey,   DNChar)
 856                  , (boolTyConKey,   DNBool)
 857                  ]
 858
 859 checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
 860         -- Look through newtypes
 861         -- Non-recursive ones are transparent to splitTyConApp,
 862         -- but recursive ones aren't.  Manuel had:
 863         --      newtype T = MkT (Ptr T)
 864         -- and wanted it to work...
 865 checkRepTyCon check_tc ty
 866   | Just (tc,_) <- splitTyConApp_maybe (repType ty) = check_tc tc
 867   | otherwise                                       = False
 868
 869 checkRepTyConKey :: [Unique] -> Type -> Bool
 870 -- Like checkRepTyCon, but just looks at the TyCon key
 871 checkRepTyConKey keys
 872   = checkRepTyCon (\tc -> tyConUnique tc `elem` keys)
 873 \end{code}
 874
 875 ----------------------------------------------
 876 These chaps do the work; they are not exported
 877 ----------------------------------------------
 878
 879 \begin{code}
 880 legalFEArgTyCon :: TyCon -> Bool
 881 -- It's illegal to return foreign objects and (mutable)
 882 -- bytearrays from a _ccall_ / foreign declaration
 883 -- (or be passed them as arguments in foreign exported functions).
 884 legalFEArgTyCon tc
 885   | isByteArrayLikeTyCon tc
 886   = False
 887   -- It's also illegal to make foreign exports that take unboxed
 888   -- arguments.  The RTS API currently can't invoke such things.  --SDM 7/2000
 889   | otherwise
 890   = boxedMarshalableTyCon tc
 891
 892 legalFIResultTyCon :: DynFlags -> TyCon -> Bool
 893 legalFIResultTyCon dflags tc
 894   | isByteArrayLikeTyCon tc = False
 895   | tc == unitTyCon         = True
 896   | otherwise               = marshalableTyCon dflags tc
 897
 898 legalFEResultTyCon :: TyCon -> Bool
 899 legalFEResultTyCon tc
 900   | isByteArrayLikeTyCon tc = False
 901   | tc == unitTyCon         = True
 902   | otherwise               = boxedMarshalableTyCon tc
 903
 904 legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
 905 -- Checks validity of types going from Haskell -> external world
 906 legalOutgoingTyCon dflags safety tc
 907   | playSafe safety && isByteArrayLikeTyCon tc
 908   = False
 909   | otherwise
 910   = marshalableTyCon dflags tc
 911
 912 legalFFITyCon :: TyCon -> Bool
 913 -- True for any TyCon that can possibly be an arg or result of an FFI call
 914 legalFFITyCon tc
 915   = isUnLiftedTyCon tc || boxedMarshalableTyCon tc || tc == unitTyCon
 916
 917 marshalableTyCon dflags tc
 918   =  (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
 919   || boxedMarshalableTyCon tc
 920
 921 boxedMarshalableTyCon tc
 922    = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
 923                          , int32TyConKey, int64TyConKey
 924                          , wordTyConKey, word8TyConKey, word16TyConKey
 925                          , word32TyConKey, word64TyConKey
 926                          , floatTyConKey, doubleTyConKey
 927                          , addrTyConKey, ptrTyConKey, funPtrTyConKey
 928                          , charTyConKey
 929                          , stablePtrTyConKey
 930                          , byteArrayTyConKey, mutableByteArrayTyConKey
 931                          , boolTyConKey
 932                          ]
 933
 934 isByteArrayLikeTyCon :: TyCon -> Bool
 935 isByteArrayLikeTyCon tc =
 936   getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
 937 \end{code}
 938
 939