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