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