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