ghc/compiler/types/Type.lhs

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