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