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