ghc/compiler/types/Type.lhs

   1 \begin{code}
   2 module Type (
   3         GenType(..), Type,
   4
   5         mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy,
   6
   7         mkAppTy, mkAppTys, splitAppTy, splitAppTys,
   8
   9         mkFunTy, mkFunTys, splitFunTy_maybe, splitFunTys,
  10
  11         mkTyConApp, mkTyConTy, splitTyConApp_maybe,
  12         splitAlgTyConApp_maybe, splitAlgTyConApp,
  13         mkDictTy, splitDictTy_maybe, isDictTy,
  14
  15         mkSynTy, isSynTy,
  16
  17         mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, applyTy,
  18
  19         TauType, RhoType, SigmaType, ThetaType,
  20         isTauTy,
  21         mkRhoTy, splitRhoTy,
  22         mkSigmaTy, splitSigmaTy,
  23
  24         isUnpointedType, isUnboxedType, typePrimRep,
  25
  26         matchTy, matchTys,
  27
  28         tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind,
  29
  30         instantiateTy, instantiateTauTy, instantiateThetaTy,
  31
  32         showTypeCategory
  33     ) where
  34
  35 #include "HsVersions.h"
  36
  37 import {-# SOURCE #-} Id        ( Id )
  38
  39 -- friends:
  40 import Class    ( classTyCon, Class )
  41 import Kind     ( mkBoxedTypeKind, resultKind, Kind )
  42 import TyCon    ( mkFunTyCon, isFunTyCon, isEnumerationTyCon, isTupleTyCon, maybeTyConSingleCon,
  43                   isPrimTyCon, isAlgTyCon, isSynTyCon, tyConArity,
  44                   tyConKind, tyConDataCons, getSynTyConDefn,
  45                   tyConPrimRep, tyConClass_maybe, TyCon )
  46 import TyVar    ( GenTyVarSet, TyVarEnv, GenTyVar, TyVar,
  47                   tyVarKind, emptyTyVarSet, unionTyVarSets, minusTyVarSet,
  48                   unitTyVarSet, lookupTyVarEnv, delFromTyVarEnv, zipTyVarEnv, mkTyVarEnv,
  49                   emptyTyVarEnv, isEmptyTyVarEnv, addToTyVarEnv )
  50 import Name     ( NamedThing(..),
  51                   NameSet(..), unionNameSets, emptyNameSet, unitNameSet, minusNameSet
  52                 )
  53
  54 -- others
  55 import BasicTypes ( Unused )
  56 import Maybes   ( maybeToBool, assocMaybe )
  57 import PrimRep  ( PrimRep(..) )
  58 import Unique   -- quite a few *Keys
  59 import Util     ( thenCmp, zipEqual, zipWithEqual, assoc )
  60 import Outputable
  61 \end{code}
  62
  63
  64
  65 %************************************************************************
  66 %*                                                                      *
  67 \subsection{The data type}
  68 %*                                                                      *
  69 %************************************************************************
  70
  71
  72 \begin{code}
  73 type Type  = GenType Unused     -- Used after typechecker
  74
  75 data GenType flexi                      -- Parameterised over the "flexi" part of a type variable
  76   = TyVarTy (GenTyVar flexi)
  77
  78   | AppTy
  79         (GenType flexi)         -- Function is *not* a TyConApp
  80         (GenType flexi)
  81
  82   | TyConApp                    -- Application of a TyCon
  83         TyCon                   -- *Invariant* saturated appliations of FunTyCon and
  84                                 --      synonyms have their own constructors, below.
  85         [GenType flexi]         -- Might not be saturated.
  86
  87   | FunTy                       -- Special case of TyConApp: TyConApp FunTyCon [t1,t2]
  88         (GenType flexi)
  89         (GenType flexi)
  90
  91   | SynTy                       -- Saturated application of a type synonym
  92         (GenType flexi)         -- The unexpanded version; always a TyConTy
  93         (GenType flexi)         -- The expanded version
  94
  95   | ForAllTy
  96         (GenTyVar flexi)
  97         (GenType flexi)         -- TypeKind
  98 \end{code}
  99
 100
 101 %************************************************************************
 102 %*                                                                      *
 103 \subsection{Constructor-specific functions}
 104 %*                                                                      *
 105 %************************************************************************
 106
 107
 108 ---------------------------------------------------------------------
 109                                 TyVarTy
 110                                 ~~~~~~~
 111 \begin{code}
 112 mkTyVarTy  :: GenTyVar flexi   -> GenType flexi
 113 mkTyVarTy  = TyVarTy
 114
 115 mkTyVarTys :: [GenTyVar flexi] -> [GenType flexi]
 116 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
 117
 118 getTyVar :: String -> GenType flexi -> GenTyVar flexi
 119 getTyVar msg (TyVarTy tv) = tv
 120 getTyVar msg (SynTy _ t)  = getTyVar msg t
 121 getTyVar msg other        = panic ("getTyVar: " ++ msg)
 122
 123 getTyVar_maybe :: GenType flexi -> Maybe (GenTyVar flexi)
 124 getTyVar_maybe (TyVarTy tv) = Just tv
 125 getTyVar_maybe (SynTy _ t)  = getTyVar_maybe t
 126 getTyVar_maybe other        = Nothing
 127
 128 isTyVarTy :: GenType flexi -> Bool
 129 isTyVarTy (TyVarTy tv) = True
 130 isTyVarTy (SynTy _ ty) = isTyVarTy ty
 131 isTyVarTy other        = False
 132 \end{code}
 133
 134
 135 ---------------------------------------------------------------------
 136                                 AppTy
 137                                 ~~~~~
 138 We need to be pretty careful with AppTy to make sure we obey the
 139 invariant that a TyConApp is always visibly so.  mkAppTy maintains the
 140 invariant: use it.
 141
 142 \begin{code}
 143 mkAppTy orig_ty1 orig_ty2 = mk_app orig_ty1
 144   where
 145     mk_app (SynTy _ ty1)     = mk_app ty1
 146     mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
 147     mk_app ty1               = AppTy orig_ty1 orig_ty2
 148
 149 mkAppTys :: GenType flexi -> [GenType flexi] -> GenType flexi
 150 mkAppTys orig_ty1 []        = orig_ty1
 151         -- This check for an empty list of type arguments
 152         -- avoids the needless of a type synonym constructor.
 153         -- For example: mkAppTys Rational []
 154         --   returns to (Ratio Integer), which has needlessly lost
 155         --   the Rational part.
 156 mkAppTys orig_ty1 orig_tys2 = mk_app orig_ty1
 157   where
 158     mk_app (SynTy _ ty1)     = mk_app ty1
 159     mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
 160     mk_app ty1               = foldl AppTy orig_ty1 orig_tys2
 161
 162 splitAppTy :: GenType flexi -> (GenType flexi, GenType flexi)
 163 splitAppTy (FunTy ty1 ty2)   = (TyConApp mkFunTyCon [ty1], ty2)
 164 splitAppTy (AppTy ty1 ty2)   = (ty1, ty2)
 165 splitAppTy (SynTy _ ty)      = splitAppTy ty
 166 splitAppTy (TyConApp tc tys) = split tys []
 167                             where
 168                                split [ty2]    acc = (TyConApp tc (reverse acc), ty2)
 169                                split (ty:tys) acc = split tys (ty:acc)
 170 splitAppTy other             = panic "splitAppTy"
 171
 172 splitAppTys :: GenType flexi -> (GenType flexi, [GenType flexi])
 173 splitAppTys ty = split ty ty []
 174   where
 175     split orig_ty (AppTy ty arg)        args = split ty ty (arg:args)
 176     split orig_ty (SynTy _ ty)          args = split orig_ty ty args
 177     split orig_ty (FunTy ty1 ty2)       args = ASSERT( null args )
 178                                                (TyConApp mkFunTyCon [], [ty1,ty2])
 179     split orig_ty (TyConApp tc tc_args) args = (TyConApp tc [], tc_args ++ args)
 180     split orig_ty ty                    args = (orig_ty, args)
 181 \end{code}
 182
 183
 184 ---------------------------------------------------------------------
 185                                 FunTy
 186                                 ~~~~~
 187
 188 \begin{code}
 189 mkFunTy :: GenType flexi -> GenType flexi -> GenType flexi
 190 mkFunTy arg res = FunTy arg res
 191
 192 mkFunTys :: [GenType flexi] -> GenType flexi -> GenType flexi
 193 mkFunTys tys ty = foldr FunTy ty tys
 194
 195 splitFunTy_maybe :: GenType flexi -> Maybe (GenType flexi, GenType flexi)
 196 splitFunTy_maybe (FunTy arg res) = Just (arg, res)
 197 splitFunTy_maybe (SynTy _ ty)    = splitFunTy_maybe ty
 198 splitFunTy_maybe other           = Nothing
 199
 200
 201 splitFunTys :: GenType flexi -> ([GenType flexi], GenType flexi)
 202 splitFunTys ty = split [] ty ty
 203   where
 204     split args orig_ty (FunTy arg res) = split (arg:args) res res
 205     split args orig_ty (SynTy _ ty)    = split args orig_ty ty
 206     split args orig_ty ty              = (reverse args, orig_ty)
 207 \end{code}
 208
 209
 210
 211 ---------------------------------------------------------------------
 212                                 TyConApp
 213                                 ~~~~~~~~
 214
 215 \begin{code}
 216 mkTyConApp :: TyCon -> [GenType flexi] -> GenType flexi
 217 mkTyConApp tycon tys
 218   | isFunTyCon tycon && length tys == 2
 219   = case tys of
 220         (ty1:ty2:_) -> FunTy ty1 ty2
 221
 222   | otherwise
 223   = ASSERT(not (isSynTyCon tycon))
 224     TyConApp tycon tys
 225
 226 mkTyConTy :: TyCon -> GenType flexi
 227 mkTyConTy tycon = ASSERT( not (isSynTyCon tycon) )
 228                   TyConApp tycon []
 229
 230 -- splitTyConApp "looks through" synonyms, because they don't
 231 -- mean a distinct type, but all other type-constructor applications
 232 -- including functions are returned as Just ..
 233
 234 splitTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi])
 235 splitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)
 236 splitTyConApp_maybe (FunTy arg res)   = Just (mkFunTyCon, [arg,res])
 237 splitTyConApp_maybe (SynTy _ ty)      = splitTyConApp_maybe ty
 238 splitTyConApp_maybe other             = Nothing
 239
 240 -- splitAlgTyConApp_maybe looks for
 241 --      *saturated* applications of *algebraic* data types
 242 -- "Algebraic" => newtype, data type, or dictionary (not function types)
 243 -- We return the constructors too.
 244
 245 splitAlgTyConApp_maybe :: GenType flexi -> Maybe (TyCon, [GenType flexi], [Id])
 246 splitAlgTyConApp_maybe (TyConApp tc tys)
 247   | isAlgTyCon tc &&
 248     tyConArity tc == length tys   = Just (tc, tys, tyConDataCons tc)
 249 splitAlgTyConApp_maybe (SynTy _ ty) = splitAlgTyConApp_maybe ty
 250 splitAlgTyConApp_maybe other      = Nothing
 251
 252 splitAlgTyConApp :: GenType flexi -> (TyCon, [GenType flexi], [Id])
 253         -- Here the "algebraic" property is an *assertion*
 254 splitAlgTyConApp (TyConApp tc tys) = ASSERT( isAlgTyCon tc && tyConArity tc == length tys )
 255                                      (tc, tys, tyConDataCons tc)
 256 splitAlgTyConApp (SynTy _ ty)      = splitAlgTyConApp ty
 257 \end{code}
 258
 259 y"Dictionary" types are just ordinary data types, but you can
 260 tell from the type constructor whether it's a dictionary or not.
 261
 262 \begin{code}
 263 mkDictTy :: Class -> [GenType flexi] -> GenType flexi
 264 mkDictTy clas tys = TyConApp (classTyCon clas) tys
 265
 266 splitDictTy_maybe :: GenType flexi -> Maybe (Class, [GenType flexi])
 267 splitDictTy_maybe (TyConApp tc tys)
 268   |  maybeToBool maybe_class
 269   && tyConArity tc == length tys = Just (clas, tys)
 270   where
 271      maybe_class = tyConClass_maybe tc
 272      Just clas   = maybe_class
 273
 274 splitDictTy_maybe (SynTy _ ty)  = splitDictTy_maybe ty
 275 splitDictTy_maybe other         = Nothing
 276
 277 isDictTy :: GenType flexi -> Bool
 278         -- This version is slightly more efficient than (maybeToBool . splitDictTy)
 279 isDictTy (TyConApp tc tys)
 280   |  maybeToBool (tyConClass_maybe tc)
 281   && tyConArity tc == length tys
 282   = True
 283 isDictTy (SynTy _ ty)           = isDictTy ty
 284 isDictTy other                  = False
 285 \end{code}
 286
 287
 288 ---------------------------------------------------------------------
 289                                 SynTy
 290                                 ~~~~~
 291
 292 \begin{code}
 293 mkSynTy syn_tycon tys
 294   = ASSERT(isSynTyCon syn_tycon)
 295     SynTy (TyConApp syn_tycon tys)
 296           (instantiateTauTy (zipTyVarEnv tyvars tys) body)
 297   where
 298     (tyvars, body) = getSynTyConDefn syn_tycon
 299
 300 isSynTy (SynTy _ _) = True
 301 isSynTy other       = False
 302 \end{code}
 303
 304 Notes on type synonyms
 305 ~~~~~~~~~~~~~~~~~~~~~~
 306 The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
 307 to return type synonyms whereever possible. Thus
 308
 309         type Foo a = a -> a
 310
 311 we want
 312         splitFunTys (a -> Foo a) = ([a], Foo a)
 313 not                                ([a], a -> a)
 314
 315 The reason is that we then get better (shorter) type signatures in
 316 interfaces.  Notably this plays a role in tcTySigs in TcBinds.lhs.
 317
 318
 319
 320
 321 ---------------------------------------------------------------------
 322                                 ForAllTy
 323                                 ~~~~~~~~
 324
 325 \begin{code}
 326 mkForAllTy = ForAllTy
 327
 328 mkForAllTys :: [GenTyVar flexi] -> GenType flexi -> GenType flexi
 329 mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
 330
 331 splitForAllTy_maybe :: GenType flexi -> Maybe (GenTyVar flexi, GenType flexi)
 332 splitForAllTy_maybe (SynTy _ ty)        = splitForAllTy_maybe ty
 333 splitForAllTy_maybe (ForAllTy tyvar ty) = Just(tyvar, ty)
 334 splitForAllTy_maybe _                   = Nothing
 335
 336 splitForAllTys :: GenType flexi -> ([GenTyVar flexi], GenType flexi)
 337 splitForAllTys ty = split ty ty []
 338    where
 339      split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
 340      split orig_ty (SynTy _ ty)     tvs = split orig_ty ty tvs
 341      split orig_ty t                tvs = (reverse tvs, orig_ty)
 342 \end{code}
 343
 344
 345 \begin{code}
 346 applyTy :: GenType flexi -> GenType flexi -> GenType flexi
 347 applyTy (SynTy _ fun)    arg = applyTy fun arg
 348 applyTy (ForAllTy tv ty) arg = instantiateTy (mkTyVarEnv [(tv,arg)]) ty
 349 applyTy other            arg = panic "applyTy"
 350 \end{code}
 351
 352
 353 %************************************************************************
 354 %*                                                                      *
 355 \subsection{Stuff to do with the source-language types}
 356 %*                                                                      *
 357 %************************************************************************
 358
 359 \begin{code}
 360 type RhoType   = Type
 361 type TauType   = Type
 362 type ThetaType = [(Class, [Type])]
 363 type SigmaType = Type
 364 \end{code}
 365
 366 @isTauTy@ tests for nested for-alls.
 367
 368 \begin{code}
 369 isTauTy :: GenType flexi -> Bool
 370 isTauTy (TyVarTy v)      = True
 371 isTauTy (TyConApp _ tys) = all isTauTy tys
 372 isTauTy (AppTy a b)      = isTauTy a && isTauTy b
 373 isTauTy (FunTy a b)      = isTauTy a && isTauTy b
 374 isTauTy (SynTy _ ty)     = isTauTy ty
 375 isTauTy other            = False
 376 \end{code}
 377
 378 \begin{code}
 379 mkRhoTy :: [(Class, [GenType flexi])] -> GenType flexi -> GenType flexi
 380 mkRhoTy theta ty = foldr (\(c,t) r -> FunTy (mkDictTy c t) r) ty theta
 381
 382 splitRhoTy :: GenType flexi -> ([(Class, [GenType flexi])], GenType flexi)
 383 splitRhoTy ty = split ty ty []
 384  where
 385   split orig_ty (FunTy arg res) ts = case splitDictTy_maybe arg of
 386                                         Just pair -> split res res (pair:ts)
 387                                         Nothing   -> (reverse ts, orig_ty)
 388   split orig_ty (SynTy _ ty) ts    = split orig_ty ty ts
 389   split orig_ty ty ts              = (reverse ts, orig_ty)
 390 \end{code}
 391
 392
 393
 394 \begin{code}
 395 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
 396
 397 splitSigmaTy :: GenType flexi -> ([GenTyVar flexi], [(Class, [GenType flexi])], GenType flexi)
 398 splitSigmaTy ty =
 399   (tyvars, theta, tau)
 400  where
 401   (tyvars,rho) = splitForAllTys ty
 402   (theta,tau)  = splitRhoTy rho
 403 \end{code}
 404
 405
 406 %************************************************************************
 407 %*                                                                      *
 408 \subsection{Kinds and free variables}
 409 %*                                                                      *
 410 %************************************************************************
 411
 412 ---------------------------------------------------------------------
 413                 Finding the kind of a type
 414                 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 415 \begin{code}
 416 typeKind :: GenType flexi -> Kind
 417
 418 typeKind (TyVarTy tyvar)        = tyVarKind tyvar
 419 typeKind (TyConApp tycon tys)   = foldr (\_ k -> resultKind k) (tyConKind tycon) tys
 420 typeKind (SynTy _ ty)           = typeKind ty
 421 typeKind (FunTy fun arg)        = mkBoxedTypeKind
 422 typeKind (AppTy fun arg)        = resultKind (typeKind fun)
 423 typeKind (ForAllTy _ _)         = mkBoxedTypeKind
 424 \end{code}
 425
 426
 427 ---------------------------------------------------------------------
 428                 Free variables of a type
 429                 ~~~~~~~~~~~~~~~~~~~~~~~~
 430 \begin{code}
 431 tyVarsOfType :: GenType flexi -> GenTyVarSet flexi
 432
 433 tyVarsOfType (TyVarTy tv)               = unitTyVarSet tv
 434 tyVarsOfType (TyConApp tycon tys)       = tyVarsOfTypes tys
 435 tyVarsOfType (SynTy ty1 ty2)            = tyVarsOfType ty1
 436 tyVarsOfType (FunTy arg res)            = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res
 437 tyVarsOfType (AppTy fun arg)            = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg
 438 tyVarsOfType (ForAllTy tyvar ty)        = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar
 439
 440 tyVarsOfTypes :: [GenType flexi] -> GenTyVarSet flexi
 441 tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys
 442
 443 -- Find the free names of a type, including the type constructors and classes it mentions
 444 namesOfType :: GenType flexi -> NameSet
 445 namesOfType (TyVarTy tv)                = unitNameSet (getName tv)
 446 namesOfType (TyConApp tycon tys)        = unitNameSet (getName tycon) `unionNameSets`
 447                                           namesOfTypes tys
 448 namesOfType (SynTy ty1 ty2)             = namesOfType ty1
 449 namesOfType (FunTy arg res)             = namesOfType arg `unionNameSets` namesOfType res
 450 namesOfType (AppTy fun arg)             = namesOfType fun `unionNameSets` namesOfType arg
 451 namesOfType (ForAllTy tyvar ty)         = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
 452
 453 namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
 454 \end{code}
 455
 456
 457 %************************************************************************
 458 %*                                                                      *
 459 \subsection{Instantiating a type}
 460 %*                                                                      *
 461 %************************************************************************
 462
 463 \begin{code}
 464 instantiateTy    :: TyVarEnv (GenType flexi)  -> GenType flexi  -> GenType flexi
 465 instantiateTauTy :: TyVarEnv (GenType flexi2) -> GenType flexi1 -> GenType flexi2
 466
 467
 468 -- instantiateTy applies a type environment to a type.
 469 -- It can handle shadowing; for example:
 470 --      f = /\ t1 t2 -> \ d ->
 471 --         letrec f' = /\ t1 -> \x -> ...(f' t1 x')...
 472 --         in f' t1
 473 -- Here, when we clone t1 to t1', say, we'll come across shadowing
 474 -- when applying the clone environment to the type of f'.
 475 --
 476 -- As a sanity check, we should also check that name capture
 477 -- doesn't occur, but that means keeping track of the free variables of the
 478 -- range of the TyVarEnv, which I don't do just yet.
 479
 480 instantiateTy tenv ty
 481   | isEmptyTyVarEnv tenv
 482   = ty
 483
 484   | otherwise
 485   = go tenv ty
 486   where
 487     go tenv ty@(TyVarTy tv)   = case (lookupTyVarEnv tenv tv) of
 488                                       Nothing -> ty
 489                                       Just ty -> ty
 490     go tenv (TyConApp tc tys) = TyConApp tc (map (go tenv) tys)
 491     go tenv (SynTy ty1 ty2)   = SynTy (go tenv ty1) (go tenv ty2)
 492     go tenv (FunTy arg res)   = FunTy (go tenv arg) (go tenv res)
 493     go tenv (AppTy fun arg)   = mkAppTy (go tenv fun) (go tenv arg)
 494     go tenv (ForAllTy tv ty)  = ForAllTy tv (go tenv' ty)
 495                               where
 496                                 tenv' = case lookupTyVarEnv tenv tv of
 497                                             Nothing -> tenv
 498                                             Just _  -> delFromTyVarEnv tenv tv
 499
 500 -- instantiateTauTy works only (a) on types with no ForAlls,
 501 --      and when               (b) all the type variables are being instantiated
 502 -- In return it is more polymorphic than instantiateTy
 503
 504 instantiateTauTy tenv ty = go ty
 505   where
 506     go ty@(TyVarTy tv)   = case (lookupTyVarEnv tenv tv) of
 507                                       Just ty -> ty  -- Must succeed
 508     go (TyConApp tc tys) = TyConApp tc (map go tys)
 509     go (SynTy ty1 ty2)   = SynTy (go ty1) (go ty2)
 510     go (FunTy arg res)   = FunTy (go arg) (go res)
 511     go (AppTy fun arg)   = mkAppTy (go fun) (go arg)
 512     go (ForAllTy tv ty)  = panic "instantiateTauTy"
 513
 514
 515 instantiateThetaTy :: TyVarEnv Type -> ThetaType -> ThetaType
 516 instantiateThetaTy tenv theta
 517  = [(clas, map (instantiateTauTy tenv) tys) | (clas, tys) <- theta]
 518 \end{code}
 519
 520
 521 %************************************************************************
 522 %*                                                                      *
 523 \subsection{Boxedness and pointedness}
 524 %*                                                                      *
 525 %************************************************************************
 526
 527 A type is
 528         *unboxed*       iff its representation is other than a pointer
 529                         Unboxed types cannot instantiate a type variable
 530                         Unboxed types are always unpointed.
 531
 532         *unpointed*     iff it can't be a thunk, and cannot have value bottom
 533                         An unpointed type may or may not be unboxed.
 534                                 (E.g. Array# is unpointed, but boxed.)
 535                         An unpointed type *can* instantiate a type variable,
 536                         provided it is boxed.
 537
 538         *primitive*     iff it is a built-in type that can't be expressed
 539                                 in Haskell
 540
 541 Currently, all primitive types are unpointed, but that's not necessarily
 542 the case.  (E.g. Int could be primitive.)
 543
 544 \begin{code}
 545 isUnboxedType :: Type -> Bool
 546 isUnboxedType ty = case typePrimRep ty of
 547                         PtrRep -> False
 548                         other  -> True
 549
 550 -- Danger!  Currently the unpointed types are precisely
 551 -- the primitive ones, but that might not always be the case
 552 isUnpointedType :: Type -> Bool
 553 isUnpointedType ty = case splitTyConApp_maybe ty of
 554                            Just (tc, ty_args) -> isPrimTyCon tc
 555                            other              -> False
 556
 557 typePrimRep :: Type -> PrimRep
 558 typePrimRep ty = case splitTyConApp_maybe ty of
 559                    Just (tc, ty_args) -> tyConPrimRep tc
 560                    other              -> PtrRep
 561 \end{code}
 562
 563
 564 %************************************************************************
 565 %*                                                                      *
 566 \subsection{Matching on types}
 567 %*                                                                      *
 568 %************************************************************************
 569
 570 Matching is a {\em unidirectional} process, matching a type against a
 571 template (which is just a type with type variables in it).  The
 572 matcher assumes that there are no repeated type variables in the
 573 template, so that it simply returns a mapping of type variables to
 574 types.  It also fails on nested foralls.
 575
 576 @matchTys@ matches corresponding elements of a list of templates and
 577 types.
 578
 579 \begin{code}
 580 matchTy :: GenType flexi1                       -- Template
 581         -> GenType flexi2                       -- Proposed instance of template
 582         -> Maybe (TyVarEnv (GenType flexi2))    -- Matching substitution
 583
 584
 585 matchTys :: [GenType flexi1]                    -- Templates
 586          -> [GenType flexi2]                    -- Proposed instance of template
 587          -> Maybe (TyVarEnv (GenType flexi2),   -- Matching substitution
 588                    [GenType flexi2])            -- Left over instance types
 589
 590 matchTy  ty1  ty2  = match      ty1  ty2  (\s  -> Just s)  emptyTyVarEnv
 591 matchTys tys1 tys2 = match_list tys1 tys2 (\pr -> Just pr) emptyTyVarEnv
 592 \end{code}
 593
 594 @match@ is the main function.
 595
 596 \begin{code}
 597 match :: GenType flexi1 -> GenType flexi2               -- Current match pair
 598       -> (TyVarEnv (GenType flexi2) -> Maybe result)    -- Continuation
 599       -> TyVarEnv (GenType flexi2)                      -- Current substitution
 600       -> Maybe result
 601
 602 -- When matching against a type variable, see if the variable
 603 -- has already been bound.  If so, check that what it's bound to
 604 -- is the same as ty; if not, bind it and carry on.
 605
 606 match (TyVarTy v) ty k = \s -> case lookupTyVarEnv s v of
 607                                  Nothing  -> k (addToTyVarEnv s v ty)
 608                                  Just ty' | ty' == ty -> k s      -- Succeeds
 609                                           | otherwise -> Nothing  -- Fails
 610
 611 match (FunTy arg1 res1)   (FunTy arg2 res2)  k = match arg1 arg2 (match res1 res2 k)
 612 match (AppTy fun1 arg1)   (AppTy fun2 arg2)  k = match fun1 fun2 (match arg1 arg2 k)
 613 match (TyConApp tc1 tys1) (TyConApp tc2 tys2) k | tc1 == tc2
 614                                                 = match_list tys1 tys2 ( \(s,tys2') ->
 615                                                     if null tys2' then
 616                                                         k s     -- Succeed
 617                                                     else
 618                                                         Nothing -- Fail
 619                                                   )
 620
 621         -- With type synonyms, we have to be careful for the exact
 622         -- same reasons as in the unifier.  Please see the
 623         -- considerable commentary there before changing anything
 624         -- here! (WDP 95/05)
 625 match (SynTy _ ty1)       ty2                k = match ty1 ty2 k
 626 match ty1                 (SynTy _ ty2)      k = match ty1 ty2 k
 627
 628 -- Catch-all fails
 629 match _ _ _ = \s -> Nothing
 630
 631 match_list []         tys2       k = \s -> k (s, tys2)
 632 match_list (ty1:tys1) []         k = panic "match_list"
 633 match_list (ty1:tys1) (ty2:tys2) k = match ty1 ty2 (match_list tys1 tys2 k)
 634 \end{code}
 635
 636 %************************************************************************
 637 %*                                                                      *
 638 \subsection{Equality on types}
 639 %*                                                                      *
 640 %************************************************************************
 641
 642 For the moment at least, type comparisons don't work if
 643 there are embedded for-alls.
 644
 645 \begin{code}
 646 instance Eq (GenType flexi) where
 647   ty1 == ty2 = case ty1 `cmpTy` ty2 of { EQ -> True; other -> False }
 648
 649 instance Ord (GenType flexi) where
 650   compare ty1 ty2 = cmpTy ty1 ty2
 651
 652 cmpTy :: GenType flexi -> GenType flexi -> Ordering
 653 cmpTy ty1 ty2
 654   = cmp emptyTyVarEnv ty1 ty2
 655   where
 656   -- The "env" maps type variables in ty1 to type variables in ty2
 657   -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
 658   -- we in effect substitute tv2 for tv1 in t1 before continuing
 659     lookup env tv1 = case lookupTyVarEnv env tv1 of
 660                           Just tv2 -> tv2
 661                           Nothing  -> tv1
 662
 663     -- Get rid of SynTy
 664     cmp env (SynTy _ ty1) ty2 = cmp env ty1 ty2
 665     cmp env ty1 (SynTy _ ty2) = cmp env ty1 ty2
 666
 667     -- Deal with equal constructors
 668     cmp env (TyVarTy tv1) (TyVarTy tv2) = lookup env tv1 `compare` tv2
 669     cmp env (AppTy f1 a1) (AppTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
 670     cmp env (FunTy f1 a1) (FunTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
 671     cmp env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmps env tys1 tys2)
 672     cmp env (ForAllTy tv1 t1)   (ForAllTy tv2 t2)   = cmp (addToTyVarEnv env tv1 tv2) t1 t2
 673
 674     -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy
 675     cmp env (AppTy _ _) (TyVarTy _) = GT
 676
 677     cmp env (FunTy _ _) (TyVarTy _) = GT
 678     cmp env (FunTy _ _) (AppTy _ _) = GT
 679
 680     cmp env (TyConApp _ _) (TyVarTy _) = GT
 681     cmp env (TyConApp _ _) (AppTy _ _) = GT
 682     cmp env (TyConApp _ _) (FunTy _ _) = GT
 683
 684     cmp env (ForAllTy _ _) other       = GT
 685
 686     cmp env _ _                        = LT
 687
 688     cmps env []     [] = EQ
 689     cmps env (t:ts) [] = GT
 690     cmps env [] (t:ts) = LT
 691     cmps env (t1:t1s) (t2:t2s) = cmp env t1 t2 `thenCmp` cmps env t1s t2s
 692 \end{code}
 693
 694
 695
 696 %************************************************************************
 697 %*                                                                      *
 698 \subsection{Grime}
 699 %*                                                                      *
 700 %************************************************************************
 701
 702
 703
 704 \begin{code}
 705 showTypeCategory :: Type -> Char
 706   {-
 707         {C,I,F,D}   char, int, float, double
 708         T           tuple
 709         S           other single-constructor type
 710         {c,i,f,d}   unboxed ditto
 711         t           *unpacked* tuple
 712         s           *unpacked" single-cons...
 713
 714         v           void#
 715         a           primitive array
 716
 717         E           enumeration type
 718         +           dictionary, unless it's a ...
 719         L           List
 720         >           function
 721         M           other (multi-constructor) data-con type
 722         .           other type
 723         -           reserved for others to mark as "uninteresting"
 724     -}
 725 showTypeCategory ty
 726   = if isDictTy ty
 727     then '+'
 728     else
 729       case splitTyConApp_maybe ty of
 730         Nothing -> if maybeToBool (splitFunTy_maybe ty)
 731                    then '>'
 732                    else '.'
 733
 734         Just (tycon, _) ->
 735           let utc = uniqueOf tycon in
 736           if      utc == charDataConKey    then 'C'
 737           else if utc == intDataConKey     then 'I'
 738           else if utc == floatDataConKey   then 'F'
 739           else if utc == doubleDataConKey  then 'D'
 740           else if utc == integerDataConKey then 'J'
 741           else if utc == charPrimTyConKey  then 'c'
 742           else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
 743                 || utc == addrPrimTyConKey)                then 'i'
 744           else if utc  == floatPrimTyConKey                then 'f'
 745           else if utc  == doublePrimTyConKey               then 'd'
 746           else if isPrimTyCon tycon {- array, we hope -}   then 'A'
 747           else if isEnumerationTyCon tycon                 then 'E'
 748           else if isTupleTyCon tycon                       then 'T'
 749           else if maybeToBool (maybeTyConSingleCon tycon)  then 'S'
 750           else if utc == listTyConKey                      then 'L'
 751           else 'M' -- oh, well...
 752 \end{code}