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