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