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