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 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, 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        = substTy (mkTyVarSubst 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 (HsIntegral i) ty
 437   | isIntTy ty && inIntRange i          -- Short cut for Int
 438   = returnNF_Tc (int_lit, emptyLIE)
 439
 440   | isIntegerTy ty                      -- Short cut for Integer
 441   = returnNF_Tc (integer_lit, emptyLIE)
 442
 443   where
 444     int_lit     = HsLit (HsInt i)
 445     integer_lit = HsLit (HsInteger i)
 446
 447 newOverloadedLit orig lit ty            -- The general case
 448   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 449     tcGetUnique                 `thenNF_Tc` \ new_uniq ->
 450     let
 451         lit_inst = LitInst lit_id lit ty loc
 452         lit_id   = mkSysLocal SLIT("lit") new_uniq ty
 453     in
 454     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 455 \end{code}
 456
 457
 458 %************************************************************************
 459 %*                                                                      *
 460 \subsection{Zonking}
 461 %*                                                                      *
 462 %************************************************************************
 463
 464 Zonking makes sure that the instance types are fully zonked,
 465 but doesn't do the same for any of the Ids in an Inst.  There's no
 466 need, and it's a lot of extra work.
 467
 468 \begin{code}
 469 zonkInst :: Inst -> NF_TcM Inst
 470 zonkInst (Dict id pred loc)
 471   = zonkTcPredType pred                 `thenNF_Tc` \ new_pred ->
 472     returnNF_Tc (Dict id new_pred loc)
 473
 474 zonkInst (Method m id tys theta tau loc)
 475   = zonkId id                   `thenNF_Tc` \ new_id ->
 476         -- Essential to zonk the id in case it's a local variable
 477         -- Can't use zonkIdOcc because the id might itself be
 478         -- an InstId, in which case it won't be in scope
 479
 480     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 481     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 482     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 483     returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
 484
 485 zonkInst (LitInst id lit ty loc)
 486   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 487     returnNF_Tc (LitInst id lit new_ty loc)
 488
 489 zonkInsts insts = mapNF_Tc zonkInst insts
 490 \end{code}
 491
 492
 493 %************************************************************************
 494 %*                                                                      *
 495 \subsection{Printing}
 496 %*                                                                      *
 497 %************************************************************************
 498
 499 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 500 relevant in error messages.
 501
 502 \begin{code}
 503 instance Outputable Inst where
 504     ppr inst = pprInst inst
 505
 506 pprInst (LitInst u lit ty loc)
 507   = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
 508
 509 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 510
 511 pprInst m@(Method u id tys theta tau loc)
 512   = hsep [ppr id, ptext SLIT("at"),
 513           brackets (interppSP tys) {- ,
 514           ptext SLIT("theta"), ppr theta,
 515           ptext SLIT("tau"), ppr tau
 516           show_uniq u,
 517           ppr (instToId m) -}]
 518
 519 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 520
 521 tidyInst :: TidyEnv -> Inst -> Inst
 522 tidyInst env (LitInst u lit ty loc)          = LitInst u lit (tidyType env ty) loc
 523 tidyInst env (Dict u pred loc)               = Dict u (tidyPred env pred) loc
 524 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
 525
 526 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 527 -- This function doesn't assume that the tyvars are in scope
 528 -- so it works like tidyOpenType, returning a TidyEnv
 529 tidyInsts insts
 530   = (env, map (tidyInst env) insts)
 531   where
 532     env = tidyFreeTyVars emptyTidyEnv (tyVarsOfInsts insts)
 533 \end{code}
 534
 535
 536 %************************************************************************
 537 %*                                                                      *
 538 \subsection{Looking up Insts}
 539 %*                                                                      *
 540 %************************************************************************
 541
 542 \begin{code}
 543 data LookupInstResult s
 544   = NoInstance
 545   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 546   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 547
 548 lookupInst :: Inst
 549            -> NF_TcM (LookupInstResult s)
 550
 551 -- Dictionaries
 552
 553 lookupInst dict@(Dict _ (ClassP clas tys) loc)
 554   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 555     case lookupInstEnv inst_env clas tys of
 556
 557       FoundInst tenv dfun_id
 558         -> let
 559                 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
 560                 mk_ty_arg tv  = case lookupSubstEnv tenv tv of
 561                                    Just (DoneTy ty) -> returnNF_Tc ty
 562                                    Nothing          -> tcInstTyVar tv   `thenNF_Tc` \ tc_tv ->
 563                                                        returnTc (mkTyVarTy tc_tv)
 564            in
 565            mapNF_Tc mk_ty_arg tyvars    `thenNF_Tc` \ ty_args ->
 566            let
 567                 subst         = mkTyVarSubst tyvars ty_args
 568                 dfun_rho      = substTy subst rho
 569                 (theta, _)    = tcSplitRhoTy dfun_rho
 570                 ty_app        = mkHsTyApp (HsVar dfun_id) ty_args
 571            in
 572            if null theta then
 573                 returnNF_Tc (SimpleInst ty_app)
 574            else
 575            newDictsAtLoc loc theta      `thenNF_Tc` \ dicts ->
 576            let
 577                 rhs = mkHsDictApp ty_app (map instToId dicts)
 578            in
 579            returnNF_Tc (GenInst dicts rhs)
 580
 581       other     -> returnNF_Tc NoInstance
 582
 583 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
 584
 585 -- Methods
 586
 587 lookupInst inst@(Method _ id tys theta _ loc)
 588   = newDictsAtLoc loc theta             `thenNF_Tc` \ dicts ->
 589     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
 590
 591 -- Literals
 592
 593 lookupInst inst@(LitInst u (HsIntegral i) ty loc)
 594   | isIntTy ty && in_int_range                  -- Short cut for Int
 595   = returnNF_Tc (GenInst [] int_lit)
 596         -- GenInst, not SimpleInst, because int_lit is actually a constructor application
 597
 598   | isIntegerTy ty                              -- Short cut for Integer
 599   = returnNF_Tc (GenInst [] integer_lit)
 600
 601   | otherwise                                   -- Alas, it is overloaded and a big literal!
 602   = tcLookupSyntaxId fromIntegerName            `thenNF_Tc` \ from_integer ->
 603     newMethodAtLoc loc from_integer [ty]        `thenNF_Tc` \ (method_inst, method_id) ->
 604     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
 605   where
 606     in_int_range   = inIntRange i
 607     integer_lit    = HsLit (HsInteger i)
 608     int_lit        = HsLit (HsInt i)
 609
 610 -- similar idea for overloaded floating point literals: if the literal is
 611 -- *definitely* a float or a double, generate the real thing here.
 612 -- This is essential  (see nofib/spectral/nucleic).
 613
 614 lookupInst inst@(LitInst u (HsFractional f) ty loc)
 615   | isFloatTy ty    = returnNF_Tc (GenInst [] float_lit)
 616   | isDoubleTy ty   = returnNF_Tc (GenInst [] double_lit)
 617
 618   | otherwise
 619   = tcLookupSyntaxId fromRationalName           `thenNF_Tc` \ from_rational ->
 620     newMethodAtLoc loc from_rational [ty]       `thenNF_Tc` \ (method_inst, method_id) ->
 621     let
 622         rational_ty  = tcFunArgTy (idType method_id)
 623         rational_lit = HsLit (HsRat f rational_ty)
 624     in
 625     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
 626
 627   where
 628     floatprim_lit  = HsLit (HsFloatPrim f)
 629     float_lit      = mkHsConApp floatDataCon [] [floatprim_lit]
 630     doubleprim_lit = HsLit (HsDoublePrim f)
 631     double_lit     = mkHsConApp doubleDataCon [] [doubleprim_lit]
 632 \end{code}
 633
 634 There is a second, simpler interface, when you want an instance of a
 635 class at a given nullary type constructor.  It just returns the
 636 appropriate dictionary if it exists.  It is used only when resolving
 637 ambiguous dictionaries.
 638
 639 \begin{code}
 640 lookupSimpleInst :: Class
 641                  -> [Type]                      -- Look up (c,t)
 642                  -> NF_TcM (Maybe ThetaType)    -- Here are the needed (c,t)s
 643
 644 lookupSimpleInst clas tys
 645   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 646     case lookupInstEnv inst_env clas tys of
 647       FoundInst tenv dfun
 648         -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
 649         where
 650            (_, rho)  = tcSplitForAllTys (idType dfun)
 651            (theta,_) = tcSplitRhoTy rho
 652
 653       other  -> returnNF_Tc Nothing
 654 \end{code}
 655
 656