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 PprType  ( pprPred )
  65 import Subst    ( emptyInScopeSet, mkSubst,
  66                   substTy, substTyWith, substTheta, mkTyVarSubst, mkTopTyVarSubst
  67                 )
  68 import Literal  ( inIntRange )
  69 import VarEnv   ( TidyEnv, lookupSubstEnv, SubstResult(..) )
  70 import VarSet   ( elemVarSet, emptyVarSet, unionVarSet )
  71 import TysWiredIn ( floatDataCon, doubleDataCon )
  72 import PrelNames( fromIntegerName, fromRationalName )
  73 import Util     ( thenCmp, equalLength )
  74 import Bag
  75 import Outputable
  76 \end{code}
  77
  78 %************************************************************************
  79 %*                                                                      *
  80 \subsection[Inst-collections]{LIE: a collection of Insts}
  81 %*                                                                      *
  82 %************************************************************************
  83
  84 \begin{code}
  85 type LIE = Bag Inst
  86
  87 isEmptyLIE        = isEmptyBag
  88 emptyLIE          = emptyBag
  89 unitLIE inst      = unitBag inst
  90 mkLIE insts       = listToBag insts
  91 plusLIE lie1 lie2 = lie1 `unionBags` lie2
  92 consLIE inst lie  = inst `consBag` lie
  93 plusLIEs lies     = unionManyBags lies
  94 lieToList         = bagToList
  95 listToLIE         = listToBag
  96
  97 zonkLIE :: LIE -> NF_TcM LIE
  98 zonkLIE lie = mapBagNF_Tc zonkInst lie
  99
 100 pprInsts :: [Inst] -> SDoc
 101 pprInsts insts  = parens (sep (punctuate comma (map pprInst insts)))
 102
 103
 104 pprInstsInFull insts
 105   = vcat (map go insts)
 106   where
 107     go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
 108 \end{code}
 109
 110 %************************************************************************
 111 %*                                                                      *
 112 \subsection[Inst-types]{@Inst@ types}
 113 %*                                                                      *
 114 %************************************************************************
 115
 116 An @Inst@ is either a dictionary, an instance of an overloaded
 117 literal, or an instance of an overloaded value.  We call the latter a
 118 ``method'' even though it may not correspond to a class operation.
 119 For example, we might have an instance of the @double@ function at
 120 type Int, represented by
 121
 122         Method 34 doubleId [Int] origin
 123
 124 \begin{code}
 125 data Inst
 126   = Dict
 127         Id
 128         TcPredType
 129         InstLoc
 130
 131   | Method
 132         Id
 133
 134         TcId    -- The overloaded function
 135                         -- This function will be a global, local, or ClassOpId;
 136                         --   inside instance decls (only) it can also be an InstId!
 137                         -- The id needn't be completely polymorphic.
 138                         -- You'll probably find its name (for documentation purposes)
 139                         --        inside the InstOrigin
 140
 141         [TcType]        -- The types to which its polymorphic tyvars
 142                         --      should be instantiated.
 143                         -- These types must saturate the Id's foralls.
 144
 145         TcThetaType     -- The (types of the) dictionaries to which the function
 146                         -- must be applied to get the method
 147
 148         TcTauType       -- The type of the method
 149
 150         InstLoc
 151
 152         -- INVARIANT: in (Method u f tys theta tau loc)
 153         --      type of (f tys dicts(from theta)) = tau
 154
 155   | LitInst
 156         Id
 157         HsOverLit       -- The literal from the occurrence site
 158         TcType          -- The type at which the literal is used
 159         InstLoc
 160 \end{code}
 161
 162 Ordering
 163 ~~~~~~~~
 164 @Insts@ are ordered by their class/type info, rather than by their
 165 unique.  This allows the context-reduction mechanism to use standard finite
 166 maps to do their stuff.
 167
 168 \begin{code}
 169 instance Ord Inst where
 170   compare = cmpInst
 171
 172 instance Eq Inst where
 173   (==) i1 i2 = case i1 `cmpInst` i2 of
 174                  EQ    -> True
 175                  other -> False
 176
 177 cmpInst (Dict _ pred1 _)          (Dict _ pred2 _)          = pred1 `tcCmpPred` pred2
 178 cmpInst (Dict _ _ _)              other                     = LT
 179
 180 cmpInst (Method _ _ _ _ _ _)      (Dict _ _ _)              = GT
 181 cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `tcCmpTypes` tys2)
 182 cmpInst (Method _ _ _ _ _ _)      other                     = LT
 183
 184 cmpInst (LitInst _ lit1 ty1 _)    (LitInst _ lit2 ty2 _)    = (lit1 `compare` lit2) `thenCmp` (ty1 `tcCmpType` ty2)
 185 cmpInst (LitInst _ _ _ _)         other                     = GT
 186
 187 -- and they can only have HsInt or HsFracs in them.
 188 \end{code}
 189
 190
 191 Selection
 192 ~~~~~~~~~
 193 \begin{code}
 194 instName :: Inst -> Name
 195 instName inst = idName (instToId inst)
 196
 197 instToId :: Inst -> TcId
 198 instToId (Dict id _ _)         = id
 199 instToId (Method id _ _ _ _ _) = id
 200 instToId (LitInst id _ _ _)    = id
 201
 202 instLoc (Dict _ _         loc) = loc
 203 instLoc (Method _ _ _ _ _ loc) = loc
 204 instLoc (LitInst _ _ _    loc) = loc
 205
 206 getDictClassTys (Dict _ pred _) = getClassPredTys pred
 207
 208 predsOfInsts :: [Inst] -> [PredType]
 209 predsOfInsts insts = concatMap predsOfInst insts
 210
 211 predsOfInst (Dict _ pred _)          = [pred]
 212 predsOfInst (Method _ _ _ theta _ _) = theta
 213 predsOfInst (LitInst _ _ _ _)        = []
 214         -- The last case is is really a big cheat
 215         -- LitInsts to give rise to a (Num a) or (Fractional a) predicate
 216         -- But Num and Fractional have only one parameter and no functional
 217         -- dependencies, so I think no caller of predsOfInst will care.
 218
 219 ipNamesOfInsts :: [Inst] -> [Name]
 220 ipNamesOfInst  :: Inst   -> [Name]
 221 -- Get the implicit parameters mentioned by these Insts
 222
 223 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
 224
 225 ipNamesOfInst (Dict _ (IParam n _) _)  = [n]
 226 ipNamesOfInst (Method _ _ _ theta _ _) = [n | IParam n _ <- theta]
 227 ipNamesOfInst other                    = []
 228
 229 tyVarsOfInst :: Inst -> TcTyVarSet
 230 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
 231 tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
 232 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 233                                          -- The id might have free type variables; in the case of
 234                                          -- locally-overloaded class methods, for example
 235
 236 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 237 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
 238 \end{code}
 239
 240 Predicates
 241 ~~~~~~~~~~
 242 \begin{code}
 243 isDict :: Inst -> Bool
 244 isDict (Dict _ _ _) = True
 245 isDict other        = False
 246
 247 isClassDict :: Inst -> Bool
 248 isClassDict (Dict _ pred _) = isClassPred pred
 249 isClassDict other           = False
 250
 251 isTyVarDict :: Inst -> Bool
 252 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
 253 isTyVarDict other           = False
 254
 255 isMethod :: Inst -> Bool
 256 isMethod (Method _ _ _ _ _ _) = True
 257 isMethod other                = False
 258
 259 isMethodFor :: TcIdSet -> Inst -> Bool
 260 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
 261 isMethodFor ids inst                         = False
 262
 263 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
 264                                         Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
 265                                         other             -> False
 266 \end{code}
 267
 268 Two predicates which deal with the case where class constraints don't
 269 necessarily result in bindings.  The first tells whether an @Inst@
 270 must be witnessed by an actual binding; the second tells whether an
 271 @Inst@ can be generalised over.
 272
 273 \begin{code}
 274 instBindingRequired :: Inst -> Bool
 275 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
 276 instBindingRequired (Dict _ (IParam _ _) _)    = False
 277 instBindingRequired other                      = True
 278
 279 instCanBeGeneralised :: Inst -> Bool
 280 instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas)
 281 instCanBeGeneralised other                      = True
 282 \end{code}
 283
 284
 285 %************************************************************************
 286 %*                                                                      *
 287 \subsection{Building dictionaries}
 288 %*                                                                      *
 289 %************************************************************************
 290
 291 \begin{code}
 292 newDicts :: InstOrigin
 293          -> TcThetaType
 294          -> NF_TcM [Inst]
 295 newDicts orig theta
 296   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 297     newDictsAtLoc loc theta
 298
 299 newDictsFromOld :: Inst -> TcThetaType -> NF_TcM [Inst]
 300 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
 301
 302 -- Local function, similar to newDicts,
 303 -- but with slightly different interface
 304 newDictsAtLoc :: InstLoc
 305               -> TcThetaType
 306               -> NF_TcM [Inst]
 307 newDictsAtLoc inst_loc@(_,loc,_) theta
 308   = tcGetUniques                        `thenNF_Tc` \ new_uniqs ->
 309     returnNF_Tc (zipWith mk_dict new_uniqs theta)
 310   where
 311     mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
 312
 313 -- For implicit parameters, since there is only one in scope
 314 -- at any time, we use the name of the implicit parameter itself
 315 newIPDict orig name ty
 316   = tcGetInstLoc orig                   `thenNF_Tc` \ inst_loc ->
 317     returnNF_Tc (Dict (mkLocalId name (mkPredTy pred)) pred inst_loc)
 318   where pred = IParam name ty
 319 \end{code}
 320
 321
 322 %************************************************************************
 323 %*                                                                      *
 324 \subsection{Building methods (calls of overloaded functions)}
 325 %*                                                                      *
 326 %************************************************************************
 327
 328 tcInstId instantiates an occurrence of an Id.
 329 The instantiate_it loop runs round instantiating the Id.
 330 It has to be a loop because we are now prepared to entertain
 331 types like
 332         f:: forall a. Eq a => forall b. Baz b => tau
 333 We want to instantiate this to
 334         f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 335
 336 The -fno-method-sharing flag controls what happens so far as the LIE
 337 is concerned.  The default case is that for an overloaded function we
 338 generate a "method" Id, and add the Method Inst to the LIE.  So you get
 339 something like
 340         f :: Num a => a -> a
 341         f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
 342 If you specify -fno-method-sharing, the dictionary application
 343 isn't shared, so we get
 344         f :: Num a => a -> a
 345         f = /\a (d:Num a) (x:a) -> (+) a d x x
 346 This gets a bit less sharing, but
 347         a) it's better for RULEs involving overloaded functions
 348         b) perhaps fewer separated lambdas
 349
 350
 351 \begin{code}
 352 tcInstId :: Id -> NF_TcM (TcExpr, LIE, TcType)
 353 tcInstId fun
 354   | opt_NoMethodSharing  = loop_noshare (HsVar fun) (idType fun)
 355   | otherwise            = loop_share fun
 356   where
 357     orig = OccurrenceOf fun
 358     loop_noshare fun fun_ty
 359       = tcInstType fun_ty               `thenNF_Tc` \ (tyvars, theta, tau) ->
 360         let
 361             ty_app = mkHsTyApp fun (mkTyVarTys tyvars)
 362         in
 363         if null theta then              -- Is it overloaded?
 364             returnNF_Tc (ty_app, emptyLIE, tau)
 365         else
 366             newDicts orig theta                                         `thenNF_Tc` \ dicts ->
 367             loop_noshare (mkHsDictApp ty_app (map instToId dicts)) tau  `thenNF_Tc` \ (expr, lie, final_tau) ->
 368             returnNF_Tc (expr, mkLIE dicts `plusLIE` lie, final_tau)
 369
 370     loop_share fun
 371       = tcInstType (idType fun)         `thenNF_Tc` \ (tyvars, theta, tau) ->
 372         let
 373             arg_tys = mkTyVarTys tyvars
 374         in
 375         if null theta then              -- Is it overloaded?
 376             returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
 377         else
 378                 -- Yes, it's overloaded
 379             newMethodWithGivenTy orig fun arg_tys theta tau     `thenNF_Tc` \ meth ->
 380             loop_share (instToId meth)                          `thenNF_Tc` \ (expr, lie, final_tau) ->
 381             returnNF_Tc (expr, unitLIE meth `plusLIE` lie, final_tau)
 382
 383
 384 newMethod :: InstOrigin
 385           -> TcId
 386           -> [TcType]
 387           -> NF_TcM Inst
 388 newMethod orig id tys
 389   =     -- Get the Id type and instantiate it at the specified types
 390     let
 391         (tyvars, rho) = tcSplitForAllTys (idType id)
 392         rho_ty        = substTyWith tyvars tys rho
 393         (pred, tau)   = tcSplitMethodTy rho_ty
 394     in
 395     newMethodWithGivenTy orig id tys [pred] tau
 396
 397 newMethodWithGivenTy orig id tys theta tau
 398   = tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 399     newMethodWith loc id tys theta tau
 400
 401 newMethodWith inst_loc@(_,loc,_) id tys theta tau
 402   = tcGetUnique         `thenNF_Tc` \ new_uniq ->
 403     let
 404         meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 405     in
 406     returnNF_Tc (Method meth_id id tys theta tau inst_loc)
 407
 408 newMethodAtLoc :: InstLoc
 409                -> Id -> [TcType]
 410                -> NF_TcM (Inst, TcId)
 411 newMethodAtLoc inst_loc real_id tys
 412         -- This actually builds the Inst
 413   =     -- Get the Id type and instantiate it at the specified types
 414     let
 415         (tyvars,rho)  = tcSplitForAllTys (idType real_id)
 416         rho_ty        = ASSERT( equalLength tyvars tys )
 417                         substTy (mkTopTyVarSubst tyvars tys) rho
 418         (theta, tau)  = tcSplitRhoTy rho_ty
 419     in
 420     newMethodWith inst_loc real_id tys theta tau        `thenNF_Tc` \ meth_inst ->
 421     returnNF_Tc (meth_inst, instToId meth_inst)
 422 \end{code}
 423
 424 In newOverloadedLit we convert directly to an Int or Integer if we
 425 know that's what we want.  This may save some time, by not
 426 temporarily generating overloaded literals, but it won't catch all
 427 cases (the rest are caught in lookupInst).
 428
 429 \begin{code}
 430 newOverloadedLit :: InstOrigin
 431                  -> HsOverLit
 432                  -> TcType
 433                  -> NF_TcM (TcExpr, LIE)
 434 newOverloadedLit orig lit ty
 435   | Just expr <- shortCutLit lit ty
 436   = returnNF_Tc (expr, emptyLIE)
 437
 438   | otherwise
 439   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 440     tcGetUnique                 `thenNF_Tc` \ new_uniq ->
 441     let
 442         lit_inst = LitInst lit_id lit ty loc
 443         lit_id   = mkSysLocal SLIT("lit") new_uniq ty
 444     in
 445     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 446
 447 shortCutLit :: HsOverLit -> TcType -> Maybe TcExpr
 448 shortCutLit (HsIntegral i fi) ty
 449   | isIntTy ty && inIntRange i && fi == fromIntegerName         -- Short cut for Int
 450   = Just (HsLit (HsInt i))
 451   | isIntegerTy ty && fi == fromIntegerName                     -- Short cut for Integer
 452   = Just (HsLit (HsInteger i))
 453
 454 shortCutLit (HsFractional f fr) ty
 455   | isFloatTy ty  && fr == fromRationalName
 456   = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
 457   | isDoubleTy ty && fr == fromRationalName
 458   = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
 459
 460 shortCutLit lit ty
 461   = Nothing
 462 \end{code}
 463
 464
 465 %************************************************************************
 466 %*                                                                      *
 467 \subsection{Zonking}
 468 %*                                                                      *
 469 %************************************************************************
 470
 471 Zonking makes sure that the instance types are fully zonked,
 472 but doesn't do the same for any of the Ids in an Inst.  There's no
 473 need, and it's a lot of extra work.
 474
 475 \begin{code}
 476 zonkInst :: Inst -> NF_TcM Inst
 477 zonkInst (Dict id pred loc)
 478   = zonkTcPredType pred                 `thenNF_Tc` \ new_pred ->
 479     returnNF_Tc (Dict id new_pred loc)
 480
 481 zonkInst (Method m id tys theta tau loc)
 482   = zonkId id                   `thenNF_Tc` \ new_id ->
 483         -- Essential to zonk the id in case it's a local variable
 484         -- Can't use zonkIdOcc because the id might itself be
 485         -- an InstId, in which case it won't be in scope
 486
 487     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 488     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 489     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 490     returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
 491
 492 zonkInst (LitInst id lit ty loc)
 493   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 494     returnNF_Tc (LitInst id lit new_ty loc)
 495
 496 zonkInsts insts = mapNF_Tc zonkInst insts
 497 \end{code}
 498
 499
 500 %************************************************************************
 501 %*                                                                      *
 502 \subsection{Printing}
 503 %*                                                                      *
 504 %************************************************************************
 505
 506 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 507 relevant in error messages.
 508
 509 \begin{code}
 510 instance Outputable Inst where
 511     ppr inst = pprInst inst
 512
 513 pprInst (LitInst u lit ty loc)
 514   = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
 515
 516 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 517
 518 pprInst m@(Method u id tys theta tau loc)
 519   = hsep [ppr id, ptext SLIT("at"),
 520           brackets (interppSP tys) {- ,
 521           ptext SLIT("theta"), ppr theta,
 522           ptext SLIT("tau"), ppr tau
 523           show_uniq u,
 524           ppr (instToId m) -}]
 525
 526 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 527
 528 tidyInst :: TidyEnv -> Inst -> Inst
 529 tidyInst env (LitInst u lit ty loc)          = LitInst u lit (tidyType env ty) loc
 530 tidyInst env (Dict u pred loc)               = Dict u (tidyPred env pred) loc
 531 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
 532
 533 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
 534 -- This function doesn't assume that the tyvars are in scope
 535 -- so it works like tidyOpenType, returning a TidyEnv
 536 tidyMoreInsts env insts
 537   = (env', map (tidyInst env') insts)
 538   where
 539     env' = tidyFreeTyVars env (tyVarsOfInsts insts)
 540
 541 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 542 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
 543 \end{code}
 544
 545
 546 %************************************************************************
 547 %*                                                                      *
 548 \subsection{Looking up Insts}
 549 %*                                                                      *
 550 %************************************************************************
 551
 552 \begin{code}
 553 data LookupInstResult s
 554   = NoInstance
 555   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 556   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 557
 558 lookupInst :: Inst
 559            -> NF_TcM (LookupInstResult s)
 560
 561 -- Dictionaries
 562
 563 lookupInst dict@(Dict _ (ClassP clas tys) loc)
 564   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 565     case lookupInstEnv inst_env clas tys of
 566
 567       FoundInst tenv dfun_id
 568         -> let
 569                 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
 570                 mk_ty_arg tv  = case lookupSubstEnv tenv tv of
 571                                    Just (DoneTy ty) -> returnNF_Tc ty
 572                                    Nothing          -> tcInstTyVar tv   `thenNF_Tc` \ tc_tv ->
 573                                                        returnTc (mkTyVarTy tc_tv)
 574            in
 575            mapNF_Tc mk_ty_arg tyvars    `thenNF_Tc` \ ty_args ->
 576            let
 577                 subst         = mkTyVarSubst tyvars ty_args
 578                 dfun_rho      = substTy subst rho
 579                 (theta, _)    = tcSplitRhoTy dfun_rho
 580                 ty_app        = mkHsTyApp (HsVar dfun_id) ty_args
 581            in
 582            if null theta then
 583                 returnNF_Tc (SimpleInst ty_app)
 584            else
 585            newDictsAtLoc loc theta      `thenNF_Tc` \ dicts ->
 586            let
 587                 rhs = mkHsDictApp ty_app (map instToId dicts)
 588            in
 589            returnNF_Tc (GenInst dicts rhs)
 590
 591       other     -> returnNF_Tc NoInstance
 592
 593 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
 594
 595 -- Methods
 596
 597 lookupInst inst@(Method _ id tys theta _ loc)
 598   = newDictsAtLoc loc theta             `thenNF_Tc` \ dicts ->
 599     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
 600
 601 -- Literals
 602
 603 -- Look for short cuts first: if the literal is *definitely* a
 604 -- int, integer, float or a double, generate the real thing here.
 605 -- This is essential  (see nofib/spectral/nucleic).
 606 -- [Same shortcut as in newOverloadedLit, but we
 607 --  may have done some unification by now]
 608
 609 lookupInst inst@(LitInst u lit ty loc)
 610   | Just expr <- shortCutLit lit ty
 611   = returnNF_Tc (GenInst [] expr)       -- GenInst, not SimpleInst, because
 612                                         -- expr may be a constructor application
 613
 614 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
 615   = tcLookupId from_integer_name                `thenNF_Tc` \ from_integer ->
 616     newMethodAtLoc loc from_integer [ty]        `thenNF_Tc` \ (method_inst, method_id) ->
 617     returnNF_Tc (GenInst [method_inst]
 618                          (HsApp (HsVar method_id) (HsLit (HsInteger i))))
 619
 620
 621 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
 622   = tcLookupId from_rat_name                    `thenNF_Tc` \ from_rational ->
 623     newMethodAtLoc loc from_rational [ty]       `thenNF_Tc` \ (method_inst, method_id) ->
 624     let
 625         rational_ty  = tcFunArgTy (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 \end{code}
 630
 631 There is a second, simpler interface, when you want an instance of a
 632 class at a given nullary type constructor.  It just returns the
 633 appropriate dictionary if it exists.  It is used only when resolving
 634 ambiguous dictionaries.
 635
 636 \begin{code}
 637 lookupSimpleInst :: Class
 638                  -> [Type]                      -- Look up (c,t)
 639                  -> NF_TcM (Maybe ThetaType)    -- Here are the needed (c,t)s
 640
 641 lookupSimpleInst clas tys
 642   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 643     case lookupInstEnv inst_env clas tys of
 644       FoundInst tenv dfun
 645         -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
 646         where
 647            (_, rho)  = tcSplitForAllTys (idType dfun)
 648            (theta,_) = tcSplitRhoTy rho
 649
 650       other  -> returnNF_Tc Nothing
 651 \end{code}