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