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 TcHsSyn  ( TcExpr, TcId,
  39                   mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
  40                 )
  41 import TcMonad
  42 import TcEnv    ( TcIdSet, tcGetInstEnv, tcLookupSyntaxId )
  43 import InstEnv  ( InstLookupResult(..), lookupInstEnv )
  44 import TcType   ( TcThetaType, TcClassContext,
  45                   TcType, TcTauType, TcTyVarSet,
  46                   zonkTcType, zonkTcTypes,
  47                   zonkTcThetaType, tcInstTyVar, tcInstType
  48                 )
  49 import CoreFVs  ( idFreeTyVars )
  50 import Class    ( Class )
  51 import Id       ( Id, idType, mkUserLocal, mkSysLocal, mkVanillaId )
  52 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
  53 import Name     ( mkDictOcc, mkMethodOcc, getOccName, mkLocalName )
  54 import NameSet  ( NameSet )
  55 import PprType  ( pprPred )
  56 import Type     ( Type, PredType(..),
  57                   isTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
  58                   splitForAllTys, splitSigmaTy, funArgTy,
  59                   splitMethodTy, splitRhoTy, classesOfPreds,
  60                   tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
  61                   tidyOpenType, tidyOpenTypes, predMentionsIPs
  62                 )
  63 import Subst    ( emptyInScopeSet, mkSubst,
  64                   substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst
  65                 )
  66 import Literal  ( inIntRange )
  67 import VarEnv   ( TidyEnv, lookupSubstEnv, SubstResult(..) )
  68 import VarSet   ( elemVarSet, emptyVarSet, unionVarSet )
  69 import TysWiredIn ( isIntTy,
  70                     floatDataCon, isFloatTy,
  71                     doubleDataCon, isDoubleTy,
  72                     isIntegerTy
  73                   )
  74 import PrelNames( fromIntName, fromIntegerName, fromRationalName )
  75 import Util     ( thenCmp, zipWithEqual, mapAccumL )
  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 `compare` 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 `compare` tys2)
 184 cmpInst (Method _ _ _ _ _ _)      other                     = LT
 185
 186 cmpInst (LitInst _ lit1 ty1 _)    (LitInst _ lit2 ty2 _)    = (lit1 `compare` lit2) `thenCmp` (ty1 `compare` 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 instToId :: Inst -> TcId
 197 instToId (Dict id _ _)         = id
 198 instToId (Method id _ _ _ _ _) = id
 199 instToId (LitInst id _ _ _)    = id
 200
 201 instLoc (Dict _ _         loc) = loc
 202 instLoc (Method _ _ _ _ _ loc) = loc
 203 instLoc (LitInst _ _ _    loc) = loc
 204
 205 getDictClassTys (Dict _ (Class clas tys) _) = (clas, tys)
 206
 207 predsOfInsts :: [Inst] -> [PredType]
 208 predsOfInsts insts = concatMap predsOfInst insts
 209
 210 predsOfInst (Dict _ pred _)          = [pred]
 211 predsOfInst (Method _ _ _ theta _ _) = theta
 212 predsOfInst (LitInst _ _ _ _)        = []
 213         -- The last case is is really a big cheat
 214         -- LitInsts to give rise to a (Num a) or (Fractional a) predicate
 215         -- But Num and Fractional have only one parameter and no functional
 216         -- dependencies, so I think no caller of predsOfInst will care.
 217
 218 ipsOfPreds theta = [(n,ty) | IParam n ty <- theta]
 219
 220 getIPs inst = ipsOfPreds (predsOfInst inst)
 221
 222 tyVarsOfInst :: Inst -> TcTyVarSet
 223 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
 224 tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
 225 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 226                                          -- The id might have free type variables; in the case of
 227                                          -- locally-overloaded class methods, for example
 228
 229 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 230 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
 231 \end{code}
 232
 233 Predicates
 234 ~~~~~~~~~~
 235 \begin{code}
 236 isDict :: Inst -> Bool
 237 isDict (Dict _ _ _) = True
 238 isDict other        = False
 239
 240 isClassDict :: Inst -> Bool
 241 isClassDict (Dict _ (Class _ _) _) = True
 242 isClassDict other                  = False
 243
 244 isMethod :: Inst -> Bool
 245 isMethod (Method _ _ _ _ _ _) = True
 246 isMethod other                = False
 247
 248 isMethodFor :: TcIdSet -> Inst -> Bool
 249 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
 250 isMethodFor ids inst                         = False
 251
 252 instMentionsIPs :: Inst -> NameSet -> Bool
 253   -- True if the Inst mentions any of the implicit
 254   -- parameters in the supplied set of names
 255 instMentionsIPs (Dict _ pred _)          ip_names = pred `predMentionsIPs` ip_names
 256 instMentionsIPs (Method _ _ _ theta _ _) ip_names = any (`predMentionsIPs` ip_names) theta
 257 instMentionsIPs other                    ip_names = False
 258
 259 isTyVarDict :: Inst -> Bool
 260 isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys
 261 isTyVarDict other                    = False
 262
 263 isStdClassTyVarDict (Dict _ (Class clas [ty]) _)
 264   = isStandardClass clas && isTyVarTy ty
 265 isStdClassTyVarDict other
 266   = 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 _ (Class clas _) _) = not (isNoDictClass clas)
 277 instBindingRequired (Dict _ (IParam _ _) _)   = False
 278 instBindingRequired other                     = True
 279
 280 instCanBeGeneralised :: Inst -> Bool
 281 instCanBeGeneralised (Dict _ (Class 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 newClassDicts :: InstOrigin
 301               -> TcClassContext
 302               -> NF_TcM [Inst]
 303 newClassDicts orig theta = newDicts orig (map (uncurry Class) theta)
 304
 305 newDictsFromOld :: Inst -> TcClassContext -> NF_TcM [Inst]
 306 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc (map (uncurry Class) theta)
 307
 308 -- Local function, similar to newDicts,
 309 -- but with slightly different interface
 310 newDictsAtLoc :: InstLoc
 311               -> TcThetaType
 312               -> NF_TcM [Inst]
 313 newDictsAtLoc inst_loc@(_,loc,_) theta
 314   = tcGetUniques (length theta)         `thenNF_Tc` \ new_uniqs ->
 315     returnNF_Tc (zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta)
 316   where
 317     mk_dict uniq pred = Dict (mkVanillaId (mk_dict_name uniq pred) (mkPredTy pred)) pred inst_loc
 318
 319     mk_dict_name uniq (Class cls tys)  = mkLocalName uniq (mkDictOcc (getOccName cls)) loc
 320     mk_dict_name uniq (IParam name ty) = name
 321
 322 newIPDict orig name ty
 323   = tcGetInstLoc orig                   `thenNF_Tc` \ inst_loc ->
 324     returnNF_Tc (Dict (mkVanillaId name ty) (IParam name ty) inst_loc)
 325 \end{code}
 326
 327
 328 %************************************************************************
 329 %*                                                                      *
 330 \subsection{Building methods (calls of overloaded functions)}
 331 %*                                                                      *
 332 %************************************************************************
 333
 334 tcInstId instantiates an occurrence of an Id.
 335 The instantiate_it loop runs round instantiating the Id.
 336 It has to be a loop because we are now prepared to entertain
 337 types like
 338         f:: forall a. Eq a => forall b. Baz b => tau
 339 We want to instantiate this to
 340         f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 341
 342 The -fno-method-sharing flag controls what happens so far as the LIE
 343 is concerned.  The default case is that for an overloaded function we
 344 generate a "method" Id, and add the Method Inst to the LIE.  So you get
 345 something like
 346         f :: Num a => a -> a
 347         f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
 348 If you specify -fno-method-sharing, the dictionary application
 349 isn't shared, so we get
 350         f :: Num a => a -> a
 351         f = /\a (d:Num a) (x:a) -> (+) a d x x
 352 This gets a bit less sharing, but
 353         a) it's better for RULEs involving overloaded functions
 354         b) perhaps fewer separated lambdas
 355
 356
 357 \begin{code}
 358 tcInstId :: Id -> NF_TcM (TcExpr, LIE, TcType)
 359 tcInstId fun
 360   | opt_NoMethodSharing  = loop_noshare (HsVar fun) (idType fun)
 361   | otherwise            = loop_share fun
 362   where
 363     orig = OccurrenceOf fun
 364     loop_noshare fun fun_ty
 365       = tcInstType fun_ty               `thenNF_Tc` \ (tyvars, theta, tau) ->
 366         let
 367             ty_app = mkHsTyApp fun (mkTyVarTys tyvars)
 368         in
 369         if null theta then              -- Is it overloaded?
 370             returnNF_Tc (ty_app, emptyLIE, tau)
 371         else
 372             newDicts orig theta                                         `thenNF_Tc` \ dicts ->
 373             loop_noshare (mkHsDictApp ty_app (map instToId dicts)) tau  `thenNF_Tc` \ (expr, lie, final_tau) ->
 374             returnNF_Tc (expr, mkLIE dicts `plusLIE` lie, final_tau)
 375
 376     loop_share fun
 377       = tcInstType (idType fun)         `thenNF_Tc` \ (tyvars, theta, tau) ->
 378         let
 379             arg_tys = mkTyVarTys tyvars
 380         in
 381         if null theta then              -- Is it overloaded?
 382             returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
 383         else
 384                 -- Yes, it's overloaded
 385             newMethodWithGivenTy orig fun arg_tys theta tau     `thenNF_Tc` \ meth ->
 386             loop_share (instToId meth)                          `thenNF_Tc` \ (expr, lie, final_tau) ->
 387             returnNF_Tc (expr, unitLIE meth `plusLIE` lie, final_tau)
 388
 389
 390 newMethod :: InstOrigin
 391           -> TcId
 392           -> [TcType]
 393           -> NF_TcM Inst
 394 newMethod orig id tys
 395   =     -- Get the Id type and instantiate it at the specified types
 396     let
 397         (tyvars, rho) = splitForAllTys (idType id)
 398         rho_ty        = substTy (mkTyVarSubst tyvars tys) rho
 399         (pred, tau)   = splitMethodTy rho_ty
 400     in
 401     newMethodWithGivenTy orig id tys [pred] tau
 402
 403 newMethodWithGivenTy orig id tys theta tau
 404   = tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 405     newMethodWith loc id tys theta tau
 406
 407 newMethodWith inst_loc@(_,loc,_) id tys theta tau
 408   = tcGetUnique         `thenNF_Tc` \ new_uniq ->
 409     let
 410         meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 411     in
 412     returnNF_Tc (Method meth_id id tys theta tau inst_loc)
 413
 414 newMethodAtLoc :: InstLoc
 415                -> Id -> [TcType]
 416                -> NF_TcM (Inst, TcId)
 417 newMethodAtLoc inst_loc real_id tys
 418         -- This actually builds the Inst
 419   =     -- Get the Id type and instantiate it at the specified types
 420     let
 421         (tyvars,rho) = splitForAllTys (idType real_id)
 422         rho_ty        = ASSERT( length tyvars == length tys )
 423                         substTy (mkTopTyVarSubst tyvars tys) rho
 424         (theta, tau)  = splitRhoTy rho_ty
 425     in
 426     newMethodWith inst_loc real_id tys theta tau        `thenNF_Tc` \ meth_inst ->
 427     returnNF_Tc (meth_inst, instToId meth_inst)
 428 \end{code}
 429
 430 In newOverloadedLit we convert directly to an Int or Integer if we
 431 know that's what we want.  This may save some time, by not
 432 temporarily generating overloaded literals, but it won't catch all
 433 cases (the rest are caught in lookupInst).
 434
 435 \begin{code}
 436 newOverloadedLit :: InstOrigin
 437                  -> HsOverLit
 438                  -> TcType
 439                  -> NF_TcM (TcExpr, LIE)
 440 newOverloadedLit orig (HsIntegral i) ty
 441   | isIntTy ty && inIntRange i          -- Short cut for Int
 442   = returnNF_Tc (int_lit, emptyLIE)
 443
 444   | isIntegerTy ty                      -- Short cut for Integer
 445   = returnNF_Tc (integer_lit, emptyLIE)
 446
 447   where
 448     int_lit     = HsLit (HsInt i)
 449     integer_lit = HsLit (HsInteger i)
 450
 451 newOverloadedLit orig lit ty            -- The general case
 452   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 453     tcGetUnique                 `thenNF_Tc` \ new_uniq ->
 454     let
 455         lit_inst = LitInst lit_id lit ty loc
 456         lit_id   = mkSysLocal SLIT("lit") new_uniq ty
 457     in
 458     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 459 \end{code}
 460
 461
 462 %************************************************************************
 463 %*                                                                      *
 464 \subsection{Zonking}
 465 %*                                                                      *
 466 %************************************************************************
 467
 468 Zonking makes sure that the instance types are fully zonked,
 469 but doesn't do the same for any of the Ids in an Inst.  There's no
 470 need, and it's a lot of extra work.
 471
 472 \begin{code}
 473 zonkPred :: TcPredType -> NF_TcM TcPredType
 474 zonkPred (Class clas tys)
 475   = zonkTcTypes tys                     `thenNF_Tc` \ new_tys ->
 476     returnNF_Tc (Class clas new_tys)
 477 zonkPred (IParam n ty)
 478   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 479     returnNF_Tc (IParam n new_ty)
 480
 481 zonkInst :: Inst -> NF_TcM Inst
 482 zonkInst (Dict id pred loc)
 483   = zonkPred pred                       `thenNF_Tc` \ new_pred ->
 484     returnNF_Tc (Dict id new_pred loc)
 485
 486 zonkInst (Method m id tys theta tau loc)
 487   = zonkId id                   `thenNF_Tc` \ new_id ->
 488         -- Essential to zonk the id in case it's a local variable
 489         -- Can't use zonkIdOcc because the id might itself be
 490         -- an InstId, in which case it won't be in scope
 491
 492     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 493     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 494     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 495     returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
 496
 497 zonkInst (LitInst id lit ty loc)
 498   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 499     returnNF_Tc (LitInst id lit new_ty loc)
 500
 501 zonkInsts insts = mapNF_Tc zonkInst insts
 502 \end{code}
 503
 504
 505 %************************************************************************
 506 %*                                                                      *
 507 \subsection{Printing}
 508 %*                                                                      *
 509 %************************************************************************
 510
 511 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 512 relevant in error messages.
 513
 514 \begin{code}
 515 instance Outputable Inst where
 516     ppr inst = pprInst inst
 517
 518 pprInst (LitInst u lit ty loc)
 519   = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
 520
 521 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 522
 523 pprInst m@(Method u id tys theta tau loc)
 524   = hsep [ppr id, ptext SLIT("at"),
 525           brackets (interppSP tys) {- ,
 526           ptext SLIT("theta"), ppr theta,
 527           ptext SLIT("tau"), ppr tau
 528           show_uniq u,
 529           ppr (instToId m) -}]
 530
 531 tidyPred :: TidyEnv -> TcPredType -> (TidyEnv, TcPredType)
 532 tidyPred env (Class clas tys)
 533   = (env', Class clas tys')
 534   where
 535     (env', tys') = tidyOpenTypes env tys
 536 tidyPred env (IParam n ty)
 537   = (env', IParam n ty')
 538   where
 539     (env', ty') = tidyOpenType env ty
 540
 541 tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
 542 tidyInst env (LitInst u lit ty loc)
 543   = (env', LitInst u lit ty' loc)
 544   where
 545     (env', ty') = tidyOpenType env ty
 546
 547 tidyInst env (Dict u pred loc)
 548   = (env', Dict u pred' loc)
 549   where
 550     (env', pred') = tidyPred env pred
 551
 552 tidyInst env (Method u id tys theta tau loc)
 553   = (env', Method u id tys' theta tau loc)
 554                 -- Leave theta, tau alone cos we don't print them
 555   where
 556     (env', tys') = tidyOpenTypes env tys
 557
 558 tidyInsts env insts = mapAccumL tidyInst env insts
 559
 560 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 561 \end{code}
 562
 563
 564 %************************************************************************
 565 %*                                                                      *
 566 \subsection{Looking up Insts}
 567 %*                                                                      *
 568 %************************************************************************
 569
 570 \begin{code}
 571 data LookupInstResult s
 572   = NoInstance
 573   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 574   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 575
 576 lookupInst :: Inst
 577            -> NF_TcM (LookupInstResult s)
 578
 579 -- Dictionaries
 580
 581 lookupInst dict@(Dict _ (Class clas tys) loc)
 582   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 583     case lookupInstEnv inst_env clas tys of
 584
 585       FoundInst tenv dfun_id
 586         -> let
 587                 (tyvars, rho) = splitForAllTys (idType dfun_id)
 588                 mk_ty_arg tv  = case lookupSubstEnv tenv tv of
 589                                    Just (DoneTy ty) -> returnNF_Tc ty
 590                                    Nothing          -> tcInstTyVar tv   `thenNF_Tc` \ tc_tv ->
 591                                                        returnTc (mkTyVarTy tc_tv)
 592            in
 593            mapNF_Tc mk_ty_arg tyvars    `thenNF_Tc` \ ty_args ->
 594            let
 595                 subst         = mkTyVarSubst tyvars ty_args
 596                 dfun_rho      = substTy subst rho
 597                 (theta, _)    = splitRhoTy dfun_rho
 598                 ty_app        = mkHsTyApp (HsVar dfun_id) ty_args
 599            in
 600            if null theta then
 601                 returnNF_Tc (SimpleInst ty_app)
 602            else
 603            newDictsAtLoc loc theta      `thenNF_Tc` \ dicts ->
 604            let
 605                 rhs = mkHsDictApp ty_app (map instToId dicts)
 606            in
 607            returnNF_Tc (GenInst dicts rhs)
 608
 609       other     -> returnNF_Tc NoInstance
 610
 611 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
 612
 613 -- Methods
 614
 615 lookupInst inst@(Method _ id tys theta _ loc)
 616   = newDictsAtLoc loc theta             `thenNF_Tc` \ dicts ->
 617     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
 618
 619 -- Literals
 620
 621 lookupInst inst@(LitInst u (HsIntegral i) ty loc)
 622   | isIntTy ty && in_int_range                  -- Short cut for Int
 623   = returnNF_Tc (GenInst [] int_lit)
 624         -- GenInst, not SimpleInst, because int_lit is actually a constructor application
 625
 626   | isIntegerTy ty                              -- Short cut for Integer
 627   = returnNF_Tc (GenInst [] integer_lit)
 628
 629   | in_int_range                                -- It's overloaded but small enough to fit into an Int
 630   =     -- So we can use the Prelude fromInt
 631     tcLookupSyntaxId fromIntName                `thenNF_Tc` \ from_int ->
 632     newMethodAtLoc loc from_int [ty]            `thenNF_Tc` \ (method_inst, method_id) ->
 633     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
 634
 635   | otherwise                                   -- Alas, it is overloaded and a big literal!
 636   = tcLookupSyntaxId fromIntegerName            `thenNF_Tc` \ from_integer ->
 637     newMethodAtLoc loc from_integer [ty]        `thenNF_Tc` \ (method_inst, method_id) ->
 638     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
 639   where
 640     in_int_range   = inIntRange i
 641     integer_lit    = HsLit (HsInteger i)
 642     int_lit        = HsLit (HsInt i)
 643
 644 -- similar idea for overloaded floating point literals: if the literal is
 645 -- *definitely* a float or a double, generate the real thing here.
 646 -- This is essential  (see nofib/spectral/nucleic).
 647
 648 lookupInst inst@(LitInst u (HsFractional f) ty loc)
 649   | isFloatTy ty    = returnNF_Tc (GenInst [] float_lit)
 650   | isDoubleTy ty   = returnNF_Tc (GenInst [] double_lit)
 651
 652   | otherwise
 653   = tcLookupSyntaxId fromRationalName           `thenNF_Tc` \ from_rational ->
 654     newMethodAtLoc loc from_rational [ty]       `thenNF_Tc` \ (method_inst, method_id) ->
 655     let
 656         rational_ty  = funArgTy (idType method_id)
 657         rational_lit = HsLit (HsRat f rational_ty)
 658     in
 659     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
 660
 661   where
 662     floatprim_lit  = HsLit (HsFloatPrim f)
 663     float_lit      = mkHsConApp floatDataCon [] [floatprim_lit]
 664     doubleprim_lit = HsLit (HsDoublePrim f)
 665     double_lit     = mkHsConApp doubleDataCon [] [doubleprim_lit]
 666 \end{code}
 667
 668 There is a second, simpler interface, when you want an instance of a
 669 class at a given nullary type constructor.  It just returns the
 670 appropriate dictionary if it exists.  It is used only when resolving
 671 ambiguous dictionaries.
 672
 673 \begin{code}
 674 lookupSimpleInst :: Class
 675                  -> [Type]                              -- Look up (c,t)
 676                  -> NF_TcM (Maybe [(Class,[Type])])     -- Here are the needed (c,t)s
 677
 678 lookupSimpleInst clas tys
 679   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 680     case lookupInstEnv inst_env clas tys of
 681       FoundInst tenv dfun
 682         -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
 683         where
 684            (_, theta, _) = splitSigmaTy (idType dfun)
 685            theta'        = classesOfPreds theta
 686
 687       other  -> returnNF_Tc Nothing
 688 \end{code}
 689
 690