ghc/compiler/typecheck/Inst.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[Inst]{The @Inst@ type: dictionaries or method instances}
   5
   6 \begin{code}
   7 module Inst (
   8         LIE, emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE,
   9         plusLIEs, mkLIE, isEmptyLIE,
  10
  11         Inst, OverloadedLit(..),
  12         pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts,
  13
  14         InstanceMapper,
  15
  16         newDictFromOld, newDicts, newDictsAtLoc,
  17         newMethod, newMethodWithGivenTy, newOverloadedLit, instOverloadedFun,
  18
  19         tyVarsOfInst, instLoc, getDictClassTys, getFunDeps, getFunDepsOfLIE,
  20
  21         lookupInst, lookupSimpleInst, LookupInstResult(..),
  22
  23         isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep,
  24         instBindingRequired, instCanBeGeneralised,
  25
  26         zonkInst, zonkFunDeps, zonkTvFunDeps, instToId, instToIdBndr,
  27
  28         InstOrigin(..), InstLoc, pprInstLoc
  29     ) where
  30
  31 #include "HsVersions.h"
  32
  33 import HsSyn    ( HsLit(..), HsExpr(..) )
  34 import RnHsSyn  ( RenamedArithSeqInfo, RenamedHsExpr, RenamedPat )
  35 import TcHsSyn  ( TcExpr, TcId,
  36                   mkHsTyApp, mkHsDictApp, zonkId
  37                 )
  38 import TcMonad
  39 import TcEnv    ( TcIdSet, tcLookupValueByKey, tcLookupTyConByKey )
  40 import TcType   ( TcThetaType,
  41                   TcType, TcTauType, TcTyVarSet,
  42                   zonkTcTyVars, zonkTcType, zonkTcTypes,
  43                   zonkTcThetaType
  44                 )
  45 import Bag
  46 import Class    ( classInstEnv, Class )
  47 import FunDeps  ( instantiateFdClassTys )
  48 import Id       ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
  49 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
  50 import Name     ( OccName, Name, mkDictOcc, mkMethodOcc, getOccName )
  51 import PprType  ( pprConstraint )
  52 import InstEnv  ( InstEnv, lookupInstEnv )
  53 import SrcLoc   ( SrcLoc )
  54 import Type     ( Type, ThetaType,
  55                   mkTyVarTy, isTyVarTy, mkDictTy, splitForAllTys, splitSigmaTy,
  56                   splitRhoTy, tyVarsOfType, tyVarsOfTypes,
  57                   mkSynTy, tidyOpenType, tidyOpenTypes
  58                 )
  59 import InstEnv  ( InstEnv )
  60 import Subst    ( emptyInScopeSet, mkSubst,
  61                   substTy, substTheta, mkTyVarSubst, mkTopTyVarSubst
  62                 )
  63 import TyCon    ( TyCon )
  64 import Var      ( TyVar )
  65 import VarEnv   ( lookupVarEnv, TidyEnv,
  66                   lookupSubstEnv, SubstResult(..)
  67                 )
  68 import VarSet   ( elemVarSet, emptyVarSet, unionVarSet )
  69 import TysPrim    ( intPrimTy, floatPrimTy, doublePrimTy )
  70 import TysWiredIn ( intDataCon, isIntTy, inIntRange,
  71                     floatDataCon, isFloatTy,
  72                     doubleDataCon, isDoubleTy,
  73                     integerTy, isIntegerTy
  74                   )
  75 import Unique   ( fromRationalClassOpKey, rationalTyConKey,
  76                   fromIntClassOpKey, fromIntegerClassOpKey, Unique
  77                 )
  78 import Maybes   ( expectJust )
  79 import Maybe    ( catMaybes )
  80 import Util     ( thenCmp, zipWithEqual, mapAccumL )
  81 import Outputable
  82 \end{code}
  83
  84 %************************************************************************
  85 %*                                                                      *
  86 \subsection[Inst-collections]{LIE: a collection of Insts}
  87 %*                                                                      *
  88 %************************************************************************
  89
  90 \begin{code}
  91 type LIE = Bag Inst
  92
  93 isEmptyLIE        = isEmptyBag
  94 emptyLIE          = emptyBag
  95 unitLIE inst      = unitBag inst
  96 mkLIE insts       = listToBag insts
  97 plusLIE lie1 lie2 = lie1 `unionBags` lie2
  98 consLIE inst lie  = inst `consBag` lie
  99 plusLIEs lies     = unionManyBags lies
 100
 101 zonkLIE :: LIE -> NF_TcM s LIE
 102 zonkLIE lie = mapBagNF_Tc zonkInst lie
 103
 104 pprInsts :: [Inst] -> SDoc
 105 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
 106
 107
 108 pprInstsInFull insts
 109   = vcat (map go insts)
 110   where
 111     go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
 112 \end{code}
 113
 114 %************************************************************************
 115 %*                                                                      *
 116 \subsection[Inst-types]{@Inst@ types}
 117 %*                                                                      *
 118 %************************************************************************
 119
 120 An @Inst@ is either a dictionary, an instance of an overloaded
 121 literal, or an instance of an overloaded value.  We call the latter a
 122 ``method'' even though it may not correspond to a class operation.
 123 For example, we might have an instance of the @double@ function at
 124 type Int, represented by
 125
 126         Method 34 doubleId [Int] origin
 127
 128 \begin{code}
 129 data Inst
 130   = Dict
 131         Unique
 132         Class           -- The type of the dict is (c ts), where
 133         [TcType]        -- c is the class and ts the types;
 134         InstLoc
 135
 136   | Method
 137         Unique
 138
 139         TcId    -- The overloaded function
 140                         -- This function will be a global, local, or ClassOpId;
 141                         --   inside instance decls (only) it can also be an InstId!
 142                         -- The id needn't be completely polymorphic.
 143                         -- You'll probably find its name (for documentation purposes)
 144                         --        inside the InstOrigin
 145
 146         [TcType]        -- The types to which its polymorphic tyvars
 147                         --      should be instantiated.
 148                         -- These types must saturate the Id's foralls.
 149
 150         TcThetaType     -- The (types of the) dictionaries to which the function
 151                         -- must be applied to get the method
 152
 153         TcTauType       -- The type of the method
 154
 155         InstLoc
 156
 157         -- INVARIANT: in (Method u f tys theta tau loc)
 158         --      type of (f tys dicts(from theta)) = tau
 159
 160   | LitInst
 161         Unique
 162         OverloadedLit
 163         TcType          -- The type at which the literal is used
 164         InstLoc
 165
 166   | FunDep
 167         Class           -- the class from which this arises
 168         [([TcType], [TcType])]
 169         InstLoc
 170
 171 data OverloadedLit
 172   = OverloadedIntegral   Integer        -- The number
 173   | OverloadedFractional Rational       -- The number
 174 \end{code}
 175
 176 Ordering
 177 ~~~~~~~~
 178 @Insts@ are ordered by their class/type info, rather than by their
 179 unique.  This allows the context-reduction mechanism to use standard finite
 180 maps to do their stuff.
 181
 182 \begin{code}
 183 instance Ord Inst where
 184   compare = cmpInst
 185
 186 instance Eq Inst where
 187   (==) i1 i2 = case i1 `cmpInst` i2 of
 188                  EQ    -> True
 189                  other -> False
 190
 191 cmpInst  (Dict _ clas1 tys1 _) (Dict _ clas2 tys2 _)
 192   = (clas1 `compare` clas2) `thenCmp` (tys1 `compare` tys2)
 193 cmpInst (Dict _ _ _ _) other
 194   = LT
 195
 196
 197 cmpInst (Method _ _ _ _ _ _) (Dict _ _ _ _)
 198   = GT
 199 cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _)
 200   = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
 201 cmpInst (Method _ _ _ _ _ _) other
 202   = LT
 203
 204 cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _)
 205   = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2)
 206 cmpInst (LitInst _ _ _ _) (FunDep _ _ _)
 207   = LT
 208 cmpInst (LitInst _ _ _ _) other
 209   = GT
 210
 211 cmpInst (FunDep clas1 fds1 _) (FunDep clas2 fds2 _)
 212   = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2)
 213 cmpInst (FunDep _ _ _) other
 214   = GT
 215
 216 cmpOverLit (OverloadedIntegral   i1) (OverloadedIntegral   i2) = i1 `compare` i2
 217 cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2
 218 cmpOverLit (OverloadedIntegral _)    (OverloadedFractional _)  = LT
 219 cmpOverLit (OverloadedFractional _)  (OverloadedIntegral _)    = GT
 220 \end{code}
 221
 222
 223 Selection
 224 ~~~~~~~~~
 225 \begin{code}
 226 instLoc (Dict   u clas tys  loc) = loc
 227 instLoc (Method u _ _ _ _   loc) = loc
 228 instLoc (LitInst u lit ty   loc) = loc
 229 instLoc (FunDep _ _         loc) = loc
 230
 231 getDictClassTys (Dict u clas tys _) = (clas, tys)
 232
 233 getFunDeps (FunDep clas fds _) = Just (clas, fds)
 234 getFunDeps _ = Nothing
 235
 236 getFunDepsOfLIE lie = catMaybes (map getFunDeps (bagToList lie))
 237
 238 tyVarsOfInst :: Inst -> TcTyVarSet
 239 tyVarsOfInst (Dict _ _ tys _)        = tyVarsOfTypes  tys
 240 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 241                                          -- The id might have free type variables; in the case of
 242                                          -- locally-overloaded class methods, for example
 243 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
 244 tyVarsOfInst (FunDep _ fds _)
 245   = foldr unionVarSet emptyVarSet (map tyVarsOfFd fds)
 246   where tyVarsOfFd (ts1, ts2) =
 247             tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts1
 248 \end{code}
 249
 250 Predicates
 251 ~~~~~~~~~~
 252 \begin{code}
 253 isDict :: Inst -> Bool
 254 isDict (Dict _ _ _ _) = True
 255 isDict other          = False
 256
 257 isMethodFor :: TcIdSet -> Inst -> Bool
 258 isMethodFor ids (Method uniq id tys _ _ loc)
 259   = id `elemVarSet` ids
 260 isMethodFor ids inst
 261   = False
 262
 263 isTyVarDict :: Inst -> Bool
 264 isTyVarDict (Dict _ _ tys _) = all isTyVarTy tys
 265 isTyVarDict other            = False
 266
 267 isStdClassTyVarDict (Dict _ clas [ty] _) = isStandardClass clas && isTyVarTy ty
 268 isStdClassTyVarDict other                = False
 269
 270 notFunDep :: Inst -> Bool
 271 notFunDep (FunDep _ _ _) = False
 272 notFunDep other          = True
 273 \end{code}
 274
 275 Two predicates which deal with the case where class constraints don't
 276 necessarily result in bindings.  The first tells whether an @Inst@
 277 must be witnessed by an actual binding; the second tells whether an
 278 @Inst@ can be generalised over.
 279
 280 \begin{code}
 281 instBindingRequired :: Inst -> Bool
 282 instBindingRequired (Dict _ clas _ _) = not (isNoDictClass clas)
 283 instBindingRequired other             = True
 284
 285 instCanBeGeneralised :: Inst -> Bool
 286 instCanBeGeneralised (Dict _ clas _ _) = not (isCcallishClass clas)
 287 instCanBeGeneralised other             = True
 288 \end{code}
 289
 290
 291 Construction
 292 ~~~~~~~~~~~~
 293
 294 \begin{code}
 295 newDicts :: InstOrigin
 296          -> TcThetaType
 297          -> NF_TcM s (LIE, [TcId])
 298 newDicts orig theta
 299   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 300     newDictsAtLoc loc theta     `thenNF_Tc` \ (dicts, ids) ->
 301     returnNF_Tc (listToBag dicts, ids)
 302
 303 -- Local function, similar to newDicts,
 304 -- but with slightly different interface
 305 newDictsAtLoc :: InstLoc
 306               -> TcThetaType
 307               -> NF_TcM s ([Inst], [TcId])
 308 newDictsAtLoc loc theta =
 309  tcGetUniques (length theta)            `thenNF_Tc` \ new_uniqs ->
 310  let
 311   mk_dict u (clas, tys) = Dict u clas tys loc
 312   dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
 313  in
 314  returnNF_Tc (dicts, map instToId dicts)
 315
 316 newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM s Inst
 317 newDictFromOld (Dict _ _ _ loc) clas tys
 318   = tcGetUnique       `thenNF_Tc` \ uniq ->
 319     returnNF_Tc (Dict uniq clas tys loc)
 320
 321
 322 newMethod :: InstOrigin
 323           -> TcId
 324           -> [TcType]
 325           -> NF_TcM s (LIE, TcId)
 326 newMethod orig id tys
 327   =     -- Get the Id type and instantiate it at the specified types
 328     let
 329         (tyvars, rho) = splitForAllTys (idType id)
 330         rho_ty        = substTy (mkTyVarSubst tyvars tys) rho
 331         (theta, tau)  = splitRhoTy rho_ty
 332     in
 333     newMethodWithGivenTy orig id tys theta tau  `thenNF_Tc` \ meth_inst ->
 334     returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
 335
 336 instOverloadedFun orig (HsVar v) arg_tys theta tau
 337   = newMethodWithGivenTy orig v arg_tys theta tau       `thenNF_Tc` \ inst ->
 338     instFunDeps orig theta                              `thenNF_Tc` \ fds ->
 339     returnNF_Tc (HsVar (instToId inst), mkLIE (inst : fds))
 340     --returnNF_Tc (HsVar (instToId inst), unitLIE inst)
 341
 342 instFunDeps orig theta
 343   = tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 344     let ifd (clas, tys) =
 345             let fds = instantiateFdClassTys clas tys in
 346             if null fds then Nothing else Just (FunDep clas fds loc)
 347     in returnNF_Tc (catMaybes (map ifd theta))
 348
 349 newMethodWithGivenTy orig id tys theta tau
 350   = tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 351     tcGetUnique         `thenNF_Tc` \ new_uniq ->
 352     let
 353         meth_inst = Method new_uniq id tys theta tau loc
 354     in
 355     returnNF_Tc meth_inst
 356
 357 newMethodAtLoc :: InstLoc
 358                -> Id -> [TcType]
 359                -> NF_TcM s (Inst, TcId)
 360 newMethodAtLoc loc real_id tys          -- Local function, similar to newMethod but with
 361                                         -- slightly different interface
 362   =     -- Get the Id type and instantiate it at the specified types
 363     tcGetUnique                                 `thenNF_Tc` \ new_uniq ->
 364     let
 365         (tyvars,rho) = splitForAllTys (idType real_id)
 366         rho_ty        = ASSERT( length tyvars == length tys )
 367                         substTy (mkTopTyVarSubst tyvars tys) rho
 368         (theta, tau)  = splitRhoTy rho_ty
 369         meth_inst     = Method new_uniq real_id tys theta tau loc
 370     in
 371     returnNF_Tc (meth_inst, instToId meth_inst)
 372 \end{code}
 373
 374 In newOverloadedLit we convert directly to an Int or Integer if we
 375 know that's what we want.  This may save some time, by not
 376 temporarily generating overloaded literals, but it won't catch all
 377 cases (the rest are caught in lookupInst).
 378
 379 \begin{code}
 380 newOverloadedLit :: InstOrigin
 381                  -> OverloadedLit
 382                  -> TcType
 383                  -> NF_TcM s (TcExpr, LIE)
 384 newOverloadedLit orig (OverloadedIntegral i) ty
 385   | isIntTy ty && inIntRange i          -- Short cut for Int
 386   = returnNF_Tc (int_lit, emptyLIE)
 387
 388   | isIntegerTy ty                      -- Short cut for Integer
 389   = returnNF_Tc (integer_lit, emptyLIE)
 390
 391   where
 392     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
 393     integer_lit    = HsLitOut (HsInt i) integerTy
 394     int_lit        = HsCon intDataCon [] [intprim_lit]
 395
 396 newOverloadedLit orig lit ty            -- The general case
 397   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 398     tcGetUnique                 `thenNF_Tc` \ new_uniq ->
 399     let
 400         lit_inst = LitInst new_uniq lit ty loc
 401     in
 402     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 403 \end{code}
 404
 405
 406 \begin{code}
 407 instToId :: Inst -> TcId
 408 instToId inst = instToIdBndr inst
 409
 410 instToIdBndr :: Inst -> TcId
 411 instToIdBndr (Dict u clas ty (_,loc,_))
 412   = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas ty) loc
 413
 414 instToIdBndr (Method u id tys theta tau (_,loc,_))
 415   = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
 416
 417 instToIdBndr (LitInst u list ty loc)
 418   = mkSysLocal SLIT("lit") u ty
 419
 420 instToIdBndr (FunDep clas fds _)
 421   = panic "FunDep escaped!!!"
 422 \end{code}
 423
 424
 425 Zonking
 426 ~~~~~~~
 427 Zonking makes sure that the instance types are fully zonked,
 428 but doesn't do the same for the Id in a Method.  There's no
 429 need, and it's a lot of extra work.
 430
 431 \begin{code}
 432 zonkInst :: Inst -> NF_TcM s Inst
 433 zonkInst (Dict u clas tys loc)
 434   = zonkTcTypes tys                     `thenNF_Tc` \ new_tys ->
 435     returnNF_Tc (Dict u clas new_tys loc)
 436
 437 zonkInst (Method u id tys theta tau loc)
 438   = zonkId id                   `thenNF_Tc` \ new_id ->
 439         -- Essential to zonk the id in case it's a local variable
 440         -- Can't use zonkIdOcc because the id might itself be
 441         -- an InstId, in which case it won't be in scope
 442
 443     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 444     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 445     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 446     returnNF_Tc (Method u new_id new_tys new_theta new_tau loc)
 447
 448 zonkInst (LitInst u lit ty loc)
 449   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 450     returnNF_Tc (LitInst u lit new_ty loc)
 451
 452 zonkInst (FunDep clas fds loc)
 453   = zonkFunDeps fds                     `thenNF_Tc` \ fds' ->
 454     returnNF_Tc (FunDep clas fds' loc)
 455
 456 zonkFunDeps fds = mapNF_Tc zonkFd fds
 457   where
 458   zonkFd (ts1, ts2)
 459     = zonkTcTypes ts1                   `thenNF_Tc` \ ts1' ->
 460       zonkTcTypes ts2                   `thenNF_Tc` \ ts2' ->
 461       returnNF_Tc (ts1', ts2')
 462
 463 zonkTvFunDeps fds = mapNF_Tc zonkFd fds
 464   where
 465   zonkFd (tvs1, tvs2)
 466     = zonkTcTyVars tvs1                 `thenNF_Tc` \ tvs1' ->
 467       zonkTcTyVars tvs2                 `thenNF_Tc` \ tvs2' ->
 468       returnNF_Tc (tvs1', tvs2')
 469 \end{code}
 470
 471
 472 Printing
 473 ~~~~~~~~
 474 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 475 relevant in error messages.
 476
 477 \begin{code}
 478 instance Outputable Inst where
 479     ppr inst = pprInst inst
 480
 481 pprInst (LitInst u lit ty loc)
 482   = hsep [case lit of
 483               OverloadedIntegral   i -> integer i
 484               OverloadedFractional f -> rational f,
 485            ptext SLIT("at"),
 486            ppr ty,
 487            show_uniq u]
 488
 489 pprInst (Dict u clas tys loc) = pprConstraint clas tys <+> show_uniq u
 490
 491 pprInst (Method u id tys _ _ loc)
 492   = hsep [ppr id, ptext SLIT("at"),
 493           brackets (interppSP tys),
 494           show_uniq u]
 495
 496 pprInst (FunDep clas fds loc)
 497   = hsep [ppr clas, ppr fds]
 498
 499 tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
 500 tidyInst env (LitInst u lit ty loc)
 501   = (env', LitInst u lit ty' loc)
 502   where
 503     (env', ty') = tidyOpenType env ty
 504
 505 tidyInst env (Dict u clas tys loc)
 506   = (env', Dict u clas tys' loc)
 507   where
 508     (env', tys') = tidyOpenTypes env tys
 509
 510 tidyInst env (Method u id tys theta tau loc)
 511   = (env', Method u id tys' theta tau loc)
 512                 -- Leave theta, tau alone cos we don't print them
 513   where
 514     (env', tys') = tidyOpenTypes env tys
 515
 516 -- this case shouldn't arise... (we never print fundeps)
 517 tidyInst env fd@(FunDep clas fds loc)
 518   = (env, fd)
 519
 520 tidyInsts env insts = mapAccumL tidyInst env insts
 521
 522 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 523 \end{code}
 524
 525
 526 %************************************************************************
 527 %*                                                                      *
 528 \subsection[InstEnv-types]{Type declarations}
 529 %*                                                                      *
 530 %************************************************************************
 531
 532 \begin{code}
 533 type InstanceMapper = Class -> InstEnv
 534 \end{code}
 535
 536 A @ClassInstEnv@ lives inside a class, and identifies all the instances
 537 of that class.  The @Id@ inside a ClassInstEnv mapping is the dfun for
 538 that instance.
 539
 540 There is an important consistency constraint between the @MatchEnv@s
 541 in and the dfun @Id@s inside them: the free type variables of the
 542 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
 543 type variables of the dfun.  Thus, the @ClassInstEnv@ for @Eq@ might
 544 contain the following entry:
 545 @
 546         [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
 547 @
 548 The "a" in the pattern must be one of the forall'd variables in
 549 the dfun type.
 550
 551 \begin{code}
 552 data LookupInstResult s
 553   = NoInstance
 554   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 555   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 556
 557 lookupInst :: Inst
 558            -> NF_TcM s (LookupInstResult s)
 559
 560 -- Dictionaries
 561
 562 lookupInst dict@(Dict _ clas tys loc)
 563   = case lookupInstEnv (ppr clas) (classInstEnv clas) tys of
 564
 565       Just (tenv, dfun_id)
 566         -> let
 567                 subst         = mkSubst (tyVarsOfTypes tys) tenv
 568                 (tyvars, rho) = splitForAllTys (idType dfun_id)
 569                 ty_args       = map subst_tv tyvars
 570                 dfun_rho      = substTy subst rho
 571                 (theta, tau)  = splitRhoTy dfun_rho
 572                 ty_app        = mkHsTyApp (HsVar dfun_id) ty_args
 573                 subst_tv tv   = case lookupSubstEnv tenv tv of
 574                                    Just (DoneTy ty)  -> ty
 575                                         -- tenv should bind all the tyvars
 576            in
 577            if null theta then
 578                 returnNF_Tc (SimpleInst ty_app)
 579            else
 580            newDictsAtLoc loc theta      `thenNF_Tc` \ (dicts, dict_ids) ->
 581            let
 582                 rhs = mkHsDictApp ty_app dict_ids
 583            in
 584            returnNF_Tc (GenInst dicts rhs)
 585
 586       Nothing   -> returnNF_Tc NoInstance
 587
 588 -- Methods
 589
 590 lookupInst inst@(Method _ id tys theta _ loc)
 591   = newDictsAtLoc loc theta             `thenNF_Tc` \ (dicts, dict_ids) ->
 592     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
 593
 594 -- Literals
 595
 596 lookupInst inst@(LitInst u (OverloadedIntegral i) ty loc)
 597   | isIntTy ty && in_int_range                  -- Short cut for Int
 598   = returnNF_Tc (GenInst [] int_lit)
 599         -- GenInst, not SimpleInst, because int_lit is actually a constructor application
 600
 601   | isIntegerTy ty                              -- Short cut for Integer
 602   = returnNF_Tc (GenInst [] integer_lit)
 603
 604   | in_int_range                                -- It's overloaded but small enough to fit into an Int
 605   = tcLookupValueByKey fromIntClassOpKey        `thenNF_Tc` \ from_int ->
 606     newMethodAtLoc loc from_int [ty]            `thenNF_Tc` \ (method_inst, method_id) ->
 607     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
 608
 609   | otherwise                                   -- Alas, it is overloaded and a big literal!
 610   = tcLookupValueByKey fromIntegerClassOpKey    `thenNF_Tc` \ from_integer ->
 611     newMethodAtLoc loc from_integer [ty]        `thenNF_Tc` \ (method_inst, method_id) ->
 612     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
 613   where
 614     in_int_range   = inIntRange i
 615     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
 616     integer_lit    = HsLitOut (HsInt i) integerTy
 617     int_lit        = HsCon intDataCon [] [intprim_lit]
 618
 619 -- similar idea for overloaded floating point literals: if the literal is
 620 -- *definitely* a float or a double, generate the real thing here.
 621 -- This is essential  (see nofib/spectral/nucleic).
 622
 623 lookupInst inst@(LitInst u (OverloadedFractional f) ty loc)
 624   | isFloatTy ty    = returnNF_Tc (GenInst [] float_lit)
 625   | isDoubleTy ty   = returnNF_Tc (GenInst [] double_lit)
 626
 627   | otherwise
 628           = tcLookupValueByKey fromRationalClassOpKey   `thenNF_Tc` \ from_rational ->
 629
 630         -- The type Rational isn't wired in so we have to conjure it up
 631     tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
 632     let
 633         rational_ty  = mkSynTy rational_tycon []
 634         rational_lit = HsLitOut (HsFrac f) rational_ty
 635     in
 636     newMethodAtLoc loc from_rational [ty]               `thenNF_Tc` \ (method_inst, method_id) ->
 637     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
 638
 639   where
 640     floatprim_lit  = HsLitOut (HsFloatPrim f) floatPrimTy
 641     float_lit      = HsCon floatDataCon [] [floatprim_lit]
 642     doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy
 643     double_lit     = HsCon doubleDataCon [] [doubleprim_lit]
 644
 645 -- there are no `instances' of functional dependencies
 646
 647 lookupInst (FunDep _ _ _)  = returnNF_Tc NoInstance
 648
 649 \end{code}
 650
 651 There is a second, simpler interface, when you want an instance of a
 652 class at a given nullary type constructor.  It just returns the
 653 appropriate dictionary if it exists.  It is used only when resolving
 654 ambiguous dictionaries.
 655
 656 \begin{code}
 657 lookupSimpleInst :: InstEnv
 658                  -> Class
 659                  -> [Type]                      -- Look up (c,t)
 660                  -> NF_TcM s (Maybe ThetaType)          -- Here are the needed (c,t)s
 661
 662 lookupSimpleInst class_inst_env clas tys
 663   = case lookupInstEnv (ppr clas) class_inst_env tys of
 664       Nothing    -> returnNF_Tc Nothing
 665
 666       Just (tenv, dfun)
 667         -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
 668         where
 669            (_, theta, _) = splitSigmaTy (idType dfun)
 670 \end{code}