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