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