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, tcInstId,
  17
  18         tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
  19         ipNamesOfInst, ipNamesOfInsts, predsOfInst, predsOfInsts,
  20         instLoc, getDictClassTys,
  21
  22         lookupInst, lookupSimpleInst, LookupInstResult(..),
  23
  24         isDict, isClassDict, isMethod, isLinearInst, linearInstType,
  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, setIdUnique )
  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 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 getDictClassTys (Dict _ pred _) = getClassPredTys pred
 209
 210 predsOfInsts :: [Inst] -> [PredType]
 211 predsOfInsts insts = concatMap predsOfInst insts
 212
 213 predsOfInst (Dict _ pred _)          = [pred]
 214 predsOfInst (Method _ _ _ theta _ _) = theta
 215 predsOfInst (LitInst _ _ _ _)        = []
 216         -- The last case is is really a big cheat
 217         -- LitInsts to give rise to a (Num a) or (Fractional a) predicate
 218         -- But Num and Fractional have only one parameter and no functional
 219         -- dependencies, so I think no caller of predsOfInst will care.
 220
 221 ipNamesOfInsts :: [Inst] -> [Name]
 222 ipNamesOfInst  :: Inst   -> [Name]
 223 -- Get the implicit parameters mentioned by these Insts
 224 -- NB: ?x and %x get different Names
 225
 226 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
 227
 228 ipNamesOfInst (Dict _ (IParam n _) _)  = [ipNameName n]
 229 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
 230 ipNamesOfInst other                    = []
 231
 232 tyVarsOfInst :: Inst -> TcTyVarSet
 233 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
 234 tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
 235 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 236                                          -- The id might have free type variables; in the case of
 237                                          -- locally-overloaded class methods, for example
 238
 239 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 240 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
 241 \end{code}
 242
 243 Predicates
 244 ~~~~~~~~~~
 245 \begin{code}
 246 isDict :: Inst -> Bool
 247 isDict (Dict _ _ _) = True
 248 isDict other        = False
 249
 250 isClassDict :: Inst -> Bool
 251 isClassDict (Dict _ pred _) = isClassPred pred
 252 isClassDict other           = False
 253
 254 isTyVarDict :: Inst -> Bool
 255 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
 256 isTyVarDict other           = False
 257
 258 isMethod :: Inst -> Bool
 259 isMethod (Method _ _ _ _ _ _) = True
 260 isMethod other                = False
 261
 262 isMethodFor :: TcIdSet -> Inst -> Bool
 263 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
 264 isMethodFor ids inst                         = False
 265
 266 isLinearInst :: Inst -> Bool
 267 isLinearInst (Dict _ pred _) = isLinearPred pred
 268 isLinearInst other           = False
 269         -- We never build Method Insts that have
 270         -- linear implicit paramters in them.
 271         -- Hence no need to look for Methods
 272         -- See Inst.tcInstId
 273
 274 isLinearPred :: TcPredType -> Bool
 275 isLinearPred (IParam (Linear n) _) = True
 276 isLinearPred other                 = False
 277
 278 linearInstType :: Inst -> TcType        -- %x::t  -->  t
 279 linearInstType (Dict _ (IParam _ ty) _) = ty
 280
 281
 282 isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
 283                                         Just (clas, [ty]) -> isStandardClass clas && tcIsTyVarTy ty
 284                                         other             -> False
 285 \end{code}
 286
 287 Two predicates which deal with the case where class constraints don't
 288 necessarily result in bindings.  The first tells whether an @Inst@
 289 must be witnessed by an actual binding; the second tells whether an
 290 @Inst@ can be generalised over.
 291
 292 \begin{code}
 293 instBindingRequired :: Inst -> Bool
 294 instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
 295 instBindingRequired other                      = True
 296
 297 instCanBeGeneralised :: Inst -> Bool
 298 instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas)
 299 instCanBeGeneralised other                      = True
 300 \end{code}
 301
 302
 303 %************************************************************************
 304 %*                                                                      *
 305 \subsection{Building dictionaries}
 306 %*                                                                      *
 307 %************************************************************************
 308
 309 \begin{code}
 310 newDicts :: InstOrigin
 311          -> TcThetaType
 312          -> NF_TcM [Inst]
 313 newDicts orig theta
 314   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 315     newDictsAtLoc loc theta
 316
 317 cloneDict :: Inst -> NF_TcM Inst
 318 cloneDict (Dict id ty loc) = tcGetUnique        `thenNF_Tc` \ uniq ->
 319                              returnNF_Tc (Dict (setIdUnique id uniq) ty loc)
 320
 321 newDictsFromOld :: Inst -> TcThetaType -> NF_TcM [Inst]
 322 newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
 323
 324 -- Local function, similar to newDicts,
 325 -- but with slightly different interface
 326 newDictsAtLoc :: InstLoc
 327               -> TcThetaType
 328               -> NF_TcM [Inst]
 329 newDictsAtLoc inst_loc@(_,loc,_) theta
 330   = tcGetUniques                        `thenNF_Tc` \ new_uniqs ->
 331     returnNF_Tc (zipWith mk_dict new_uniqs theta)
 332   where
 333     mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
 334
 335 -- For vanilla implicit parameters, there is only one in scope
 336 -- at any time, so we used to use the name of the implicit parameter itself
 337 -- But with splittable implicit parameters there may be many in
 338 -- scope, so we make up a new name.
 339 newIPDict :: InstOrigin -> IPName Name -> Type
 340           -> NF_TcM (IPName Id, Inst)
 341 newIPDict orig ip_name ty
 342   = tcGetInstLoc orig                   `thenNF_Tc` \ inst_loc@(_,loc,_) ->
 343     tcGetUnique                         `thenNF_Tc` \ uniq ->
 344     let
 345         pred = IParam ip_name ty
 346         id   = mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)
 347     in
 348     returnNF_Tc (mapIPName (\n -> id) ip_name, Dict id pred inst_loc)
 349 \end{code}
 350
 351
 352 %************************************************************************
 353 %*                                                                      *
 354 \subsection{Building methods (calls of overloaded functions)}
 355 %*                                                                      *
 356 %************************************************************************
 357
 358 tcInstId instantiates an occurrence of an Id.
 359 The instantiate_it loop runs round instantiating the Id.
 360 It has to be a loop because we are now prepared to entertain
 361 types like
 362         f:: forall a. Eq a => forall b. Baz b => tau
 363 We want to instantiate this to
 364         f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 365
 366 The -fno-method-sharing flag controls what happens so far as the LIE
 367 is concerned.  The default case is that for an overloaded function we
 368 generate a "method" Id, and add the Method Inst to the LIE.  So you get
 369 something like
 370         f :: Num a => a -> a
 371         f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
 372 If you specify -fno-method-sharing, the dictionary application
 373 isn't shared, so we get
 374         f :: Num a => a -> a
 375         f = /\a (d:Num a) (x:a) -> (+) a d x x
 376 This gets a bit less sharing, but
 377         a) it's better for RULEs involving overloaded functions
 378         b) perhaps fewer separated lambdas
 379
 380
 381 \begin{code}
 382 tcInstId :: Id -> NF_TcM (TcExpr, LIE, TcType)
 383 tcInstId fun
 384   = loop (HsVar fun) emptyLIE (idType fun)
 385   where
 386     orig = OccurrenceOf fun
 387     loop fun lie fun_ty = tcInstType fun_ty             `thenNF_Tc` \ (tyvars, theta, tau) ->
 388                           loop_help fun lie (mkTyVarTys tyvars) theta tau
 389
 390     loop_help fun lie arg_tys [] tau    -- Not overloaded
 391         = returnNF_Tc (mkHsTyApp fun arg_tys, lie, tau)
 392
 393     loop_help (HsVar fun_id) lie arg_tys theta tau
 394         | can_share theta               -- Sharable method binding
 395         = newMethodWithGivenTy orig fun_id arg_tys theta tau    `thenNF_Tc` \ meth ->
 396           loop (HsVar (instToId meth))
 397                (unitLIE meth `plusLIE` lie) tau
 398
 399     loop_help fun lie arg_tys theta tau -- The general case
 400         = newDicts orig theta                                   `thenNF_Tc` \ dicts ->
 401           loop (mkHsDictApp (mkHsTyApp fun arg_tys) (map instToId dicts))
 402                (mkLIE dicts `plusLIE` lie) tau
 403
 404     can_share theta | opt_NoMethodSharing = False
 405                     | otherwise           = not (any isLinearPred theta)
 406         -- This is a slight hack.
 407         -- If   f :: (%x :: T) => Int -> Int
 408         -- Then if we have two separate calls, (f 3, f 4), we cannot
 409         -- make a method constraint that then gets shared, thus:
 410         --      let m = f %x in (m 3, m 4)
 411         -- because that loses the linearity of the constraint.
 412         -- The simplest thing to do is never to construct a method constraint
 413         -- in the first place that has a linear implicit parameter in it.
 414
 415 newMethod :: InstOrigin
 416           -> TcId
 417           -> [TcType]
 418           -> NF_TcM Inst
 419 newMethod orig id tys
 420   =     -- Get the Id type and instantiate it at the specified types
 421     let
 422         (tyvars, rho) = tcSplitForAllTys (idType id)
 423         rho_ty        = substTyWith tyvars tys rho
 424         (pred, tau)   = tcSplitMethodTy rho_ty
 425     in
 426     newMethodWithGivenTy orig id tys [pred] tau
 427
 428 newMethodWithGivenTy orig id tys theta tau
 429   = tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 430     newMethodWith loc id tys theta tau
 431
 432 newMethodWith inst_loc@(_,loc,_) id tys theta tau
 433   = tcGetUnique         `thenNF_Tc` \ new_uniq ->
 434     let
 435         meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 436     in
 437     returnNF_Tc (Method meth_id id tys theta tau inst_loc)
 438
 439 newMethodAtLoc :: InstLoc
 440                -> Id -> [TcType]
 441                -> NF_TcM (Inst, TcId)
 442 newMethodAtLoc inst_loc real_id tys
 443         -- This actually builds the Inst
 444   =     -- Get the Id type and instantiate it at the specified types
 445     let
 446         (tyvars,rho)  = tcSplitForAllTys (idType real_id)
 447         rho_ty        = ASSERT( equalLength tyvars tys )
 448                         substTy (mkTopTyVarSubst tyvars tys) rho
 449         (theta, tau)  = tcSplitRhoTy rho_ty
 450     in
 451     newMethodWith inst_loc real_id tys theta tau        `thenNF_Tc` \ meth_inst ->
 452     returnNF_Tc (meth_inst, instToId meth_inst)
 453 \end{code}
 454
 455 In newOverloadedLit we convert directly to an Int or Integer if we
 456 know that's what we want.  This may save some time, by not
 457 temporarily generating overloaded literals, but it won't catch all
 458 cases (the rest are caught in lookupInst).
 459
 460 \begin{code}
 461 newOverloadedLit :: InstOrigin
 462                  -> HsOverLit
 463                  -> TcType
 464                  -> NF_TcM (TcExpr, LIE)
 465 newOverloadedLit orig lit ty
 466   | Just expr <- shortCutLit lit ty
 467   = returnNF_Tc (expr, emptyLIE)
 468
 469   | otherwise
 470   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 471     tcGetUnique                 `thenNF_Tc` \ new_uniq ->
 472     let
 473         lit_inst = LitInst lit_id lit ty loc
 474         lit_id   = mkSysLocal SLIT("lit") new_uniq ty
 475     in
 476     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 477
 478 shortCutLit :: HsOverLit -> TcType -> Maybe TcExpr
 479 shortCutLit (HsIntegral i fi) ty
 480   | isIntTy ty && inIntRange i && fi == fromIntegerName         -- Short cut for Int
 481   = Just (HsLit (HsInt i))
 482   | isIntegerTy ty && fi == fromIntegerName                     -- Short cut for Integer
 483   = Just (HsLit (HsInteger i))
 484
 485 shortCutLit (HsFractional f fr) ty
 486   | isFloatTy ty  && fr == fromRationalName
 487   = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
 488   | isDoubleTy ty && fr == fromRationalName
 489   = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
 490
 491 shortCutLit lit ty
 492   = Nothing
 493 \end{code}
 494
 495
 496 %************************************************************************
 497 %*                                                                      *
 498 \subsection{Zonking}
 499 %*                                                                      *
 500 %************************************************************************
 501
 502 Zonking makes sure that the instance types are fully zonked,
 503 but doesn't do the same for any of the Ids in an Inst.  There's no
 504 need, and it's a lot of extra work.
 505
 506 \begin{code}
 507 zonkInst :: Inst -> NF_TcM Inst
 508 zonkInst (Dict id pred loc)
 509   = zonkTcPredType pred                 `thenNF_Tc` \ new_pred ->
 510     returnNF_Tc (Dict id new_pred loc)
 511
 512 zonkInst (Method m id tys theta tau loc)
 513   = zonkId id                   `thenNF_Tc` \ new_id ->
 514         -- Essential to zonk the id in case it's a local variable
 515         -- Can't use zonkIdOcc because the id might itself be
 516         -- an InstId, in which case it won't be in scope
 517
 518     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 519     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 520     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 521     returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
 522
 523 zonkInst (LitInst id lit ty loc)
 524   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 525     returnNF_Tc (LitInst id lit new_ty loc)
 526
 527 zonkInsts insts = mapNF_Tc zonkInst insts
 528 \end{code}
 529
 530
 531 %************************************************************************
 532 %*                                                                      *
 533 \subsection{Printing}
 534 %*                                                                      *
 535 %************************************************************************
 536
 537 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 538 relevant in error messages.
 539
 540 \begin{code}
 541 instance Outputable Inst where
 542     ppr inst = pprInst inst
 543
 544 pprInst (LitInst u lit ty loc)
 545   = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
 546
 547 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 548
 549 pprInst m@(Method u id tys theta tau loc)
 550   = hsep [ppr id, ptext SLIT("at"),
 551           brackets (interppSP tys) {- ,
 552           ptext SLIT("theta"), ppr theta,
 553           ptext SLIT("tau"), ppr tau
 554           show_uniq u,
 555           ppr (instToId m) -}]
 556
 557 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 558
 559 tidyInst :: TidyEnv -> Inst -> Inst
 560 tidyInst env (LitInst u lit ty loc)          = LitInst u lit (tidyType env ty) loc
 561 tidyInst env (Dict u pred loc)               = Dict u (tidyPred env pred) loc
 562 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
 563
 564 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
 565 -- This function doesn't assume that the tyvars are in scope
 566 -- so it works like tidyOpenType, returning a TidyEnv
 567 tidyMoreInsts env insts
 568   = (env', map (tidyInst env') insts)
 569   where
 570     env' = tidyFreeTyVars env (tyVarsOfInsts insts)
 571
 572 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 573 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
 574 \end{code}
 575
 576
 577 %************************************************************************
 578 %*                                                                      *
 579 \subsection{Looking up Insts}
 580 %*                                                                      *
 581 %************************************************************************
 582
 583 \begin{code}
 584 data LookupInstResult s
 585   = NoInstance
 586   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 587   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 588
 589 lookupInst :: Inst
 590            -> NF_TcM (LookupInstResult s)
 591
 592 -- Dictionaries
 593
 594 lookupInst dict@(Dict _ (ClassP clas tys) loc)
 595   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 596     case lookupInstEnv inst_env clas tys of
 597
 598       FoundInst tenv dfun_id
 599         -> let
 600                 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
 601                 mk_ty_arg tv  = case lookupSubstEnv tenv tv of
 602                                    Just (DoneTy ty) -> returnNF_Tc ty
 603                                    Nothing          -> tcInstTyVar tv   `thenNF_Tc` \ tc_tv ->
 604                                                        returnTc (mkTyVarTy tc_tv)
 605            in
 606            mapNF_Tc mk_ty_arg tyvars    `thenNF_Tc` \ ty_args ->
 607            let
 608                 subst         = mkTyVarSubst tyvars ty_args
 609                 dfun_rho      = substTy subst rho
 610                 (theta, _)    = tcSplitRhoTy dfun_rho
 611                 ty_app        = mkHsTyApp (HsVar dfun_id) ty_args
 612            in
 613            if null theta then
 614                 returnNF_Tc (SimpleInst ty_app)
 615            else
 616            newDictsAtLoc loc theta      `thenNF_Tc` \ dicts ->
 617            let
 618                 rhs = mkHsDictApp ty_app (map instToId dicts)
 619            in
 620            returnNF_Tc (GenInst dicts rhs)
 621
 622       other     -> returnNF_Tc NoInstance
 623
 624 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
 625
 626 -- Methods
 627
 628 lookupInst inst@(Method _ id tys theta _ loc)
 629   = newDictsAtLoc loc theta             `thenNF_Tc` \ dicts ->
 630     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
 631
 632 -- Literals
 633
 634 -- Look for short cuts first: if the literal is *definitely* a
 635 -- int, integer, float or a double, generate the real thing here.
 636 -- This is essential  (see nofib/spectral/nucleic).
 637 -- [Same shortcut as in newOverloadedLit, but we
 638 --  may have done some unification by now]
 639
 640 lookupInst inst@(LitInst u lit ty loc)
 641   | Just expr <- shortCutLit lit ty
 642   = returnNF_Tc (GenInst [] expr)       -- GenInst, not SimpleInst, because
 643                                         -- expr may be a constructor application
 644
 645 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
 646   = tcLookupId from_integer_name                `thenNF_Tc` \ from_integer ->
 647     newMethodAtLoc loc from_integer [ty]        `thenNF_Tc` \ (method_inst, method_id) ->
 648     returnNF_Tc (GenInst [method_inst]
 649                          (HsApp (HsVar method_id) (HsLit (HsInteger i))))
 650
 651
 652 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
 653   = tcLookupId from_rat_name                    `thenNF_Tc` \ from_rational ->
 654     newMethodAtLoc loc from_rational [ty]       `thenNF_Tc` \ (method_inst, method_id) ->
 655     let
 656         rational_ty  = tcFunArgTy (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 \end{code}
 661
 662 There is a second, simpler interface, when you want an instance of a
 663 class at a given nullary type constructor.  It just returns the
 664 appropriate dictionary if it exists.  It is used only when resolving
 665 ambiguous dictionaries.
 666
 667 \begin{code}
 668 lookupSimpleInst :: Class
 669                  -> [Type]                      -- Look up (c,t)
 670                  -> NF_TcM (Maybe ThetaType)    -- Here are the needed (c,t)s
 671
 672 lookupSimpleInst clas tys
 673   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 674     case lookupInstEnv inst_env clas tys of
 675       FoundInst tenv dfun
 676         -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
 677         where
 678            (_, rho)  = tcSplitForAllTys (idType dfun)
 679            (theta,_) = tcSplitRhoTy rho
 680
 681       other  -> returnNF_Tc Nothing
 682 \end{code}