ghc/compiler/types/Type.lhs

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