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