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 (mkPredTy pred)) pred inst_loc)
 318   where pred = IParam name ty
 319 \end{code}
 320
 321
 322 %************************************************************************
 323 %*                                                                      *
 324 \subsection{Building methods (calls of overloaded functions)}
 325 %*                                                                      *
 326 %************************************************************************
 327
 328 tcInstId instantiates an occurrence of an Id.
 329 The instantiate_it loop runs round instantiating the Id.
 330 It has to be a loop because we are now prepared to entertain
 331 types like
 332         f:: forall a. Eq a => forall b. Baz b => tau
 333 We want to instantiate this to
 334         f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 335
 336 The -fno-method-sharing flag controls what happens so far as the LIE
 337 is concerned.  The default case is that for an overloaded function we
 338 generate a "method" Id, and add the Method Inst to the LIE.  So you get
 339 something like
 340         f :: Num a => a -> a
 341         f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
 342 If you specify -fno-method-sharing, the dictionary application
 343 isn't shared, so we get
 344         f :: Num a => a -> a
 345         f = /\a (d:Num a) (x:a) -> (+) a d x x
 346 This gets a bit less sharing, but
 347         a) it's better for RULEs involving overloaded functions
 348         b) perhaps fewer separated lambdas
 349
 350
 351 \begin{code}
 352 tcInstId :: Id -> NF_TcM (TcExpr, LIE, TcType)
 353 tcInstId fun
 354   | opt_NoMethodSharing  = loop_noshare (HsVar fun) (idType fun)
 355   | otherwise            = loop_share fun
 356   where
 357     orig = OccurrenceOf fun
 358     loop_noshare fun fun_ty
 359       = tcInstType fun_ty               `thenNF_Tc` \ (tyvars, theta, tau) ->
 360         let
 361             ty_app = mkHsTyApp fun (mkTyVarTys tyvars)
 362         in
 363         if null theta then              -- Is it overloaded?
 364             returnNF_Tc (ty_app, emptyLIE, tau)
 365         else
 366             newDicts orig theta                                         `thenNF_Tc` \ dicts ->
 367             loop_noshare (mkHsDictApp ty_app (map instToId dicts)) tau  `thenNF_Tc` \ (expr, lie, final_tau) ->
 368             returnNF_Tc (expr, mkLIE dicts `plusLIE` lie, final_tau)
 369
 370     loop_share fun
 371       = tcInstType (idType fun)         `thenNF_Tc` \ (tyvars, theta, tau) ->
 372         let
 373             arg_tys = mkTyVarTys tyvars
 374         in
 375         if null theta then              -- Is it overloaded?
 376             returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
 377         else
 378                 -- Yes, it's overloaded
 379             newMethodWithGivenTy orig fun arg_tys theta tau     `thenNF_Tc` \ meth ->
 380             loop_share (instToId meth)                          `thenNF_Tc` \ (expr, lie, final_tau) ->
 381             returnNF_Tc (expr, unitLIE meth `plusLIE` lie, final_tau)
 382
 383
 384 newMethod :: InstOrigin
 385           -> TcId
 386           -> [TcType]
 387           -> NF_TcM Inst
 388 newMethod orig id tys
 389   =     -- Get the Id type and instantiate it at the specified types
 390     let
 391         (tyvars, rho) = splitForAllTys (idType id)
 392         rho_ty        = substTy (mkTyVarSubst tyvars tys) rho
 393         (pred, tau)   = splitMethodTy rho_ty
 394     in
 395     newMethodWithGivenTy orig id tys [pred] tau
 396
 397 newMethodWithGivenTy orig id tys theta tau
 398   = tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 399     newMethodWith loc id tys theta tau
 400
 401 newMethodWith inst_loc@(_,loc,_) id tys theta tau
 402   = tcGetUnique         `thenNF_Tc` \ new_uniq ->
 403     let
 404         meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 405     in
 406     returnNF_Tc (Method meth_id id tys theta tau inst_loc)
 407
 408 newMethodAtLoc :: InstLoc
 409                -> Id -> [TcType]
 410                -> NF_TcM (Inst, TcId)
 411 newMethodAtLoc inst_loc real_id tys
 412         -- This actually builds the Inst
 413   =     -- Get the Id type and instantiate it at the specified types
 414     let
 415         (tyvars,rho) = splitForAllTys (idType real_id)
 416         rho_ty        = ASSERT( length tyvars == length tys )
 417                         substTy (mkTopTyVarSubst tyvars tys) rho
 418         (theta, tau)  = splitRhoTy rho_ty
 419     in
 420     newMethodWith inst_loc real_id tys theta tau        `thenNF_Tc` \ meth_inst ->
 421     returnNF_Tc (meth_inst, instToId meth_inst)
 422 \end{code}
 423
 424 In newOverloadedLit we convert directly to an Int or Integer if we
 425 know that's what we want.  This may save some time, by not
 426 temporarily generating overloaded literals, but it won't catch all
 427 cases (the rest are caught in lookupInst).
 428
 429 \begin{code}
 430 newOverloadedLit :: InstOrigin
 431                  -> HsOverLit
 432                  -> TcType
 433                  -> NF_TcM (TcExpr, LIE)
 434 newOverloadedLit orig (HsIntegral i) ty
 435   | isIntTy ty && inIntRange i          -- Short cut for Int
 436   = returnNF_Tc (int_lit, emptyLIE)
 437
 438   | isIntegerTy ty                      -- Short cut for Integer
 439   = returnNF_Tc (integer_lit, emptyLIE)
 440
 441   where
 442     int_lit     = HsLit (HsInt i)
 443     integer_lit = HsLit (HsInteger i)
 444
 445 newOverloadedLit orig lit ty            -- The general case
 446   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 447     tcGetUnique                 `thenNF_Tc` \ new_uniq ->
 448     let
 449         lit_inst = LitInst lit_id lit ty loc
 450         lit_id   = mkSysLocal SLIT("lit") new_uniq ty
 451     in
 452     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 453 \end{code}
 454
 455
 456 %************************************************************************
 457 %*                                                                      *
 458 \subsection{Zonking}
 459 %*                                                                      *
 460 %************************************************************************
 461
 462 Zonking makes sure that the instance types are fully zonked,
 463 but doesn't do the same for any of the Ids in an Inst.  There's no
 464 need, and it's a lot of extra work.
 465
 466 \begin{code}
 467 zonkInst :: Inst -> NF_TcM Inst
 468 zonkInst (Dict id pred loc)
 469   = zonkTcPredType pred                 `thenNF_Tc` \ new_pred ->
 470     returnNF_Tc (Dict id new_pred loc)
 471
 472 zonkInst (Method m id tys theta tau loc)
 473   = zonkId id                   `thenNF_Tc` \ new_id ->
 474         -- Essential to zonk the id in case it's a local variable
 475         -- Can't use zonkIdOcc because the id might itself be
 476         -- an InstId, in which case it won't be in scope
 477
 478     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 479     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 480     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 481     returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
 482
 483 zonkInst (LitInst id lit ty loc)
 484   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 485     returnNF_Tc (LitInst id lit new_ty loc)
 486
 487 zonkInsts insts = mapNF_Tc zonkInst insts
 488 \end{code}
 489
 490
 491 %************************************************************************
 492 %*                                                                      *
 493 \subsection{Printing}
 494 %*                                                                      *
 495 %************************************************************************
 496
 497 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 498 relevant in error messages.
 499
 500 \begin{code}
 501 instance Outputable Inst where
 502     ppr inst = pprInst inst
 503
 504 pprInst (LitInst u lit ty loc)
 505   = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
 506
 507 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 508
 509 pprInst m@(Method u id tys theta tau loc)
 510   = hsep [ppr id, ptext SLIT("at"),
 511           brackets (interppSP tys) {- ,
 512           ptext SLIT("theta"), ppr theta,
 513           ptext SLIT("tau"), ppr tau
 514           show_uniq u,
 515           ppr (instToId m) -}]
 516
 517 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 518
 519 tidyInst :: TidyEnv -> Inst -> Inst
 520 tidyInst env (LitInst u lit ty loc)          = LitInst u lit (tidyType env ty) loc
 521 tidyInst env (Dict u pred loc)               = Dict u (tidyPred env pred) loc
 522 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
 523
 524 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 525 -- This function doesn't assume that the tyvars are in scope
 526 -- so it works like tidyOpenType, returning a TidyEnv
 527 tidyInsts insts
 528   = (env, map (tidyInst env) insts)
 529   where
 530     env = tidyFreeTyVars emptyTidyEnv (tyVarsOfInsts insts)
 531 \end{code}
 532
 533
 534 %************************************************************************
 535 %*                                                                      *
 536 \subsection{Looking up Insts}
 537 %*                                                                      *
 538 %************************************************************************
 539
 540 \begin{code}
 541 data LookupInstResult s
 542   = NoInstance
 543   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 544   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 545
 546 lookupInst :: Inst
 547            -> NF_TcM (LookupInstResult s)
 548
 549 -- Dictionaries
 550
 551 lookupInst dict@(Dict _ (ClassP clas tys) loc)
 552   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 553     case lookupInstEnv inst_env clas tys of
 554
 555       FoundInst tenv dfun_id
 556         -> let
 557                 (tyvars, rho) = splitForAllTys (idType dfun_id)
 558                 mk_ty_arg tv  = case lookupSubstEnv tenv tv of
 559                                    Just (DoneTy ty) -> returnNF_Tc ty
 560                                    Nothing          -> tcInstTyVar tv   `thenNF_Tc` \ tc_tv ->
 561                                                        returnTc (mkTyVarTy tc_tv)
 562            in
 563            mapNF_Tc mk_ty_arg tyvars    `thenNF_Tc` \ ty_args ->
 564            let
 565                 subst         = mkTyVarSubst tyvars ty_args
 566                 dfun_rho      = substTy subst rho
 567                 (theta, _)    = splitRhoTy dfun_rho
 568                 ty_app        = mkHsTyApp (HsVar dfun_id) ty_args
 569            in
 570            if null theta then
 571                 returnNF_Tc (SimpleInst ty_app)
 572            else
 573            newDictsAtLoc loc theta      `thenNF_Tc` \ dicts ->
 574            let
 575                 rhs = mkHsDictApp ty_app (map instToId dicts)
 576            in
 577            returnNF_Tc (GenInst dicts rhs)
 578
 579       other     -> returnNF_Tc NoInstance
 580
 581 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
 582
 583 -- Methods
 584
 585 lookupInst inst@(Method _ id tys theta _ loc)
 586   = newDictsAtLoc loc theta             `thenNF_Tc` \ dicts ->
 587     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
 588
 589 -- Literals
 590
 591 lookupInst inst@(LitInst u (HsIntegral i) ty loc)
 592   | isIntTy ty && in_int_range                  -- Short cut for Int
 593   = returnNF_Tc (GenInst [] int_lit)
 594         -- GenInst, not SimpleInst, because int_lit is actually a constructor application
 595
 596   | isIntegerTy ty                              -- Short cut for Integer
 597   = returnNF_Tc (GenInst [] integer_lit)
 598
 599   | otherwise                                   -- Alas, it is overloaded and a big literal!
 600   = tcLookupSyntaxId fromIntegerName            `thenNF_Tc` \ from_integer ->
 601     newMethodAtLoc loc from_integer [ty]        `thenNF_Tc` \ (method_inst, method_id) ->
 602     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
 603   where
 604     in_int_range   = inIntRange i
 605     integer_lit    = HsLit (HsInteger i)
 606     int_lit        = HsLit (HsInt i)
 607
 608 -- similar idea for overloaded floating point literals: if the literal is
 609 -- *definitely* a float or a double, generate the real thing here.
 610 -- This is essential  (see nofib/spectral/nucleic).
 611
 612 lookupInst inst@(LitInst u (HsFractional f) ty loc)
 613   | isFloatTy ty    = returnNF_Tc (GenInst [] float_lit)
 614   | isDoubleTy ty   = returnNF_Tc (GenInst [] double_lit)
 615
 616   | otherwise
 617   = tcLookupSyntaxId fromRationalName           `thenNF_Tc` \ from_rational ->
 618     newMethodAtLoc loc from_rational [ty]       `thenNF_Tc` \ (method_inst, method_id) ->
 619     let
 620         rational_ty  = funArgTy (idType method_id)
 621         rational_lit = HsLit (HsRat f rational_ty)
 622     in
 623     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
 624
 625   where
 626     floatprim_lit  = HsLit (HsFloatPrim f)
 627     float_lit      = mkHsConApp floatDataCon [] [floatprim_lit]
 628     doubleprim_lit = HsLit (HsDoublePrim f)
 629     double_lit     = mkHsConApp doubleDataCon [] [doubleprim_lit]
 630 \end{code}
 631
 632 There is a second, simpler interface, when you want an instance of a
 633 class at a given nullary type constructor.  It just returns the
 634 appropriate dictionary if it exists.  It is used only when resolving
 635 ambiguous dictionaries.
 636
 637 \begin{code}
 638 lookupSimpleInst :: Class
 639                  -> [Type]                              -- Look up (c,t)
 640                  -> NF_TcM (Maybe ThetaType)    -- Here are the needed (c,t)s
 641
 642 lookupSimpleInst clas tys
 643   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 644     case lookupInstEnv inst_env clas tys of
 645       FoundInst tenv dfun
 646         -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
 647         where
 648            (_, theta, _) = splitSigmaTy (idType dfun)
 649
 650       other  -> returnNF_Tc Nothing
 651 \end{code}
 652
 653