ghc/compiler/types/Type.lhs

   1 \begin{code}
   2 #include "HsVersions.h"
   3
   4 module Type (
   5         GenType(..), Type(..), TauType(..),
   6         mkTyVarTy, mkTyVarTys,
   7         getTyVar, getTyVar_maybe, isTyVarTy,
   8         mkAppTy, mkAppTys, splitAppTy,
   9         mkFunTy, mkFunTys, splitFunTy, splitFunTyExpandingDicts,
  10         getFunTy_maybe, getFunTyExpandingDicts_maybe,
  11         mkTyConTy, getTyCon_maybe, applyTyCon,
  12         mkSynTy,
  13         mkForAllTy, mkForAllTys, getForAllTy_maybe, splitForAllTy,
  14         mkForAllUsageTy, getForAllUsageTy,
  15         applyTy,
  16 #ifdef DEBUG
  17         expandTy, -- only let out for debugging (ToDo: rm?)
  18 #endif
  19         isPrimType, isUnboxedType, typePrimRep,
  20
  21         RhoType(..), SigmaType(..), ThetaType(..),
  22         mkDictTy,
  23         mkRhoTy, splitRhoTy, mkTheta,
  24         mkSigmaTy, splitSigmaTy,
  25
  26         maybeAppTyCon, getAppTyCon,
  27         maybeAppDataTyCon, getAppDataTyCon, getAppSpecDataTyCon,
  28         maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts,
  29         getAppDataTyConExpandingDicts,  getAppSpecDataTyConExpandingDicts,
  30         maybeBoxedPrimType,
  31
  32         matchTy, matchTys, eqTy, eqSimpleTy, eqSimpleTheta,
  33
  34         instantiateTy, instantiateTauTy, instantiateUsage,
  35         applyTypeEnvToTy,
  36
  37         isTauTy,
  38
  39         tyVarsOfType, tyVarsOfTypes, typeKind
  40     ) where
  41
  42 import Ubiq
  43 import IdLoop    -- for paranoia checking
  44 import TyLoop    -- for paranoia checking
  45 import PrelLoop  -- for paranoia checking
  46
  47 -- ToDo:rm
  48 --import PprType        ( pprGenType ) -- ToDo: rm
  49 --import PprStyle ( PprStyle(..) )
  50 --import Util   ( pprPanic )
  51
  52 -- friends:
  53 import Class    ( classSig, classOpLocalType, GenClass{-instances-} )
  54 import Kind     ( mkBoxedTypeKind, resultKind )
  55 import TyCon    ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, isSynTyCon, tyConArity,
  56                   tyConKind, tyConDataCons, getSynTyConDefn, TyCon )
  57 import TyVar    ( tyVarKind, GenTyVar{-instances-}, GenTyVarSet(..),
  58                   emptyTyVarSet, unionTyVarSets, minusTyVarSet,
  59                   unitTyVarSet, nullTyVarEnv, lookupTyVarEnv,
  60                   addOneToTyVarEnv, TyVarEnv(..) )
  61 import Usage    ( usageOmega, GenUsage, Usage(..), UVar(..), UVarEnv(..),
  62                   nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar,
  63                   eqUsage )
  64
  65 -- others
  66 import Maybes   ( maybeToBool )
  67 import PrimRep  ( PrimRep(..) )
  68 import Util     ( thenCmp, zipEqual, panic, panic#, assertPanic, pprTrace{-ToDo:rm-}, pprPanic{-ToDo:rm-},
  69                   Ord3(..){-instances-}
  70                 )
  71 -- ToDo:rm all these
  72 import  {-mumble-}
  73         Pretty
  74 import  {-mumble-}
  75         PprStyle
  76 import  {-mumble-}
  77         PprType (pprType )
  78 import  {-mumble-}
  79         UniqFM (ufmToList )
  80 import  {-mumble-}
  81         Unique (pprUnique )
  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         [arg_ty] -> expandTy arg_ty     -- just the <whatever> itself
 153
 154                 -- The extra expandTy is to make sure that
 155                 -- the result isn't still a dict, which it might be
 156                 -- if the original guy was a dict with one superdict and
 157                 -- no methods!
 158
 159         other -> ASSERT(not (null all_arg_tys))
 160                 foldl AppTy (TyConTy (mkTupleTyCon (length all_arg_tys)) u) all_arg_tys
 161
 162                 -- A tuple of 'em
 163                 -- Note: length of all_arg_tys can be 0 if the class is
 164                 --       CCallable, CReturnable (and anything else
 165                 --       *really weird* that the user writes).
 166   where
 167     (tyvar, super_classes, ops) = classSig clas
 168     super_dict_tys = map mk_super_ty super_classes
 169     class_op_tys   = map mk_op_ty ops
 170     all_arg_tys    = super_dict_tys ++ class_op_tys
 171     mk_super_ty sc = DictTy sc ty usageOmega
 172     mk_op_ty    op = instantiateTy [(tyvar,ty)] (classOpLocalType op)
 173
 174 expandTy ty = ty
 175 \end{code}
 176
 177 Simple construction and analysis functions
 178 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 179 \begin{code}
 180 mkTyVarTy  :: t   -> GenType t u
 181 mkTyVarTys :: [t] -> [GenType t y]
 182 mkTyVarTy  = TyVarTy
 183 mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy
 184
 185 getTyVar :: String -> GenType t u -> t
 186 getTyVar msg (TyVarTy tv)   = tv
 187 getTyVar msg (SynTy _ _ t)  = getTyVar msg t
 188 getTyVar msg other          = panic ("getTyVar: " ++ msg)
 189
 190 getTyVar_maybe :: GenType t u -> Maybe t
 191 getTyVar_maybe (TyVarTy tv)  = Just tv
 192 getTyVar_maybe (SynTy _ _ t) = getTyVar_maybe t
 193 getTyVar_maybe other         = Nothing
 194
 195 isTyVarTy :: GenType t u -> Bool
 196 isTyVarTy (TyVarTy tv)  = True
 197 isTyVarTy (SynTy _ _ t) = isTyVarTy t
 198 isTyVarTy other = False
 199 \end{code}
 200
 201 \begin{code}
 202 mkAppTy = AppTy
 203
 204 mkAppTys :: GenType t u -> [GenType t u] -> GenType t u
 205 mkAppTys t ts = foldl AppTy t ts
 206
 207 splitAppTy :: GenType t u -> (GenType t u, [GenType t u])
 208 splitAppTy t = go t []
 209   where
 210     go (AppTy t arg)     ts = go t (arg:ts)
 211     go (FunTy fun arg u) ts = (TyConTy mkFunTyCon u, fun:arg:ts)
 212     go (SynTy _ _ t)     ts = go t ts
 213     go t                 ts = (t,ts)
 214 \end{code}
 215
 216 \begin{code}
 217 -- NB mkFunTy, mkFunTys puts in Omega usages, for now at least
 218 mkFunTy arg res = FunTy arg res usageOmega
 219
 220 mkFunTys :: [GenType t u] -> GenType t u -> GenType t u
 221 mkFunTys ts t = foldr (\ f a -> FunTy f a usageOmega) t ts
 222
 223   -- getFunTy_maybe and splitFunTy *must* have the general type given, which
 224   -- means they *can't* do the DictTy jiggery-pokery that
 225   -- *is* sometimes required.  Hence we also have the ExpandingDicts variants
 226   -- The relationship between these
 227   -- two functions is like that between eqTy and eqSimpleTy.
 228   -- ToDo: NUKE when we do dicts via newtype
 229
 230 getFunTy_maybe :: GenType t u -> Maybe (GenType t u, GenType t u)
 231 getFunTy_maybe (FunTy arg result _) = Just (arg,result)
 232 getFunTy_maybe (AppTy (AppTy (TyConTy tycon _) arg) res)
 233                  | isFunTyCon tycon = Just (arg, res)
 234 getFunTy_maybe (SynTy _ _ t)        = getFunTy_maybe t
 235 getFunTy_maybe other                = Nothing
 236
 237 getFunTyExpandingDicts_maybe :: Type -> Maybe (Type, Type)
 238 getFunTyExpandingDicts_maybe (FunTy arg result _) = Just (arg,result)
 239 getFunTyExpandingDicts_maybe
 240         (AppTy (AppTy (TyConTy tycon _) arg) res) | isFunTyCon tycon = Just (arg, res)
 241 getFunTyExpandingDicts_maybe (SynTy _ _ t)        = getFunTyExpandingDicts_maybe t
 242 getFunTyExpandingDicts_maybe ty@(DictTy _ _ _)    = getFunTyExpandingDicts_maybe (expandTy ty)
 243 getFunTyExpandingDicts_maybe other                = Nothing
 244
 245 splitFunTy               :: GenType t u -> ([GenType t u], GenType t u)
 246 splitFunTyExpandingDicts :: Type        -> ([Type], Type)
 247
 248 splitFunTy               t = split_fun_ty getFunTy_maybe               t
 249 splitFunTyExpandingDicts t = split_fun_ty getFunTyExpandingDicts_maybe t
 250
 251 split_fun_ty get t = go t []
 252   where
 253     go t ts = case (get t) of
 254                 Just (arg,res) -> go res (arg:ts)
 255                 Nothing        -> (reverse ts, t)
 256 \end{code}
 257
 258 \begin{code}
 259 -- NB applyTyCon puts in usageOmega, for now at least
 260 mkTyConTy tycon
 261   = ASSERT(not (isSynTyCon tycon))
 262     TyConTy tycon usageOmega
 263
 264 applyTyCon :: TyCon -> [GenType t u] -> GenType t u
 265 applyTyCon tycon tys
 266   = ASSERT (not (isSynTyCon tycon))
 267     foldl AppTy (TyConTy tycon usageOmega) tys
 268
 269 getTyCon_maybe               :: GenType t u -> Maybe TyCon
 270 --getTyConExpandingDicts_maybe :: Type        -> Maybe TyCon
 271
 272 getTyCon_maybe (TyConTy tycon _) = Just tycon
 273 getTyCon_maybe (SynTy _ _ t)     = getTyCon_maybe t
 274 getTyCon_maybe other_ty          = Nothing
 275
 276 --getTyConExpandingDicts_maybe (TyConTy tycon _) = Just tycon
 277 --getTyConExpandingDicts_maybe (SynTy _ _ t)     = getTyConExpandingDicts_maybe t
 278 --getTyConExpandingDicts_maybe ty@(DictTy _ _ _) = getTyConExpandingDicts_maybe (expandTy ty)
 279 --getTyConExpandingDicts_maybe other_ty        = Nothing
 280 \end{code}
 281
 282 \begin{code}
 283 mkSynTy syn_tycon tys
 284   = ASSERT(isSynTyCon syn_tycon)
 285     SynTy syn_tycon tys (instantiateTauTy (zipEqual "mkSynTy" tyvars tys) body)
 286   where
 287     (tyvars, body) = getSynTyConDefn syn_tycon
 288 \end{code}
 289
 290 Tau stuff
 291 ~~~~~~~~~
 292 \begin{code}
 293 isTauTy :: GenType t u -> Bool
 294 isTauTy (TyVarTy v)        = True
 295 isTauTy (TyConTy _ _)      = True
 296 isTauTy (AppTy a b)        = isTauTy a && isTauTy b
 297 isTauTy (FunTy a b _)      = isTauTy a && isTauTy b
 298 isTauTy (SynTy _ _ ty)     = isTauTy ty
 299 isTauTy other              = False
 300 \end{code}
 301
 302 Rho stuff
 303 ~~~~~~~~~
 304 NB mkRhoTy and mkDictTy put in usageOmega, for now at least
 305
 306 \begin{code}
 307 mkDictTy :: Class -> GenType t u -> GenType t u
 308 mkDictTy clas ty = DictTy clas ty usageOmega
 309
 310 mkRhoTy :: [(Class, GenType t u)] -> GenType t u -> GenType t u
 311 mkRhoTy theta ty =
 312   foldr (\(c,t) r -> FunTy (DictTy c t usageOmega) r usageOmega) ty theta
 313
 314 splitRhoTy :: GenType t u -> ([(Class,GenType t u)], GenType t u)
 315 splitRhoTy t =
 316   go t []
 317  where
 318   go (FunTy (DictTy c t _) r _) ts = go r ((c,t):ts)
 319   go (AppTy (AppTy (TyConTy tycon _) (DictTy c t _)) r) ts
 320         | isFunTyCon tycon
 321         = go r ((c,t):ts)
 322   go (SynTy _ _ t) ts = go t ts
 323   go t ts = (reverse ts, t)
 324
 325
 326 mkTheta :: [Type] -> ThetaType
 327     -- recover a ThetaType from the types of some dictionaries
 328 mkTheta dict_tys
 329   = map cvt dict_tys
 330   where
 331     cvt (DictTy clas ty _) = (clas, ty)
 332     cvt other              = pprPanic "mkTheta:" (pprType PprDebug other)
 333 \end{code}
 334
 335
 336 Forall stuff
 337 ~~~~~~~~~~~~
 338 \begin{code}
 339 mkForAllTy = ForAllTy
 340
 341 mkForAllTys :: [t] -> GenType t u -> GenType t u
 342 mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
 343
 344 getForAllTy_maybe :: GenType t u -> Maybe (t,GenType t u)
 345 getForAllTy_maybe (SynTy _ _ t)      = getForAllTy_maybe t
 346 getForAllTy_maybe (ForAllTy tyvar t) = Just(tyvar,t)
 347 getForAllTy_maybe _                  = Nothing
 348
 349 splitForAllTy :: GenType t u-> ([t], GenType t u)
 350 splitForAllTy t = go t []
 351                where
 352                     go (ForAllTy tv t) tvs = go t (tv:tvs)
 353                     go (SynTy _ _ t)   tvs = go t tvs
 354                     go t               tvs = (reverse tvs, t)
 355 \end{code}
 356
 357 \begin{code}
 358 mkForAllUsageTy :: u -> [u] -> GenType t u -> GenType t u
 359 mkForAllUsageTy = ForAllUsageTy
 360
 361 getForAllUsageTy :: GenType t u -> Maybe (u,[u],GenType t u)
 362 getForAllUsageTy (ForAllUsageTy uvar bounds t) = Just(uvar,bounds,t)
 363 getForAllUsageTy (SynTy _ _ t) = getForAllUsageTy t
 364 getForAllUsageTy _ = Nothing
 365 \end{code}
 366
 367 Applied tycons (includes FunTyCons)
 368 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 369 \begin{code}
 370 maybeAppTyCon
 371         :: GenType tyvar uvar
 372         -> Maybe (TyCon,                -- the type constructor
 373                   [GenType tyvar uvar]) -- types to which it is applied
 374
 375 maybeAppTyCon ty
 376   = case (getTyCon_maybe app_ty) of
 377         Nothing    -> Nothing
 378         Just tycon -> Just (tycon, arg_tys)
 379   where
 380     (app_ty, arg_tys) = splitAppTy ty
 381
 382
 383 getAppTyCon
 384         :: GenType tyvar uvar
 385         -> (TyCon,                      -- the type constructor
 386             [GenType tyvar uvar])       -- types to which it is applied
 387
 388 getAppTyCon ty
 389   = case maybeAppTyCon ty of
 390       Just stuff -> stuff
 391 #ifdef DEBUG
 392       Nothing    -> panic "Type.getAppTyCon" -- (ppr PprShowAll ty)
 393 #endif
 394 \end{code}
 395
 396 Applied data tycons (give back constrs)
 397 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 398 \begin{code}
 399 maybeAppDataTyCon
 400         :: GenType tyvar uvar
 401         -> Maybe (TyCon,                -- the type constructor
 402                   [GenType tyvar uvar], -- types to which it is applied
 403                   [Id])                 -- its family of data-constructors
 404 maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts
 405         :: Type -> Maybe (TyCon, [Type], [Id])
 406
 407 maybeAppDataTyCon                   ty = maybe_app_data_tycon (\x->x) ty
 408 maybeAppDataTyConExpandingDicts     ty = maybe_app_data_tycon expandTy ty
 409 maybeAppSpecDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty
 410
 411
 412 maybe_app_data_tycon expand ty
 413   = case (getTyCon_maybe app_ty) of
 414         Just tycon |  isDataTyCon tycon &&
 415                       tyConArity tycon == length arg_tys
 416                         -- Must be saturated for ty to be a data type
 417                    -> Just (tycon, arg_tys, tyConDataCons tycon)
 418
 419         other      -> Nothing
 420   where
 421     (app_ty, arg_tys) = splitAppTy (expand ty)
 422
 423 getAppDataTyCon, getAppSpecDataTyCon
 424         :: GenType tyvar uvar
 425         -> (TyCon,                      -- the type constructor
 426             [GenType tyvar uvar],       -- types to which it is applied
 427             [Id])                       -- its family of data-constructors
 428 getAppDataTyConExpandingDicts, getAppSpecDataTyConExpandingDicts
 429         :: Type -> (TyCon, [Type], [Id])
 430
 431 getAppDataTyCon               ty = get_app_data_tycon maybeAppDataTyCon ty
 432 getAppDataTyConExpandingDicts ty = get_app_data_tycon maybeAppDataTyConExpandingDicts ty
 433
 434 -- these should work like the UniTyFuns.getUniDataSpecTyCon* things of old (ToDo)
 435 getAppSpecDataTyCon               = getAppDataTyCon
 436 getAppSpecDataTyConExpandingDicts = getAppDataTyConExpandingDicts
 437
 438 get_app_data_tycon maybe ty
 439   = case maybe ty of
 440       Just stuff -> stuff
 441 #ifdef DEBUG
 442       Nothing    -> panic "Type.getAppDataTyCon" -- (pprGenType PprShowAll ty)
 443 #endif
 444
 445
 446 maybeBoxedPrimType :: Type -> Maybe (Id, Type)
 447
 448 maybeBoxedPrimType ty
 449   = case (maybeAppDataTyCon ty) of              -- Data type,
 450       Just (tycon, tys_applied, [data_con])     -- with exactly one constructor
 451         -> case (dataConArgTys data_con tys_applied) of
 452              [data_con_arg_ty]                  -- Applied to exactly one type,
 453                 | isPrimType data_con_arg_ty    -- which is primitive
 454                 -> Just (data_con, data_con_arg_ty)
 455              other_cases -> Nothing
 456       other_cases -> Nothing
 457 \end{code}
 458
 459 \begin{code}
 460 splitSigmaTy :: GenType t u -> ([t], [(Class,GenType t u)], GenType t u)
 461 splitSigmaTy ty =
 462   (tyvars, theta, tau)
 463  where
 464   (tyvars,rho) = splitForAllTy ty
 465   (theta,tau)  = splitRhoTy rho
 466
 467 mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkRhoTy theta tau)
 468 \end{code}
 469
 470
 471 Finding the kind of a type
 472 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 473 \begin{code}
 474 typeKind :: GenType (GenTyVar any) u -> Kind
 475 typeKind (TyVarTy tyvar)        = tyVarKind tyvar
 476 typeKind (TyConTy tycon usage)  = tyConKind tycon
 477 typeKind (SynTy _ _ ty)         = typeKind ty
 478 typeKind (FunTy fun arg _)      = mkBoxedTypeKind
 479 typeKind (DictTy clas arg _)    = mkBoxedTypeKind
 480 typeKind (AppTy fun arg)        = resultKind (typeKind fun)
 481 typeKind (ForAllTy _ _)         = mkBoxedTypeKind
 482 typeKind (ForAllUsageTy _ _ _)  = mkBoxedTypeKind
 483 \end{code}
 484
 485
 486 Free variables of a type
 487 ~~~~~~~~~~~~~~~~~~~~~~~~
 488 \begin{code}
 489 tyVarsOfType :: GenType (GenTyVar flexi) uvar -> GenTyVarSet flexi
 490
 491 tyVarsOfType (TyVarTy tv)               = unitTyVarSet tv
 492 tyVarsOfType (TyConTy tycon usage)      = emptyTyVarSet
 493 tyVarsOfType (SynTy _ tys ty)           = tyVarsOfTypes tys
 494 tyVarsOfType (FunTy arg res _)          = tyVarsOfType arg `unionTyVarSets` tyVarsOfType res
 495 tyVarsOfType (AppTy fun arg)            = tyVarsOfType fun `unionTyVarSets` tyVarsOfType arg
 496 tyVarsOfType (DictTy clas ty _)         = tyVarsOfType ty
 497 tyVarsOfType (ForAllTy tyvar ty)        = tyVarsOfType ty `minusTyVarSet` unitTyVarSet tyvar
 498 tyVarsOfType (ForAllUsageTy _ _ ty)     = tyVarsOfType ty
 499
 500 tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi
 501 tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys
 502 \end{code}
 503
 504
 505 Instantiating a type
 506 ~~~~~~~~~~~~~~~~~~~~
 507 \begin{code}
 508 applyTy :: GenType (GenTyVar flexi) uvar
 509         -> GenType (GenTyVar flexi) uvar
 510         -> GenType (GenTyVar flexi) uvar
 511
 512 applyTy (SynTy _ _ fun)  arg = applyTy fun arg
 513 applyTy (ForAllTy tv ty) arg = instantiateTy [(tv,arg)] ty
 514 applyTy other            arg = panic "applyTy"
 515 \end{code}
 516
 517 \begin{code}
 518 instantiateTy   :: [(GenTyVar flexi, GenType (GenTyVar flexi) uvar)]
 519                 -> GenType (GenTyVar flexi) uvar
 520                 -> GenType (GenTyVar flexi) uvar
 521
 522 instantiateTauTy :: Eq tv =>
 523                    [(tv, GenType tv' u)]
 524                 -> GenType tv u
 525                 -> GenType tv' u
 526
 527 applyTypeEnvToTy :: TyVarEnv Type -> SigmaType -> SigmaType
 528
 529 -- instantiateTauTy works only (a) on types with no ForAlls,
 530 --      and when               (b) all the type variables are being instantiated
 531 -- In return it is more polymorphic than instantiateTy
 532
 533 instant_help ty lookup_tv deflt_tv choose_tycon
 534                 if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
 535   = go ty
 536   where
 537     go (TyVarTy tv)                = case (lookup_tv tv) of
 538                                        Nothing -> deflt_tv tv
 539                                        Just ty -> ty
 540     go ty@(TyConTy tycon usage)    = choose_tycon ty tycon usage
 541     go (SynTy tycon tys ty)        = SynTy tycon (map go tys) (go ty)
 542     go (FunTy arg res usage)       = FunTy (go arg) (go res) usage
 543     go (AppTy fun arg)             = AppTy (go fun) (go arg)
 544     go (DictTy clas ty usage)      = DictTy clas (go ty) usage
 545     go (ForAllUsageTy uvar bds ty) = if_usage $
 546                                      ForAllUsageTy uvar bds (go ty)
 547     go (ForAllTy tv ty)            = if_forall $
 548                                      (if (bound_forall_tv_BAD && maybeToBool (lookup_tv tv)) then
 549                                         trace "instantiateTy: unexpected forall hit"
 550                                      else
 551                                         \x->x) ForAllTy (deflt_forall_tv tv) (go ty)
 552
 553 instantiateTy tenv ty
 554   = instant_help ty lookup_tv deflt_tv choose_tycon
 555                     if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
 556   where
 557     lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of
 558                      []   -> Nothing
 559                      [ty] -> Just ty
 560                      _    -> panic "instantiateTy:lookup_tv"
 561
 562     deflt_tv tv = TyVarTy tv
 563     choose_tycon ty _ _ = ty
 564     if_usage ty = ty
 565     if_forall ty = ty
 566     bound_forall_tv_BAD = True
 567     deflt_forall_tv tv  = tv
 568
 569 instantiateTauTy tenv ty
 570   = instant_help ty lookup_tv deflt_tv choose_tycon
 571                     if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
 572   where
 573     lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of
 574                      []   -> Nothing
 575                      [ty] -> Just ty
 576                      _    -> panic "instantiateTauTy:lookup_tv"
 577
 578     deflt_tv tv = panic "instantiateTauTy"
 579     choose_tycon _ tycon usage = TyConTy tycon usage
 580     if_usage ty = panic "instantiateTauTy:ForAllUsageTy"
 581     if_forall ty = panic "instantiateTauTy:ForAllTy"
 582     bound_forall_tv_BAD = panic "instantiateTauTy:bound_forall_tv"
 583     deflt_forall_tv tv  = panic "instantiateTauTy:deflt_forall_tv"
 584
 585 applyTypeEnvToTy tenv ty
 586   = instant_help ty lookup_tv deflt_tv choose_tycon
 587                     if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
 588   where
 589     lookup_tv = lookupTyVarEnv tenv
 590     deflt_tv tv = TyVarTy tv
 591     choose_tycon ty _ _ = ty
 592     if_usage ty = ty
 593     if_forall ty = ty
 594     bound_forall_tv_BAD = False -- ToDo: probably should be True (i.e., no shadowing)
 595     deflt_forall_tv tv  = case (lookup_tv tv) of
 596                             Nothing -> tv
 597                             Just (TyVarTy tv2) -> tv2
 598                             _ -> panic "applyTypeEnvToTy"
 599 {-
 600 instantiateTy tenv ty
 601   = go ty
 602   where
 603     go (TyVarTy tv)             = case [ty | (tv',ty) <- tenv, tv==tv'] of
 604                                   []     -> TyVarTy tv
 605                                   (ty:_) -> ty
 606     go ty@(TyConTy tycon usage) = ty
 607     go (SynTy tycon tys ty)     = SynTy tycon (map go tys) (go ty)
 608     go (FunTy arg res usage)    = FunTy (go arg) (go res) usage
 609     go (AppTy fun arg)          = AppTy (go fun) (go arg)
 610     go (DictTy clas ty usage)   = DictTy clas (go ty) usage
 611     go (ForAllTy tv ty)         = ASSERT(null tv_bound)
 612                                   ForAllTy tv (go ty)
 613                                 where
 614                                   tv_bound = [() | (tv',_) <- tenv, tv==tv']
 615
 616     go (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go ty)
 617
 618 instantiateTauTy tenv ty
 619   = go ty
 620   where
 621     go (TyVarTy tv)             = case [ty | (tv',ty) <- tenv, tv==tv'] of
 622                                   (ty:_) -> ty
 623                                   []     -> panic "instantiateTauTy"
 624     go (TyConTy tycon usage)    = TyConTy tycon usage
 625     go (SynTy tycon tys ty)     = SynTy tycon (map go tys) (go ty)
 626     go (FunTy arg res usage)    = FunTy (go arg) (go res) usage
 627     go (AppTy fun arg)          = AppTy (go fun) (go arg)
 628     go (DictTy clas ty usage)   = DictTy clas (go ty) usage
 629
 630 applyTypeEnvToTy tenv ty
 631   = let
 632         result = mapOverTyVars v_fn ty
 633     in
 634 --    pprTrace "applyTypeEnv:" (ppAboves [pprType PprDebug ty, pprType PprDebug result, ppAboves [ppCat [pprUnique u, pprType PprDebug t] | (u,t) <- ufmToList tenv]]) $
 635     result
 636   where
 637     v_fn v = case (lookupTyVarEnv tenv v) of
 638                 Just ty -> ty
 639                 Nothing -> TyVarTy v
 640 \end{code}
 641
 642 @mapOverTyVars@ is a local function which actually does the work.  It
 643 does no cloning or other checks for shadowing, so be careful when
 644 calling this on types with Foralls in them.
 645
 646 \begin{code}
 647 mapOverTyVars :: (TyVar -> Type) -> Type -> Type
 648
 649 mapOverTyVars v_fn ty
 650   = let
 651         mapper = mapOverTyVars v_fn
 652     in
 653     case ty of
 654       TyVarTy v         -> v_fn v
 655       SynTy c as e      -> SynTy c (map mapper as) (mapper e)
 656       FunTy a r u       -> FunTy (mapper a) (mapper r) u
 657       AppTy f a         -> AppTy (mapper f) (mapper a)
 658       DictTy c t u      -> DictTy c (mapper t) u
 659       ForAllTy v t      -> case (v_fn v) of
 660                              TyVarTy v2 -> ForAllTy v2 (mapper t)
 661                              _ -> panic "mapOverTyVars"
 662       tc@(TyConTy _ _)  -> tc
 663 -}
 664 \end{code}
 665
 666 \begin{code}
 667 instantiateUsage
 668         :: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u'
 669
 670 instantiateUsage = panic "instantiateUsage: not implemented"
 671 \end{code}
 672
 673 At present there are no unboxed non-primitive types, so
 674 isUnboxedType is the same as isPrimType.
 675
 676 \begin{code}
 677 isPrimType, isUnboxedType :: GenType tyvar uvar -> Bool
 678
 679 isPrimType (AppTy ty _)      = isPrimType ty
 680 isPrimType (SynTy _ _ ty)    = isPrimType ty
 681 isPrimType (TyConTy tycon _) = isPrimTyCon tycon
 682 isPrimType _                 = False
 683
 684 isUnboxedType = isPrimType
 685 \end{code}
 686
 687 This is *not* right: it is a placeholder (ToDo 96/03 WDP):
 688 \begin{code}
 689 typePrimRep :: GenType tyvar uvar -> PrimRep
 690
 691 typePrimRep (SynTy _ _ ty)  = typePrimRep ty
 692 typePrimRep (TyConTy tc _)  = if isPrimTyCon tc then panic "typePrimRep:PrimTyCon" else PtrRep
 693 typePrimRep (AppTy ty _)    = typePrimRep ty
 694 typePrimRep _               = PtrRep -- the "default"
 695 \end{code}
 696
 697 %************************************************************************
 698 %*                                                                      *
 699 \subsection{Matching on types}
 700 %*                                                                      *
 701 %************************************************************************
 702
 703 Matching is a {\em unidirectional} process, matching a type against a
 704 template (which is just a type with type variables in it).  The
 705 matcher assumes that there are no repeated type variables in the
 706 template, so that it simply returns a mapping of type variables to
 707 types.  It also fails on nested foralls.
 708
 709 @matchTys@ matches corresponding elements of a list of templates and
 710 types.
 711
 712 \begin{code}
 713 matchTy :: GenType t1 u1                -- Template
 714         -> GenType t2 u2                -- Proposed instance of template
 715         -> Maybe [(t1,GenType t2 u2)]   -- Matching substitution
 716
 717 matchTys :: [GenType t1 u1]             -- Templates
 718          -> [GenType t2 u2]             -- Proposed instance of template
 719          -> Maybe [(t1,GenType t2 u2)]  -- Matching substitution
 720
 721 matchTy  ty1  ty2  = match  [] [] ty1 ty2
 722 matchTys tys1 tys2 = match' [] (zipEqual "matchTys" tys1 tys2)
 723 \end{code}
 724
 725 @match@ is the main function.
 726
 727 \begin{code}
 728 match :: [(t1, GenType t2 u2)]                  -- r, the accumulating result
 729       -> [(GenType t1 u1, GenType t2 u2)]       -- w, the work list
 730       -> GenType t1 u1 -> GenType t2 u2         -- Current match pair
 731       -> Maybe [(t1, GenType t2 u2)]
 732
 733 match r w (TyVarTy v)          ty                   = match' ((v,ty) : r) w
 734 match r w (FunTy fun1 arg1 _)  (FunTy fun2 arg2 _)  = match r ((fun1,fun2):w) arg1 arg2
 735 match r w (AppTy fun1 arg1)  (AppTy fun2 arg2)      = match r ((fun1,fun2):w) arg1 arg2
 736 match r w (TyConTy con1 _)     (TyConTy con2 _)     | con1  == con2  = match' r w
 737 match r w (DictTy clas1 ty1 _) (DictTy clas2 ty2 _) | clas1 == clas2 = match r w ty1 ty2
 738 match r w (SynTy _ _ ty1)      ty2                  = match r w ty1 ty2
 739 match r w ty1                  (SynTy _ _ ty2)      = match r w ty1 ty2
 740
 741         -- With type synonyms, we have to be careful for the exact
 742         -- same reasons as in the unifier.  Please see the
 743         -- considerable commentary there before changing anything
 744         -- here! (WDP 95/05)
 745
 746 -- Catch-all fails
 747 match _ _ _ _ = Nothing
 748
 749 match' r []            = Just r
 750 match' r ((ty1,ty2):w) = match r w ty1 ty2
 751 \end{code}
 752
 753 %************************************************************************
 754 %*                                                                      *
 755 \subsection{Equality on types}
 756 %*                                                                      *
 757 %************************************************************************
 758
 759 The functions eqSimpleTy and eqSimpleTheta are polymorphic in the types t
 760 and u, but ONLY WORK FOR SIMPLE TYPES (ie. they panic if they see
 761 dictionaries or polymorphic types).  The function eqTy has a more
 762 specific type, but does the `right thing' for all types.
 763
 764 \begin{code}
 765 eqSimpleTheta :: (Eq t,Eq u) =>
 766     [(Class,GenType t u)] -> [(Class,GenType t u)] -> Bool
 767
 768 eqSimpleTheta [] [] = True
 769 eqSimpleTheta ((c1,t1):th1) ((c2,t2):th2) =
 770   c1==c2 && t1 `eqSimpleTy` t2 && th1 `eqSimpleTheta` th2
 771 eqSimpleTheta other1 other2 = False
 772 \end{code}
 773
 774 \begin{code}
 775 eqSimpleTy :: (Eq t,Eq u) => GenType t u -> GenType t u -> Bool
 776
 777 (TyVarTy tv1) `eqSimpleTy` (TyVarTy tv2) =
 778   tv1 == tv2
 779 (AppTy f1 a1)  `eqSimpleTy` (AppTy f2 a2) =
 780   f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2
 781 (TyConTy tc1 u1) `eqSimpleTy` (TyConTy tc2 u2) =
 782   tc1 == tc2 && u1 == u2
 783
 784 (FunTy f1 a1 u1) `eqSimpleTy` (FunTy f2 a2 u2) =
 785   f1 `eqSimpleTy` f2 && a1 `eqSimpleTy` a2 && u1 == u2
 786 (FunTy f1 a1 u1) `eqSimpleTy` t2 =
 787   -- Expand t1 just in case t2 matches that version
 788   (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) `eqSimpleTy` t2
 789 t1 `eqSimpleTy` (FunTy f2 a2 u2) =
 790   -- Expand t2 just in case t1 matches that version
 791   t1 `eqSimpleTy` (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
 792
 793 (SynTy tc1 ts1 t1) `eqSimpleTy` (SynTy tc2 ts2 t2) =
 794   (tc1 == tc2 && and (zipWith eqSimpleTy ts1 ts2) && length ts1 == length ts2)
 795   || t1 `eqSimpleTy` t2
 796 (SynTy _ _ t1) `eqSimpleTy` t2 =
 797   t1 `eqSimpleTy` t2  -- Expand the abbrevation and try again
 798 t1 `eqSimpleTy` (SynTy _ _ t2) =
 799   t1 `eqSimpleTy` t2  -- Expand the abbrevation and try again
 800
 801 (DictTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got DictTy"
 802 _ `eqSimpleTy` (DictTy _ _ _) = panic "eqSimpleTy: got DictTy"
 803
 804 (ForAllTy _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllTy"
 805 _ `eqSimpleTy` (ForAllTy _ _) = panic "eqSimpleTy: got ForAllTy"
 806
 807 (ForAllUsageTy _ _ _) `eqSimpleTy` _ = panic "eqSimpleTy: got ForAllUsageTy"
 808 _ `eqSimpleTy` (ForAllUsageTy _ _ _) = panic "eqSimpleTy: got ForAllUsageTy"
 809
 810 _ `eqSimpleTy` _ = False
 811 \end{code}
 812
 813 Types are ordered so we can sort on types in the renamer etc.  DNT: Since
 814 this class is also used in CoreLint and other such places, we DO expand out
 815 Fun/Syn/Dict types (if necessary).
 816
 817 \begin{code}
 818 eqTy :: Type -> Type -> Bool
 819
 820 eqTy t1 t2 =
 821   eq nullTyVarEnv nullUVarEnv t1 t2
 822  where
 823   eq tve uve (TyVarTy tv1) (TyVarTy tv2) =
 824     tv1 == tv2 ||
 825     case (lookupTyVarEnv tve tv1) of
 826       Just tv -> tv == tv2
 827       Nothing -> False
 828   eq tve uve (AppTy f1 a1) (AppTy f2 a2) =
 829     eq tve uve f1 f2 && eq tve uve a1 a2
 830   eq tve uve (TyConTy tc1 u1) (TyConTy tc2 u2) =
 831     tc1 == tc2 && eqUsage uve u1 u2
 832
 833   eq tve uve (FunTy f1 a1 u1) (FunTy f2 a2 u2) =
 834     eq tve uve f1 f2 && eq tve uve a1 a2 && eqUsage uve u1 u2
 835   eq tve uve (FunTy f1 a1 u1) t2 =
 836     -- Expand t1 just in case t2 matches that version
 837     eq tve uve (AppTy (AppTy (TyConTy mkFunTyCon u1) f1) a1) t2
 838   eq tve uve t1 (FunTy f2 a2 u2) =
 839     -- Expand t2 just in case t1 matches that version
 840     eq tve uve t1 (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
 841
 842   eq tve uve (DictTy c1 t1 u1) (DictTy c2 t2 u2)
 843     | c1 == c2
 844     = eq tve uve t1 t2 && eqUsage uve u1 u2
 845         -- NB we use a guard for c1==c2 so that if they aren't equal we
 846         -- fall through into expanding the type.  Why?  Because brain-dead
 847         -- people might write
 848         --      class Foo a => Baz a where {}
 849         -- and that means that a Foo dictionary and a Baz dictionary are identical
 850         -- Sigh.  Let's hope we don't spend too much time in here!
 851
 852   eq tve uve t1@(DictTy _ _ _) t2 =
 853     eq tve uve (expandTy t1) t2  -- Expand the dictionary and try again
 854   eq tve uve t1 t2@(DictTy _ _ _) =
 855     eq tve uve t1 (expandTy t2)  -- Expand the dictionary and try again
 856
 857   eq tve uve (SynTy tc1 ts1 t1) (SynTy tc2 ts2 t2) =
 858     (tc1 == tc2 && and (zipWith (eq tve uve) ts1 ts2) && length ts1 == length ts2)
 859     || eq tve uve t1 t2
 860   eq tve uve (SynTy _ _ t1) t2 =
 861     eq tve uve t1 t2  -- Expand the abbrevation and try again
 862   eq tve uve t1 (SynTy _ _ t2) =
 863     eq tve uve t1 t2  -- Expand the abbrevation and try again
 864
 865   eq tve uve (ForAllTy tv1 t1) (ForAllTy tv2 t2) =
 866     eq (addOneToTyVarEnv tve tv1 tv2) uve t1 t2
 867   eq tve uve (ForAllUsageTy u1 b1 t1) (ForAllUsageTy u2 b2 t2) =
 868     eqBounds uve b1 b2 && eq tve (addOneToUVarEnv uve u1 u2) t1 t2
 869
 870   eq _ _ _ _ = False
 871
 872   eqBounds uve [] [] = True
 873   eqBounds uve (u1:b1) (u2:b2) = eqUVar uve u1 u2 && eqBounds uve b1 b2
 874   eqBounds uve _ _ = False
 875 \end{code}