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, lieToList, listToLIE,
  10
  11         Inst,
  12         pprInst, pprInsts, pprInstsInFull, tidyInsts,
  13
  14         newDictsFromOld, newDicts,
  15         newMethod, newMethodWithGivenTy, newOverloadedLit,
  16         newIPDict, tcInstId,
  17
  18         tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, instLoc, getDictClassTys,
  19         getIPs,
  20         predsOfInsts, predsOfInst,
  21
  22         lookupInst, lookupSimpleInst, LookupInstResult(..),
  23
  24         isDict, isClassDict, isMethod, instMentionsIPs,
  25         isTyVarDict, isStdClassTyVarDict, isMethodFor,
  26         instBindingRequired, instCanBeGeneralised,
  27
  28         zonkInst, zonkInsts,
  29         instToId, instName,
  30
  31         InstOrigin(..), InstLoc, pprInstLoc
  32     ) where
  33
  34 #include "HsVersions.h"
  35
  36 import CmdLineOpts ( opt_NoMethodSharing )
  37 import HsSyn    ( HsLit(..), HsOverLit(..), HsExpr(..) )
  38 import TcHsSyn  ( TcExpr, TcId,
  39                   mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
  40                 )
  41 import TcMonad
  42 import TcEnv    ( TcIdSet, tcGetInstEnv, tcLookupId )
  43 import InstEnv  ( InstLookupResult(..), lookupInstEnv )
  44 import TcMType  ( zonkTcType, zonkTcTypes, zonkTcPredType,
  45                   zonkTcThetaType, tcInstTyVar, tcInstType,
  46                 )
  47 import TcType   ( Type,
  48                   SourceType(..), PredType, ThetaType,
  49                   tcSplitForAllTys, tcSplitForAllTys,
  50                   tcSplitMethodTy, tcSplitRhoTy, tcFunArgTy,
  51                   isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
  52                   tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
  53                   tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
  54                   predMentionsIPs, isClassPred, isTyVarClassPred,
  55                   getClassPredTys, getClassPredTys_maybe, mkPredName,
  56                   tidyType, tidyTypes, tidyFreeTyVars,
  57                   tcCmpType, tcCmpTypes, tcCmpPred
  58                 )
  59 import CoreFVs  ( idFreeTyVars )
  60 import Class    ( Class )
  61 import Id       ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId )
  62 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
  63 import Name     ( Name, mkMethodOcc, getOccName )
  64 import NameSet  ( NameSet )
  65 import PprType  ( pprPred )
  66 import Subst    ( emptyInScopeSet, mkSubst,
  67                   substTy, substTyWith, substTheta, mkTyVarSubst, mkTopTyVarSubst
  68                 )
  69 import Literal  ( inIntRange )
  70 import VarEnv   ( TidyEnv, lookupSubstEnv, SubstResult(..) )
  71 import VarSet   ( elemVarSet, emptyVarSet, unionVarSet )
  72 import TysWiredIn ( floatDataCon, doubleDataCon )
  73 import PrelNames( fromIntegerName, fromRationalName )
  74 import Util     ( thenCmp )
  75 import Bag
  76 import Outputable
  77 \end{code}
  78
  79 %************************************************************************
  80 %*                                                                      *
  81 \subsection[Inst-collections]{LIE: a collection of Insts}
  82 %*                                                                      *
  83 %************************************************************************
  84
  85 \begin{code}
  86 type LIE = Bag Inst
  87
  88 isEmptyLIE        = isEmptyBag
  89 emptyLIE          = emptyBag
  90 unitLIE inst      = unitBag inst
  91 mkLIE insts       = listToBag insts
  92 plusLIE lie1 lie2 = lie1 `unionBags` lie2
  93 consLIE inst lie  = inst `consBag` lie
  94 plusLIEs lies     = unionManyBags lies
  95 lieToList         = bagToList
  96 listToLIE         = listToBag
  97
  98 zonkLIE :: LIE -> NF_TcM LIE
  99 zonkLIE lie = mapBagNF_Tc zonkInst lie
 100
 101 pprInsts :: [Inst] -> SDoc
 102 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
 103
 104
 105 pprInstsInFull insts
 106   = vcat (map go insts)
 107   where
 108     go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
 109 \end{code}
 110
 111 %************************************************************************
 112 %*                                                                      *
 113 \subsection[Inst-types]{@Inst@ types}
 114 %*                                                                      *
 115 %************************************************************************
 116
 117 An @Inst@ is either a dictionary, an instance of an overloaded
 118 literal, or an instance of an overloaded value.  We call the latter a
 119 ``method'' even though it may not correspond to a class operation.
 120 For example, we might have an instance of the @double@ function at
 121 type Int, represented by
 122
 123         Method 34 doubleId [Int] origin
 124
 125 \begin{code}
 126 data Inst
 127   = Dict
 128         Id
 129         TcPredType
 130         InstLoc
 131
 132   | Method
 133         Id
 134
 135         TcId    -- The overloaded function
 136                         -- This function will be a global, local, or ClassOpId;
 137                         --   inside instance decls (only) it can also be an InstId!
 138                         -- The id needn't be completely polymorphic.
 139                         -- You'll probably find its name (for documentation purposes)
 140                         --        inside the InstOrigin
 141
 142         [TcType]        -- The types to which its polymorphic tyvars
 143                         --      should be instantiated.
 144                         -- These types must saturate the Id's foralls.
 145
 146         TcThetaType     -- The (types of the) dictionaries to which the function
 147                         -- must be applied to get the method
 148
 149         TcTauType       -- The type of the method
 150
 151         InstLoc
 152
 153         -- INVARIANT: in (Method u f tys theta tau loc)
 154         --      type of (f tys dicts(from theta)) = tau
 155
 156   | LitInst
 157         Id
 158         HsOverLit       -- The literal from the occurrence site
 159         TcType          -- The type at which the literal is used
 160         InstLoc
 161 \end{code}
 162
 163 Ordering
 164 ~~~~~~~~
 165 @Insts@ are ordered by their class/type info, rather than by their
 166 unique.  This allows the context-reduction mechanism to use standard finite
 167 maps to do their stuff.
 168
 169 \begin{code}
 170 instance Ord Inst where
 171   compare = cmpInst
 172
 173 instance Eq Inst where
 174   (==) i1 i2 = case i1 `cmpInst` i2 of
 175                  EQ    -> True
 176                  other -> False
 177
 178 cmpInst (Dict _ pred1 _)          (Dict _ pred2 _)          = pred1 `tcCmpPred` pred2
 179 cmpInst (Dict _ _ _)              other                     = LT
 180
 181 cmpInst (Method _ _ _ _ _ _)      (Dict _ _ _)              = GT
 182 cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `tcCmpTypes` tys2)
 183 cmpInst (Method _ _ _ _ _ _)      other                     = LT
 184
 185 cmpInst (LitInst _ lit1 ty1 _)    (LitInst _ lit2 ty2 _)    = (lit1 `compare` lit2) `thenCmp` (ty1 `tcCmpType` ty2)
 186 cmpInst (LitInst _ _ _ _)         other                     = GT
 187
 188 -- and they can only have HsInt or HsFracs in them.
 189 \end{code}
 190
 191
 192 Selection
 193 ~~~~~~~~~
 194 \begin{code}
 195 instName :: Inst -> Name
 196 instName inst = idName (instToId inst)
 197
 198 instToId :: Inst -> TcId
 199 instToId (Dict id _ _)         = id
 200 instToId (Method id _ _ _ _ _) = id
 201 instToId (LitInst id _ _ _)    = id
 202
 203 instLoc (Dict _ _         loc) = loc
 204 instLoc (Method _ _ _ _ _ loc) = loc
 205 instLoc (LitInst _ _ _    loc) = loc
 206
 207 getDictClassTys (Dict _ pred _) = getClassPredTys pred
 208
 209 predsOfInsts :: [Inst] -> [PredType]
 210 predsOfInsts insts = concatMap predsOfInst insts
 211
 212 predsOfInst (Dict _ pred _)          = [pred]
 213 predsOfInst (Method _ _ _ theta _ _) = theta
 214 predsOfInst (LitInst _ _ _ _)        = []
 215         -- The last case is is really a big cheat
 216         -- LitInsts to give rise to a (Num a) or (Fractional a) predicate
 217         -- But Num and Fractional have only one parameter and no functional
 218         -- dependencies, so I think no caller of predsOfInst will care.
 219
 220 ipsOfPreds theta = [(n,ty) | IParam n ty <- theta]
 221
 222 getIPs inst = ipsOfPreds (predsOfInst inst)
 223
 224 tyVarsOfInst :: Inst -> TcTyVarSet
 225 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
 226 tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
 227 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 228                                          -- The id might have free type variables; in the case of
 229                                          -- locally-overloaded class methods, for example
 230
 231 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 232 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
 233 \end{code}
 234
 235 Predicates
 236 ~~~~~~~~~~
 237 \begin{code}
 238 isDict :: Inst -> Bool
 239 isDict (Dict _ _ _) = True
 240 isDict other        = False
 241
 242 isClassDict :: Inst -> Bool
 243 isClassDict (Dict _ pred _) = isClassPred pred
 244 isClassDict other           = False
 245
 246 isTyVarDict :: Inst -> Bool
 247 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
 248 isTyVarDict other           = False
 249
 250 isMethod :: Inst -> Bool
 251 isMethod (Method _ _ _ _ _ _) = True
 252 isMethod other                = False
 253
 254 isMethodFor :: TcIdSet -> Inst -> Bool
 255 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
 256 isMethodFor ids inst                         = False
 257
 258 instMentionsIPs :: Inst -> NameSet -> Bool
 259   -- True if the Inst mentions any of the implicit
 260   -- parameters in the supplied set of names
 261 instMentionsIPs (Dict _ pred _)          ip_names = pred `predMentionsIPs` ip_names
 262 instMentionsIPs (Method _ _ _ theta _ _) ip_names = any (`predMentionsIPs` ip_names) theta
 263 instMentionsIPs other                    ip_names = False
 264
 265 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
 266                                         Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
 267                                         other             -> False
 268 \end{code}
 269
 270 Two predicates which deal with the case where class constraints don't
 271 necessarily result in bindings.  The first tells whether an @Inst@
 272 must be witnessed by an actual binding; the second tells whether an
 273 @Inst@ can be generalised over.
 274
 275 \begin{code}
 276 instBindingRequired :: Inst -> Bool
 277 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
 278 instBindingRequired (Dict _ (IParam _ _) _)    = False
 279 instBindingRequired other                      = True
 280
 281 instCanBeGeneralised :: Inst -> Bool
 282 instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas)
 283 instCanBeGeneralised other                      = True
 284 \end{code}
 285
 286
 287 %************************************************************************
 288 %*                                                                      *
 289 \subsection{Building dictionaries}
 290 %*                                                                      *
 291 %************************************************************************
 292
 293 \begin{code}
 294 newDicts :: InstOrigin
 295          -> TcThetaType
 296          -> NF_TcM [Inst]
 297 newDicts orig theta
 298   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 299     newDictsAtLoc loc theta
 300
 301 newDictsFromOld :: Inst -> TcThetaType -> NF_TcM [Inst]
 302 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
 303
 304 -- Local function, similar to newDicts,
 305 -- but with slightly different interface
 306 newDictsAtLoc :: InstLoc
 307               -> TcThetaType
 308               -> NF_TcM [Inst]
 309 newDictsAtLoc inst_loc@(_,loc,_) theta
 310   = tcGetUniques                        `thenNF_Tc` \ new_uniqs ->
 311     returnNF_Tc (zipWith mk_dict new_uniqs theta)
 312   where
 313     mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
 314
 315 -- For implicit parameters, since there is only one in scope
 316 -- at any time, we use the name of the implicit parameter itself
 317 newIPDict orig name ty
 318   = tcGetInstLoc orig                   `thenNF_Tc` \ inst_loc ->
 319     returnNF_Tc (Dict (mkLocalId name (mkPredTy pred)) pred inst_loc)
 320   where pred = IParam name ty
 321 \end{code}
 322
 323
 324 %************************************************************************
 325 %*                                                                      *
 326 \subsection{Building methods (calls of overloaded functions)}
 327 %*                                                                      *
 328 %************************************************************************
 329
 330 tcInstId instantiates an occurrence of an Id.
 331 The instantiate_it loop runs round instantiating the Id.
 332 It has to be a loop because we are now prepared to entertain
 333 types like
 334         f:: forall a. Eq a => forall b. Baz b => tau
 335 We want to instantiate this to
 336         f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 337
 338 The -fno-method-sharing flag controls what happens so far as the LIE
 339 is concerned.  The default case is that for an overloaded function we
 340 generate a "method" Id, and add the Method Inst to the LIE.  So you get
 341 something like
 342         f :: Num a => a -> a
 343         f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
 344 If you specify -fno-method-sharing, the dictionary application
 345 isn't shared, so we get
 346         f :: Num a => a -> a
 347         f = /\a (d:Num a) (x:a) -> (+) a d x x
 348 This gets a bit less sharing, but
 349         a) it's better for RULEs involving overloaded functions
 350         b) perhaps fewer separated lambdas
 351
 352
 353 \begin{code}
 354 tcInstId :: Id -> NF_TcM (TcExpr, LIE, TcType)
 355 tcInstId fun
 356   | opt_NoMethodSharing  = loop_noshare (HsVar fun) (idType fun)
 357   | otherwise            = loop_share fun
 358   where
 359     orig = OccurrenceOf fun
 360     loop_noshare fun fun_ty
 361       = tcInstType fun_ty               `thenNF_Tc` \ (tyvars, theta, tau) ->
 362         let
 363             ty_app = mkHsTyApp fun (mkTyVarTys tyvars)
 364         in
 365         if null theta then              -- Is it overloaded?
 366             returnNF_Tc (ty_app, emptyLIE, tau)
 367         else
 368             newDicts orig theta                                         `thenNF_Tc` \ dicts ->
 369             loop_noshare (mkHsDictApp ty_app (map instToId dicts)) tau  `thenNF_Tc` \ (expr, lie, final_tau) ->
 370             returnNF_Tc (expr, mkLIE dicts `plusLIE` lie, final_tau)
 371
 372     loop_share fun
 373       = tcInstType (idType fun)         `thenNF_Tc` \ (tyvars, theta, tau) ->
 374         let
 375             arg_tys = mkTyVarTys tyvars
 376         in
 377         if null theta then              -- Is it overloaded?
 378             returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
 379         else
 380                 -- Yes, it's overloaded
 381             newMethodWithGivenTy orig fun arg_tys theta tau     `thenNF_Tc` \ meth ->
 382             loop_share (instToId meth)                          `thenNF_Tc` \ (expr, lie, final_tau) ->
 383             returnNF_Tc (expr, unitLIE meth `plusLIE` lie, final_tau)
 384
 385
 386 newMethod :: InstOrigin
 387           -> TcId
 388           -> [TcType]
 389           -> NF_TcM Inst
 390 newMethod orig id tys
 391   =     -- Get the Id type and instantiate it at the specified types
 392     let
 393         (tyvars, rho) = tcSplitForAllTys (idType id)
 394         rho_ty        = substTyWith tyvars tys rho
 395         (pred, tau)   = tcSplitMethodTy rho_ty
 396     in
 397     newMethodWithGivenTy orig id tys [pred] tau
 398
 399 newMethodWithGivenTy orig id tys theta tau
 400   = tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 401     newMethodWith loc id tys theta tau
 402
 403 newMethodWith inst_loc@(_,loc,_) id tys theta tau
 404   = tcGetUnique         `thenNF_Tc` \ new_uniq ->
 405     let
 406         meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 407     in
 408     returnNF_Tc (Method meth_id id tys theta tau inst_loc)
 409
 410 newMethodAtLoc :: InstLoc
 411                -> Id -> [TcType]
 412                -> NF_TcM (Inst, TcId)
 413 newMethodAtLoc inst_loc real_id tys
 414         -- This actually builds the Inst
 415   =     -- Get the Id type and instantiate it at the specified types
 416     let
 417         (tyvars,rho)  = tcSplitForAllTys (idType real_id)
 418         rho_ty        = ASSERT( length tyvars == length tys )
 419                         substTy (mkTopTyVarSubst tyvars tys) rho
 420         (theta, tau)  = tcSplitRhoTy rho_ty
 421     in
 422     newMethodWith inst_loc real_id tys theta tau        `thenNF_Tc` \ meth_inst ->
 423     returnNF_Tc (meth_inst, instToId meth_inst)
 424 \end{code}
 425
 426 In newOverloadedLit we convert directly to an Int or Integer if we
 427 know that's what we want.  This may save some time, by not
 428 temporarily generating overloaded literals, but it won't catch all
 429 cases (the rest are caught in lookupInst).
 430
 431 \begin{code}
 432 newOverloadedLit :: InstOrigin
 433                  -> HsOverLit
 434                  -> TcType
 435                  -> NF_TcM (TcExpr, LIE)
 436 newOverloadedLit orig lit ty
 437   | Just expr <- shortCutLit lit ty
 438   = returnNF_Tc (expr, emptyLIE)
 439
 440   | otherwise
 441   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 442     tcGetUnique                 `thenNF_Tc` \ new_uniq ->
 443     let
 444         lit_inst = LitInst lit_id lit ty loc
 445         lit_id   = mkSysLocal SLIT("lit") new_uniq ty
 446     in
 447     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 448
 449 shortCutLit :: HsOverLit -> TcType -> Maybe TcExpr
 450 shortCutLit (HsIntegral i fi) ty
 451   | isIntTy ty && inIntRange i && fi == fromIntegerName         -- Short cut for Int
 452   = Just (HsLit (HsInt i))
 453   | isIntegerTy ty && fi == fromIntegerName                     -- Short cut for Integer
 454   = Just (HsLit (HsInteger i))
 455
 456 shortCutLit (HsFractional f fr) ty
 457   | isFloatTy ty  && fr == fromRationalName
 458   = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
 459   | isDoubleTy ty && fr == fromRationalName
 460   = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
 461
 462 shortCutLit lit ty
 463   = Nothing
 464 \end{code}
 465
 466
 467 %************************************************************************
 468 %*                                                                      *
 469 \subsection{Zonking}
 470 %*                                                                      *
 471 %************************************************************************
 472
 473 Zonking makes sure that the instance types are fully zonked,
 474 but doesn't do the same for any of the Ids in an Inst.  There's no
 475 need, and it's a lot of extra work.
 476
 477 \begin{code}
 478 zonkInst :: Inst -> NF_TcM Inst
 479 zonkInst (Dict id pred loc)
 480   = zonkTcPredType pred                 `thenNF_Tc` \ new_pred ->
 481     returnNF_Tc (Dict id new_pred loc)
 482
 483 zonkInst (Method m id tys theta tau loc)
 484   = zonkId id                   `thenNF_Tc` \ new_id ->
 485         -- Essential to zonk the id in case it's a local variable
 486         -- Can't use zonkIdOcc because the id might itself be
 487         -- an InstId, in which case it won't be in scope
 488
 489     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 490     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 491     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 492     returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
 493
 494 zonkInst (LitInst id lit ty loc)
 495   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 496     returnNF_Tc (LitInst id lit new_ty loc)
 497
 498 zonkInsts insts = mapNF_Tc zonkInst insts
 499 \end{code}
 500
 501
 502 %************************************************************************
 503 %*                                                                      *
 504 \subsection{Printing}
 505 %*                                                                      *
 506 %************************************************************************
 507
 508 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 509 relevant in error messages.
 510
 511 \begin{code}
 512 instance Outputable Inst where
 513     ppr inst = pprInst inst
 514
 515 pprInst (LitInst u lit ty loc)
 516   = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
 517
 518 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 519
 520 pprInst m@(Method u id tys theta tau loc)
 521   = hsep [ppr id, ptext SLIT("at"),
 522           brackets (interppSP tys) {- ,
 523           ptext SLIT("theta"), ppr theta,
 524           ptext SLIT("tau"), ppr tau
 525           show_uniq u,
 526           ppr (instToId m) -}]
 527
 528 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 529
 530 tidyInst :: TidyEnv -> Inst -> Inst
 531 tidyInst env (LitInst u lit ty loc)          = LitInst u lit (tidyType env ty) loc
 532 tidyInst env (Dict u pred loc)               = Dict u (tidyPred env pred) loc
 533 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
 534
 535 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 536 -- This function doesn't assume that the tyvars are in scope
 537 -- so it works like tidyOpenType, returning a TidyEnv
 538 tidyInsts insts
 539   = (env, map (tidyInst env) insts)
 540   where
 541     env = tidyFreeTyVars emptyTidyEnv (tyVarsOfInsts insts)
 542 \end{code}
 543
 544
 545 %************************************************************************
 546 %*                                                                      *
 547 \subsection{Looking up Insts}
 548 %*                                                                      *
 549 %************************************************************************
 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 (LookupInstResult s)
 559
 560 -- Dictionaries
 561
 562 lookupInst dict@(Dict _ (ClassP clas tys) loc)
 563   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 564     case lookupInstEnv inst_env clas tys of
 565
 566       FoundInst tenv dfun_id
 567         -> let
 568                 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
 569                 mk_ty_arg tv  = case lookupSubstEnv tenv tv of
 570                                    Just (DoneTy ty) -> returnNF_Tc ty
 571                                    Nothing          -> tcInstTyVar tv   `thenNF_Tc` \ tc_tv ->
 572                                                        returnTc (mkTyVarTy tc_tv)
 573            in
 574            mapNF_Tc mk_ty_arg tyvars    `thenNF_Tc` \ ty_args ->
 575            let
 576                 subst         = mkTyVarSubst tyvars ty_args
 577                 dfun_rho      = substTy subst rho
 578                 (theta, _)    = tcSplitRhoTy dfun_rho
 579                 ty_app        = mkHsTyApp (HsVar dfun_id) ty_args
 580            in
 581            if null theta then
 582                 returnNF_Tc (SimpleInst ty_app)
 583            else
 584            newDictsAtLoc loc theta      `thenNF_Tc` \ dicts ->
 585            let
 586                 rhs = mkHsDictApp ty_app (map instToId dicts)
 587            in
 588            returnNF_Tc (GenInst dicts rhs)
 589
 590       other     -> returnNF_Tc NoInstance
 591
 592 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
 593
 594 -- Methods
 595
 596 lookupInst inst@(Method _ id tys theta _ loc)
 597   = newDictsAtLoc loc theta             `thenNF_Tc` \ dicts ->
 598     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
 599
 600 -- Literals
 601
 602 -- Look for short cuts first: if the literal is *definitely* a
 603 -- int, integer, float or a double, generate the real thing here.
 604 -- This is essential  (see nofib/spectral/nucleic).
 605 -- [Same shortcut as in newOverloadedLit, but we
 606 --  may have done some unification by now]
 607
 608 lookupInst inst@(LitInst u lit ty loc)
 609   | Just expr <- shortCutLit lit ty
 610   = returnNF_Tc (GenInst [] expr)       -- GenInst, not SimpleInst, because
 611                                         -- expr may be a constructor application
 612
 613 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
 614   = tcLookupId from_integer_name                `thenNF_Tc` \ from_integer ->
 615     newMethodAtLoc loc from_integer [ty]        `thenNF_Tc` \ (method_inst, method_id) ->
 616     returnNF_Tc (GenInst [method_inst]
 617                          (HsApp (HsVar method_id) (HsLit (HsInteger i))))
 618
 619
 620 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
 621   = tcLookupId from_rat_name                    `thenNF_Tc` \ from_rational ->
 622     newMethodAtLoc loc from_rational [ty]       `thenNF_Tc` \ (method_inst, method_id) ->
 623     let
 624         rational_ty  = tcFunArgTy (idType method_id)
 625         rational_lit = HsLit (HsRat f rational_ty)
 626     in
 627     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
 628 \end{code}
 629
 630 There is a second, simpler interface, when you want an instance of a
 631 class at a given nullary type constructor.  It just returns the
 632 appropriate dictionary if it exists.  It is used only when resolving
 633 ambiguous dictionaries.
 634
 635 \begin{code}
 636 lookupSimpleInst :: Class
 637                  -> [Type]                      -- Look up (c,t)
 638                  -> NF_TcM (Maybe ThetaType)    -- Here are the needed (c,t)s
 639
 640 lookupSimpleInst clas tys
 641   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 642     case lookupInstEnv inst_env clas tys of
 643       FoundInst tenv dfun
 644         -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
 645         where
 646            (_, rho)  = tcSplitForAllTys (idType dfun)
 647            (theta,_) = tcSplitRhoTy rho
 648
 649       other  -> returnNF_Tc Nothing
 650 \end{code}
 651
 652