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,
  20
  21         lookupInst, lookupSimpleInst, LookupInstResult(..),
  22
  23         isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep,
  24         instBindingRequired, instCanBeGeneralised,
  25
  26         zonkInst, zonkFunDeps, 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 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 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   | FunDep
 166         Class           -- the class from which this arises
 167         [([TcType], [TcType])]
 168         InstLoc
 169
 170 data OverloadedLit
 171   = OverloadedIntegral   Integer        -- The number
 172   | OverloadedFractional Rational       -- The number
 173 \end{code}
 174
 175 Ordering
 176 ~~~~~~~~
 177 @Insts@ are ordered by their class/type info, rather than by their
 178 unique.  This allows the context-reduction mechanism to use standard finite
 179 maps to do their stuff.
 180
 181 \begin{code}
 182 instance Ord Inst where
 183   compare = cmpInst
 184
 185 instance Eq Inst where
 186   (==) i1 i2 = case i1 `cmpInst` i2 of
 187                  EQ    -> True
 188                  other -> False
 189
 190 cmpInst  (Dict _ clas1 tys1 _) (Dict _ clas2 tys2 _)
 191   = (clas1 `compare` clas2) `thenCmp` (tys1 `compare` tys2)
 192 cmpInst (Dict _ _ _ _) other
 193   = LT
 194
 195
 196 cmpInst (Method _ _ _ _ _ _) (Dict _ _ _ _)
 197   = GT
 198 cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _)
 199   = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
 200 cmpInst (Method _ _ _ _ _ _) other
 201   = LT
 202
 203 cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _)
 204   = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2)
 205 cmpInst (LitInst _ _ _ _) (FunDep _ _ _)
 206   = LT
 207 cmpInst (LitInst _ _ _ _) other
 208   = GT
 209
 210 cmpInst (FunDep clas1 fds1 _) (FunDep clas2 fds2 _)
 211   = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2)
 212 cmpInst (FunDep _ _ _) other
 213   = GT
 214
 215 cmpOverLit (OverloadedIntegral   i1) (OverloadedIntegral   i2) = i1 `compare` i2
 216 cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2
 217 cmpOverLit (OverloadedIntegral _)    (OverloadedFractional _)  = LT
 218 cmpOverLit (OverloadedFractional _)  (OverloadedIntegral _)    = GT
 219 \end{code}
 220
 221
 222 Selection
 223 ~~~~~~~~~
 224 \begin{code}
 225 instLoc (Dict   u clas tys  loc) = loc
 226 instLoc (Method u _ _ _ _   loc) = loc
 227 instLoc (LitInst u lit ty   loc) = loc
 228 instLoc (FunDep _ _         loc) = loc
 229
 230 getDictClassTys (Dict u clas tys _) = (clas, tys)
 231
 232 getFunDeps (FunDep clas fds _) = Just (clas, fds)
 233 getFunDeps _ = Nothing
 234
 235 tyVarsOfInst :: Inst -> TcTyVarSet
 236 tyVarsOfInst (Dict _ _ tys _)        = tyVarsOfTypes  tys
 237 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 238                                          -- The id might have free type variables; in the case of
 239                                          -- locally-overloaded class methods, for example
 240 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
 241 tyVarsOfInst (FunDep _ fds _)
 242   = foldr unionVarSet emptyVarSet (map tyVarsOfFd fds)
 243   where tyVarsOfFd (ts1, ts2) =
 244             tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts1
 245 \end{code}
 246
 247 Predicates
 248 ~~~~~~~~~~
 249 \begin{code}
 250 isDict :: Inst -> Bool
 251 isDict (Dict _ _ _ _) = True
 252 isDict other          = False
 253
 254 isMethodFor :: TcIdSet -> Inst -> Bool
 255 isMethodFor ids (Method uniq id tys _ _ loc)
 256   = id `elemVarSet` ids
 257 isMethodFor ids inst
 258   = False
 259
 260 isTyVarDict :: Inst -> Bool
 261 isTyVarDict (Dict _ _ tys _) = all isTyVarTy tys
 262 isTyVarDict other            = False
 263
 264 isStdClassTyVarDict (Dict _ clas [ty] _) = isStandardClass clas && isTyVarTy ty
 265 isStdClassTyVarDict other                = False
 266
 267 notFunDep :: Inst -> Bool
 268 notFunDep (FunDep _ _ _) = False
 269 notFunDep other          = True
 270 \end{code}
 271
 272 Two predicates which deal with the case where class constraints don't
 273 necessarily result in bindings.  The first tells whether an @Inst@
 274 must be witnessed by an actual binding; the second tells whether an
 275 @Inst@ can be generalised over.
 276
 277 \begin{code}
 278 instBindingRequired :: Inst -> Bool
 279 instBindingRequired (Dict _ clas _ _) = not (isNoDictClass clas)
 280 instBindingRequired other             = True
 281
 282 instCanBeGeneralised :: Inst -> Bool
 283 instCanBeGeneralised (Dict _ clas _ _) = not (isCcallishClass clas)
 284 instCanBeGeneralised other             = True
 285 \end{code}
 286
 287
 288 Construction
 289 ~~~~~~~~~~~~
 290
 291 \begin{code}
 292 newDicts :: InstOrigin
 293          -> TcThetaType
 294          -> NF_TcM s (LIE, [TcId])
 295 newDicts orig theta
 296   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 297     newDictsAtLoc loc theta     `thenNF_Tc` \ (dicts, ids) ->
 298     returnNF_Tc (listToBag dicts, ids)
 299
 300 -- Local function, similar to newDicts,
 301 -- but with slightly different interface
 302 newDictsAtLoc :: InstLoc
 303               -> TcThetaType
 304               -> NF_TcM s ([Inst], [TcId])
 305 newDictsAtLoc loc theta =
 306  tcGetUniques (length theta)            `thenNF_Tc` \ new_uniqs ->
 307  let
 308   mk_dict u (clas, tys) = Dict u clas tys loc
 309   dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
 310  in
 311  returnNF_Tc (dicts, map instToId dicts)
 312
 313 newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM s Inst
 314 newDictFromOld (Dict _ _ _ loc) clas tys
 315   = tcGetUnique       `thenNF_Tc` \ uniq ->
 316     returnNF_Tc (Dict uniq clas tys loc)
 317
 318
 319 newMethod :: InstOrigin
 320           -> TcId
 321           -> [TcType]
 322           -> NF_TcM s (LIE, TcId)
 323 newMethod orig id tys
 324   =     -- Get the Id type and instantiate it at the specified types
 325     let
 326         (tyvars, rho) = splitForAllTys (idType id)
 327         rho_ty        = substTy (mkTyVarSubst tyvars tys) rho
 328         (theta, tau)  = splitRhoTy rho_ty
 329     in
 330     newMethodWithGivenTy orig id tys theta tau  `thenNF_Tc` \ meth_inst ->
 331     returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
 332
 333 instOverloadedFun orig (HsVar v) arg_tys theta tau
 334   = newMethodWithGivenTy orig v arg_tys theta tau       `thenNF_Tc` \ inst ->
 335     instFunDeps orig theta                              `thenNF_Tc` \ fds ->
 336     returnNF_Tc (HsVar (instToId inst), mkLIE (inst : fds))
 337     --returnNF_Tc (HsVar (instToId inst), unitLIE inst)
 338
 339 instFunDeps orig theta
 340   = tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 341     let ifd (clas, tys) = FunDep clas (instantiateFdClassTys clas tys) loc in
 342     returnNF_Tc (map ifd theta)
 343
 344 newMethodWithGivenTy orig id tys theta tau
 345   = tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 346     tcGetUnique         `thenNF_Tc` \ new_uniq ->
 347     let
 348         meth_inst = Method new_uniq id tys theta tau loc
 349     in
 350     returnNF_Tc meth_inst
 351
 352 newMethodAtLoc :: InstLoc
 353                -> Id -> [TcType]
 354                -> NF_TcM s (Inst, TcId)
 355 newMethodAtLoc loc real_id tys          -- Local function, similar to newMethod but with
 356                                         -- slightly different interface
 357   =     -- Get the Id type and instantiate it at the specified types
 358     tcGetUnique                                 `thenNF_Tc` \ new_uniq ->
 359     let
 360         (tyvars,rho) = splitForAllTys (idType real_id)
 361         rho_ty        = ASSERT( length tyvars == length tys )
 362                         substTy (mkTopTyVarSubst tyvars tys) rho
 363         (theta, tau)  = splitRhoTy rho_ty
 364         meth_inst     = Method new_uniq real_id tys theta tau loc
 365     in
 366     returnNF_Tc (meth_inst, instToId meth_inst)
 367 \end{code}
 368
 369 In newOverloadedLit we convert directly to an Int or Integer if we
 370 know that's what we want.  This may save some time, by not
 371 temporarily generating overloaded literals, but it won't catch all
 372 cases (the rest are caught in lookupInst).
 373
 374 \begin{code}
 375 newOverloadedLit :: InstOrigin
 376                  -> OverloadedLit
 377                  -> TcType
 378                  -> NF_TcM s (TcExpr, LIE)
 379 newOverloadedLit orig (OverloadedIntegral i) ty
 380   | isIntTy ty && inIntRange i          -- Short cut for Int
 381   = returnNF_Tc (int_lit, emptyLIE)
 382
 383   | isIntegerTy ty                      -- Short cut for Integer
 384   = returnNF_Tc (integer_lit, emptyLIE)
 385
 386   where
 387     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
 388     integer_lit    = HsLitOut (HsInt i) integerTy
 389     int_lit        = HsCon intDataCon [] [intprim_lit]
 390
 391 newOverloadedLit orig lit ty            -- The general case
 392   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 393     tcGetUnique                 `thenNF_Tc` \ new_uniq ->
 394     let
 395         lit_inst = LitInst new_uniq lit ty loc
 396     in
 397     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 398 \end{code}
 399
 400
 401 \begin{code}
 402 instToId :: Inst -> TcId
 403 instToId inst = instToIdBndr inst
 404
 405 instToIdBndr :: Inst -> TcId
 406 instToIdBndr (Dict u clas ty (_,loc,_))
 407   = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas ty) loc
 408
 409 instToIdBndr (Method u id tys theta tau (_,loc,_))
 410   = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
 411
 412 instToIdBndr (LitInst u list ty loc)
 413   = mkSysLocal SLIT("lit") u ty
 414
 415 instToIdBndr (FunDep clas fds _)
 416   = panic "FunDep escaped!!!"
 417 \end{code}
 418
 419
 420 Zonking
 421 ~~~~~~~
 422 Zonking makes sure that the instance types are fully zonked,
 423 but doesn't do the same for the Id in a Method.  There's no
 424 need, and it's a lot of extra work.
 425
 426 \begin{code}
 427 zonkInst :: Inst -> NF_TcM s Inst
 428 zonkInst (Dict u clas tys loc)
 429   = zonkTcTypes tys                     `thenNF_Tc` \ new_tys ->
 430     returnNF_Tc (Dict u clas new_tys loc)
 431
 432 zonkInst (Method u id tys theta tau loc)
 433   = zonkId id                   `thenNF_Tc` \ new_id ->
 434         -- Essential to zonk the id in case it's a local variable
 435         -- Can't use zonkIdOcc because the id might itself be
 436         -- an InstId, in which case it won't be in scope
 437
 438     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 439     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 440     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 441     returnNF_Tc (Method u new_id new_tys new_theta new_tau loc)
 442
 443 zonkInst (LitInst u lit ty loc)
 444   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 445     returnNF_Tc (LitInst u lit new_ty loc)
 446
 447 zonkInst (FunDep clas fds loc)
 448   = zonkFunDeps fds                     `thenNF_Tc` \ fds' ->
 449     returnNF_Tc (FunDep clas fds' loc)
 450
 451 zonkFunDeps fds = mapNF_Tc zonkFd fds
 452   where
 453   zonkFd (ts1, ts2)
 454     = zonkTcTypes ts1                   `thenNF_Tc` \ ts1' ->
 455       zonkTcTypes ts2                   `thenNF_Tc` \ ts2' ->
 456       returnNF_Tc (ts1', ts2')
 457 \end{code}
 458
 459
 460 Printing
 461 ~~~~~~~~
 462 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 463 relevant in error messages.
 464
 465 \begin{code}
 466 instance Outputable Inst where
 467     ppr inst = pprInst inst
 468
 469 pprInst (LitInst u lit ty loc)
 470   = hsep [case lit of
 471               OverloadedIntegral   i -> integer i
 472               OverloadedFractional f -> rational f,
 473            ptext SLIT("at"),
 474            ppr ty,
 475            show_uniq u]
 476
 477 pprInst (Dict u clas tys loc) = pprConstraint clas tys <+> show_uniq u
 478
 479 pprInst (Method u id tys _ _ loc)
 480   = hsep [ppr id, ptext SLIT("at"),
 481           brackets (interppSP tys),
 482           show_uniq u]
 483
 484 pprInst (FunDep clas fds loc)
 485   = ptext SLIT("fundep!")
 486
 487 tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
 488 tidyInst env (LitInst u lit ty loc)
 489   = (env', LitInst u lit ty' loc)
 490   where
 491     (env', ty') = tidyOpenType env ty
 492
 493 tidyInst env (Dict u clas tys loc)
 494   = (env', Dict u clas tys' loc)
 495   where
 496     (env', tys') = tidyOpenTypes env tys
 497
 498 tidyInst env (Method u id tys theta tau loc)
 499   = (env', Method u id tys' theta tau loc)
 500                 -- Leave theta, tau alone cos we don't print them
 501   where
 502     (env', tys') = tidyOpenTypes env tys
 503
 504 -- this case shouldn't arise... (we never print fundeps)
 505 tidyInst env fd@(FunDep clas fds loc)
 506   = (env, fd)
 507
 508 tidyInsts env insts = mapAccumL tidyInst env insts
 509
 510 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 511 \end{code}
 512
 513
 514 %************************************************************************
 515 %*                                                                      *
 516 \subsection[InstEnv-types]{Type declarations}
 517 %*                                                                      *
 518 %************************************************************************
 519
 520 \begin{code}
 521 type InstanceMapper = Class -> InstEnv
 522 \end{code}
 523
 524 A @ClassInstEnv@ lives inside a class, and identifies all the instances
 525 of that class.  The @Id@ inside a ClassInstEnv mapping is the dfun for
 526 that instance.
 527
 528 There is an important consistency constraint between the @MatchEnv@s
 529 in and the dfun @Id@s inside them: the free type variables of the
 530 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
 531 type variables of the dfun.  Thus, the @ClassInstEnv@ for @Eq@ might
 532 contain the following entry:
 533 @
 534         [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
 535 @
 536 The "a" in the pattern must be one of the forall'd variables in
 537 the dfun type.
 538
 539 \begin{code}
 540 data LookupInstResult s
 541   = NoInstance
 542   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 543   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 544
 545 lookupInst :: Inst
 546            -> NF_TcM s (LookupInstResult s)
 547
 548 -- Dictionaries
 549
 550 lookupInst dict@(Dict _ clas tys loc)
 551   = case lookupInstEnv (ppr clas) (classInstEnv clas) tys of
 552
 553       Just (tenv, dfun_id)
 554         -> let
 555                 subst         = mkSubst (tyVarsOfTypes tys) tenv
 556                 (tyvars, rho) = splitForAllTys (idType dfun_id)
 557                 ty_args       = map subst_tv tyvars
 558                 dfun_rho      = substTy subst rho
 559                 (theta, tau)  = splitRhoTy dfun_rho
 560                 ty_app        = mkHsTyApp (HsVar dfun_id) ty_args
 561                 subst_tv tv   = case lookupSubstEnv tenv tv of
 562                                    Just (DoneTy ty)  -> ty
 563                                         -- tenv should bind all the tyvars
 564            in
 565            if null theta then
 566                 returnNF_Tc (SimpleInst ty_app)
 567            else
 568            newDictsAtLoc loc theta      `thenNF_Tc` \ (dicts, dict_ids) ->
 569            let
 570                 rhs = mkHsDictApp ty_app dict_ids
 571            in
 572            returnNF_Tc (GenInst dicts rhs)
 573
 574       Nothing   -> returnNF_Tc NoInstance
 575
 576 -- Methods
 577
 578 lookupInst inst@(Method _ id tys theta _ loc)
 579   = newDictsAtLoc loc theta             `thenNF_Tc` \ (dicts, dict_ids) ->
 580     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
 581
 582 -- Literals
 583
 584 lookupInst inst@(LitInst u (OverloadedIntegral i) ty loc)
 585   | isIntTy ty && in_int_range                  -- Short cut for Int
 586   = returnNF_Tc (GenInst [] int_lit)
 587         -- GenInst, not SimpleInst, because int_lit is actually a constructor application
 588
 589   | isIntegerTy ty                              -- Short cut for Integer
 590   = returnNF_Tc (GenInst [] integer_lit)
 591
 592   | in_int_range                                -- It's overloaded but small enough to fit into an Int
 593   = tcLookupValueByKey fromIntClassOpKey        `thenNF_Tc` \ from_int ->
 594     newMethodAtLoc loc from_int [ty]            `thenNF_Tc` \ (method_inst, method_id) ->
 595     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
 596
 597   | otherwise                                   -- Alas, it is overloaded and a big literal!
 598   = tcLookupValueByKey fromIntegerClassOpKey    `thenNF_Tc` \ from_integer ->
 599     newMethodAtLoc loc from_integer [ty]        `thenNF_Tc` \ (method_inst, method_id) ->
 600     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
 601   where
 602     in_int_range   = inIntRange i
 603     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
 604     integer_lit    = HsLitOut (HsInt i) integerTy
 605     int_lit        = HsCon intDataCon [] [intprim_lit]
 606
 607 -- similar idea for overloaded floating point literals: if the literal is
 608 -- *definitely* a float or a double, generate the real thing here.
 609 -- This is essential  (see nofib/spectral/nucleic).
 610
 611 lookupInst inst@(LitInst u (OverloadedFractional f) ty loc)
 612   | isFloatTy ty    = returnNF_Tc (GenInst [] float_lit)
 613   | isDoubleTy ty   = returnNF_Tc (GenInst [] double_lit)
 614
 615   | otherwise
 616           = tcLookupValueByKey fromRationalClassOpKey   `thenNF_Tc` \ from_rational ->
 617
 618         -- The type Rational isn't wired in so we have to conjure it up
 619     tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
 620     let
 621         rational_ty  = mkSynTy rational_tycon []
 622         rational_lit = HsLitOut (HsFrac f) rational_ty
 623     in
 624     newMethodAtLoc loc from_rational [ty]               `thenNF_Tc` \ (method_inst, method_id) ->
 625     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
 626
 627   where
 628     floatprim_lit  = HsLitOut (HsFloatPrim f) floatPrimTy
 629     float_lit      = HsCon floatDataCon [] [floatprim_lit]
 630     doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy
 631     double_lit     = HsCon doubleDataCon [] [doubleprim_lit]
 632
 633 -- there are no `instances' of functional dependencies
 634
 635 lookupInst (FunDep _ _ _)  = returnNF_Tc NoInstance
 636
 637 \end{code}
 638
 639 There is a second, simpler interface, when you want an instance of a
 640 class at a given nullary type constructor.  It just returns the
 641 appropriate dictionary if it exists.  It is used only when resolving
 642 ambiguous dictionaries.
 643
 644 \begin{code}
 645 lookupSimpleInst :: InstEnv
 646                  -> Class
 647                  -> [Type]                      -- Look up (c,t)
 648                  -> NF_TcM s (Maybe ThetaType)          -- Here are the needed (c,t)s
 649
 650 lookupSimpleInst class_inst_env clas tys
 651   = case lookupInstEnv (ppr clas) class_inst_env tys of
 652       Nothing    -> returnNF_Tc Nothing
 653
 654       Just (tenv, dfun)
 655         -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
 656         where
 657            (_, theta, _) = splitSigmaTy (idType dfun)
 658 \end{code}