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