ghc/compiler/types/Type.lhs

   1 \begin{code}
   2 #include "HsVersions.h"
   3
   4 module Type (
   5         GenType(..), Type(..), TauType(..),
   6         mkTyVarTy, mkTyVarTys,
   7         getTyVar, getTyVar_maybe, isTyVarTy,
   8         mkAppTy, mkAppTys, splitAppTy,
   9         mkFunTy, mkFunTys, splitFunTy, getFunTy_maybe,
  10         mkTyConTy, getTyCon_maybe, applyTyCon,
  11         mkSynTy,
  12         mkForAllTy, mkForAllTys, getForAllTy_maybe, splitForAllTy,
  13         mkForAllUsageTy, getForAllUsageTy,
  14         applyTy,
  15
  16         isPrimType, isUnboxedType, typePrimRep,
  17
  18         RhoType(..), SigmaType(..), ThetaType(..),
  19         mkDictTy,
  20         mkRhoTy, splitRhoTy,
  21         mkSigmaTy, splitSigmaTy,
  22
  23         maybeAppTyCon, getAppTyCon,
  24         maybeAppDataTyCon, getAppDataTyCon,
  25         maybeBoxedPrimType,
  26
  27         matchTy, matchTys, eqTy, eqSimpleTy, eqSimpleTheta,
  28
  29         instantiateTy, instantiateTauTy, instantiateUsage,
  30         applyTypeEnvToTy,
  31
  32         isTauTy,
  33
  34         tyVarsOfType, tyVarsOfTypes, typeKind
  35     ) where
  36
  37 import Ubiq
  38 import IdLoop    -- for paranoia checking
  39 import TyLoop    -- for paranoia checking
  40 import PrelLoop  -- for paranoia checking
  41
  42 -- ToDo:rm
  43 --import PprType        ( pprGenType ) -- ToDo: rm
  44 --import PprStyle ( PprStyle(..) )
  45 --import Util   ( pprPanic )
  46
  47 -- friends:
  48 import Class    ( classSig, classOpLocalType, GenClass{-instances-} )
  49 import Kind     ( mkBoxedTypeKind, resultKind )
  50 import TyCon    ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, isSynTyCon, tyConArity,
  51                   tyConKind, tyConDataCons, getSynTyConDefn, TyCon )
  52 import TyVar    ( tyVarKind, GenTyVar{-instances-}, GenTyVarSet(..),
  53                   emptyTyVarSet, unionTyVarSets, minusTyVarSet,
  54                   unitTyVarSet, nullTyVarEnv, lookupTyVarEnv,
  55                   addOneToTyVarEnv, TyVarEnv(..) )
  56 import Usage    ( usageOmega, GenUsage, Usage(..), UVar(..), UVarEnv(..),
  57                   nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar,
  58                   eqUsage )
  59
  60 -- others
  61 import PrimRep  ( PrimRep(..) )
  62 import Util     ( thenCmp, zipEqual, panic, panic#, assertPanic,
  63                   Ord3(..){-instances-}
  64                 )
  65 \end{code}
  66
  67 Data types
  68 ~~~~~~~~~~
  69
  70 \begin{code}
  71 type Type  = GenType TyVar UVar -- Used after typechecker
  72
  73 data GenType tyvar uvar -- Parameterised over type and usage variables
  74   = TyVarTy tyvar
  75
  76   | AppTy
  77         (GenType tyvar uvar)
  78         (GenType tyvar uvar)
  79
  80   | TyConTy     -- Constants of a specified kind
  81         TyCon   -- Must *not* be a SynTyCon
  82         (GenUsage uvar) -- Usage gives uvar of the full application,
  83                         -- iff the full application is of kind Type
  84                         -- c.f. the Usage field in TyVars
  85
  86   | SynTy       -- Synonyms must be saturated, and contain their expansion
  87         TyCon   -- Must be a SynTyCon
  88         [GenType tyvar uvar]
  89         (GenType tyvar uvar)    -- Expansion!
  90
  91   | ForAllTy
  92         tyvar
  93         (GenType tyvar uvar)    -- TypeKind
  94
  95   | ForAllUsageTy
  96         uvar                    -- Quantify over this
  97         [uvar]                  -- Bounds; the quantified var must be
  98                                 -- less than or equal to all these
  99         (GenType tyvar uvar)
 100
 101         -- Two special cases that save a *lot* of administrative
 102         -- overhead:
 103
 104   | FunTy                       -- BoxedTypeKind
 105         (GenType tyvar uvar)    -- Both args are of TypeKind
 106         (GenType tyvar uvar)
 107         (GenUsage uvar)
 108
 109   | DictTy                      -- TypeKind
 110         Class                   -- Class
 111         (GenType tyvar uvar)    -- Arg has kind TypeKind
 112         (GenUsage uvar)
 113 \end{code}
 114
 115 \begin{code}
 116 type RhoType   = Type
 117 type TauType   = Type
 118 type ThetaType = [(Class, Type)]
 119 type SigmaType = Type
 120 \end{code}
 121
 122
 123 Expand abbreviations
 124 ~~~~~~~~~~~~~~~~~~~~
 125 Removes just the top level of any abbreviations.
 126
 127 \begin{code}
 128 expandTy :: Type -> Type        -- Restricted to Type due to Dict expansion
 129
 130 expandTy (FunTy t1 t2 u) = AppTy (AppTy (TyConTy mkFunTyCon u) t1) t2
 131 expandTy (SynTy _  _  t) = expandTy t
 132 expandTy (DictTy clas ty u)
 133   = case all_arg_tys of
 134
 135         [arg_ty] -> expandTy arg_ty     -- just the <whatever> itself
 136
 137                 -- The extra expandTy is to make sure that
 138                 -- the result isn't still a dict, which it might be
 139                 -- if the original guy was a dict with one superdict and
 140                 -- no methods!
 141
 142         other -> ASSERT(not (null all_arg_tys))
 143                 foldl AppTy (TyConTy (mkTupleTyCon (length all_arg_tys)) u) all_arg_tys
 144
 145                 -- A tuple of 'em
 146                 -- Note: length of all_arg_tys can be 0 if the class is
 147                 --       CCallable, CReturnable (and anything else
 148                 --       *really weird* that the user writes).
 149   where
 150     (tyvar, super_classes, ops) = classSig clas
 151     super_dict_tys = map mk_super_ty super_classes
 152     class_op_tys   = map mk_op_ty ops
 153     all_arg_tys    = super_dict_tys ++ class_op_tys
 154     mk_super_ty sc = DictTy sc ty usageOmega
 155     mk_op_ty    op = instantiateTy [(tyvar,ty)] (classOpLocalType op)
 156
 157 expandTy ty = ty
 158 \end{code}
 159
 160 Simple construction and analysis functions
 161 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 162 \begin{code}
 163 mkTyVarTy  :: t   -> GenType t u
 164 mkTyVarTys :: [t] -> [GenType t y]
 165 mkTyVarTy  = TyVarTy
 166 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
 167
 168 getTyVar :: String -> GenType t u -> t
 169 getTyVar msg (TyVarTy tv)   = tv
 170 getTyVar msg (SynTy _ _ t)  = getTyVar msg t
 171 getTyVar msg other          = panic ("getTyVar: " ++ msg)
 172
 173 getTyVar_maybe :: GenType t u -> Maybe t
 174 getTyVar_maybe (TyVarTy tv)  = Just tv
 175 getTyVar_maybe (SynTy _ _ t) = getTyVar_maybe t
 176 getTyVar_maybe other         = Nothing
 177
 178 isTyVarTy :: GenType t u -> Bool
 179 isTyVarTy (TyVarTy tv)  = True
 180 isTyVarTy (SynTy _ _ t) = isTyVarTy t
 181 isTyVarTy other = False
 182 \end{code}
 183
 184 \begin{code}
 185 mkAppTy = AppTy
 186
 187 mkAppTys :: GenType t u -> [GenType t u] -> GenType t u
 188 mkAppTys t ts = foldl AppTy t ts
 189
 190 splitAppTy :: GenType t u -> (GenType t u, [GenType t u])
 191 splitAppTy t = go t []
 192   where
 193     go (AppTy t arg)     ts = go t (arg:ts)
 194     go (FunTy fun arg u) ts = (TyConTy mkFunTyCon u, fun:arg:ts)
 195     go (SynTy _ _ t)     ts = go t ts
 196     go t                 ts = (t,ts)
 197 \end{code}
 198
 199 \begin{code}
 200 -- NB mkFunTy, mkFunTys puts in Omega usages, for now at least
 201 mkFunTy arg res = FunTy arg res usageOmega
 202
 203 mkFunTys :: [GenType t u] -> GenType t u -> GenType t u
 204 mkFunTys ts t = foldr (\ f a -> FunTy f a usageOmega) t ts
 205
 206 getFunTy_maybe :: GenType t u -> Maybe (GenType t u, GenType t u)
 207 getFunTy_maybe (FunTy arg result _) = Just (arg,result)
 208 getFunTy_maybe (AppTy (AppTy (TyConTy tycon _) arg) res)
 209                  | isFunTyCon tycon = Just (arg, res)
 210 getFunTy_maybe (SynTy _ _ t)        = getFunTy_maybe t
 211 getFunTy_maybe other                = Nothing
 212
 213 splitFunTy :: GenType t u -> ([GenType t u], GenType t u)
 214 splitFunTy t = go t []
 215   where
 216     go (FunTy arg res _) ts = go res (arg:ts)
 217     go (AppTy (AppTy (TyConTy tycon _) arg) res) ts
 218         | isFunTyCon tycon
 219         = go res (arg:ts)
 220     go (SynTy _ _ t) ts
 221         = go t ts
 222     go t ts
 223         = (reverse ts, t)
 224 \end{code}
 225
 226 \begin{code}
 227 -- NB applyTyCon puts in usageOmega, for now at least
 228 mkTyConTy tycon
 229   = ASSERT(not (isSynTyCon tycon))
 230     TyConTy tycon usageOmega
 231
 232 applyTyCon :: TyCon -> [GenType t u] -> GenType t u
 233 applyTyCon tycon tys
 234   = ASSERT (not (isSynTyCon tycon))
 235     foldl AppTy (TyConTy tycon usageOmega) tys
 236
 237 getTyCon_maybe :: GenType t u -> Maybe TyCon
 238 getTyCon_maybe (TyConTy tycon _) = Just tycon
 239 getTyCon_maybe (SynTy _ _ t)     = getTyCon_maybe t
 240 getTyCon_maybe other_ty          = Nothing
 241 \end{code}
 242
 243 \begin{code}
 244 mkSynTy syn_tycon tys
 245   = ASSERT(isSynTyCon syn_tycon)
 246     SynTy syn_tycon tys (instantiateTauTy (zipEqual tyvars tys) body)
 247   where
 248     (tyvars, body) = getSynTyConDefn syn_tycon
 249 \end{code}
 250
 251 Tau stuff
 252 ~~~~~~~~~
 253 \begin{code}
 254 isTauTy :: GenType t u -> Bool
 255 isTauTy (TyVarTy v)        = True
 256 isTauTy (TyConTy _ _)      = True
 257 isTauTy (AppTy a b)        = isTauTy a && isTauTy b
 258 isTauTy (FunTy a b _)      = isTauTy a && isTauTy b
 259 isTauTy (SynTy _ _ ty)     = isTauTy ty
 260 isTauTy other              = False
 261 \end{code}
 262
 263 Rho stuff
 264 ~~~~~~~~~
 265 NB mkRhoTy and mkDictTy put in usageOmega, for now at least
 266
 267 \begin{code}
 268 mkDictTy :: Class -> GenType t u -> GenType t u
 269 mkDictTy clas ty = DictTy clas ty usageOmega
 270
 271 mkRhoTy :: [(Class, GenType t u)] -> GenType t u -> GenType t u
 272 mkRhoTy theta ty =
 273   foldr (\(c,t) r -> FunTy (DictTy c t usageOmega) r usageOmega) ty theta
 274
 275 splitRhoTy :: GenType t u -> ([(Class,GenType t u)], GenType t u)
 276 splitRhoTy t =
 277   go t []
 278  where
 279   go (FunTy (DictTy c t _) r _) ts = go r ((c,t):ts)
 280   go (AppTy (AppTy (TyConTy tycon _) (DictTy c t _)) r) ts
 281         | isFunTyCon tycon
 282         = go r ((c,t):ts)
 283   go (SynTy _ _ t) ts = go t ts
 284   go t ts = (reverse ts, t)
 285 \end{code}
 286
 287
 288 Forall stuff
 289 ~~~~~~~~~~~~
 290 \begin{code}
 291 mkForAllTy = ForAllTy
 292
 293 mkForAllTys :: [t] -> GenType t u -> GenType t u
 294 mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
 295
 296 getForAllTy_maybe :: GenType t u -> Maybe (t,GenType t u)
 297 getForAllTy_maybe (SynTy _ _ t)      = getForAllTy_maybe t
 298 getForAllTy_maybe (ForAllTy tyvar t) = Just(tyvar,t)
 299 getForAllTy_maybe _                  = Nothing
 300
 301 splitForAllTy :: GenType t u-> ([t], GenType t u)
 302 splitForAllTy t = go t []
 303                where
 304                     go (ForAllTy tv t) tvs = go t (tv:tvs)
 305                     go (SynTy _ _ t)   tvs = go t tvs
 306                     go t               tvs = (reverse tvs, t)
 307 \end{code}
 308
 309 \begin{code}
 310 mkForAllUsageTy :: u -> [u] -> GenType t u -> GenType t u
 311 mkForAllUsageTy = ForAllUsageTy
 312
 313 getForAllUsageTy :: GenType t u -> Maybe (u,[u],GenType t u)
 314 getForAllUsageTy (ForAllUsageTy uvar bounds t) = Just(uvar,bounds,t)
 315 getForAllUsageTy (SynTy _ _ t) = getForAllUsageTy t
 316 getForAllUsageTy _ = Nothing
 317 \end{code}
 318
 319 Applied tycons (includes FunTyCons)
 320 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 321 \begin{code}
 322 maybeAppTyCon
 323         :: GenType tyvar uvar
 324         -> Maybe (TyCon,                -- the type constructor
 325                   [GenType tyvar uvar]) -- types to which it is applied
 326
 327 maybeAppTyCon ty
 328   = case (getTyCon_maybe app_ty) of
 329         Nothing    -> Nothing
 330         Just tycon -> Just (tycon, arg_tys)
 331   where
 332     (app_ty, arg_tys) = splitAppTy ty
 333
 334
 335 getAppTyCon
 336         :: GenType tyvar uvar
 337         -> (TyCon,                      -- the type constructor
 338             [GenType tyvar uvar])       -- types to which it is applied
 339
 340 getAppTyCon ty
 341   = case maybeAppTyCon ty of
 342       Just stuff -> stuff
 343 #ifdef DEBUG
 344       Nothing    -> panic "Type.getAppTyCon" -- (ppr PprShowAll ty)
 345 #endif
 346 \end{code}
 347
 348 Applied data tycons (give back constrs)
 349 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 350 \begin{code}
 351 maybeAppDataTyCon
 352         :: GenType tyvar uvar
 353         -> Maybe (TyCon,                -- the type constructor
 354                   [GenType tyvar uvar], -- types to which it is applied
 355                   [Id])                 -- its family of data-constructors
 356
 357 maybeAppDataTyCon ty
 358   = case (getTyCon_maybe app_ty) of
 359         Just tycon |  isDataTyCon tycon &&
 360                       tyConArity tycon == length arg_tys
 361                         -- Must be saturated for ty to be a data type
 362                    -> Just (tycon, arg_tys, tyConDataCons tycon)
 363
 364         other      -> Nothing
 365   where
 366     (app_ty, arg_tys) = splitAppTy ty
 367
 368
 369 getAppDataTyCon
 370         :: GenType tyvar uvar
 371         -> (TyCon,                      -- the type constructor
 372             [GenType tyvar uvar],       -- types to which it is applied
 373             [Id])                       -- its family of data-constructors
 374
 375 getAppDataTyCon ty
 376   = case maybeAppDataTyCon ty of
 377       Just stuff -> stuff
 378 #ifdef DEBUG
 379       Nothing    -> panic "Type.getAppDataTyCon: " -- (pprGenType PprShowAll ty)
 380 #endif
 381
 382
 383 maybeBoxedPrimType :: Type -> Maybe (Id, Type)
 384
 385 maybeBoxedPrimType ty
 386   = case (maybeAppDataTyCon ty) of              -- Data type,
 387       Just (tycon, tys_applied, [data_con])     -- with exactly one constructor
 388         -> case (dataConArgTys data_con tys_applied) of
 389              [data_con_arg_ty]                  -- Applied to exactly one type,
 390                 | isPrimType data_con_arg_ty    -- which is primitive
 391                 -> Just (data_con, data_con_arg_ty)
 392              other_cases -> Nothing
 393       other_cases -> Nothing
 394 \end{code}
 395
 396 \begin{code}
 397 splitSigmaTy :: GenType t u -> ([t], [(Class,GenType t u)], GenType t u)
 398 splitSigmaTy ty =
 399   (tyvars, theta, tau)
 400  where
 401   (tyvars,rho) = splitForAllTy ty
 402   (theta,tau)  = splitRhoTy rho
 403
 404 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
 405 \end{code}
 406
 407
 408 Finding the kind of a type
 409 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 410 \begin{code}
 411 typeKind :: GenType (GenTyVar any) u -> Kind
 412 typeKind (TyVarTy tyvar)        = tyVarKind tyvar
 413 typeKind (TyConTy tycon usage)  = tyConKind tycon
 414 typeKind (SynTy _ _ ty)         = typeKind ty
 415 typeKind (FunTy fun arg _)      = mkBoxedTypeKind
 416 typeKind (DictTy clas arg _)    = mkBoxedTypeKind
 417 typeKind (AppTy fun arg)        = resultKind (typeKind fun)
 418 typeKind (ForAllTy _ _)         = mkBoxedTypeKind
 419 typeKind (ForAllUsageTy _ _ _)  = mkBoxedTypeKind
 420 \end{code}
 421
 422
 423 Free variables of a type
 424 ~~~~~~~~~~~~~~~~~~~~~~~~
 425 \begin{code}
 426 tyVarsOfType :: GenType (GenTyVar flexi) uvar -> GenTyVarSet flexi
 427
 428 tyVarsOfType (TyVarTy tv)               = unitTyVarSet tv
 429 tyVarsOfType (TyConTy tycon usage)      = emptyTyVarSet
 430 tyVarsOfType (SynTy _ tys ty)           = tyVarsOfTypes tys
 431 tyVarsOfType (FunTy arg res _)          = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res
 432 tyVarsOfType (AppTy fun arg)            = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg
 433 tyVarsOfType (DictTy clas ty _)         = tyVarsOfType ty
 434 tyVarsOfType (ForAllTy tyvar ty)        = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar
 435 tyVarsOfType (ForAllUsageTy _ _ ty)     = tyVarsOfType ty
 436
 437 tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi
 438 tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys
 439 \end{code}
 440
 441
 442 Instantiating a type
 443 ~~~~~~~~~~~~~~~~~~~~
 444 \begin{code}
 445 applyTy :: Eq t => GenType t u -> GenType t u -> GenType t u
 446 applyTy (SynTy _ _ fun)  arg = applyTy fun arg
 447 applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty
 448 applyTy other            arg = panic "applyTy"
 449
 450 instantiateTy :: Eq t => [(t, GenType t u)] -> GenType t u -> GenType t u
 451 instantiateTy tenv ty
 452   = go ty
 453   where
 454     go (TyVarTy tv)             = case [ty | (tv',ty) <- tenv, tv==tv'] of
 455                                   []     -> TyVarTy tv
 456                                   (ty:_) -> ty
 457     go ty@(TyConTy tycon usage) = ty
 458     go (SynTy tycon tys ty)     = SynTy tycon (map go tys) (go ty)
 459     go (FunTy arg res usage)    = FunTy (go arg) (go res) usage
 460     go (AppTy fun arg)          = AppTy (go fun) (go arg)
 461     go (DictTy clas ty usage)   = DictTy clas (go ty) usage
 462     go (ForAllTy tv ty)         = ASSERT(null tv_bound)
 463                                   ForAllTy tv (go ty)
 464                                 where
 465                                   tv_bound = [() | (tv',_) <- tenv, tv==tv']
 466
 467     go (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go ty)
 468
 469
 470 -- instantiateTauTy works only (a) on types with no ForAlls,
 471 --      and when               (b) all the type variables are being instantiated
 472 -- In return it is more polymorphic than instantiateTy
 473
 474 instantiateTauTy :: Eq t => [(t, GenType t' u)] -> GenType t u -> GenType t' u
 475 instantiateTauTy tenv ty
 476   = go ty
 477   where
 478     go (TyVarTy tv)             = case [ty | (tv',ty) <- tenv, tv==tv'] of
 479                                   (ty:_) -> ty
 480                                   []     -> panic "instantiateTauTy"
 481     go (TyConTy tycon usage)    = TyConTy tycon usage
 482     go (SynTy tycon tys ty)     = SynTy tycon (map go tys) (go ty)
 483     go (FunTy arg res usage)    = FunTy (go arg) (go res) usage
 484     go (AppTy fun arg)          = AppTy (go fun) (go arg)
 485     go (DictTy clas ty usage)   = DictTy clas (go ty) usage
 486
 487 instantiateUsage
 488         :: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u'
 489 instantiateUsage = error "instantiateUsage: not implemented"
 490 \end{code}
 491
 492 \begin{code}
 493 type TypeEnv = TyVarEnv Type
 494
 495 applyTypeEnvToTy :: TypeEnv -> SigmaType -> SigmaType
 496 applyTypeEnvToTy tenv ty
 497   = mapOverTyVars v_fn ty
 498   where
 499     v_fn v = case (lookupTyVarEnv tenv v) of
 500                 Just ty -> ty
 501                 Nothing -> TyVarTy v
 502 \end{code}
 503
 504 @mapOverTyVars@ is a local function which actually does the work.  It
 505 does no cloning or other checks for shadowing, so be careful when
 506 calling this on types with Foralls in them.
 507
 508 \begin{code}
 509 mapOverTyVars :: (TyVar -> Type) -> Type -> Type
 510
 511 mapOverTyVars v_fn ty
 512   = let
 513         mapper = mapOverTyVars v_fn
 514     in
 515     case ty of
 516       TyVarTy v         -> v_fn v
 517       SynTy c as e      -> SynTy c (map mapper as) (mapper e)
 518       FunTy a r u       -> FunTy (mapper a) (mapper r) u
 519       AppTy f a         -> AppTy (mapper f) (mapper a)
 520       DictTy c t u      -> DictTy c (mapper t) u
 521       ForAllTy v t      -> ForAllTy v (mapper t)
 522       tc@(TyConTy _ _)  -> tc
 523 \end{code}
 524
 525 At present there are no unboxed non-primitive types, so
 526 isUnboxedType is the same as isPrimType.
 527
 528 \begin{code}
 529 isPrimType, isUnboxedType :: GenType tyvar uvar -> Bool
 530
 531 isPrimType (AppTy ty _)      = isPrimType ty
 532 isPrimType (SynTy _ _ ty)    = isPrimType ty
 533 isPrimType (TyConTy tycon _) = isPrimTyCon tycon
 534 isPrimType _                 = False
 535
 536 isUnboxedType = isPrimType
 537 \end{code}
 538
 539 This is *not* right: it is a placeholder (ToDo 96/03 WDP):
 540 \begin{code}
 541 typePrimRep :: GenType tyvar uvar -> PrimRep
 542
 543 typePrimRep (SynTy _ _ ty)  = typePrimRep ty
 544 typePrimRep (TyConTy tc _)  = if isPrimTyCon tc then panic "typePrimRep:PrimTyCon" else PtrRep
 545 typePrimRep (AppTy ty _)    = typePrimRep ty
 546 typePrimRep _               = PtrRep -- the "default"
 547 \end{code}
 548
 549 %************************************************************************
 550 %*                                                                      *
 551 \subsection{Matching on types}
 552 %*                                                                      *
 553 %************************************************************************
 554
 555 Matching is a {\em unidirectional} process, matching a type against a
 556 template (which is just a type with type variables in it).  The
 557 matcher assumes that there are no repeated type variables in the
 558 template, so that it simply returns a mapping of type variables to
 559 types.  It also fails on nested foralls.
 560
 561 @matchTys@ matches corresponding elements of a list of templates and
 562 types.
 563
 564 \begin{code}
 565 matchTy :: GenType t1 u1                -- Template
 566         -> GenType t2 u2                -- Proposed instance of template
 567         -> Maybe [(t1,GenType t2 u2)]   -- Matching substitution
 568
 569 matchTys :: [GenType t1 u1]             -- Templates
 570          -> [GenType t2 u2]             -- Proposed instance of template
 571          -> Maybe [(t1,GenType t2 u2)]  -- Matching substitution
 572
 573 matchTy  ty1  ty2  = match  [] [] ty1 ty2
 574 matchTys tys1 tys2 = match' [] (zipEqual tys1 tys2)
 575 \end{code}
 576
 577 @match@ is the main function.
 578
 579 \begin{code}
 580 match :: [(t1, GenType t2 u2)]                  -- r, the accumulating result
 581       -> [(GenType t1 u1, GenType t2 u2)]       -- w, the work list
 582       -> GenType t1 u1 -> GenType t2 u2         -- Current match pair
 583       -> Maybe [(t1, GenType t2 u2)]
 584
 585 match r w (TyVarTy v)          ty                   = match' ((v,ty) : r) w
 586 match r w (FunTy fun1 arg1 _)  (FunTy fun2 arg2 _)  = match r ((fun1,fun2):w) arg1 arg2
 587 match r w (AppTy fun1 arg1)  (AppTy fun2 arg2)      = match r ((fun1,fun2):w) arg1 arg2
 588 match r w (TyConTy con1 _)     (TyConTy con2 _)     | con1  == con2  = match' r w
 589 match r w (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) | clas1 == clas2 = match r w ty1 ty2
 590 match r w (SynTy _ _ ty1)      ty2                  = match r w ty1 ty2
 591 match r w ty1                  (SynTy _ _ ty2)      = match r w ty1 ty2
 592
 593         -- With type synonyms, we have to be careful for the exact
 594         -- same reasons as in the unifier.  Please see the
 595         -- considerable commentary there before changing anything
 596         -- here! (WDP 95/05)
 597
 598 -- Catch-all fails
 599 match _ _ _ _ = Nothing
 600
 601 match' r []            = Just r
 602 match' r ((ty1,ty2):w) = match r w ty1 ty2
 603 \end{code}
 604
 605 %************************************************************************
 606 %*                                                                      *
 607 \subsection{Equality on types}
 608 %*                                                                      *
 609 %************************************************************************
 610
 611 The functions eqSimpleTy and eqSimpleTheta are polymorphic in the types t
 612 and u, but ONLY WORK FOR SIMPLE TYPES (ie. they panic if they see
 613 dictionaries or polymorphic types).  The function eqTy has a more
 614 specific type, but does the `right thing' for all types.
 615
 616 \begin{code}
 617 eqSimpleTheta :: (Eq t,Eq u) =>
 618     [(Class,GenType t u)] -> [(Class,GenType t u)] -> Bool
 619
 620 eqSimpleTheta [] [] = True
 621 eqSimpleTheta ((c1,t1):th1) ((c2,t2):th2) =
 622   c1==c2 && t1 `eqSimpleTy` t2 && th1 `eqSimpleTheta` th2
 623 eqSimpleTheta other1 other2 = False
 624 \end{code}
 625
 626 \begin{code}
 627 eqSimpleTy :: (Eq t,Eq u) => GenType t u -> GenType t u -> Bool
 628
 629 (TyVarTy tv1) `eqSimpleTy` (TyVarTy tv2) =
 630   tv1 == tv2
 631 (AppTy f1 a1)  `eqSimpleTy` (AppTy f2 a2) =
 632   f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2
 633 (TyConTy tc1 u1) `eqSimpleTy` (TyConTy tc2 u2) =
 634   tc1 == tc2 && u1 == u2
 635
 636 (FunTy f1 a1 u1) `eqSimpleTy` (FunTy f2 a2 u2) =
 637   f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 && u1 == u2
 638 (FunTy f1 a1 u1) `eqSimpleTy` t2 =
 639   -- Expand t1 just in case t2 matches that version
 640   (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) `eqSimpleTy` t2
 641 t1 `eqSimpleTy` (FunTy f2 a2 u2) =
 642   -- Expand t2 just in case t1 matches that version
 643   t1 `eqSimpleTy` (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
 644
 645 (SynTy tc1 ts1 t1) `eqSimpleTy` (SynTy tc2 ts2 t2) =
 646   (tc1 == tc2 && and (zipWith eqSimpleTy ts1 ts2) && length ts1 == length ts2)
 647   || t1 `eqSimpleTy` t2
 648 (SynTy _ _ t1) `eqSimpleTy` t2 =
 649   t1 `eqSimpleTy` t2  -- Expand the abbrevation and try again
 650 t1 `eqSimpleTy` (SynTy _ _ t2) =
 651   t1 `eqSimpleTy` t2  -- Expand the abbrevation and try again
 652
 653 (DictTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got DictTy"
 654 _ `eqSimpleTy` (DictTy _ _ _) = panic "eqSimpleTy: got DictTy"
 655
 656 (ForAllTy _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllTy"
 657 _ `eqSimpleTy` (ForAllTy _ _) = panic "eqSimpleTy: got ForAllTy"
 658
 659 (ForAllUsageTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllUsageTy"
 660 _ `eqSimpleTy` (ForAllUsageTy _ _ _) = panic "eqSimpleTy: got ForAllUsageTy"
 661
 662 _ `eqSimpleTy` _ = False
 663 \end{code}
 664
 665 Types are ordered so we can sort on types in the renamer etc.  DNT: Since
 666 this class is also used in CoreLint and other such places, we DO expand out
 667 Fun/Syn/Dict types (if necessary).
 668
 669 \begin{code}
 670 eqTy :: Type -> Type -> Bool
 671
 672 eqTy t1 t2 =
 673   eq nullTyVarEnv nullUVarEnv t1 t2
 674  where
 675   eq tve uve (TyVarTy tv1) (TyVarTy tv2) =
 676     tv1 == tv2 ||
 677     case (lookupTyVarEnv tve tv1) of
 678       Just tv -> tv == tv2
 679       Nothing -> False
 680   eq tve uve (AppTy f1 a1) (AppTy f2 a2) =
 681     eq tve uve f1 f2 && eq tve uve a1 a2
 682   eq tve uve (TyConTy tc1 u1) (TyConTy tc2 u2) =
 683     tc1 == tc2 && eqUsage uve u1 u2
 684
 685   eq tve uve (FunTy f1 a1 u1) (FunTy f2 a2 u2) =
 686     eq tve uve f1 f2 && eq tve uve a1 a2 && eqUsage uve u1 u2
 687   eq tve uve (FunTy f1 a1 u1) t2 =
 688     -- Expand t1 just in case t2 matches that version
 689     eq tve uve (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) t2
 690   eq tve uve t1 (FunTy f2 a2 u2) =
 691     -- Expand t2 just in case t1 matches that version
 692     eq tve uve t1 (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
 693
 694   eq tve uve (DictTy c1 t1 u1) (DictTy c2 t2 u2) =
 695     c1 == c2 && eq tve uve t1 t2 && eqUsage uve u1 u2
 696   eq tve uve t1@(DictTy _ _ _) t2 =
 697     eq tve uve (expandTy t1) t2  -- Expand the dictionary and try again
 698   eq tve uve t1 t2@(DictTy _ _ _) =
 699     eq tve uve t1 (expandTy t2)  -- Expand the dictionary and try again
 700
 701   eq tve uve (SynTy tc1 ts1 t1) (SynTy tc2 ts2 t2) =
 702     (tc1 == tc2 && and (zipWith (eq tve uve) ts1 ts2) && length ts1 == length ts2)
 703     || eq tve uve t1 t2
 704   eq tve uve (SynTy _ _ t1) t2 =
 705     eq tve uve t1 t2  -- Expand the abbrevation and try again
 706   eq tve uve t1 (SynTy _ _ t2) =
 707     eq tve uve t1 t2  -- Expand the abbrevation and try again
 708
 709   eq tve uve (ForAllTy tv1 t1) (ForAllTy tv2 t2) =
 710     eq (addOneToTyVarEnv tve tv1 tv2) uve t1 t2
 711   eq tve uve (ForAllUsageTy u1 b1 t1) (ForAllUsageTy u2 b2 t2) =
 712     eqBounds uve b1 b2 && eq tve (addOneToUVarEnv uve u1 u2) t1 t2
 713
 714   eq _ _ _ _ = False
 715
 716   eqBounds uve [] [] = True
 717   eqBounds uve (u1:b1) (u2:b2) = eqUVar uve u1 u2 && eqBounds uve b1 b2
 718   eqBounds uve _ _ = False
 719 \end{code}