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,
  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, 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 = go ty
 514   where
 515     go ty@(TyVarTy tv)   = case (lookupTyVarEnv tenv tv) of
 516                                       Just ty -> ty  -- Must succeed
 517     go (TyConApp tc tys) = TyConApp tc (map go tys)
 518     go (SynTy ty1 ty2)   = SynTy (go ty1) (go ty2)
 519     go (FunTy arg res)   = FunTy (go arg) (go res)
 520     go (AppTy fun arg)   = mkAppTy (go fun) (go arg)
 521     go (ForAllTy tv ty)  = panic "instantiateTauTy"
 522
 523
 524 instantiateThetaTy :: TyVarEnv Type -> ThetaType -> ThetaType
 525 instantiateThetaTy tenv theta
 526  = [(clas, map (instantiateTauTy tenv) tys) | (clas, tys) <- theta]
 527 \end{code}
 528
 529
 530 %************************************************************************
 531 %*                                                                      *
 532 \subsection{Boxedness and pointedness}
 533 %*                                                                      *
 534 %************************************************************************
 535
 536 A type is
 537         *unboxed*       iff its representation is other than a pointer
 538                         Unboxed types cannot instantiate a type variable
 539                         Unboxed types are always unpointed.
 540
 541         *unpointed*     iff it can't be a thunk, and cannot have value bottom
 542                         An unpointed type may or may not be unboxed.
 543                                 (E.g. Array# is unpointed, but boxed.)
 544                         An unpointed type *can* instantiate a type variable,
 545                         provided it is boxed.
 546
 547         *primitive*     iff it is a built-in type that can't be expressed
 548                                 in Haskell
 549
 550 Currently, all primitive types are unpointed, but that's not necessarily
 551 the case.  (E.g. Int could be primitive.)
 552
 553 \begin{code}
 554 isUnboxedType :: Type -> Bool
 555 isUnboxedType ty = case typePrimRep ty of
 556                         PtrRep -> False
 557                         other  -> True
 558
 559 -- Danger!  Currently the unpointed types are precisely
 560 -- the primitive ones, but that might not always be the case
 561 isUnpointedType :: Type -> Bool
 562 isUnpointedType ty = case splitTyConApp_maybe ty of
 563                            Just (tc, ty_args) -> isPrimTyCon tc
 564                            other              -> False
 565
 566 typePrimRep :: Type -> PrimRep
 567 typePrimRep ty = case splitTyConApp_maybe ty of
 568                    Just (tc, ty_args) -> tyConPrimRep tc
 569                    other              -> PtrRep
 570 \end{code}
 571
 572
 573 %************************************************************************
 574 %*                                                                      *
 575 \subsection{Matching on types}
 576 %*                                                                      *
 577 %************************************************************************
 578
 579 Matching is a {\em unidirectional} process, matching a type against a
 580 template (which is just a type with type variables in it).  The
 581 matcher assumes that there are no repeated type variables in the
 582 template, so that it simply returns a mapping of type variables to
 583 types.  It also fails on nested foralls.
 584
 585 @matchTys@ matches corresponding elements of a list of templates and
 586 types.
 587
 588 \begin{code}
 589 matchTy :: GenType flexi1                       -- Template
 590         -> GenType flexi2                       -- Proposed instance of template
 591         -> Maybe (TyVarEnv (GenType flexi2))    -- Matching substitution
 592
 593
 594 matchTys :: [GenType flexi1]                    -- Templates
 595          -> [GenType flexi2]                    -- Proposed instance of template
 596          -> Maybe (TyVarEnv (GenType flexi2),   -- Matching substitution
 597                    [GenType flexi2])            -- Left over instance types
 598
 599 matchTy  ty1  ty2  = match      ty1  ty2  (\s  -> Just s)  emptyTyVarEnv
 600 matchTys tys1 tys2 = match_list tys1 tys2 (\pr -> Just pr) emptyTyVarEnv
 601 \end{code}
 602
 603 @match@ is the main function.
 604
 605 \begin{code}
 606 match :: GenType flexi1 -> GenType flexi2               -- Current match pair
 607       -> (TyVarEnv (GenType flexi2) -> Maybe result)    -- Continuation
 608       -> TyVarEnv (GenType flexi2)                      -- Current substitution
 609       -> Maybe result
 610
 611 -- When matching against a type variable, see if the variable
 612 -- has already been bound.  If so, check that what it's bound to
 613 -- is the same as ty; if not, bind it and carry on.
 614
 615 match (TyVarTy v) ty k = \s -> case lookupTyVarEnv s v of
 616                                  Nothing  -> k (addToTyVarEnv s v ty)
 617                                  Just ty' | ty' == ty -> k s      -- Succeeds
 618                                           | otherwise -> Nothing  -- Fails
 619
 620 match (FunTy arg1 res1)   (FunTy arg2 res2)  k = match arg1 arg2 (match res1 res2 k)
 621 match (AppTy fun1 arg1)   (AppTy fun2 arg2)  k = match fun1 fun2 (match arg1 arg2 k)
 622 match (TyConApp tc1 tys1) (TyConApp tc2 tys2) k | tc1 == tc2
 623                                                 = match_list tys1 tys2 ( \(s,tys2') ->
 624                                                     if null tys2' then
 625                                                         k s     -- Succeed
 626                                                     else
 627                                                         Nothing -- Fail
 628                                                   )
 629
 630         -- With type synonyms, we have to be careful for the exact
 631         -- same reasons as in the unifier.  Please see the
 632         -- considerable commentary there before changing anything
 633         -- here! (WDP 95/05)
 634 match (SynTy _ ty1)       ty2                k = match ty1 ty2 k
 635 match ty1                 (SynTy _ ty2)      k = match ty1 ty2 k
 636
 637 -- Catch-all fails
 638 match _ _ _ = \s -> Nothing
 639
 640 match_list []         tys2       k = \s -> k (s, tys2)
 641 match_list (ty1:tys1) []         k = panic "match_list"
 642 match_list (ty1:tys1) (ty2:tys2) k = match ty1 ty2 (match_list tys1 tys2 k)
 643 \end{code}
 644
 645 %************************************************************************
 646 %*                                                                      *
 647 \subsection{Equality on types}
 648 %*                                                                      *
 649 %************************************************************************
 650
 651 For the moment at least, type comparisons don't work if
 652 there are embedded for-alls.
 653
 654 \begin{code}
 655 instance Eq (GenType flexi) where
 656   ty1 == ty2 = case ty1 `cmpTy` ty2 of { EQ -> True; other -> False }
 657
 658 instance Ord (GenType flexi) where
 659   compare ty1 ty2 = cmpTy ty1 ty2
 660
 661 cmpTy :: GenType flexi -> GenType flexi -> Ordering
 662 cmpTy ty1 ty2
 663   = cmp emptyTyVarEnv ty1 ty2
 664   where
 665   -- The "env" maps type variables in ty1 to type variables in ty2
 666   -- So when comparing for-alls.. (forall tv1 . t1) (forall tv2 . t2)
 667   -- we in effect substitute tv2 for tv1 in t1 before continuing
 668     lookup env tv1 = case lookupTyVarEnv env tv1 of
 669                           Just tv2 -> tv2
 670                           Nothing  -> tv1
 671
 672     -- Get rid of SynTy
 673     cmp env (SynTy _ ty1) ty2 = cmp env ty1 ty2
 674     cmp env ty1 (SynTy _ ty2) = cmp env ty1 ty2
 675
 676     -- Deal with equal constructors
 677     cmp env (TyVarTy tv1) (TyVarTy tv2) = lookup env tv1 `compare` tv2
 678     cmp env (AppTy f1 a1) (AppTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
 679     cmp env (FunTy f1 a1) (FunTy f2 a2) = cmp env f1 f2 `thenCmp` cmp env a1 a2
 680     cmp env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` (cmps env tys1 tys2)
 681     cmp env (ForAllTy tv1 t1)   (ForAllTy tv2 t2)   = cmp (addToTyVarEnv env tv1 tv2) t1 t2
 682
 683     -- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy
 684     cmp env (AppTy _ _) (TyVarTy _) = GT
 685
 686     cmp env (FunTy _ _) (TyVarTy _) = GT
 687     cmp env (FunTy _ _) (AppTy _ _) = GT
 688
 689     cmp env (TyConApp _ _) (TyVarTy _) = GT
 690     cmp env (TyConApp _ _) (AppTy _ _) = GT
 691     cmp env (TyConApp _ _) (FunTy _ _) = GT
 692
 693     cmp env (ForAllTy _ _) other       = GT
 694
 695     cmp env _ _                        = LT
 696
 697     cmps env []     [] = EQ
 698     cmps env (t:ts) [] = GT
 699     cmps env [] (t:ts) = LT
 700     cmps env (t1:t1s) (t2:t2s) = cmp env t1 t2 `thenCmp` cmps env t1s t2s
 701 \end{code}
 702
 703
 704
 705 %************************************************************************
 706 %*                                                                      *
 707 \subsection{Grime}
 708 %*                                                                      *
 709 %************************************************************************
 710
 711
 712
 713 \begin{code}
 714 showTypeCategory :: Type -> Char
 715   {-
 716         {C,I,F,D}   char, int, float, double
 717         T           tuple
 718         S           other single-constructor type
 719         {c,i,f,d}   unboxed ditto
 720         t           *unpacked* tuple
 721         s           *unpacked" single-cons...
 722
 723         v           void#
 724         a           primitive array
 725
 726         E           enumeration type
 727         +           dictionary, unless it's a ...
 728         L           List
 729         >           function
 730         M           other (multi-constructor) data-con type
 731         .           other type
 732         -           reserved for others to mark as "uninteresting"
 733     -}
 734 showTypeCategory ty
 735   = if isDictTy ty
 736     then '+'
 737     else
 738       case splitTyConApp_maybe ty of
 739         Nothing -> if maybeToBool (splitFunTy_maybe ty)
 740                    then '>'
 741                    else '.'
 742
 743         Just (tycon, _) ->
 744           let utc = uniqueOf tycon in
 745           if      utc == charDataConKey    then 'C'
 746           else if utc == intDataConKey     then 'I'
 747           else if utc == floatDataConKey   then 'F'
 748           else if utc == doubleDataConKey  then 'D'
 749           else if utc == integerDataConKey then 'J'
 750           else if utc == charPrimTyConKey  then 'c'
 751           else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
 752                 || utc == addrPrimTyConKey)                then 'i'
 753           else if utc  == floatPrimTyConKey                then 'f'
 754           else if utc  == doublePrimTyConKey               then 'd'
 755           else if isPrimTyCon tycon {- array, we hope -}   then 'A'
 756           else if isEnumerationTyCon tycon                 then 'E'
 757           else if isTupleTyCon tycon                       then 'T'
 758           else if maybeToBool (maybeTyConSingleCon tycon)  then 'S'
 759           else if utc == listTyConKey                      then 'L'
 760           else 'M' -- oh, well...
 761 \end{code}