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