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, tidyMoreInsts,
  13
  14         newDictsFromOld, newDicts,
  15         newMethod, newMethodWithGivenTy, newOverloadedLit,
  16         newIPDict, tcInstId,
  17
  18         tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
  19         ipNamesOfInst, ipNamesOfInsts, predsOfInst, predsOfInsts,
  20         instLoc, getDictClassTys,
  21
  22         lookupInst, lookupSimpleInst, LookupInstResult(..),
  23
  24         isDict, isClassDict, isMethod,
  25         isTyVarDict, isStdClassTyVarDict, isMethodFor,
  26         instBindingRequired, instCanBeGeneralised,
  27
  28         zonkInst, zonkInsts,
  29         instToId, instName,
  30
  31         InstOrigin(..), InstLoc, pprInstLoc
  32     ) where
  33
  34 #include "HsVersions.h"
  35
  36 import CmdLineOpts ( opt_NoMethodSharing )
  37 import HsSyn    ( HsLit(..), HsOverLit(..), HsExpr(..) )
  38 import TcHsSyn  ( TcExpr, TcId,
  39                   mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
  40                 )
  41 import TcMonad
  42 import TcEnv    ( TcIdSet, tcGetInstEnv, tcLookupId )
  43 import InstEnv  ( InstLookupResult(..), lookupInstEnv )
  44 import TcMType  ( zonkTcType, zonkTcTypes, zonkTcPredType,
  45                   zonkTcThetaType, tcInstTyVar, tcInstType,
  46                 )
  47 import TcType   ( Type, TcType, TcThetaType, TcPredType, TcTauType, TcTyVarSet,
  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                   isClassPred, isTyVarClassPred,
  55                   getClassPredTys, getClassPredTys_maybe, mkPredName,
  56                   tidyType, tidyTypes, tidyFreeTyVars,
  57                   tcCmpType, tcCmpTypes, tcCmpPred,
  58                   IPName, mapIPName, ipNameName
  59                 )
  60 import CoreFVs  ( idFreeTyVars )
  61 import Class    ( Class )
  62 import Id       ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId )
  63 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
  64 import Name     ( Name, mkMethodOcc, getOccName )
  65 import PprType  ( pprPred )
  66 import Subst    ( emptyInScopeSet, mkSubst,
  67                   substTy, substTyWith, substTheta, mkTyVarSubst, mkTopTyVarSubst
  68                 )
  69 import Literal  ( inIntRange )
  70 import VarEnv   ( TidyEnv, lookupSubstEnv, SubstResult(..) )
  71 import VarSet   ( elemVarSet, emptyVarSet, unionVarSet )
  72 import TysWiredIn ( floatDataCon, doubleDataCon )
  73 import PrelNames( fromIntegerName, fromRationalName )
  74 import Util     ( thenCmp, equalLength )
  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 ipNamesOfInsts :: [Inst] -> [Name]
 221 ipNamesOfInst  :: Inst   -> [Name]
 222 -- Get the implicit parameters mentioned by these Insts
 223 -- NB: ?x and %x get different Names
 224
 225 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
 226
 227 ipNamesOfInst (Dict _ (IParam n _) _)  = [ipNameName n]
 228 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
 229 ipNamesOfInst other                    = []
 230
 231 tyVarsOfInst :: Inst -> TcTyVarSet
 232 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
 233 tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
 234 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 235                                          -- The id might have free type variables; in the case of
 236                                          -- locally-overloaded class methods, for example
 237
 238 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 239 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
 240 \end{code}
 241
 242 Predicates
 243 ~~~~~~~~~~
 244 \begin{code}
 245 isDict :: Inst -> Bool
 246 isDict (Dict _ _ _) = True
 247 isDict other        = False
 248
 249 isClassDict :: Inst -> Bool
 250 isClassDict (Dict _ pred _) = isClassPred pred
 251 isClassDict other           = False
 252
 253 isTyVarDict :: Inst -> Bool
 254 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
 255 isTyVarDict other           = False
 256
 257 isMethod :: Inst -> Bool
 258 isMethod (Method _ _ _ _ _ _) = True
 259 isMethod other                = False
 260
 261 isMethodFor :: TcIdSet -> Inst -> Bool
 262 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
 263 isMethodFor ids inst                         = 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 other                      = True
 279
 280 instCanBeGeneralised :: Inst -> Bool
 281 instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas)
 282 instCanBeGeneralised other                      = True
 283 \end{code}
 284
 285
 286 %************************************************************************
 287 %*                                                                      *
 288 \subsection{Building dictionaries}
 289 %*                                                                      *
 290 %************************************************************************
 291
 292 \begin{code}
 293 newDicts :: InstOrigin
 294          -> TcThetaType
 295          -> NF_TcM [Inst]
 296 newDicts orig theta
 297   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 298     newDictsAtLoc loc theta
 299
 300 newDictsFromOld :: Inst -> TcThetaType -> NF_TcM [Inst]
 301 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
 302
 303 -- Local function, similar to newDicts,
 304 -- but with slightly different interface
 305 newDictsAtLoc :: InstLoc
 306               -> TcThetaType
 307               -> NF_TcM [Inst]
 308 newDictsAtLoc inst_loc@(_,loc,_) theta
 309   = tcGetUniques                        `thenNF_Tc` \ new_uniqs ->
 310     returnNF_Tc (zipWith mk_dict new_uniqs theta)
 311   where
 312     mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
 313
 314 -- For vanilla implicit parameters, there is only one in scope
 315 -- at any time, so we used to use the name of the implicit parameter itself
 316 -- But with splittable implicit parameters there may be many in
 317 -- scope, so we make up a new name.
 318 newIPDict :: InstOrigin -> IPName Name -> Type
 319           -> NF_TcM (IPName Id, Inst)
 320 newIPDict orig ip_name ty
 321   = tcGetInstLoc orig                   `thenNF_Tc` \ inst_loc@(_,loc,_) ->
 322     tcGetUnique                         `thenNF_Tc` \ uniq ->
 323     let
 324         pred = IParam ip_name ty
 325         id   = mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)
 326     in
 327     returnNF_Tc (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
 328 \end{code}
 329
 330
 331 %************************************************************************
 332 %*                                                                      *
 333 \subsection{Building methods (calls of overloaded functions)}
 334 %*                                                                      *
 335 %************************************************************************
 336
 337 tcInstId instantiates an occurrence of an Id.
 338 The instantiate_it loop runs round instantiating the Id.
 339 It has to be a loop because we are now prepared to entertain
 340 types like
 341         f:: forall a. Eq a => forall b. Baz b => tau
 342 We want to instantiate this to
 343         f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 344
 345 The -fno-method-sharing flag controls what happens so far as the LIE
 346 is concerned.  The default case is that for an overloaded function we
 347 generate a "method" Id, and add the Method Inst to the LIE.  So you get
 348 something like
 349         f :: Num a => a -> a
 350         f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
 351 If you specify -fno-method-sharing, the dictionary application
 352 isn't shared, so we get
 353         f :: Num a => a -> a
 354         f = /\a (d:Num a) (x:a) -> (+) a d x x
 355 This gets a bit less sharing, but
 356         a) it's better for RULEs involving overloaded functions
 357         b) perhaps fewer separated lambdas
 358
 359
 360 \begin{code}
 361 tcInstId :: Id -> NF_TcM (TcExpr, LIE, TcType)
 362 tcInstId fun
 363   | opt_NoMethodSharing  = loop_noshare (HsVar fun) (idType fun)
 364   | otherwise            = loop_share fun
 365   where
 366     orig = OccurrenceOf fun
 367     loop_noshare fun fun_ty
 368       = tcInstType fun_ty               `thenNF_Tc` \ (tyvars, theta, tau) ->
 369         let
 370             ty_app = mkHsTyApp fun (mkTyVarTys tyvars)
 371         in
 372         if null theta then              -- Is it overloaded?
 373             returnNF_Tc (ty_app, emptyLIE, tau)
 374         else
 375             newDicts orig theta                                         `thenNF_Tc` \ dicts ->
 376             loop_noshare (mkHsDictApp ty_app (map instToId dicts)) tau  `thenNF_Tc` \ (expr, lie, final_tau) ->
 377             returnNF_Tc (expr, mkLIE dicts `plusLIE` lie, final_tau)
 378
 379     loop_share fun
 380       = tcInstType (idType fun)         `thenNF_Tc` \ (tyvars, theta, tau) ->
 381         let
 382             arg_tys = mkTyVarTys tyvars
 383         in
 384         if null theta then              -- Is it overloaded?
 385             returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
 386         else
 387                 -- Yes, it's overloaded
 388             newMethodWithGivenTy orig fun arg_tys theta tau     `thenNF_Tc` \ meth ->
 389             loop_share (instToId meth)                          `thenNF_Tc` \ (expr, lie, final_tau) ->
 390             returnNF_Tc (expr, unitLIE meth `plusLIE` lie, final_tau)
 391
 392
 393 newMethod :: InstOrigin
 394           -> TcId
 395           -> [TcType]
 396           -> NF_TcM Inst
 397 newMethod orig id tys
 398   =     -- Get the Id type and instantiate it at the specified types
 399     let
 400         (tyvars, rho) = tcSplitForAllTys (idType id)
 401         rho_ty        = substTyWith tyvars tys rho
 402         (pred, tau)   = tcSplitMethodTy rho_ty
 403     in
 404     newMethodWithGivenTy orig id tys [pred] tau
 405
 406 newMethodWithGivenTy orig id tys theta tau
 407   = tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 408     newMethodWith loc id tys theta tau
 409
 410 newMethodWith inst_loc@(_,loc,_) id tys theta tau
 411   = tcGetUnique         `thenNF_Tc` \ new_uniq ->
 412     let
 413         meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 414     in
 415     returnNF_Tc (Method meth_id id tys theta tau inst_loc)
 416
 417 newMethodAtLoc :: InstLoc
 418                -> Id -> [TcType]
 419                -> NF_TcM (Inst, TcId)
 420 newMethodAtLoc inst_loc real_id tys
 421         -- This actually builds the Inst
 422   =     -- Get the Id type and instantiate it at the specified types
 423     let
 424         (tyvars,rho)  = tcSplitForAllTys (idType real_id)
 425         rho_ty        = ASSERT( equalLength tyvars tys )
 426                         substTy (mkTopTyVarSubst tyvars tys) rho
 427         (theta, tau)  = tcSplitRhoTy rho_ty
 428     in
 429     newMethodWith inst_loc real_id tys theta tau        `thenNF_Tc` \ meth_inst ->
 430     returnNF_Tc (meth_inst, instToId meth_inst)
 431 \end{code}
 432
 433 In newOverloadedLit we convert directly to an Int or Integer if we
 434 know that's what we want.  This may save some time, by not
 435 temporarily generating overloaded literals, but it won't catch all
 436 cases (the rest are caught in lookupInst).
 437
 438 \begin{code}
 439 newOverloadedLit :: InstOrigin
 440                  -> HsOverLit
 441                  -> TcType
 442                  -> NF_TcM (TcExpr, LIE)
 443 newOverloadedLit orig lit ty
 444   | Just expr <- shortCutLit lit ty
 445   = returnNF_Tc (expr, emptyLIE)
 446
 447   | otherwise
 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
 456 shortCutLit :: HsOverLit -> TcType -> Maybe TcExpr
 457 shortCutLit (HsIntegral i fi) ty
 458   | isIntTy ty && inIntRange i && fi == fromIntegerName         -- Short cut for Int
 459   = Just (HsLit (HsInt i))
 460   | isIntegerTy ty && fi == fromIntegerName                     -- Short cut for Integer
 461   = Just (HsLit (HsInteger i))
 462
 463 shortCutLit (HsFractional f fr) ty
 464   | isFloatTy ty  && fr == fromRationalName
 465   = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
 466   | isDoubleTy ty && fr == fromRationalName
 467   = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
 468
 469 shortCutLit lit ty
 470   = Nothing
 471 \end{code}
 472
 473
 474 %************************************************************************
 475 %*                                                                      *
 476 \subsection{Zonking}
 477 %*                                                                      *
 478 %************************************************************************
 479
 480 Zonking makes sure that the instance types are fully zonked,
 481 but doesn't do the same for any of the Ids in an Inst.  There's no
 482 need, and it's a lot of extra work.
 483
 484 \begin{code}
 485 zonkInst :: Inst -> NF_TcM Inst
 486 zonkInst (Dict id pred loc)
 487   = zonkTcPredType pred                 `thenNF_Tc` \ new_pred ->
 488     returnNF_Tc (Dict id new_pred loc)
 489
 490 zonkInst (Method m id tys theta tau loc)
 491   = zonkId id                   `thenNF_Tc` \ new_id ->
 492         -- Essential to zonk the id in case it's a local variable
 493         -- Can't use zonkIdOcc because the id might itself be
 494         -- an InstId, in which case it won't be in scope
 495
 496     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 497     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 498     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 499     returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
 500
 501 zonkInst (LitInst id lit ty loc)
 502   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 503     returnNF_Tc (LitInst id lit new_ty loc)
 504
 505 zonkInsts insts = mapNF_Tc zonkInst insts
 506 \end{code}
 507
 508
 509 %************************************************************************
 510 %*                                                                      *
 511 \subsection{Printing}
 512 %*                                                                      *
 513 %************************************************************************
 514
 515 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 516 relevant in error messages.
 517
 518 \begin{code}
 519 instance Outputable Inst where
 520     ppr inst = pprInst inst
 521
 522 pprInst (LitInst u lit ty loc)
 523   = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
 524
 525 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 526
 527 pprInst m@(Method u id tys theta tau loc)
 528   = hsep [ppr id, ptext SLIT("at"),
 529           brackets (interppSP tys) {- ,
 530           ptext SLIT("theta"), ppr theta,
 531           ptext SLIT("tau"), ppr tau
 532           show_uniq u,
 533           ppr (instToId m) -}]
 534
 535 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 536
 537 tidyInst :: TidyEnv -> Inst -> Inst
 538 tidyInst env (LitInst u lit ty loc)          = LitInst u lit (tidyType env ty) loc
 539 tidyInst env (Dict u pred loc)               = Dict u (tidyPred env pred) loc
 540 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
 541
 542 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
 543 -- This function doesn't assume that the tyvars are in scope
 544 -- so it works like tidyOpenType, returning a TidyEnv
 545 tidyMoreInsts env insts
 546   = (env', map (tidyInst env') insts)
 547   where
 548     env' = tidyFreeTyVars env (tyVarsOfInsts insts)
 549
 550 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 551 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
 552 \end{code}
 553
 554
 555 %************************************************************************
 556 %*                                                                      *
 557 \subsection{Looking up Insts}
 558 %*                                                                      *
 559 %************************************************************************
 560
 561 \begin{code}
 562 data LookupInstResult s
 563   = NoInstance
 564   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 565   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 566
 567 lookupInst :: Inst
 568            -> NF_TcM (LookupInstResult s)
 569
 570 -- Dictionaries
 571
 572 lookupInst dict@(Dict _ (ClassP clas tys) loc)
 573   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 574     case lookupInstEnv inst_env clas tys of
 575
 576       FoundInst tenv dfun_id
 577         -> let
 578                 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
 579                 mk_ty_arg tv  = case lookupSubstEnv tenv tv of
 580                                    Just (DoneTy ty) -> returnNF_Tc ty
 581                                    Nothing          -> tcInstTyVar tv   `thenNF_Tc` \ tc_tv ->
 582                                                        returnTc (mkTyVarTy tc_tv)
 583            in
 584            mapNF_Tc mk_ty_arg tyvars    `thenNF_Tc` \ ty_args ->
 585            let
 586                 subst         = mkTyVarSubst tyvars ty_args
 587                 dfun_rho      = substTy subst rho
 588                 (theta, _)    = tcSplitRhoTy dfun_rho
 589                 ty_app        = mkHsTyApp (HsVar dfun_id) ty_args
 590            in
 591            if null theta then
 592                 returnNF_Tc (SimpleInst ty_app)
 593            else
 594            newDictsAtLoc loc theta      `thenNF_Tc` \ dicts ->
 595            let
 596                 rhs = mkHsDictApp ty_app (map instToId dicts)
 597            in
 598            returnNF_Tc (GenInst dicts rhs)
 599
 600       other     -> returnNF_Tc NoInstance
 601
 602 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
 603
 604 -- Methods
 605
 606 lookupInst inst@(Method _ id tys theta _ loc)
 607   = newDictsAtLoc loc theta             `thenNF_Tc` \ dicts ->
 608     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
 609
 610 -- Literals
 611
 612 -- Look for short cuts first: if the literal is *definitely* a
 613 -- int, integer, float or a double, generate the real thing here.
 614 -- This is essential  (see nofib/spectral/nucleic).
 615 -- [Same shortcut as in newOverloadedLit, but we
 616 --  may have done some unification by now]
 617
 618 lookupInst inst@(LitInst u lit ty loc)
 619   | Just expr <- shortCutLit lit ty
 620   = returnNF_Tc (GenInst [] expr)       -- GenInst, not SimpleInst, because
 621                                         -- expr may be a constructor application
 622
 623 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
 624   = tcLookupId from_integer_name                `thenNF_Tc` \ from_integer ->
 625     newMethodAtLoc loc from_integer [ty]        `thenNF_Tc` \ (method_inst, method_id) ->
 626     returnNF_Tc (GenInst [method_inst]
 627                          (HsApp (HsVar method_id) (HsLit (HsInteger i))))
 628
 629
 630 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
 631   = tcLookupId from_rat_name                    `thenNF_Tc` \ from_rational ->
 632     newMethodAtLoc loc from_rational [ty]       `thenNF_Tc` \ (method_inst, method_id) ->
 633     let
 634         rational_ty  = tcFunArgTy (idType method_id)
 635         rational_lit = HsLit (HsRat f rational_ty)
 636     in
 637     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
 638 \end{code}
 639
 640 There is a second, simpler interface, when you want an instance of a
 641 class at a given nullary type constructor.  It just returns the
 642 appropriate dictionary if it exists.  It is used only when resolving
 643 ambiguous dictionaries.
 644
 645 \begin{code}
 646 lookupSimpleInst :: Class
 647                  -> [Type]                      -- Look up (c,t)
 648                  -> NF_TcM (Maybe ThetaType)    -- Here are the needed (c,t)s
 649
 650 lookupSimpleInst clas tys
 651   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 652     case lookupInstEnv inst_env clas tys of
 653       FoundInst tenv dfun
 654         -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
 655         where
 656            (_, rho)  = tcSplitForAllTys (idType dfun)
 657            (theta,_) = tcSplitRhoTy rho
 658
 659       other  -> returnNF_Tc Nothing
 660 \end{code}