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