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