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, delFromTyVarEnv,
  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
 616 -- applyTypeEnv applies a type environment to a type.
 617 -- It can handle shadowing; for example:
 618 --      f = /\ t1 t2 -> \ d ->
 619 --         letrec f' = /\ t1 -> \x -> ...(f' t1 x')...
 620 --         in f' t1
 621 -- Here, when we clone t1 to t1', say, we'll come across shadowing
 622 -- when applying the clone environment to the type of f'.
 623 --
 624 -- As a sanity check, we should also check that name capture
 625 -- doesn't occur, but that means keeping track of the free variables of the
 626 -- range of the TyVarEnv, which I don't do just yet.
 627 --
 628 -- We don't use instant_help because we need to carry in the environment
 629
 630 applyTypeEnvToTy tenv ty
 631   = go tenv ty
 632   where
 633     go tenv ty@(TyVarTy tv)             = case (lookupTyVarEnv tenv tv) of
 634                                              Nothing -> ty
 635                                              Just ty -> ty
 636     go tenv ty@(TyConTy tycon usage)    = ty
 637     go tenv (SynTy tycon tys ty)        = SynTy tycon (map (go tenv) tys) (go tenv ty)
 638     go tenv (FunTy arg res usage)       = FunTy (go tenv arg) (go tenv res) usage
 639     go tenv (AppTy fun arg)             = AppTy (go tenv fun) (go tenv arg)
 640     go tenv (DictTy clas ty usage)      = DictTy clas (go tenv ty) usage
 641     go tenv (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go tenv ty)
 642     go tenv (ForAllTy tv ty)            = ForAllTy tv (go tenv' ty)
 643                                         where
 644                                           tenv' = case lookupTyVarEnv tenv tv of
 645                                                     Nothing -> tenv
 646                                                     Just _  -> delFromTyVarEnv tenv tv
 647 \end{code}
 648
 649 \begin{code}
 650 instantiateUsage
 651         :: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u'
 652
 653 instantiateUsage = panic "instantiateUsage: not implemented"
 654 \end{code}
 655
 656
 657 At present there are no unboxed non-primitive types, so
 658 isUnboxedType is the same as isPrimType.
 659
 660 We're a bit cavalier about finding out whether something is
 661 primitive/unboxed or not.  Rather than deal with the type
 662 arguemnts we just zoom into the function part of the type.
 663 That is, given (T a) we just recurse into the "T" part,
 664 ignoring "a".
 665
 666 \begin{code}
 667 isPrimType, isUnboxedType :: Type -> Bool
 668
 669 isPrimType (AppTy ty _)      = isPrimType ty
 670 isPrimType (SynTy _ _ ty)    = isPrimType ty
 671 isPrimType (TyConTy tycon _) = case maybeNewTyCon tycon of
 672                                   Just (tyvars, ty) -> isPrimType ty
 673                                   Nothing           -> isPrimTyCon tycon
 674
 675 isPrimType _                 = False
 676
 677 isUnboxedType = isPrimType
 678 \end{code}
 679
 680 This is *not* right: it is a placeholder (ToDo 96/03 WDP):
 681 \begin{code}
 682 typePrimRep :: Type -> PrimRep
 683
 684 typePrimRep (SynTy _ _ ty)  = typePrimRep ty
 685 typePrimRep (AppTy ty _)    = typePrimRep ty
 686 typePrimRep (TyConTy tc _)
 687   | isPrimTyCon tc          = case (assocMaybe tc_primrep_list (uniqueOf tc)) of
 688                                    Just xx -> xx
 689                                    Nothing -> pprPanic "typePrimRep:" (pprTyCon PprDebug tc)
 690
 691   | otherwise               = case maybeNewTyCon tc of
 692                                   Just (tyvars, ty) | isPrimType ty -> typePrimRep ty
 693                                   _ -> PtrRep   -- Default
 694
 695 typePrimRep _               = PtrRep -- the "default"
 696
 697 tc_primrep_list
 698   = [(addrPrimTyConKey,             AddrRep)
 699     ,(arrayPrimTyConKey,            ArrayRep)
 700     ,(byteArrayPrimTyConKey,        ByteArrayRep)
 701     ,(charPrimTyConKey,             CharRep)
 702     ,(doublePrimTyConKey,           DoubleRep)
 703     ,(floatPrimTyConKey,            FloatRep)
 704     ,(foreignObjPrimTyConKey,       ForeignObjRep)
 705     ,(intPrimTyConKey,              IntRep)
 706     ,(mutableArrayPrimTyConKey,     ArrayRep)
 707     ,(mutableByteArrayPrimTyConKey, ByteArrayRep)
 708     ,(stablePtrPrimTyConKey,        StablePtrRep)
 709     ,(statePrimTyConKey,            VoidRep)
 710     ,(synchVarPrimTyConKey,         PtrRep)
 711     ,(voidTyConKey,                 VoidRep)
 712     ,(wordPrimTyConKey,             WordRep)
 713     ]
 714 \end{code}
 715
 716 %************************************************************************
 717 %*                                                                      *
 718 \subsection{Matching on types}
 719 %*                                                                      *
 720 %************************************************************************
 721
 722 Matching is a {\em unidirectional} process, matching a type against a
 723 template (which is just a type with type variables in it).  The
 724 matcher assumes that there are no repeated type variables in the
 725 template, so that it simply returns a mapping of type variables to
 726 types.  It also fails on nested foralls.
 727
 728 @matchTys@ matches corresponding elements of a list of templates and
 729 types.
 730
 731 \begin{code}
 732 matchTy :: GenType t1 u1                -- Template
 733         -> GenType t2 u2                -- Proposed instance of template
 734         -> Maybe [(t1,GenType t2 u2)]   -- Matching substitution
 735
 736 matchTys :: [GenType t1 u1]             -- Templates
 737          -> [GenType t2 u2]             -- Proposed instance of template
 738          -> Maybe [(t1,GenType t2 u2)]  -- Matching substitution
 739
 740 matchTy  ty1  ty2  = match  [] [] ty1 ty2
 741 matchTys tys1 tys2 = match' [] (zipEqual "matchTys" tys1 tys2)
 742 \end{code}
 743
 744 @match@ is the main function.
 745
 746 \begin{code}
 747 match :: [(t1, GenType t2 u2)]                  -- r, the accumulating result
 748       -> [(GenType t1 u1, GenType t2 u2)]       -- w, the work list
 749       -> GenType t1 u1 -> GenType t2 u2         -- Current match pair
 750       -> Maybe [(t1, GenType t2 u2)]
 751
 752 match r w (TyVarTy v)          ty                   = match' ((v,ty) : r) w
 753 match r w (FunTy fun1 arg1 _)  (FunTy fun2 arg2 _)  = match r ((fun1,fun2):w) arg1 arg2
 754 match r w (AppTy fun1 arg1)  (AppTy fun2 arg2)      = match r ((fun1,fun2):w) arg1 arg2
 755 match r w (TyConTy con1 _)     (TyConTy con2 _)     | con1  == con2  = match' r w
 756 match r w (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) | clas1 == clas2 = match r w ty1 ty2
 757 match r w (SynTy _ _ ty1)      ty2                  = match r w ty1 ty2
 758 match r w ty1                  (SynTy _ _ ty2)      = match r w ty1 ty2
 759
 760         -- With type synonyms, we have to be careful for the exact
 761         -- same reasons as in the unifier.  Please see the
 762         -- considerable commentary there before changing anything
 763         -- here! (WDP 95/05)
 764
 765 -- Catch-all fails
 766 match _ _ _ _ = Nothing
 767
 768 match' r []            = Just r
 769 match' r ((ty1,ty2):w) = match r w ty1 ty2
 770 \end{code}
 771
 772 %************************************************************************
 773 %*                                                                      *
 774 \subsection{Equality on types}
 775 %*                                                                      *
 776 %************************************************************************
 777
 778 The functions eqSimpleTy and eqSimpleTheta are polymorphic in the types t
 779 and u, but ONLY WORK FOR SIMPLE TYPES (ie. they panic if they see
 780 dictionaries or polymorphic types).  The function eqTy has a more
 781 specific type, but does the `right thing' for all types.
 782
 783 \begin{code}
 784 eqSimpleTheta :: (Eq t,Eq u) =>
 785     [(Class,GenType t u)] -> [(Class,GenType t u)] -> Bool
 786
 787 eqSimpleTheta [] [] = True
 788 eqSimpleTheta ((c1,t1):th1) ((c2,t2):th2) =
 789   c1==c2 && t1 `eqSimpleTy` t2 && th1 `eqSimpleTheta` th2
 790 eqSimpleTheta other1 other2 = False
 791 \end{code}
 792
 793 \begin{code}
 794 eqSimpleTy :: (Eq t,Eq u) => GenType t u -> GenType t u -> Bool
 795
 796 (TyVarTy tv1) `eqSimpleTy` (TyVarTy tv2) =
 797   tv1 == tv2
 798 (AppTy f1 a1)  `eqSimpleTy` (AppTy f2 a2) =
 799   f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2
 800 (TyConTy tc1 u1) `eqSimpleTy` (TyConTy tc2 u2) =
 801   tc1 == tc2 --ToDo: later: && u1 == u2
 802
 803 (FunTy f1 a1 u1) `eqSimpleTy` (FunTy f2 a2 u2) =
 804   f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 && u1 == u2
 805 (FunTy f1 a1 u1) `eqSimpleTy` t2 =
 806   -- Expand t1 just in case t2 matches that version
 807   (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) `eqSimpleTy` t2
 808 t1 `eqSimpleTy` (FunTy f2 a2 u2) =
 809   -- Expand t2 just in case t1 matches that version
 810   t1 `eqSimpleTy` (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
 811
 812 (SynTy tc1 ts1 t1) `eqSimpleTy` (SynTy tc2 ts2 t2) =
 813   (tc1 == tc2 && and (zipWith eqSimpleTy ts1 ts2) && length ts1 == length ts2)
 814   || t1 `eqSimpleTy` t2
 815 (SynTy _ _ t1) `eqSimpleTy` t2 =
 816   t1 `eqSimpleTy` t2  -- Expand the abbrevation and try again
 817 t1 `eqSimpleTy` (SynTy _ _ t2) =
 818   t1 `eqSimpleTy` t2  -- Expand the abbrevation and try again
 819
 820 (DictTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got DictTy"
 821 _ `eqSimpleTy` (DictTy _ _ _) = panic "eqSimpleTy: got DictTy"
 822
 823 (ForAllTy _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllTy"
 824 _ `eqSimpleTy` (ForAllTy _ _) = panic "eqSimpleTy: got ForAllTy"
 825
 826 (ForAllUsageTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllUsageTy"
 827 _ `eqSimpleTy` (ForAllUsageTy _ _ _) = panic "eqSimpleTy: got ForAllUsageTy"
 828
 829 _ `eqSimpleTy` _ = False
 830 \end{code}
 831
 832 Types are ordered so we can sort on types in the renamer etc.  DNT: Since
 833 this class is also used in CoreLint and other such places, we DO expand out
 834 Fun/Syn/Dict types (if necessary).
 835
 836 \begin{code}
 837 eqTy :: Type -> Type -> Bool
 838
 839 eqTy t1 t2 =
 840   eq nullTyVarEnv nullUVarEnv t1 t2
 841  where
 842   eq tve uve (TyVarTy tv1) (TyVarTy tv2) =
 843     tv1 == tv2 ||
 844     case (lookupTyVarEnv tve tv1) of
 845       Just tv -> tv == tv2
 846       Nothing -> False
 847   eq tve uve (AppTy f1 a1) (AppTy f2 a2) =
 848     eq tve uve f1 f2 && eq tve uve a1 a2
 849   eq tve uve (TyConTy tc1 u1) (TyConTy tc2 u2) =
 850     tc1 == tc2 -- ToDo: LATER: && eqUsage uve u1 u2
 851
 852   eq tve uve (FunTy f1 a1 u1) (FunTy f2 a2 u2) =
 853     eq tve uve f1 f2 && eq tve uve a1 a2 && eqUsage uve u1 u2
 854   eq tve uve (FunTy f1 a1 u1) t2 =
 855     -- Expand t1 just in case t2 matches that version
 856     eq tve uve (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) t2
 857   eq tve uve t1 (FunTy f2 a2 u2) =
 858     -- Expand t2 just in case t1 matches that version
 859     eq tve uve t1 (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
 860
 861   eq tve uve (DictTy c1 t1 u1) (DictTy c2 t2 u2)
 862     | c1 == c2
 863     = eq tve uve t1 t2 && eqUsage uve u1 u2
 864         -- NB we use a guard for c1==c2 so that if they aren't equal we
 865         -- fall through into expanding the type.  Why?  Because brain-dead
 866         -- people might write
 867         --      class Foo a => Baz a where {}
 868         -- and that means that a Foo dictionary and a Baz dictionary are identical
 869         -- Sigh.  Let's hope we don't spend too much time in here!
 870
 871   eq tve uve t1@(DictTy _ _ _) t2 =
 872     eq tve uve (expandTy t1) t2  -- Expand the dictionary and try again
 873   eq tve uve t1 t2@(DictTy _ _ _) =
 874     eq tve uve t1 (expandTy t2)  -- Expand the dictionary and try again
 875
 876   eq tve uve (SynTy tc1 ts1 t1) (SynTy tc2 ts2 t2) =
 877     (tc1 == tc2 && and (zipWith (eq tve uve) ts1 ts2) && length ts1 == length ts2)
 878     || eq tve uve t1 t2
 879   eq tve uve (SynTy _ _ t1) t2 =
 880     eq tve uve t1 t2  -- Expand the abbrevation and try again
 881   eq tve uve t1 (SynTy _ _ t2) =
 882     eq tve uve t1 t2  -- Expand the abbrevation and try again
 883
 884   eq tve uve (ForAllTy tv1 t1) (ForAllTy tv2 t2) =
 885     eq (addOneToTyVarEnv tve tv1 tv2) uve t1 t2
 886   eq tve uve (ForAllUsageTy u1 b1 t1) (ForAllUsageTy u2 b2 t2) =
 887     eqBounds uve b1 b2 && eq tve (addOneToUVarEnv uve u1 u2) t1 t2
 888
 889   eq _ _ _ _ = False
 890
 891   eqBounds uve [] [] = True
 892   eqBounds uve (u1:b1) (u2:b2) = eqUVar uve u1 u2 && eqBounds uve b1 b2
 893   eqBounds uve _ _ = False
 894 \end{code}