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