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