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, isDictTy,
  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)
  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,
  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              = panic "Type.mkTheta" -- pprPanic "mkTheta:" (pprType PprDebug other)
 352
 353 isDictTy (DictTy _ _ _) = True
 354 isDictTy (SynTy  _ _ t) = isDictTy t
 355 isDictTy _              = False
 356 \end{code}
 357
 358
 359 Forall stuff
 360 ~~~~~~~~~~~~
 361 \begin{code}
 362 mkForAllTy = ForAllTy
 363
 364 mkForAllTys :: [t] -> GenType t u -> GenType t u
 365 mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
 366
 367 getForAllTy_maybe :: GenType t u -> Maybe (t,GenType t u)
 368 getForAllTy_maybe (SynTy _ _ t)      = getForAllTy_maybe t
 369 getForAllTy_maybe (ForAllTy tyvar t) = Just(tyvar,t)
 370 getForAllTy_maybe _                  = Nothing
 371
 372 getForAllTyExpandingDicts_maybe :: Type -> Maybe (TyVar, Type)
 373 getForAllTyExpandingDicts_maybe (SynTy _ _ t)      = getForAllTyExpandingDicts_maybe t
 374 getForAllTyExpandingDicts_maybe (ForAllTy tyvar t) = Just(tyvar,t)
 375 getForAllTyExpandingDicts_maybe ty@(DictTy _ _ _)  = getForAllTyExpandingDicts_maybe (expandTy ty)
 376 getForAllTyExpandingDicts_maybe _                  = Nothing
 377
 378 splitForAllTy :: GenType t u-> ([t], GenType t u)
 379 splitForAllTy t = go t []
 380                where
 381                     go (ForAllTy tv t) tvs = go t (tv:tvs)
 382                     go (SynTy _ _ t)   tvs = go t tvs
 383                     go t               tvs = (reverse tvs, t)
 384 \end{code}
 385
 386 \begin{code}
 387 mkForAllUsageTy :: u -> [u] -> GenType t u -> GenType t u
 388 mkForAllUsageTy = ForAllUsageTy
 389
 390 getForAllUsageTy :: GenType t u -> Maybe (u,[u],GenType t u)
 391 getForAllUsageTy (ForAllUsageTy uvar bounds t) = Just(uvar,bounds,t)
 392 getForAllUsageTy (SynTy _ _ t) = getForAllUsageTy t
 393 getForAllUsageTy _ = Nothing
 394 \end{code}
 395
 396 Applied tycons (includes FunTyCons)
 397 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 398 \begin{code}
 399 maybeAppTyCon
 400         :: GenType tyvar uvar
 401         -> Maybe (TyCon,                -- the type constructor
 402                   [GenType tyvar uvar]) -- types to which it is applied
 403
 404 maybeAppTyCon ty
 405   = case (getTyCon_maybe app_ty) of
 406         Nothing    -> Nothing
 407         Just tycon -> Just (tycon, arg_tys)
 408   where
 409     (app_ty, arg_tys) = splitAppTy ty
 410
 411
 412 getAppTyCon
 413         :: GenType tyvar uvar
 414         -> (TyCon,                      -- the type constructor
 415             [GenType tyvar uvar])       -- types to which it is applied
 416
 417 getAppTyCon ty
 418   = case maybeAppTyCon ty of
 419       Just stuff -> stuff
 420 #ifdef DEBUG
 421       Nothing    -> panic "Type.getAppTyCon" -- (ppr PprShowAll ty)
 422 #endif
 423 \end{code}
 424
 425 Applied data tycons (give back constrs)
 426 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 427 \begin{code}
 428 maybeAppDataTyCon
 429         :: GenType (GenTyVar any) uvar
 430         -> Maybe (TyCon,                -- the type constructor
 431                   [GenType (GenTyVar any) uvar],        -- types to which it is applied
 432                   [Id])                 -- its family of data-constructors
 433 maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts
 434         :: Type -> Maybe (TyCon, [Type], [Id])
 435
 436 maybeAppDataTyCon                   ty = maybe_app_data_tycon (\x->x) ty
 437 maybeAppDataTyConExpandingDicts     ty = maybe_app_data_tycon expandTy ty
 438 maybeAppSpecDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty
 439
 440
 441 maybe_app_data_tycon expand ty
 442   = let
 443         expanded_ty       = expand ty
 444         (app_ty, arg_tys) = splitAppTy expanded_ty
 445     in
 446     case (getTyCon_maybe app_ty) of
 447         Just tycon |  --pprTrace "maybe_app:" (ppCat [ppr PprDebug (isDataTyCon tycon), ppr PprDebug (notArrowKind (typeKind expanded_ty))]) $
 448                       isDataTyCon tycon &&
 449                       notArrowKind (typeKind expanded_ty)
 450                         -- Must be saturated for ty to be a data type
 451                    -> Just (tycon, arg_tys, tyConDataCons tycon)
 452
 453         other      -> Nothing
 454
 455 getAppDataTyCon, getAppSpecDataTyCon
 456         :: GenType (GenTyVar any) uvar
 457         -> (TyCon,                      -- the type constructor
 458             [GenType (GenTyVar any) uvar],      -- types to which it is applied
 459             [Id])                       -- its family of data-constructors
 460 getAppDataTyConExpandingDicts, getAppSpecDataTyConExpandingDicts
 461         :: Type -> (TyCon, [Type], [Id])
 462
 463 getAppDataTyCon               ty = get_app_data_tycon maybeAppDataTyCon ty
 464 getAppDataTyConExpandingDicts ty = --pprTrace "getAppDataTyConEx...:" (pprType PprDebug ty) $
 465                                    get_app_data_tycon maybeAppDataTyConExpandingDicts ty
 466
 467 -- these should work like the UniTyFuns.getUniDataSpecTyCon* things of old (ToDo)
 468 getAppSpecDataTyCon               = getAppDataTyCon
 469 getAppSpecDataTyConExpandingDicts = getAppDataTyConExpandingDicts
 470
 471 get_app_data_tycon maybe ty
 472   = case maybe ty of
 473       Just stuff -> stuff
 474 #ifdef DEBUG
 475       Nothing    -> panic "Type.getAppDataTyCon" -- (pprGenType PprShowAll ty)
 476 #endif
 477
 478
 479 maybeBoxedPrimType :: Type -> Maybe (Id, Type)
 480
 481 maybeBoxedPrimType ty
 482   = case (maybeAppDataTyCon ty) of              -- Data type,
 483       Just (tycon, tys_applied, [data_con])     -- with exactly one constructor
 484         -> case (dataConArgTys data_con tys_applied) of
 485              [data_con_arg_ty]                  -- Applied to exactly one type,
 486                 | isPrimType data_con_arg_ty    -- which is primitive
 487                 -> Just (data_con, data_con_arg_ty)
 488              other_cases -> Nothing
 489       other_cases -> Nothing
 490 \end{code}
 491
 492 \begin{code}
 493 splitSigmaTy :: GenType t u -> ([t], [(Class,GenType t u)], GenType t u)
 494 splitSigmaTy ty =
 495   (tyvars, theta, tau)
 496  where
 497   (tyvars,rho) = splitForAllTy ty
 498   (theta,tau)  = splitRhoTy rho
 499
 500 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
 501 \end{code}
 502
 503
 504 Finding the kind of a type
 505 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 506 \begin{code}
 507 typeKind :: GenType (GenTyVar any) u -> Kind
 508
 509 typeKind (TyVarTy tyvar)        = tyVarKind tyvar
 510 typeKind (TyConTy tycon usage)  = tyConKind tycon
 511 typeKind (SynTy _ _ ty)         = typeKind ty
 512 typeKind (FunTy fun arg _)      = mkBoxedTypeKind
 513 typeKind (DictTy clas arg _)    = mkBoxedTypeKind
 514 typeKind (AppTy fun arg)        = resultKind (typeKind fun)
 515 typeKind (ForAllTy _ _)         = mkBoxedTypeKind
 516 typeKind (ForAllUsageTy _ _ _)  = mkBoxedTypeKind
 517 \end{code}
 518
 519
 520 Free variables of a type
 521 ~~~~~~~~~~~~~~~~~~~~~~~~
 522 \begin{code}
 523 tyVarsOfType :: GenType (GenTyVar flexi) uvar -> GenTyVarSet flexi
 524
 525 tyVarsOfType (TyVarTy tv)               = unitTyVarSet tv
 526 tyVarsOfType (TyConTy tycon usage)      = emptyTyVarSet
 527 tyVarsOfType (SynTy _ tys ty)           = tyVarsOfTypes tys
 528 tyVarsOfType (FunTy arg res _)          = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res
 529 tyVarsOfType (AppTy fun arg)            = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg
 530 tyVarsOfType (DictTy clas ty _)         = tyVarsOfType ty
 531 tyVarsOfType (ForAllTy tyvar ty)        = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar
 532 tyVarsOfType (ForAllUsageTy _ _ ty)     = tyVarsOfType ty
 533
 534 tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi
 535 tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys
 536 \end{code}
 537
 538
 539 Instantiating a type
 540 ~~~~~~~~~~~~~~~~~~~~
 541 \begin{code}
 542 applyTy :: GenType (GenTyVar flexi) uvar
 543         -> GenType (GenTyVar flexi) uvar
 544         -> GenType (GenTyVar flexi) uvar
 545
 546 applyTy (SynTy _ _ fun)  arg = applyTy fun arg
 547 applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty
 548 applyTy other            arg = panic "applyTy"
 549 \end{code}
 550
 551 \begin{code}
 552 instantiateTy   :: [(GenTyVar flexi, GenType (GenTyVar flexi) uvar)]
 553                 -> GenType (GenTyVar flexi) uvar
 554                 -> GenType (GenTyVar flexi) uvar
 555
 556 instantiateTauTy :: Eq tv =>
 557                    [(tv, GenType tv' u)]
 558                 -> GenType tv u
 559                 -> GenType tv' u
 560
 561 applyTypeEnvToTy :: TyVarEnv Type -> SigmaType -> SigmaType
 562
 563 -- instantiateTauTy works only (a) on types with no ForAlls,
 564 --      and when               (b) all the type variables are being instantiated
 565 -- In return it is more polymorphic than instantiateTy
 566
 567 instant_help ty lookup_tv deflt_tv choose_tycon
 568                 if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
 569   = go ty
 570   where
 571     go (TyVarTy tv)                = case (lookup_tv tv) of
 572                                        Nothing -> deflt_tv tv
 573                                        Just ty -> ty
 574     go ty@(TyConTy tycon usage)    = choose_tycon ty tycon usage
 575     go (SynTy tycon tys ty)        = SynTy tycon (map go tys) (go ty)
 576     go (FunTy arg res usage)       = FunTy (go arg) (go res) usage
 577     go (AppTy fun arg)             = AppTy (go fun) (go arg)
 578     go (DictTy clas ty usage)      = DictTy clas (go ty) usage
 579     go (ForAllUsageTy uvar bds ty) = if_usage $
 580                                      ForAllUsageTy uvar bds (go ty)
 581     go (ForAllTy tv ty)            = if_forall $
 582                                      (if (bound_forall_tv_BAD && maybeToBool (lookup_tv tv)) then
 583                                         trace "instantiateTy: unexpected forall hit"
 584                                      else
 585                                         \x->x) ForAllTy (deflt_forall_tv tv) (go ty)
 586
 587 instantiateTy tenv ty
 588   = instant_help ty lookup_tv deflt_tv choose_tycon
 589                     if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
 590   where
 591     lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of
 592                      []   -> Nothing
 593                      [ty] -> Just ty
 594                      _    -> panic "instantiateTy:lookup_tv"
 595
 596     deflt_tv tv = TyVarTy tv
 597     choose_tycon ty _ _ = ty
 598     if_usage ty = ty
 599     if_forall ty = ty
 600     bound_forall_tv_BAD = True
 601     deflt_forall_tv tv  = tv
 602
 603 instantiateTauTy tenv ty
 604   = instant_help ty lookup_tv deflt_tv choose_tycon
 605                     if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
 606   where
 607     lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of
 608                      []   -> Nothing
 609                      [ty] -> Just ty
 610                      _    -> panic "instantiateTauTy:lookup_tv"
 611
 612     deflt_tv tv = panic "instantiateTauTy"
 613     choose_tycon _ tycon usage = TyConTy tycon usage
 614     if_usage ty = panic "instantiateTauTy:ForAllUsageTy"
 615     if_forall ty = panic "instantiateTauTy:ForAllTy"
 616     bound_forall_tv_BAD = panic "instantiateTauTy:bound_forall_tv"
 617     deflt_forall_tv tv  = panic "instantiateTauTy:deflt_forall_tv"
 618
 619
 620 -- applyTypeEnv applies a type environment to a type.
 621 -- It can handle shadowing; for example:
 622 --      f = /\ t1 t2 -> \ d ->
 623 --         letrec f' = /\ t1 -> \x -> ...(f' t1 x')...
 624 --         in f' t1
 625 -- Here, when we clone t1 to t1', say, we'll come across shadowing
 626 -- when applying the clone environment to the type of f'.
 627 --
 628 -- As a sanity check, we should also check that name capture
 629 -- doesn't occur, but that means keeping track of the free variables of the
 630 -- range of the TyVarEnv, which I don't do just yet.
 631 --
 632 -- We don't use instant_help because we need to carry in the environment
 633
 634 applyTypeEnvToTy tenv ty
 635   = go tenv ty
 636   where
 637     go tenv ty@(TyVarTy tv)             = case (lookupTyVarEnv tenv tv) of
 638                                              Nothing -> ty
 639                                              Just ty -> ty
 640     go tenv ty@(TyConTy tycon usage)    = ty
 641     go tenv (SynTy tycon tys ty)        = SynTy tycon (map (go tenv) tys) (go tenv ty)
 642     go tenv (FunTy arg res usage)       = FunTy (go tenv arg) (go tenv res) usage
 643     go tenv (AppTy fun arg)             = AppTy (go tenv fun) (go tenv arg)
 644     go tenv (DictTy clas ty usage)      = DictTy clas (go tenv ty) usage
 645     go tenv (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go tenv ty)
 646     go tenv (ForAllTy tv ty)            = ForAllTy tv (go tenv' ty)
 647                                         where
 648                                           tenv' = case lookupTyVarEnv tenv tv of
 649                                                     Nothing -> tenv
 650                                                     Just _  -> delFromTyVarEnv tenv tv
 651 \end{code}
 652
 653 \begin{code}
 654 instantiateUsage
 655         :: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u'
 656
 657 instantiateUsage = panic "instantiateUsage: not implemented"
 658 \end{code}
 659
 660
 661 At present there are no unboxed non-primitive types, so
 662 isUnboxedType is the same as isPrimType.
 663
 664 We're a bit cavalier about finding out whether something is
 665 primitive/unboxed or not.  Rather than deal with the type
 666 arguemnts we just zoom into the function part of the type.
 667 That is, given (T a) we just recurse into the "T" part,
 668 ignoring "a".
 669
 670 \begin{code}
 671 isPrimType, isUnboxedType :: Type -> Bool
 672
 673 isPrimType (AppTy ty _)      = isPrimType ty
 674 isPrimType (SynTy _ _ ty)    = isPrimType ty
 675 isPrimType (TyConTy tycon _) = case maybeNewTyCon tycon of
 676                                   Just (tyvars, ty) -> isPrimType ty
 677                                   Nothing           -> isPrimTyCon tycon
 678
 679 isPrimType _                 = False
 680
 681 isUnboxedType = isPrimType
 682 \end{code}
 683
 684 This is *not* right: it is a placeholder (ToDo 96/03 WDP):
 685 \begin{code}
 686 typePrimRep :: Type -> PrimRep
 687
 688 typePrimRep (SynTy _ _ ty)  = typePrimRep ty
 689 typePrimRep (AppTy ty _)    = typePrimRep ty
 690 typePrimRep (TyConTy tc _)
 691   | isPrimTyCon tc          = case (assocMaybe tc_primrep_list (uniqueOf tc)) of
 692                                    Just xx -> xx
 693                                    Nothing -> panic "Type.typePrimRep" -- pprPanic "typePrimRep:" (pprTyCon PprDebug tc)
 694
 695   | otherwise               = case maybeNewTyCon tc of
 696                                   Just (tyvars, ty) | isPrimType ty -> typePrimRep ty
 697                                   _ -> PtrRep   -- Default
 698
 699 typePrimRep _               = PtrRep -- the "default"
 700
 701 tc_primrep_list
 702   = [(addrPrimTyConKey,             AddrRep)
 703     ,(arrayPrimTyConKey,            ArrayRep)
 704     ,(byteArrayPrimTyConKey,        ByteArrayRep)
 705     ,(charPrimTyConKey,             CharRep)
 706     ,(doublePrimTyConKey,           DoubleRep)
 707     ,(floatPrimTyConKey,            FloatRep)
 708     ,(foreignObjPrimTyConKey,       ForeignObjRep)
 709     ,(intPrimTyConKey,              IntRep)
 710     ,(mutableArrayPrimTyConKey,     ArrayRep)
 711     ,(mutableByteArrayPrimTyConKey, ByteArrayRep)
 712     ,(stablePtrPrimTyConKey,        StablePtrRep)
 713     ,(statePrimTyConKey,            VoidRep)
 714     ,(synchVarPrimTyConKey,         PtrRep)
 715     ,(voidTyConKey,                 VoidRep)
 716     ,(wordPrimTyConKey,             WordRep)
 717     ]
 718 \end{code}
 719
 720 %************************************************************************
 721 %*                                                                      *
 722 \subsection{Matching on types}
 723 %*                                                                      *
 724 %************************************************************************
 725
 726 Matching is a {\em unidirectional} process, matching a type against a
 727 template (which is just a type with type variables in it).  The
 728 matcher assumes that there are no repeated type variables in the
 729 template, so that it simply returns a mapping of type variables to
 730 types.  It also fails on nested foralls.
 731
 732 @matchTys@ matches corresponding elements of a list of templates and
 733 types.
 734
 735 \begin{code}
 736 matchTy :: GenType t1 u1                -- Template
 737         -> GenType t2 u2                -- Proposed instance of template
 738         -> Maybe [(t1,GenType t2 u2)]   -- Matching substitution
 739
 740
 741 matchTys :: [GenType t1 u1]             -- Templates
 742          -> [GenType t2 u2]             -- Proposed instance of template
 743          -> Maybe ([(t1,GenType t2 u2)],-- Matching substitution
 744                    [GenType t2 u2])     -- Left over instance types
 745
 746 matchTy  ty1  ty2  = match  ty1 ty2 (\s -> Just s) []
 747 matchTys tys1 tys2 = go [] tys1 tys2
 748                    where
 749                      go s []        tys2        = Just (s,tys2)
 750                      go s (ty1:tys1) []         = trace "matchTys" Nothing
 751                      go s (ty1:tys1) (ty2:tys2) = match ty1 ty2 (\s' -> go s' tys1 tys2) s
 752 \end{code}
 753
 754 @match@ is the main function.
 755
 756 \begin{code}
 757 match :: GenType t1 u1 -> GenType t2 u2                 -- Current match pair
 758       -> ([(t1, GenType t2 u2)] -> Maybe result)        -- Continuation
 759       -> [(t1, GenType t2 u2)]                          -- Current substitution
 760       -> Maybe result
 761
 762 match (TyVarTy v)          ty                   k = \s -> k ((v,ty) : s)
 763 match (FunTy fun1 arg1 _)  (FunTy fun2 arg2 _)  k = match fun1 fun2 (match arg1 arg2 k)
 764 match (AppTy fun1 arg1)    (AppTy fun2 arg2)    k = match fun1 fun2 (match arg1 arg2 k)
 765 match (TyConTy con1 _)     (TyConTy con2 _)     k | con1  == con2  = k
 766 match (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) k | clas1 == clas2 = match ty1 ty2 k
 767 match (SynTy _ _ ty1)      ty2                  k = match ty1 ty2 k
 768 match ty1                      (SynTy _ _ ty2)  k = match ty1 ty2 k
 769
 770         -- With type synonyms, we have to be careful for the exact
 771         -- same reasons as in the unifier.  Please see the
 772         -- considerable commentary there before changing anything
 773         -- here! (WDP 95/05)
 774
 775 -- Catch-all fails
 776 match _ _ _ = \s -> Nothing
 777 \end{code}
 778
 779 %************************************************************************
 780 %*                                                                      *
 781 \subsection{Equality on types}
 782 %*                                                                      *
 783 %************************************************************************
 784
 785 The functions eqSimpleTy and eqSimpleTheta are polymorphic in the types t
 786 and u, but ONLY WORK FOR SIMPLE TYPES (ie. they panic if they see
 787 dictionaries or polymorphic types).  The function eqTy has a more
 788 specific type, but does the `right thing' for all types.
 789
 790 \begin{code}
 791 eqSimpleTheta :: (Eq t,Eq u) =>
 792     [(Class,GenType t u)] -> [(Class,GenType t u)] -> Bool
 793
 794 eqSimpleTheta [] [] = True
 795 eqSimpleTheta ((c1,t1):th1) ((c2,t2):th2) =
 796   c1==c2 && t1 `eqSimpleTy` t2 && th1 `eqSimpleTheta` th2
 797 eqSimpleTheta other1 other2 = False
 798 \end{code}
 799
 800 \begin{code}
 801 eqSimpleTy :: (Eq t,Eq u) => GenType t u -> GenType t u -> Bool
 802
 803 (TyVarTy tv1) `eqSimpleTy` (TyVarTy tv2) =
 804   tv1 == tv2
 805 (AppTy f1 a1)  `eqSimpleTy` (AppTy f2 a2) =
 806   f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2
 807 (TyConTy tc1 u1) `eqSimpleTy` (TyConTy tc2 u2) =
 808   tc1 == tc2 --ToDo: later: && u1 == u2
 809
 810 (FunTy f1 a1 u1) `eqSimpleTy` (FunTy f2 a2 u2) =
 811   f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 && u1 == u2
 812 (FunTy f1 a1 u1) `eqSimpleTy` t2 =
 813   -- Expand t1 just in case t2 matches that version
 814   (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) `eqSimpleTy` t2
 815 t1 `eqSimpleTy` (FunTy f2 a2 u2) =
 816   -- Expand t2 just in case t1 matches that version
 817   t1 `eqSimpleTy` (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
 818
 819 (SynTy tc1 ts1 t1) `eqSimpleTy` (SynTy tc2 ts2 t2) =
 820   (tc1 == tc2 && and (zipWith eqSimpleTy ts1 ts2) && length ts1 == length ts2)
 821   || t1 `eqSimpleTy` t2
 822 (SynTy _ _ t1) `eqSimpleTy` t2 =
 823   t1 `eqSimpleTy` t2  -- Expand the abbrevation and try again
 824 t1 `eqSimpleTy` (SynTy _ _ t2) =
 825   t1 `eqSimpleTy` t2  -- Expand the abbrevation and try again
 826
 827 (DictTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got DictTy"
 828 _ `eqSimpleTy` (DictTy _ _ _) = panic "eqSimpleTy: got DictTy"
 829
 830 (ForAllTy _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllTy"
 831 _ `eqSimpleTy` (ForAllTy _ _) = panic "eqSimpleTy: got ForAllTy"
 832
 833 (ForAllUsageTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllUsageTy"
 834 _ `eqSimpleTy` (ForAllUsageTy _ _ _) = panic "eqSimpleTy: got ForAllUsageTy"
 835
 836 _ `eqSimpleTy` _ = False
 837 \end{code}
 838
 839 Types are ordered so we can sort on types in the renamer etc.  DNT: Since
 840 this class is also used in CoreLint and other such places, we DO expand out
 841 Fun/Syn/Dict types (if necessary).
 842
 843 \begin{code}
 844 eqTy :: Type -> Type -> Bool
 845
 846 eqTy t1 t2 =
 847   eq nullTyVarEnv nullUVarEnv t1 t2
 848  where
 849   eq tve uve (TyVarTy tv1) (TyVarTy tv2) =
 850     tv1 == tv2 ||
 851     case (lookupTyVarEnv tve tv1) of
 852       Just tv -> tv == tv2
 853       Nothing -> False
 854   eq tve uve (AppTy f1 a1) (AppTy f2 a2) =
 855     eq tve uve f1 f2 && eq tve uve a1 a2
 856   eq tve uve (TyConTy tc1 u1) (TyConTy tc2 u2) =
 857     tc1 == tc2 -- ToDo: LATER: && eqUsage uve u1 u2
 858
 859   eq tve uve (FunTy f1 a1 u1) (FunTy f2 a2 u2) =
 860     eq tve uve f1 f2 && eq tve uve a1 a2 && eqUsage uve u1 u2
 861   eq tve uve (FunTy f1 a1 u1) t2 =
 862     -- Expand t1 just in case t2 matches that version
 863     eq tve uve (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) t2
 864   eq tve uve t1 (FunTy f2 a2 u2) =
 865     -- Expand t2 just in case t1 matches that version
 866     eq tve uve t1 (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
 867
 868   eq tve uve (DictTy c1 t1 u1) (DictTy c2 t2 u2)
 869     | c1 == c2
 870     = eq tve uve t1 t2 && eqUsage uve u1 u2
 871         -- NB we use a guard for c1==c2 so that if they aren't equal we
 872         -- fall through into expanding the type.  Why?  Because brain-dead
 873         -- people might write
 874         --      class Foo a => Baz a where {}
 875         -- and that means that a Foo dictionary and a Baz dictionary are identical
 876         -- Sigh.  Let's hope we don't spend too much time in here!
 877
 878   eq tve uve t1@(DictTy _ _ _) t2 =
 879     eq tve uve (expandTy t1) t2  -- Expand the dictionary and try again
 880   eq tve uve t1 t2@(DictTy _ _ _) =
 881     eq tve uve t1 (expandTy t2)  -- Expand the dictionary and try again
 882
 883   eq tve uve (SynTy tc1 ts1 t1) (SynTy tc2 ts2 t2) =
 884     (tc1 == tc2 && and (zipWith (eq tve uve) ts1 ts2) && length ts1 == length ts2)
 885     || eq tve uve t1 t2
 886   eq tve uve (SynTy _ _ t1) t2 =
 887     eq tve uve t1 t2  -- Expand the abbrevation and try again
 888   eq tve uve t1 (SynTy _ _ t2) =
 889     eq tve uve t1 t2  -- Expand the abbrevation and try again
 890
 891   eq tve uve (ForAllTy tv1 t1) (ForAllTy tv2 t2) =
 892     eq (addOneToTyVarEnv tve tv1 tv2) uve t1 t2
 893   eq tve uve (ForAllUsageTy u1 b1 t1) (ForAllUsageTy u2 b2 t2) =
 894     eqBounds uve b1 b2 && eq tve (addOneToUVarEnv uve u1 u2) t1 t2
 895
 896   eq _ _ _ _ = False
 897
 898   eqBounds uve [] [] = True
 899   eqBounds uve (u1:b1) (u2:b2) = eqUVar uve u1 u2 && eqBounds uve b1 b2
 900   eqBounds uve _ _ = False
 901 \end{code}