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,
  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, tcLookupSyntaxId )
  43 import InstEnv  ( InstLookupResult(..), lookupInstEnv )
  44 import TcType   ( TcThetaType,
  45                   TcType, TcTauType, TcTyVarSet,
  46                   zonkTcType, zonkTcTypes, zonkTcPredType,
  47                   zonkTcThetaType, tcInstTyVar, tcInstType
  48                 )
  49 import CoreFVs  ( idFreeTyVars )
  50 import Class    ( Class )
  51 import Id       ( Id, idType, mkUserLocal, mkSysLocal, mkLocalId )
  52 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
  53 import Name     ( mkMethodOcc, getOccName )
  54 import NameSet  ( NameSet )
  55 import PprType  ( pprPred )
  56 import Type     ( Type, PredType(..), ThetaType,
  57                   isTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
  58                   splitForAllTys, splitSigmaTy, funArgTy,
  59                   splitMethodTy, splitRhoTy,
  60                   tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
  61                   predMentionsIPs, isClassPred, isTyVarClassPred,
  62                   getClassPredTys, getClassPredTys_maybe, mkPredName,
  63                   tidyType, tidyTypes, tidyFreeTyVars
  64                 )
  65 import Subst    ( emptyInScopeSet, mkSubst,
  66                   substTy, substTheta, mkTyVarSubst, mkTopTyVarSubst
  67                 )
  68 import Literal  ( inIntRange )
  69 import VarEnv   ( TidyEnv, lookupSubstEnv, SubstResult(..) )
  70 import VarSet   ( elemVarSet, emptyVarSet, unionVarSet )
  71 import TysWiredIn ( isIntTy,
  72                     floatDataCon, isFloatTy,
  73                     doubleDataCon, isDoubleTy,
  74                     isIntegerTy
  75                   )
  76 import PrelNames( fromIntegerName, fromRationalName )
  77 import Util     ( thenCmp, zipWithEqual )
  78 import Bag
  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 lieToList         = bagToList
  99 listToLIE         = listToBag
 100
 101 zonkLIE :: LIE -> NF_TcM LIE
 102 zonkLIE lie = mapBagNF_Tc zonkInst lie
 103
 104 pprInsts :: [Inst] -> SDoc
 105 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
 106
 107
 108 pprInstsInFull insts
 109   = vcat (map go insts)
 110   where
 111     go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
 112 \end{code}
 113
 114 %************************************************************************
 115 %*                                                                      *
 116 \subsection[Inst-types]{@Inst@ types}
 117 %*                                                                      *
 118 %************************************************************************
 119
 120 An @Inst@ is either a dictionary, an instance of an overloaded
 121 literal, or an instance of an overloaded value.  We call the latter a
 122 ``method'' even though it may not correspond to a class operation.
 123 For example, we might have an instance of the @double@ function at
 124 type Int, represented by
 125
 126         Method 34 doubleId [Int] origin
 127
 128 \begin{code}
 129 data Inst
 130   = Dict
 131         Id
 132         TcPredType
 133         InstLoc
 134
 135   | Method
 136         Id
 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         Id
 161         HsOverLit       -- The literal from the occurrence site
 162         TcType          -- The type at which the literal is used
 163         InstLoc
 164 \end{code}
 165
 166 Ordering
 167 ~~~~~~~~
 168 @Insts@ are ordered by their class/type info, rather than by their
 169 unique.  This allows the context-reduction mechanism to use standard finite
 170 maps to do their stuff.
 171
 172 \begin{code}
 173 instance Ord Inst where
 174   compare = cmpInst
 175
 176 instance Eq Inst where
 177   (==) i1 i2 = case i1 `cmpInst` i2 of
 178                  EQ    -> True
 179                  other -> False
 180
 181 cmpInst (Dict _ pred1 _)          (Dict _ pred2 _)          = (pred1 `compare` pred2)
 182 cmpInst (Dict _ _ _)              other                     = LT
 183
 184 cmpInst (Method _ _ _ _ _ _)      (Dict _ _ _)              = GT
 185 cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
 186 cmpInst (Method _ _ _ _ _ _)      other                     = LT
 187
 188 cmpInst (LitInst _ lit1 ty1 _)    (LitInst _ lit2 ty2 _)    = (lit1 `compare` lit2) `thenCmp` (ty1 `compare` ty2)
 189 cmpInst (LitInst _ _ _ _)         other                     = GT
 190
 191 -- and they can only have HsInt or HsFracs in them.
 192 \end{code}
 193
 194
 195 Selection
 196 ~~~~~~~~~
 197 \begin{code}
 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 && isTyVarTy 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 (length theta)         `thenNF_Tc` \ new_uniqs ->
 311     returnNF_Tc (zipWithEqual "newDictsAtLoc" 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 newIPDict orig name ty
 316   = tcGetInstLoc orig                   `thenNF_Tc` \ inst_loc ->
 317     returnNF_Tc (Dict (mkLocalId name ty) (IParam name ty) inst_loc)
 318 \end{code}
 319
 320
 321 %************************************************************************
 322 %*                                                                      *
 323 \subsection{Building methods (calls of overloaded functions)}
 324 %*                                                                      *
 325 %************************************************************************
 326
 327 tcInstId instantiates an occurrence of an Id.
 328 The instantiate_it loop runs round instantiating the Id.
 329 It has to be a loop because we are now prepared to entertain
 330 types like
 331         f:: forall a. Eq a => forall b. Baz b => tau
 332 We want to instantiate this to
 333         f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 334
 335 The -fno-method-sharing flag controls what happens so far as the LIE
 336 is concerned.  The default case is that for an overloaded function we
 337 generate a "method" Id, and add the Method Inst to the LIE.  So you get
 338 something like
 339         f :: Num a => a -> a
 340         f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
 341 If you specify -fno-method-sharing, the dictionary application
 342 isn't shared, so we get
 343         f :: Num a => a -> a
 344         f = /\a (d:Num a) (x:a) -> (+) a d x x
 345 This gets a bit less sharing, but
 346         a) it's better for RULEs involving overloaded functions
 347         b) perhaps fewer separated lambdas
 348
 349
 350 \begin{code}
 351 tcInstId :: Id -> NF_TcM (TcExpr, LIE, TcType)
 352 tcInstId fun
 353   | opt_NoMethodSharing  = loop_noshare (HsVar fun) (idType fun)
 354   | otherwise            = loop_share fun
 355   where
 356     orig = OccurrenceOf fun
 357     loop_noshare fun fun_ty
 358       = tcInstType fun_ty               `thenNF_Tc` \ (tyvars, theta, tau) ->
 359         let
 360             ty_app = mkHsTyApp fun (mkTyVarTys tyvars)
 361         in
 362         if null theta then              -- Is it overloaded?
 363             returnNF_Tc (ty_app, emptyLIE, tau)
 364         else
 365             newDicts orig theta                                         `thenNF_Tc` \ dicts ->
 366             loop_noshare (mkHsDictApp ty_app (map instToId dicts)) tau  `thenNF_Tc` \ (expr, lie, final_tau) ->
 367             returnNF_Tc (expr, mkLIE dicts `plusLIE` lie, final_tau)
 368
 369     loop_share fun
 370       = tcInstType (idType fun)         `thenNF_Tc` \ (tyvars, theta, tau) ->
 371         let
 372             arg_tys = mkTyVarTys tyvars
 373         in
 374         if null theta then              -- Is it overloaded?
 375             returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
 376         else
 377                 -- Yes, it's overloaded
 378             newMethodWithGivenTy orig fun arg_tys theta tau     `thenNF_Tc` \ meth ->
 379             loop_share (instToId meth)                          `thenNF_Tc` \ (expr, lie, final_tau) ->
 380             returnNF_Tc (expr, unitLIE meth `plusLIE` lie, final_tau)
 381
 382
 383 newMethod :: InstOrigin
 384           -> TcId
 385           -> [TcType]
 386           -> NF_TcM Inst
 387 newMethod orig id tys
 388   =     -- Get the Id type and instantiate it at the specified types
 389     let
 390         (tyvars, rho) = splitForAllTys (idType id)
 391         rho_ty        = substTy (mkTyVarSubst tyvars tys) rho
 392         (pred, tau)   = splitMethodTy rho_ty
 393     in
 394     newMethodWithGivenTy orig id tys [pred] tau
 395
 396 newMethodWithGivenTy orig id tys theta tau
 397   = tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 398     newMethodWith loc id tys theta tau
 399
 400 newMethodWith inst_loc@(_,loc,_) id tys theta tau
 401   = tcGetUnique         `thenNF_Tc` \ new_uniq ->
 402     let
 403         meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 404     in
 405     returnNF_Tc (Method meth_id id tys theta tau inst_loc)
 406
 407 newMethodAtLoc :: InstLoc
 408                -> Id -> [TcType]
 409                -> NF_TcM (Inst, TcId)
 410 newMethodAtLoc inst_loc real_id tys
 411         -- This actually builds the Inst
 412   =     -- Get the Id type and instantiate it at the specified types
 413     let
 414         (tyvars,rho) = splitForAllTys (idType real_id)
 415         rho_ty        = ASSERT( length tyvars == length tys )
 416                         substTy (mkTopTyVarSubst tyvars tys) rho
 417         (theta, tau)  = splitRhoTy rho_ty
 418     in
 419     newMethodWith inst_loc real_id tys theta tau        `thenNF_Tc` \ meth_inst ->
 420     returnNF_Tc (meth_inst, instToId meth_inst)
 421 \end{code}
 422
 423 In newOverloadedLit we convert directly to an Int or Integer if we
 424 know that's what we want.  This may save some time, by not
 425 temporarily generating overloaded literals, but it won't catch all
 426 cases (the rest are caught in lookupInst).
 427
 428 \begin{code}
 429 newOverloadedLit :: InstOrigin
 430                  -> HsOverLit
 431                  -> TcType
 432                  -> NF_TcM (TcExpr, LIE)
 433 newOverloadedLit orig (HsIntegral i) ty
 434   | isIntTy ty && inIntRange i          -- Short cut for Int
 435   = returnNF_Tc (int_lit, emptyLIE)
 436
 437   | isIntegerTy ty                      -- Short cut for Integer
 438   = returnNF_Tc (integer_lit, emptyLIE)
 439
 440   where
 441     int_lit     = HsLit (HsInt i)
 442     integer_lit = HsLit (HsInteger i)
 443
 444 newOverloadedLit orig lit ty            -- The general case
 445   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 446     tcGetUnique                 `thenNF_Tc` \ new_uniq ->
 447     let
 448         lit_inst = LitInst lit_id lit ty loc
 449         lit_id   = mkSysLocal SLIT("lit") new_uniq ty
 450     in
 451     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 452 \end{code}
 453
 454
 455 %************************************************************************
 456 %*                                                                      *
 457 \subsection{Zonking}
 458 %*                                                                      *
 459 %************************************************************************
 460
 461 Zonking makes sure that the instance types are fully zonked,
 462 but doesn't do the same for any of the Ids in an Inst.  There's no
 463 need, and it's a lot of extra work.
 464
 465 \begin{code}
 466 zonkInst :: Inst -> NF_TcM Inst
 467 zonkInst (Dict id pred loc)
 468   = zonkTcPredType pred                 `thenNF_Tc` \ new_pred ->
 469     returnNF_Tc (Dict id new_pred loc)
 470
 471 zonkInst (Method m id tys theta tau loc)
 472   = zonkId id                   `thenNF_Tc` \ new_id ->
 473         -- Essential to zonk the id in case it's a local variable
 474         -- Can't use zonkIdOcc because the id might itself be
 475         -- an InstId, in which case it won't be in scope
 476
 477     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 478     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 479     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 480     returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
 481
 482 zonkInst (LitInst id lit ty loc)
 483   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 484     returnNF_Tc (LitInst id lit new_ty loc)
 485
 486 zonkInsts insts = mapNF_Tc zonkInst insts
 487 \end{code}
 488
 489
 490 %************************************************************************
 491 %*                                                                      *
 492 \subsection{Printing}
 493 %*                                                                      *
 494 %************************************************************************
 495
 496 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 497 relevant in error messages.
 498
 499 \begin{code}
 500 instance Outputable Inst where
 501     ppr inst = pprInst inst
 502
 503 pprInst (LitInst u lit ty loc)
 504   = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
 505
 506 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 507
 508 pprInst m@(Method u id tys theta tau loc)
 509   = hsep [ppr id, ptext SLIT("at"),
 510           brackets (interppSP tys) {- ,
 511           ptext SLIT("theta"), ppr theta,
 512           ptext SLIT("tau"), ppr tau
 513           show_uniq u,
 514           ppr (instToId m) -}]
 515
 516 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 517
 518 tidyInst :: TidyEnv -> Inst -> Inst
 519 tidyInst env (LitInst u lit ty loc)          = LitInst u lit (tidyType env ty) loc
 520 tidyInst env (Dict u pred loc)               = Dict u (tidyPred env pred) loc
 521 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
 522
 523 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 524 -- This function doesn't assume that the tyvars are in scope
 525 -- so it works like tidyOpenType, returning a TidyEnv
 526 tidyInsts insts
 527   = (env, map (tidyInst env) insts)
 528   where
 529     env = tidyFreeTyVars emptyTidyEnv (tyVarsOfInsts insts)
 530 \end{code}
 531
 532
 533 %************************************************************************
 534 %*                                                                      *
 535 \subsection{Looking up Insts}
 536 %*                                                                      *
 537 %************************************************************************
 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 (LookupInstResult s)
 547
 548 -- Dictionaries
 549
 550 lookupInst dict@(Dict _ (ClassP clas tys) loc)
 551   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 552     case lookupInstEnv inst_env clas tys of
 553
 554       FoundInst tenv dfun_id
 555         -> let
 556                 (tyvars, rho) = splitForAllTys (idType dfun_id)
 557                 mk_ty_arg tv  = case lookupSubstEnv tenv tv of
 558                                    Just (DoneTy ty) -> returnNF_Tc ty
 559                                    Nothing          -> tcInstTyVar tv   `thenNF_Tc` \ tc_tv ->
 560                                                        returnTc (mkTyVarTy tc_tv)
 561            in
 562            mapNF_Tc mk_ty_arg tyvars    `thenNF_Tc` \ ty_args ->
 563            let
 564                 subst         = mkTyVarSubst tyvars ty_args
 565                 dfun_rho      = substTy subst rho
 566                 (theta, _)    = splitRhoTy dfun_rho
 567                 ty_app        = mkHsTyApp (HsVar dfun_id) ty_args
 568            in
 569            if null theta then
 570                 returnNF_Tc (SimpleInst ty_app)
 571            else
 572            newDictsAtLoc loc theta      `thenNF_Tc` \ dicts ->
 573            let
 574                 rhs = mkHsDictApp ty_app (map instToId dicts)
 575            in
 576            returnNF_Tc (GenInst dicts rhs)
 577
 578       other     -> returnNF_Tc NoInstance
 579
 580 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
 581
 582 -- Methods
 583
 584 lookupInst inst@(Method _ id tys theta _ loc)
 585   = newDictsAtLoc loc theta             `thenNF_Tc` \ dicts ->
 586     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
 587
 588 -- Literals
 589
 590 lookupInst inst@(LitInst u (HsIntegral i) ty loc)
 591   | isIntTy ty && in_int_range                  -- Short cut for Int
 592   = returnNF_Tc (GenInst [] int_lit)
 593         -- GenInst, not SimpleInst, because int_lit is actually a constructor application
 594
 595   | isIntegerTy ty                              -- Short cut for Integer
 596   = returnNF_Tc (GenInst [] integer_lit)
 597
 598   | otherwise                                   -- Alas, it is overloaded and a big literal!
 599   = tcLookupSyntaxId fromIntegerName            `thenNF_Tc` \ from_integer ->
 600     newMethodAtLoc loc from_integer [ty]        `thenNF_Tc` \ (method_inst, method_id) ->
 601     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
 602   where
 603     in_int_range   = inIntRange i
 604     integer_lit    = HsLit (HsInteger i)
 605     int_lit        = HsLit (HsInt i)
 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 (HsFractional f) ty loc)
 612   | isFloatTy ty    = returnNF_Tc (GenInst [] float_lit)
 613   | isDoubleTy ty   = returnNF_Tc (GenInst [] double_lit)
 614
 615   | otherwise
 616   = tcLookupSyntaxId fromRationalName           `thenNF_Tc` \ from_rational ->
 617     newMethodAtLoc loc from_rational [ty]       `thenNF_Tc` \ (method_inst, method_id) ->
 618     let
 619         rational_ty  = funArgTy (idType method_id)
 620         rational_lit = HsLit (HsRat f rational_ty)
 621     in
 622     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
 623
 624   where
 625     floatprim_lit  = HsLit (HsFloatPrim f)
 626     float_lit      = mkHsConApp floatDataCon [] [floatprim_lit]
 627     doubleprim_lit = HsLit (HsDoublePrim f)
 628     double_lit     = mkHsConApp doubleDataCon [] [doubleprim_lit]
 629 \end{code}
 630
 631 There is a second, simpler interface, when you want an instance of a
 632 class at a given nullary type constructor.  It just returns the
 633 appropriate dictionary if it exists.  It is used only when resolving
 634 ambiguous dictionaries.
 635
 636 \begin{code}
 637 lookupSimpleInst :: Class
 638                  -> [Type]                              -- Look up (c,t)
 639                  -> NF_TcM (Maybe ThetaType)    -- Here are the needed (c,t)s
 640
 641 lookupSimpleInst clas tys
 642   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 643     case lookupInstEnv inst_env clas tys of
 644       FoundInst tenv dfun
 645         -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
 646         where
 647            (_, theta, _) = splitSigmaTy (idType dfun)
 648
 649       other  -> returnNF_Tc Nothing
 650 \end{code}
 651
 652