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