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, 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, idName, idType, mkUserLocal, mkSysLocal, mkLocalId )
  52 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
  53 import Name     ( 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 )
  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 instName :: Inst -> Name
 199 instName inst = idName (instToId inst)
 200
 201 instToId :: Inst -> TcId
 202 instToId (Dict id _ _)         = id
 203 instToId (Method id _ _ _ _ _) = id
 204 instToId (LitInst id _ _ _)    = id
 205
 206 instLoc (Dict _ _         loc) = loc
 207 instLoc (Method _ _ _ _ _ loc) = loc
 208 instLoc (LitInst _ _ _    loc) = loc
 209
 210 getDictClassTys (Dict _ pred _) = getClassPredTys pred
 211
 212 predsOfInsts :: [Inst] -> [PredType]
 213 predsOfInsts insts = concatMap predsOfInst insts
 214
 215 predsOfInst (Dict _ pred _)          = [pred]
 216 predsOfInst (Method _ _ _ theta _ _) = theta
 217 predsOfInst (LitInst _ _ _ _)        = []
 218         -- The last case is is really a big cheat
 219         -- LitInsts to give rise to a (Num a) or (Fractional a) predicate
 220         -- But Num and Fractional have only one parameter and no functional
 221         -- dependencies, so I think no caller of predsOfInst will care.
 222
 223 ipsOfPreds theta = [(n,ty) | IParam n ty <- theta]
 224
 225 getIPs inst = ipsOfPreds (predsOfInst inst)
 226
 227 tyVarsOfInst :: Inst -> TcTyVarSet
 228 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
 229 tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
 230 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 231                                          -- The id might have free type variables; in the case of
 232                                          -- locally-overloaded class methods, for example
 233
 234 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 235 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
 236 \end{code}
 237
 238 Predicates
 239 ~~~~~~~~~~
 240 \begin{code}
 241 isDict :: Inst -> Bool
 242 isDict (Dict _ _ _) = True
 243 isDict other        = False
 244
 245 isClassDict :: Inst -> Bool
 246 isClassDict (Dict _ pred _) = isClassPred pred
 247 isClassDict other           = False
 248
 249 isTyVarDict :: Inst -> Bool
 250 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
 251 isTyVarDict other           = False
 252
 253 isMethod :: Inst -> Bool
 254 isMethod (Method _ _ _ _ _ _) = True
 255 isMethod other                = False
 256
 257 isMethodFor :: TcIdSet -> Inst -> Bool
 258 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
 259 isMethodFor ids inst                         = False
 260
 261 instMentionsIPs :: Inst -> NameSet -> Bool
 262   -- True if the Inst mentions any of the implicit
 263   -- parameters in the supplied set of names
 264 instMentionsIPs (Dict _ pred _)          ip_names = pred `predMentionsIPs` ip_names
 265 instMentionsIPs (Method _ _ _ theta _ _) ip_names = any (`predMentionsIPs` ip_names) theta
 266 instMentionsIPs other                    ip_names = False
 267
 268 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
 269                                         Just (clas, [ty]) -> isStandardClass clas && isTyVarTy ty
 270                                         other             -> False
 271 \end{code}
 272
 273 Two predicates which deal with the case where class constraints don't
 274 necessarily result in bindings.  The first tells whether an @Inst@
 275 must be witnessed by an actual binding; the second tells whether an
 276 @Inst@ can be generalised over.
 277
 278 \begin{code}
 279 instBindingRequired :: Inst -> Bool
 280 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
 281 instBindingRequired (Dict _ (IParam _ _) _)    = False
 282 instBindingRequired other                      = True
 283
 284 instCanBeGeneralised :: Inst -> Bool
 285 instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas)
 286 instCanBeGeneralised other                      = True
 287 \end{code}
 288
 289
 290 %************************************************************************
 291 %*                                                                      *
 292 \subsection{Building dictionaries}
 293 %*                                                                      *
 294 %************************************************************************
 295
 296 \begin{code}
 297 newDicts :: InstOrigin
 298          -> TcThetaType
 299          -> NF_TcM [Inst]
 300 newDicts orig theta
 301   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 302     newDictsAtLoc loc theta
 303
 304 newDictsFromOld :: Inst -> TcThetaType -> NF_TcM [Inst]
 305 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
 306
 307 -- Local function, similar to newDicts,
 308 -- but with slightly different interface
 309 newDictsAtLoc :: InstLoc
 310               -> TcThetaType
 311               -> NF_TcM [Inst]
 312 newDictsAtLoc inst_loc@(_,loc,_) theta
 313   = tcGetUniques                        `thenNF_Tc` \ new_uniqs ->
 314     returnNF_Tc (zipWith mk_dict new_uniqs theta)
 315   where
 316     mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
 317
 318 -- For implicit parameters, since there is only one in scope
 319 -- at any time, we use the name of the implicit parameter itself
 320 newIPDict orig name ty
 321   = tcGetInstLoc orig                   `thenNF_Tc` \ inst_loc ->
 322     returnNF_Tc (Dict (mkLocalId name (mkPredTy pred)) pred inst_loc)
 323   where pred = IParam name ty
 324 \end{code}
 325
 326
 327 %************************************************************************
 328 %*                                                                      *
 329 \subsection{Building methods (calls of overloaded functions)}
 330 %*                                                                      *
 331 %************************************************************************
 332
 333 tcInstId instantiates an occurrence of an Id.
 334 The instantiate_it loop runs round instantiating the Id.
 335 It has to be a loop because we are now prepared to entertain
 336 types like
 337         f:: forall a. Eq a => forall b. Baz b => tau
 338 We want to instantiate this to
 339         f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 340
 341 The -fno-method-sharing flag controls what happens so far as the LIE
 342 is concerned.  The default case is that for an overloaded function we
 343 generate a "method" Id, and add the Method Inst to the LIE.  So you get
 344 something like
 345         f :: Num a => a -> a
 346         f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
 347 If you specify -fno-method-sharing, the dictionary application
 348 isn't shared, so we get
 349         f :: Num a => a -> a
 350         f = /\a (d:Num a) (x:a) -> (+) a d x x
 351 This gets a bit less sharing, but
 352         a) it's better for RULEs involving overloaded functions
 353         b) perhaps fewer separated lambdas
 354
 355
 356 \begin{code}
 357 tcInstId :: Id -> NF_TcM (TcExpr, LIE, TcType)
 358 tcInstId fun
 359   | opt_NoMethodSharing  = loop_noshare (HsVar fun) (idType fun)
 360   | otherwise            = loop_share fun
 361   where
 362     orig = OccurrenceOf fun
 363     loop_noshare fun fun_ty
 364       = tcInstType fun_ty               `thenNF_Tc` \ (tyvars, theta, tau) ->
 365         let
 366             ty_app = mkHsTyApp fun (mkTyVarTys tyvars)
 367         in
 368         if null theta then              -- Is it overloaded?
 369             returnNF_Tc (ty_app, emptyLIE, tau)
 370         else
 371             newDicts orig theta                                         `thenNF_Tc` \ dicts ->
 372             loop_noshare (mkHsDictApp ty_app (map instToId dicts)) tau  `thenNF_Tc` \ (expr, lie, final_tau) ->
 373             returnNF_Tc (expr, mkLIE dicts `plusLIE` lie, final_tau)
 374
 375     loop_share fun
 376       = tcInstType (idType fun)         `thenNF_Tc` \ (tyvars, theta, tau) ->
 377         let
 378             arg_tys = mkTyVarTys tyvars
 379         in
 380         if null theta then              -- Is it overloaded?
 381             returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
 382         else
 383                 -- Yes, it's overloaded
 384             newMethodWithGivenTy orig fun arg_tys theta tau     `thenNF_Tc` \ meth ->
 385             loop_share (instToId meth)                          `thenNF_Tc` \ (expr, lie, final_tau) ->
 386             returnNF_Tc (expr, unitLIE meth `plusLIE` lie, final_tau)
 387
 388
 389 newMethod :: InstOrigin
 390           -> TcId
 391           -> [TcType]
 392           -> NF_TcM Inst
 393 newMethod orig id tys
 394   =     -- Get the Id type and instantiate it at the specified types
 395     let
 396         (tyvars, rho) = splitForAllTys (idType id)
 397         rho_ty        = substTy (mkTyVarSubst tyvars tys) rho
 398         (pred, tau)   = splitMethodTy rho_ty
 399     in
 400     newMethodWithGivenTy orig id tys [pred] tau
 401
 402 newMethodWithGivenTy orig id tys theta tau
 403   = tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 404     newMethodWith loc id tys theta tau
 405
 406 newMethodWith inst_loc@(_,loc,_) id tys theta tau
 407   = tcGetUnique         `thenNF_Tc` \ new_uniq ->
 408     let
 409         meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 410     in
 411     returnNF_Tc (Method meth_id id tys theta tau inst_loc)
 412
 413 newMethodAtLoc :: InstLoc
 414                -> Id -> [TcType]
 415                -> NF_TcM (Inst, TcId)
 416 newMethodAtLoc inst_loc real_id tys
 417         -- This actually builds the Inst
 418   =     -- Get the Id type and instantiate it at the specified types
 419     let
 420         (tyvars,rho) = splitForAllTys (idType real_id)
 421         rho_ty        = ASSERT( length tyvars == length tys )
 422                         substTy (mkTopTyVarSubst tyvars tys) rho
 423         (theta, tau)  = splitRhoTy rho_ty
 424     in
 425     newMethodWith inst_loc real_id tys theta tau        `thenNF_Tc` \ meth_inst ->
 426     returnNF_Tc (meth_inst, instToId meth_inst)
 427 \end{code}
 428
 429 In newOverloadedLit we convert directly to an Int or Integer if we
 430 know that's what we want.  This may save some time, by not
 431 temporarily generating overloaded literals, but it won't catch all
 432 cases (the rest are caught in lookupInst).
 433
 434 \begin{code}
 435 newOverloadedLit :: InstOrigin
 436                  -> HsOverLit
 437                  -> TcType
 438                  -> NF_TcM (TcExpr, LIE)
 439 newOverloadedLit orig (HsIntegral i) ty
 440   | isIntTy ty && inIntRange i          -- Short cut for Int
 441   = returnNF_Tc (int_lit, emptyLIE)
 442
 443   | isIntegerTy ty                      -- Short cut for Integer
 444   = returnNF_Tc (integer_lit, emptyLIE)
 445
 446   where
 447     int_lit     = HsLit (HsInt i)
 448     integer_lit = HsLit (HsInteger i)
 449
 450 newOverloadedLit orig lit ty            -- The general case
 451   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 452     tcGetUnique                 `thenNF_Tc` \ new_uniq ->
 453     let
 454         lit_inst = LitInst lit_id lit ty loc
 455         lit_id   = mkSysLocal SLIT("lit") new_uniq ty
 456     in
 457     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 458 \end{code}
 459
 460
 461 %************************************************************************
 462 %*                                                                      *
 463 \subsection{Zonking}
 464 %*                                                                      *
 465 %************************************************************************
 466
 467 Zonking makes sure that the instance types are fully zonked,
 468 but doesn't do the same for any of the Ids in an Inst.  There's no
 469 need, and it's a lot of extra work.
 470
 471 \begin{code}
 472 zonkInst :: Inst -> NF_TcM Inst
 473 zonkInst (Dict id pred loc)
 474   = zonkTcPredType pred                 `thenNF_Tc` \ new_pred ->
 475     returnNF_Tc (Dict id new_pred loc)
 476
 477 zonkInst (Method m id tys theta tau loc)
 478   = zonkId id                   `thenNF_Tc` \ new_id ->
 479         -- Essential to zonk the id in case it's a local variable
 480         -- Can't use zonkIdOcc because the id might itself be
 481         -- an InstId, in which case it won't be in scope
 482
 483     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 484     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 485     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 486     returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
 487
 488 zonkInst (LitInst id lit ty loc)
 489   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 490     returnNF_Tc (LitInst id lit new_ty loc)
 491
 492 zonkInsts insts = mapNF_Tc zonkInst insts
 493 \end{code}
 494
 495
 496 %************************************************************************
 497 %*                                                                      *
 498 \subsection{Printing}
 499 %*                                                                      *
 500 %************************************************************************
 501
 502 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 503 relevant in error messages.
 504
 505 \begin{code}
 506 instance Outputable Inst where
 507     ppr inst = pprInst inst
 508
 509 pprInst (LitInst u lit ty loc)
 510   = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
 511
 512 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 513
 514 pprInst m@(Method u id tys theta tau loc)
 515   = hsep [ppr id, ptext SLIT("at"),
 516           brackets (interppSP tys) {- ,
 517           ptext SLIT("theta"), ppr theta,
 518           ptext SLIT("tau"), ppr tau
 519           show_uniq u,
 520           ppr (instToId m) -}]
 521
 522 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 523
 524 tidyInst :: TidyEnv -> Inst -> Inst
 525 tidyInst env (LitInst u lit ty loc)          = LitInst u lit (tidyType env ty) loc
 526 tidyInst env (Dict u pred loc)               = Dict u (tidyPred env pred) loc
 527 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
 528
 529 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 530 -- This function doesn't assume that the tyvars are in scope
 531 -- so it works like tidyOpenType, returning a TidyEnv
 532 tidyInsts insts
 533   = (env, map (tidyInst env) insts)
 534   where
 535     env = tidyFreeTyVars emptyTidyEnv (tyVarsOfInsts insts)
 536 \end{code}
 537
 538
 539 %************************************************************************
 540 %*                                                                      *
 541 \subsection{Looking up Insts}
 542 %*                                                                      *
 543 %************************************************************************
 544
 545 \begin{code}
 546 data LookupInstResult s
 547   = NoInstance
 548   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 549   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 550
 551 lookupInst :: Inst
 552            -> NF_TcM (LookupInstResult s)
 553
 554 -- Dictionaries
 555
 556 lookupInst dict@(Dict _ (ClassP clas tys) loc)
 557   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 558     case lookupInstEnv inst_env clas tys of
 559
 560       FoundInst tenv dfun_id
 561         -> let
 562                 (tyvars, rho) = splitForAllTys (idType dfun_id)
 563                 mk_ty_arg tv  = case lookupSubstEnv tenv tv of
 564                                    Just (DoneTy ty) -> returnNF_Tc ty
 565                                    Nothing          -> tcInstTyVar tv   `thenNF_Tc` \ tc_tv ->
 566                                                        returnTc (mkTyVarTy tc_tv)
 567            in
 568            mapNF_Tc mk_ty_arg tyvars    `thenNF_Tc` \ ty_args ->
 569            let
 570                 subst         = mkTyVarSubst tyvars ty_args
 571                 dfun_rho      = substTy subst rho
 572                 (theta, _)    = splitRhoTy dfun_rho
 573                 ty_app        = mkHsTyApp (HsVar dfun_id) ty_args
 574            in
 575            if null theta then
 576                 returnNF_Tc (SimpleInst ty_app)
 577            else
 578            newDictsAtLoc loc theta      `thenNF_Tc` \ dicts ->
 579            let
 580                 rhs = mkHsDictApp ty_app (map instToId dicts)
 581            in
 582            returnNF_Tc (GenInst dicts rhs)
 583
 584       other     -> returnNF_Tc NoInstance
 585
 586 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
 587
 588 -- Methods
 589
 590 lookupInst inst@(Method _ id tys theta _ loc)
 591   = newDictsAtLoc loc theta             `thenNF_Tc` \ dicts ->
 592     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
 593
 594 -- Literals
 595
 596 lookupInst inst@(LitInst u (HsIntegral i) ty loc)
 597   | isIntTy ty && in_int_range                  -- Short cut for Int
 598   = returnNF_Tc (GenInst [] int_lit)
 599         -- GenInst, not SimpleInst, because int_lit is actually a constructor application
 600
 601   | isIntegerTy ty                              -- Short cut for Integer
 602   = returnNF_Tc (GenInst [] integer_lit)
 603
 604   | otherwise                                   -- Alas, it is overloaded and a big literal!
 605   = tcLookupSyntaxId fromIntegerName            `thenNF_Tc` \ from_integer ->
 606     newMethodAtLoc loc from_integer [ty]        `thenNF_Tc` \ (method_inst, method_id) ->
 607     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
 608   where
 609     in_int_range   = inIntRange i
 610     integer_lit    = HsLit (HsInteger i)
 611     int_lit        = HsLit (HsInt i)
 612
 613 -- similar idea for overloaded floating point literals: if the literal is
 614 -- *definitely* a float or a double, generate the real thing here.
 615 -- This is essential  (see nofib/spectral/nucleic).
 616
 617 lookupInst inst@(LitInst u (HsFractional f) ty loc)
 618   | isFloatTy ty    = returnNF_Tc (GenInst [] float_lit)
 619   | isDoubleTy ty   = returnNF_Tc (GenInst [] double_lit)
 620
 621   | otherwise
 622   = tcLookupSyntaxId fromRationalName           `thenNF_Tc` \ from_rational ->
 623     newMethodAtLoc loc from_rational [ty]       `thenNF_Tc` \ (method_inst, method_id) ->
 624     let
 625         rational_ty  = funArgTy (idType method_id)
 626         rational_lit = HsLit (HsRat f rational_ty)
 627     in
 628     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
 629
 630   where
 631     floatprim_lit  = HsLit (HsFloatPrim f)
 632     float_lit      = mkHsConApp floatDataCon [] [floatprim_lit]
 633     doubleprim_lit = HsLit (HsDoublePrim f)
 634     double_lit     = mkHsConApp doubleDataCon [] [doubleprim_lit]
 635 \end{code}
 636
 637 There is a second, simpler interface, when you want an instance of a
 638 class at a given nullary type constructor.  It just returns the
 639 appropriate dictionary if it exists.  It is used only when resolving
 640 ambiguous dictionaries.
 641
 642 \begin{code}
 643 lookupSimpleInst :: Class
 644                  -> [Type]                              -- Look up (c,t)
 645                  -> NF_TcM (Maybe ThetaType)    -- Here are the needed (c,t)s
 646
 647 lookupSimpleInst clas tys
 648   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 649     case lookupInstEnv inst_env clas tys of
 650       FoundInst tenv dfun
 651         -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
 652         where
 653            (_, theta, _) = splitSigmaTy (idType dfun)
 654
 655       other  -> returnNF_Tc Nothing
 656 \end{code}
 657
 658