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,
  18         applyTy, applyTys, isForAllTy,
  19
  20         TauType, RhoType, SigmaType, ThetaType,
  21         isTauTy,
  22         mkRhoTy, splitRhoTy,
  23         mkSigmaTy, splitSigmaTy,
  24
  25         isUnpointedType, isUnboxedType, typePrimRep,
  26
  27         matchTy, matchTys,
  28
  29         tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind,
  30
  31         instantiateTy, instantiateTauTy, instantiateThetaTy, applyToTyVars,
  32
  33         showTypeCategory
  34     ) where
  35
  36 #include "HsVersions.h"
  37
  38 import {-# SOURCE #-} Id        ( Id )
  39
  40 -- friends:
  41 import Class    ( classTyCon, Class )
  42 import Kind     ( mkBoxedTypeKind, resultKind, Kind )
  43 import TyCon    ( mkFunTyCon, isFunTyCon, isEnumerationTyCon, isTupleTyCon, maybeTyConSingleCon,
  44                   isPrimTyCon, isAlgTyCon, isSynTyCon, tyConArity,
  45                   tyConKind, tyConDataCons, getSynTyConDefn,
  46                   tyConPrimRep, tyConClass_maybe, TyCon )
  47 import TyVar    ( GenTyVarSet, TyVarEnv, GenTyVar, TyVar,
  48                   tyVarKind, tyVarFlexi, emptyTyVarSet, unionTyVarSets, minusTyVarSet,
  49                   unitTyVarSet, lookupTyVarEnv, delFromTyVarEnv, zipTyVarEnv, mkTyVarEnv,
  50                   emptyTyVarEnv, isEmptyTyVarEnv, addToTyVarEnv )
  51 import Name     ( NamedThing(..),
  52                   NameSet(..), unionNameSets, emptyNameSet, unitNameSet, minusNameSet
  53                 )
  54
  55 -- others
  56 import BasicTypes ( Unused )
  57 import Maybes   ( maybeToBool, assocMaybe )
  58 import PrimRep  ( PrimRep(..) )
  59 import Unique   -- quite a few *Keys
  60 import Util     ( thenCmp, panic, assertPanic )
  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 "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 isForAllTy :: GenType flexi -> Bool
 337 isForAllTy (SynTy _ ty)        = isForAllTy ty
 338 isForAllTy (ForAllTy tyvar ty) = True
 339 isForAllTy _                 = False
 340
 341 splitForAllTys :: GenType flexi -> ([GenTyVar flexi], GenType flexi)
 342 splitForAllTys ty = split ty ty []
 343    where
 344      split orig_ty (ForAllTy tv ty) tvs = split ty ty (tv:tvs)
 345      split orig_ty (SynTy _ ty)     tvs = split orig_ty ty tvs
 346      split orig_ty t                tvs = (reverse tvs, orig_ty)
 347 \end{code}
 348
 349
 350 \begin{code}
 351 applyTy :: GenType flexi -> GenType flexi -> GenType flexi
 352 applyTy (SynTy _ fun)    arg = applyTy fun arg
 353 applyTy (ForAllTy tv ty) arg = instantiateTy (mkTyVarEnv [(tv,arg)]) ty
 354 applyTy other            arg = panic "applyTy"
 355
 356 applyTys :: GenType flexi -> [GenType flexi] -> GenType flexi
 357 applyTys fun_ty arg_tys
 358  = go [] fun_ty arg_tys
 359  where
 360    go env ty               []         = instantiateTy (mkTyVarEnv env) ty
 361    go env (SynTy _ fun)    args       = go env fun args
 362    go env (ForAllTy tv ty) (arg:args) = go ((tv,arg):env) ty args
 363    go env other            args       = panic "applyTys"
 364 \end{code}
 365
 366
 367 %************************************************************************
 368 %*                                                                      *
 369 \subsection{Stuff to do with the source-language types}
 370 %*                                                                      *
 371 %************************************************************************
 372
 373 \begin{code}
 374 type RhoType   = Type
 375 type TauType   = Type
 376 type ThetaType = [(Class, [Type])]
 377 type SigmaType = Type
 378 \end{code}
 379
 380 @isTauTy@ tests for nested for-alls.
 381
 382 \begin{code}
 383 isTauTy :: GenType flexi -> Bool
 384 isTauTy (TyVarTy v)      = True
 385 isTauTy (TyConApp _ tys) = all isTauTy tys
 386 isTauTy (AppTy a b)      = isTauTy a && isTauTy b
 387 isTauTy (FunTy a b)      = isTauTy a && isTauTy b
 388 isTauTy (SynTy _ ty)     = isTauTy ty
 389 isTauTy other            = False
 390 \end{code}
 391
 392 \begin{code}
 393 mkRhoTy :: [(Class, [GenType flexi])] -> GenType flexi -> GenType flexi
 394 mkRhoTy theta ty = foldr (\(c,t) r -> FunTy (mkDictTy c t) r) ty theta
 395
 396 splitRhoTy :: GenType flexi -> ([(Class, [GenType flexi])], GenType flexi)
 397 splitRhoTy ty = split ty ty []
 398  where
 399   split orig_ty (FunTy arg res) ts = case splitDictTy_maybe arg of
 400                                         Just pair -> split res res (pair:ts)
 401                                         Nothing   -> (reverse ts, orig_ty)
 402   split orig_ty (SynTy _ ty) ts    = split orig_ty ty ts
 403   split orig_ty ty ts              = (reverse ts, orig_ty)
 404 \end{code}
 405
 406
 407
 408 \begin{code}
 409 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
 410
 411 splitSigmaTy :: GenType flexi -> ([GenTyVar flexi], [(Class, [GenType flexi])], GenType flexi)
 412 splitSigmaTy ty =
 413   (tyvars, theta, tau)
 414  where
 415   (tyvars,rho) = splitForAllTys ty
 416   (theta,tau)  = splitRhoTy rho
 417 \end{code}
 418
 419
 420 %************************************************************************
 421 %*                                                                      *
 422 \subsection{Kinds and free variables}
 423 %*                                                                      *
 424 %************************************************************************
 425
 426 ---------------------------------------------------------------------
 427                 Finding the kind of a type
 428                 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 429 \begin{code}
 430 typeKind :: GenType flexi -> Kind
 431
 432 typeKind (TyVarTy tyvar)        = tyVarKind tyvar
 433 typeKind (TyConApp tycon tys)   = foldr (\_ k -> resultKind k) (tyConKind tycon) tys
 434 typeKind (SynTy _ ty)           = typeKind ty
 435 typeKind (FunTy fun arg)        = mkBoxedTypeKind
 436 typeKind (AppTy fun arg)        = resultKind (typeKind fun)
 437 typeKind (ForAllTy _ _)         = mkBoxedTypeKind
 438 \end{code}
 439
 440
 441 ---------------------------------------------------------------------
 442                 Free variables of a type
 443                 ~~~~~~~~~~~~~~~~~~~~~~~~
 444 \begin{code}
 445 tyVarsOfType :: GenType flexi -> GenTyVarSet flexi
 446
 447 tyVarsOfType (TyVarTy tv)               = unitTyVarSet tv
 448 tyVarsOfType (TyConApp tycon tys)       = tyVarsOfTypes tys
 449 tyVarsOfType (SynTy ty1 ty2)            = tyVarsOfType ty1
 450 tyVarsOfType (FunTy arg res)            = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res
 451 tyVarsOfType (AppTy fun arg)            = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg
 452 tyVarsOfType (ForAllTy tyvar ty)        = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar
 453
 454 tyVarsOfTypes :: [GenType flexi] -> GenTyVarSet flexi
 455 tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys
 456
 457 -- Find the free names of a type, including the type constructors and classes it mentions
 458 namesOfType :: GenType flexi -> NameSet
 459 namesOfType (TyVarTy tv)                = unitNameSet (getName tv)
 460 namesOfType (TyConApp tycon tys)        = unitNameSet (getName tycon) `unionNameSets`
 461                                           namesOfTypes tys
 462 namesOfType (SynTy ty1 ty2)             = namesOfType ty1
 463 namesOfType (FunTy arg res)             = namesOfType arg `unionNameSets` namesOfType res
 464 namesOfType (AppTy fun arg)             = namesOfType fun `unionNameSets` namesOfType arg
 465 namesOfType (ForAllTy tyvar ty)         = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
 466
 467 namesOfTypes tys = foldr (unionNameSets . namesOfType) emptyNameSet tys
 468 \end{code}
 469
 470
 471 %************************************************************************
 472 %*                                                                      *
 473 \subsection{Instantiating a type}
 474 %*                                                                      *
 475 %************************************************************************
 476
 477 \begin{code}
 478 instantiateTy    :: TyVarEnv (GenType flexi)  -> GenType flexi  -> GenType flexi
 479 instantiateTauTy :: TyVarEnv (GenType flexi2) -> GenType flexi1 -> GenType flexi2
 480
 481
 482 -- instantiateTy applies a type environment to a type.
 483 -- It can handle shadowing; for example:
 484 --      f = /\ t1 t2 -> \ d ->
 485 --         letrec f' = /\ t1 -> \x -> ...(f' t1 x')...
 486 --         in f' t1
 487 -- Here, when we clone t1 to t1', say, we'll come across shadowing
 488 -- when applying the clone environment to the type of f'.
 489 --
 490 -- As a sanity check, we should also check that name capture
 491 -- doesn't occur, but that means keeping track of the free variables of the
 492 -- range of the TyVarEnv, which I don't do just yet.
 493
 494 instantiateTy tenv ty
 495   | isEmptyTyVarEnv tenv
 496   = ty
 497
 498   | otherwise
 499   = go tenv ty
 500   where
 501     go tenv ty@(TyVarTy tv)   = case (lookupTyVarEnv tenv tv) of
 502                                       Nothing -> ty
 503                                       Just ty -> ty
 504     go tenv (TyConApp tc tys) = TyConApp tc (map (go tenv) tys)
 505     go tenv (SynTy ty1 ty2)   = SynTy (go tenv ty1) (go tenv ty2)
 506     go tenv (FunTy arg res)   = FunTy (go tenv arg) (go tenv res)
 507     go tenv (AppTy fun arg)   = mkAppTy (go tenv fun) (go tenv arg)
 508     go tenv (ForAllTy tv ty)  = ForAllTy tv (go tenv' ty)
 509                               where
 510                                 tenv' = case lookupTyVarEnv tenv tv of
 511                                             Nothing -> tenv
 512                                             Just _  -> delFromTyVarEnv tenv tv
 513
 514 -- instantiateTauTy works only (a) on types with no ForAlls,
 515 --      and when               (b) all the type variables are being instantiated
 516 -- In return it is more polymorphic than instantiateTy
 517
 518 instantiateTauTy tenv ty = applyToTyVars lookup ty
 519                          where
 520                            lookup tv = case lookupTyVarEnv tenv tv of
 521                                           Just ty -> ty  -- Must succeed
 522
 523
 524 instantiateThetaTy :: TyVarEnv Type -> ThetaType -> ThetaType
 525 instantiateThetaTy tenv theta
 526  = [(clas, map (instantiateTauTy tenv) tys) | (clas, tys) <- theta]
 527
 528 applyToTyVars :: (GenTyVar flexi1 -> GenType flexi2)
 529               -> GenType flexi1
 530               -> GenType flexi2
 531 applyToTyVars f ty = go ty
 532   where
 533     go (TyVarTy tv)      = f tv
 534     go (TyConApp tc tys) = TyConApp tc (map go tys)
 535     go (SynTy ty1 ty2)   = SynTy (go ty1) (go ty2)
 536     go (FunTy arg res)   = FunTy (go arg) (go res)
 537     go (AppTy fun arg)   = mkAppTy (go fun) (go arg)
 538     go (ForAllTy tv ty)  = panic "instantiateTauTy"
 539 \end{code}
 540
 541
 542 %************************************************************************
 543 %*                                                                      *
 544 \subsection{Boxedness and pointedness}
 545 %*                                                                      *
 546 %************************************************************************
 547
 548 A type is
 549         *unboxed*       iff its representation is other than a pointer
 550                         Unboxed types cannot instantiate a type variable
 551                         Unboxed types are always unpointed.
 552
 553         *unpointed*     iff it can't be a thunk, and cannot have value bottom
 554                         An unpointed type may or may not be unboxed.
 555                                 (E.g. Array# is unpointed, but boxed.)
 556                         An unpointed type *can* instantiate a type variable,
 557                         provided it is boxed.
 558
 559         *primitive*     iff it is a built-in type that can't be expressed
 560                                 in Haskell
 561
 562 Currently, all primitive types are unpointed, but that's not necessarily
 563 the case.  (E.g. Int could be primitive.)
 564
 565 \begin{code}
 566 isUnboxedType :: Type -> Bool
 567 isUnboxedType ty = case typePrimRep ty of
 568                         PtrRep -> False
 569                         other  -> True
 570
 571 -- Danger!  Currently the unpointed types are precisely
 572 -- the primitive ones, but that might not always be the case
 573 isUnpointedType :: Type -> Bool
 574 isUnpointedType ty = case splitTyConApp_maybe ty of
 575                            Just (tc, ty_args) -> isPrimTyCon tc
 576                            other              -> False
 577
 578 typePrimRep :: Type -> PrimRep
 579 typePrimRep ty = case splitTyConApp_maybe ty of
 580                    Just (tc, ty_args) -> tyConPrimRep tc
 581                    other              -> PtrRep
 582 \end{code}
 583
 584
 585 %************************************************************************
 586 %*                                                                      *
 587 \subsection{Matching on types}
 588 %*                                                                      *
 589 %************************************************************************
 590
 591 Matching is a {\em unidirectional} process, matching a type against a
 592 template (which is just a type with type variables in it).  The
 593 matcher assumes that there are no repeated type variables in the
 594 template, so that it simply returns a mapping of type variables to
 595 types.  It also fails on nested foralls.
 596
 597 @matchTys@ matches corresponding elements of a list of templates and
 598 types.
 599
 600 \begin{code}
 601 matchTy :: GenType Bool                         -- Template
 602         -> GenType flexi                        -- Proposed instance of template
 603         -> Maybe (TyVarEnv (GenType flexi))     -- Matching substitution
 604
 605
 606 matchTys :: [GenType Bool]                      -- Templates
 607          -> [GenType flexi]                     -- Proposed instance of template
 608          -> Maybe (TyVarEnv (GenType flexi),    -- Matching substitution
 609                    [GenType flexi])             -- Left over instance types
 610
 611 matchTy  ty1  ty2  = match      ty1  ty2  (\s  -> Just s)  emptyTyVarEnv
 612 matchTys tys1 tys2 = match_list tys1 tys2 (\pr -> Just pr) emptyTyVarEnv
 613 \end{code}
 614
 615 @match@ is the main function.
 616
 617 \begin{code}
 618 match :: GenType Bool -> GenType flexi                  -- Current match pair
 619       -> (TyVarEnv (GenType flexi) -> Maybe result)     -- Continuation
 620       -> TyVarEnv (GenType flexi)                       -- Current substitution
 621       -> Maybe result
 622
 623 -- When matching against a type variable, see if the variable
 624 -- has already been bound.  If so, check that what it's bound to
 625 -- is the same as ty; if not, bind it and carry on.
 626
 627 match (TyVarTy v) ty k = \s -> if tyVarFlexi v then
 628                                      -- v is a template variable
 629                                      case lookupTyVarEnv s v of
 630                                        Nothing  -> k (addToTyVarEnv s v ty)
 631                                        Just ty' | ty' == ty -> k s      -- Succeeds
 632                                                 | otherwise -> Nothing  -- Fails
 633                                else
 634                                      -- v is not a template variable; ty had better match
 635                                      -- Can't use (==) because types differ
 636                                      case ty of
 637                                        TyVarTy v' | uniqueOf v == uniqueOf v'
 638                                                   -> k s       -- Success
 639                                        other      -> Nothing   -- Failure
 640
 641 match (FunTy arg1 res1)   (FunTy arg2 res2)   k = match arg1 arg2 (match res1 res2 k)
 642 match (AppTy fun1 arg1)   (AppTy fun2 arg2)   k = match fun1 fun2 (match arg1 arg2 k)
 643 match (TyConApp tc1 tys1) (TyConApp tc2 tys2) k | tc1 == tc2
 644                                                 = match_list tys1 tys2 ( \(s,tys2') ->
 645                                                   if null tys2' then
 646                                                         k s     -- Succeed
 647                                                   else
 648                                                         Nothing -- Fail
 649                                                   )
 650
 651         -- With type synonyms, we have to be careful for the exact
 652         -- same reasons as in the unifier.  Please see the
 653         -- considerable commentary there before changing anything
 654         -- here! (WDP 95/05)
 655 match (SynTy _ ty1) ty2           k = match ty1 ty2 k
 656 match ty1           (SynTy _ ty2) k = match ty1 ty2 k
 657
 658 -- Catch-all fails
 659 match _ _ _ = \s -> Nothing
 660
 661 match_list []         tys2       k = \s -> k (s, tys2)
 662 match_list (ty1:tys1) []         k = \s -> Nothing      -- Not enough arg tys => failure
 663 match_list (ty1:tys1) (ty2:tys2) k = match ty1 ty2 (match_list tys1 tys2 k)
 664 \end{code}
 665
 666 %************************************************************************
 667 %*                                                                      *
 668 \subsection{Equality on types}
 669 %*                                                                      *
 670 %************************************************************************
 671
 672 For the moment at least, type comparisons don't work if
 673 there are embedded for-alls.
 674
 675 \begin{code}
 676 instance Eq (GenType flexi) where
 677   ty1 == ty2 = case ty1 `cmpTy` ty2 of { EQ -> True; other -> False }
 678
 679 instance Ord (GenType flexi) where
 680   compare ty1 ty2 = cmpTy ty1 ty2
 681
 682 cmpTy :: GenType flexi -> GenType flexi -> Ordering
 683 cmpTy ty1 ty2
 684   = cmp emptyTyVarEnv ty1 ty2
 685   where
 686   -- The "env" maps type variables in ty1 to type variables in ty2
 687   -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
 688   -- we in effect substitute tv2 for tv1 in t1 before continuing
 689     lookup env tv1 = case lookupTyVarEnv env tv1 of
 690                           Just tv2 -> tv2
 691                           Nothing  -> tv1
 692
 693     -- Get rid of SynTy
 694     cmp env (SynTy _ ty1) ty2 = cmp env ty1 ty2
 695     cmp env ty1 (SynTy _ ty2) = cmp env ty1 ty2
 696
 697     -- Deal with equal constructors
 698     cmp env (TyVarTy tv1) (TyVarTy tv2) = lookup env tv1 `compare` tv2
 699     cmp env (AppTy f1 a1) (AppTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
 700     cmp env (FunTy f1 a1) (FunTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
 701     cmp env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmps env tys1 tys2)
 702     cmp env (ForAllTy tv1 t1)   (ForAllTy tv2 t2)   = cmp (addToTyVarEnv env tv1 tv2) t1 t2
 703
 704     -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy
 705     cmp env (AppTy _ _) (TyVarTy _) = GT
 706
 707     cmp env (FunTy _ _) (TyVarTy _) = GT
 708     cmp env (FunTy _ _) (AppTy _ _) = GT
 709
 710     cmp env (TyConApp _ _) (TyVarTy _) = GT
 711     cmp env (TyConApp _ _) (AppTy _ _) = GT
 712     cmp env (TyConApp _ _) (FunTy _ _) = GT
 713
 714     cmp env (ForAllTy _ _) other       = GT
 715
 716     cmp env _ _                        = LT
 717
 718     cmps env []     [] = EQ
 719     cmps env (t:ts) [] = GT
 720     cmps env [] (t:ts) = LT
 721     cmps env (t1:t1s) (t2:t2s) = cmp env t1 t2 `thenCmp` cmps env t1s t2s
 722 \end{code}
 723
 724
 725
 726 %************************************************************************
 727 %*                                                                      *
 728 \subsection{Grime}
 729 %*                                                                      *
 730 %************************************************************************
 731
 732
 733
 734 \begin{code}
 735 showTypeCategory :: Type -> Char
 736   {-
 737         {C,I,F,D}   char, int, float, double
 738         T           tuple
 739         S           other single-constructor type
 740         {c,i,f,d}   unboxed ditto
 741         t           *unpacked* tuple
 742         s           *unpacked" single-cons...
 743
 744         v           void#
 745         a           primitive array
 746
 747         E           enumeration type
 748         +           dictionary, unless it's a ...
 749         L           List
 750         >           function
 751         M           other (multi-constructor) data-con type
 752         .           other type
 753         -           reserved for others to mark as "uninteresting"
 754     -}
 755 showTypeCategory ty
 756   = if isDictTy ty
 757     then '+'
 758     else
 759       case splitTyConApp_maybe ty of
 760         Nothing -> if maybeToBool (splitFunTy_maybe ty)
 761                    then '>'
 762                    else '.'
 763
 764         Just (tycon, _) ->
 765           let utc = uniqueOf tycon in
 766           if      utc == charDataConKey    then 'C'
 767           else if utc == intDataConKey     then 'I'
 768           else if utc == floatDataConKey   then 'F'
 769           else if utc == doubleDataConKey  then 'D'
 770           else if utc == integerDataConKey then 'J'
 771           else if utc == charPrimTyConKey  then 'c'
 772           else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
 773                 || utc == addrPrimTyConKey)                then 'i'
 774           else if utc  == floatPrimTyConKey                then 'f'
 775           else if utc  == doublePrimTyConKey               then 'd'
 776           else if isPrimTyCon tycon {- array, we hope -}   then 'A'
 777           else if isEnumerationTyCon tycon                 then 'E'
 778           else if isTupleTyCon tycon                       then 'T'
 779           else if maybeToBool (maybeTyConSingleCon tycon)  then 'S'
 780           else if utc == listTyConKey                      then 'L'
 781           else 'M' -- oh, well...
 782 \end{code}