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, newMethodFromName, newMethodWithGivenTy, newMethodAtLoc,
  16         newOverloadedLit, newIPDict, tcInstCall, tcInstDataCon,
  17
  18         tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
  19         ipNamesOfInst, ipNamesOfInsts, predsOfInst, predsOfInsts,
  20         instLoc, getDictClassTys, dictPred,
  21
  22         lookupInst, lookupSimpleInst, LookupInstResult(..),
  23
  24         isDict, isClassDict, isMethod,
  25         isLinearInst, linearInstType,
  26         isTyVarDict, isStdClassTyVarDict, isMethodFor,
  27         instBindingRequired, instCanBeGeneralised,
  28
  29         zonkInst, zonkInsts,
  30         instToId, instName,
  31
  32         InstOrigin(..), InstLoc, pprInstLoc
  33     ) where
  34
  35 #include "HsVersions.h"
  36
  37 import HsSyn    ( HsLit(..), HsOverLit(..), HsExpr(..) )
  38 import TcHsSyn  ( TcExpr, TcId, TypecheckedHsExpr,
  39                   mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
  40                 )
  41 import TcMonad
  42 import TcEnv    ( TcIdSet, tcGetInstEnv, tcLookupId )
  43 import InstEnv  ( InstLookupResult(..), lookupInstEnv )
  44 import TcMType  ( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType,
  45                   zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
  46                 )
  47 import TcType   ( Type, TcType, TcThetaType, TcPredType, TcTauType, TcTyVarSet,
  48                   SourceType(..), PredType, ThetaType, TyVarDetails(VanillaTv),
  49                   tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
  50                   tcSplitMethodTy, tcSplitPhiTy, tcFunArgTy,
  51                   isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
  52                   tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
  53                   tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
  54                   isClassPred, isTyVarClassPred, isLinearPred,
  55                   getClassPredTys, getClassPredTys_maybe, mkPredName,
  56                   tidyType, tidyTypes, tidyFreeTyVars,
  57                   tcCmpType, tcCmpTypes, tcCmpPred
  58                 )
  59 import CoreFVs  ( idFreeTyVars )
  60 import Class    ( Class )
  61 import DataCon  ( dataConSig )
  62 import Id       ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
  63 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
  64 import Name     ( Name, mkMethodOcc, getOccName )
  65 import PprType  ( pprPred, pprParendType )
  66 import Subst    ( emptyInScopeSet, mkSubst,
  67                   substTy, substTyWith, substTheta, mkTyVarSubst, mkTopTyVarSubst
  68                 )
  69 import Literal  ( inIntRange )
  70 import VarEnv   ( TidyEnv, lookupSubstEnv, SubstResult(..) )
  71 import VarSet   ( elemVarSet, emptyVarSet, unionVarSet )
  72 import TysWiredIn ( floatDataCon, doubleDataCon )
  73 import PrelNames( fromIntegerName, fromRationalName )
  74 import Util     ( thenCmp, equalLength )
  75 import BasicTypes( IPName(..), mapIPName, ipNameName )
  76
  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         HsOverLit       -- 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 `tcCmpPred` 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 `tcCmpTypes` tys2)
 185 cmpInst (Method _ _ _ _ _ _)      other                     = LT
 186
 187 cmpInst (LitInst _ lit1 ty1 _)    (LitInst _ lit2 ty2 _)    = (lit1 `compare` lit2) `thenCmp` (ty1 `tcCmpType` 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 instName :: Inst -> Name
 198 instName inst = idName (instToId inst)
 199
 200 instToId :: Inst -> TcId
 201 instToId (Dict id _ _)         = id
 202 instToId (Method id _ _ _ _ _) = id
 203 instToId (LitInst id _ _ _)    = id
 204
 205 instLoc (Dict _ _         loc) = loc
 206 instLoc (Method _ _ _ _ _ loc) = loc
 207 instLoc (LitInst _ _ _    loc) = loc
 208
 209 dictPred (Dict _ pred _ ) = pred
 210 dictPred inst             = pprPanic "dictPred" (ppr inst)
 211
 212 getDictClassTys (Dict _ pred _) = getClassPredTys pred
 213
 214 predsOfInsts :: [Inst] -> [PredType]
 215 predsOfInsts insts = concatMap predsOfInst insts
 216
 217 predsOfInst (Dict _ pred _)          = [pred]
 218 predsOfInst (Method _ _ _ theta _ _) = theta
 219 predsOfInst (LitInst _ _ _ _)        = []
 220         -- The last case is is really a big cheat
 221         -- LitInsts to give rise to a (Num a) or (Fractional a) predicate
 222         -- But Num and Fractional have only one parameter and no functional
 223         -- dependencies, so I think no caller of predsOfInst will care.
 224
 225 ipNamesOfInsts :: [Inst] -> [Name]
 226 ipNamesOfInst  :: Inst   -> [Name]
 227 -- Get the implicit parameters mentioned by these Insts
 228 -- NB: ?x and %x get different Names
 229
 230 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
 231
 232 ipNamesOfInst (Dict _ (IParam n _) _)  = [ipNameName n]
 233 ipNamesOfInst (Method _ _ _ theta _ _) = [ipNameName n | IParam n _ <- theta]
 234 ipNamesOfInst other                    = []
 235
 236 tyVarsOfInst :: Inst -> TcTyVarSet
 237 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
 238 tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
 239 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 240                                          -- The id might have free type variables; in the case of
 241                                          -- locally-overloaded class methods, for example
 242
 243 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 244 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
 245 \end{code}
 246
 247 Predicates
 248 ~~~~~~~~~~
 249 \begin{code}
 250 isDict :: Inst -> Bool
 251 isDict (Dict _ _ _) = True
 252 isDict other        = False
 253
 254 isClassDict :: Inst -> Bool
 255 isClassDict (Dict _ pred _) = isClassPred pred
 256 isClassDict other           = False
 257
 258 isTyVarDict :: Inst -> Bool
 259 isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
 260 isTyVarDict other           = False
 261
 262 isMethod :: Inst -> Bool
 263 isMethod (Method _ _ _ _ _ _) = True
 264 isMethod other                = False
 265
 266 isMethodFor :: TcIdSet -> Inst -> Bool
 267 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
 268 isMethodFor ids inst                         = False
 269
 270 isLinearInst :: Inst -> Bool
 271 isLinearInst (Dict _ pred _) = isLinearPred pred
 272 isLinearInst other           = False
 273         -- We never build Method Insts that have
 274         -- linear implicit paramters in them.
 275         -- Hence no need to look for Methods
 276         -- See TcExpr.tcId
 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
 359 \begin{code}
 360 tcInstCall :: InstOrigin  -> TcType -> NF_TcM (TypecheckedHsExpr -> TypecheckedHsExpr, LIE, TcType)
 361 tcInstCall orig fun_ty  -- fun_ty is usually a sigma-type
 362   = tcInstType VanillaTv fun_ty `thenNF_Tc` \ (tyvars, theta, tau) ->
 363     newDicts orig theta         `thenNF_Tc` \ dicts ->
 364     let
 365         inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts)
 366     in
 367     returnNF_Tc (inst_fn, mkLIE dicts, tau)
 368
 369 tcInstDataCon orig data_con
 370   = let
 371         (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
 372              -- We generate constraints for the stupid theta even when
 373              -- pattern matching (as the Report requires)
 374     in
 375     tcInstTyVars VanillaTv (tvs ++ ex_tvs)      `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
 376     let
 377         stupid_theta' = substTheta tenv stupid_theta
 378         ex_theta'     = substTheta tenv ex_theta
 379         arg_tys'      = map (substTy tenv) arg_tys
 380
 381         n_normal_tvs  = length tvs
 382         ex_tvs'       = drop n_normal_tvs all_tvs'
 383         result_ty     = mkTyConApp tycon (take n_normal_tvs ty_args')
 384     in
 385     newDicts orig stupid_theta' `thenNF_Tc` \ stupid_dicts ->
 386     newDicts orig ex_theta'     `thenNF_Tc` \ ex_dicts ->
 387
 388         -- Note that we return the stupid theta *only* in the LIE;
 389         -- we don't otherwise use it at all
 390     returnNF_Tc (ty_args', map instToId ex_dicts, arg_tys', result_ty,
 391                  mkLIE stupid_dicts, mkLIE ex_dicts, ex_tvs')
 392
 393
 394 newMethodFromName :: InstOrigin -> TcType -> Name -> NF_TcM Inst
 395 newMethodFromName origin ty name
 396   = tcLookupId name             `thenNF_Tc` \ id ->
 397         -- Use tcLookupId not tcLookupGlobalId; the method is almost
 398         -- always a class op, but with -fno-implicit-prelude GHC is
 399         -- meant to find whatever thing is in scope, and that may
 400         -- be an ordinary function.
 401     newMethod origin id [ty]
 402
 403 newMethod :: InstOrigin
 404           -> TcId
 405           -> [TcType]
 406           -> NF_TcM Inst
 407 newMethod orig id tys
 408   =     -- Get the Id type and instantiate it at the specified types
 409     let
 410         (tyvars, rho) = tcSplitForAllTys (idType id)
 411         rho_ty        = substTyWith tyvars tys rho
 412         (pred, tau)   = tcSplitMethodTy rho_ty
 413     in
 414     newMethodWithGivenTy orig id tys [pred] tau
 415
 416 newMethodWithGivenTy orig id tys theta tau
 417   = tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 418     newMethodWith loc id tys theta tau
 419
 420 newMethodWith inst_loc@(_,loc,_) id tys theta tau
 421   = tcGetUnique         `thenNF_Tc` \ new_uniq ->
 422     let
 423         meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 424     in
 425     returnNF_Tc (Method meth_id id tys theta tau inst_loc)
 426
 427 newMethodAtLoc :: InstLoc
 428                -> Id -> [TcType]
 429                -> NF_TcM (Inst, TcId)
 430 newMethodAtLoc inst_loc real_id tys
 431         -- This actually builds the Inst
 432   =     -- Get the Id type and instantiate it at the specified types
 433     let
 434         (tyvars,rho)  = tcSplitForAllTys (idType real_id)
 435         rho_ty        = ASSERT( equalLength tyvars tys )
 436                         substTy (mkTopTyVarSubst tyvars tys) rho
 437         (theta, tau)  = tcSplitPhiTy rho_ty
 438     in
 439     newMethodWith inst_loc real_id tys theta tau        `thenNF_Tc` \ meth_inst ->
 440     returnNF_Tc (meth_inst, instToId meth_inst)
 441 \end{code}
 442
 443 In newOverloadedLit we convert directly to an Int or Integer if we
 444 know that's what we want.  This may save some time, by not
 445 temporarily generating overloaded literals, but it won't catch all
 446 cases (the rest are caught in lookupInst).
 447
 448 \begin{code}
 449 newOverloadedLit :: InstOrigin
 450                  -> HsOverLit
 451                  -> TcType
 452                  -> NF_TcM (TcExpr, LIE)
 453 newOverloadedLit orig lit expected_ty
 454   | Just expr <- shortCutLit lit expected_ty
 455   = returnNF_Tc (expr, emptyLIE)
 456
 457   | otherwise
 458   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 459     tcGetUnique                 `thenNF_Tc` \ new_uniq ->
 460     zapToType expected_ty       `thenNF_Tc_`
 461         -- The expected type might be a 'hole' type variable,
 462         -- in which case we must zap it to an ordinary type variable
 463     let
 464         lit_inst = LitInst lit_id lit expected_ty loc
 465         lit_id   = mkSysLocal FSLIT("lit") new_uniq expected_ty
 466     in
 467     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 468
 469 shortCutLit :: HsOverLit -> TcType -> Maybe TcExpr
 470 shortCutLit (HsIntegral i fi) ty
 471   | isIntTy ty && inIntRange i && fi == fromIntegerName         -- Short cut for Int
 472   = Just (HsLit (HsInt i))
 473   | isIntegerTy ty && fi == fromIntegerName                     -- Short cut for Integer
 474   = Just (HsLit (HsInteger i))
 475
 476 shortCutLit (HsFractional f fr) ty
 477   | isFloatTy ty  && fr == fromRationalName
 478   = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)])
 479   | isDoubleTy ty && fr == fromRationalName
 480   = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)])
 481
 482 shortCutLit lit ty
 483   = Nothing
 484 \end{code}
 485
 486
 487 %************************************************************************
 488 %*                                                                      *
 489 \subsection{Zonking}
 490 %*                                                                      *
 491 %************************************************************************
 492
 493 Zonking makes sure that the instance types are fully zonked,
 494 but doesn't do the same for any of the Ids in an Inst.  There's no
 495 need, and it's a lot of extra work.
 496
 497 \begin{code}
 498 zonkInst :: Inst -> NF_TcM Inst
 499 zonkInst (Dict id pred loc)
 500   = zonkTcPredType pred                 `thenNF_Tc` \ new_pred ->
 501     returnNF_Tc (Dict id new_pred loc)
 502
 503 zonkInst (Method m id tys theta tau loc)
 504   = zonkId id                   `thenNF_Tc` \ new_id ->
 505         -- Essential to zonk the id in case it's a local variable
 506         -- Can't use zonkIdOcc because the id might itself be
 507         -- an InstId, in which case it won't be in scope
 508
 509     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 510     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 511     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 512     returnNF_Tc (Method m new_id new_tys new_theta new_tau loc)
 513
 514 zonkInst (LitInst id lit ty loc)
 515   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 516     returnNF_Tc (LitInst id lit new_ty loc)
 517
 518 zonkInsts insts = mapNF_Tc zonkInst insts
 519 \end{code}
 520
 521
 522 %************************************************************************
 523 %*                                                                      *
 524 \subsection{Printing}
 525 %*                                                                      *
 526 %************************************************************************
 527
 528 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 529 relevant in error messages.
 530
 531 \begin{code}
 532 instance Outputable Inst where
 533     ppr inst = pprInst inst
 534
 535 pprInst (LitInst u lit ty loc)
 536   = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
 537
 538 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 539
 540 pprInst m@(Method u id tys theta tau loc)
 541   = hsep [ppr id, ptext SLIT("at"),
 542           brackets (sep (map pprParendType tys)) {- ,
 543           ptext SLIT("theta"), ppr theta,
 544           ptext SLIT("tau"), ppr tau
 545           show_uniq u,
 546           ppr (instToId m) -}]
 547
 548 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 549
 550 tidyInst :: TidyEnv -> Inst -> Inst
 551 tidyInst env (LitInst u lit ty loc)          = LitInst u lit (tidyType env ty) loc
 552 tidyInst env (Dict u pred loc)               = Dict u (tidyPred env pred) loc
 553 tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
 554
 555 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
 556 -- This function doesn't assume that the tyvars are in scope
 557 -- so it works like tidyOpenType, returning a TidyEnv
 558 tidyMoreInsts env insts
 559   = (env', map (tidyInst env') insts)
 560   where
 561     env' = tidyFreeTyVars env (tyVarsOfInsts insts)
 562
 563 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 564 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
 565 \end{code}
 566
 567
 568 %************************************************************************
 569 %*                                                                      *
 570 \subsection{Looking up Insts}
 571 %*                                                                      *
 572 %************************************************************************
 573
 574 \begin{code}
 575 data LookupInstResult s
 576   = NoInstance
 577   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 578   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 579
 580 lookupInst :: Inst
 581            -> NF_TcM (LookupInstResult s)
 582
 583 -- Dictionaries
 584
 585 lookupInst dict@(Dict _ (ClassP clas tys) loc)
 586   = getDOptsTc                  `thenNF_Tc` \ dflags ->
 587     tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 588     case lookupInstEnv dflags inst_env clas tys of
 589
 590       FoundInst tenv dfun_id
 591         ->      -- It's possible that not all the tyvars are in
 592                 -- the substitution, tenv. For example:
 593                 --      instance C X a => D X where ...
 594                 -- (presumably there's a functional dependency in class C)
 595                 -- Hence the mk_ty_arg to instantiate any un-substituted tyvars.
 596            let
 597                 (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
 598                 mk_ty_arg tv  = case lookupSubstEnv tenv tv of
 599                                    Just (DoneTy ty) -> returnNF_Tc ty
 600                                    Nothing          -> tcInstTyVar VanillaTv tv `thenNF_Tc` \ tc_tv ->
 601                                                        returnTc (mkTyVarTy tc_tv)
 602            in
 603            mapNF_Tc mk_ty_arg tyvars    `thenNF_Tc` \ ty_args ->
 604            let
 605                 dfun_rho   = substTy (mkTyVarSubst tyvars ty_args) rho
 606                 (theta, _) = tcSplitPhiTy dfun_rho
 607                 ty_app     = mkHsTyApp (HsVar dfun_id) ty_args
 608            in
 609            if null theta then
 610                 returnNF_Tc (SimpleInst ty_app)
 611            else
 612            newDictsAtLoc loc theta      `thenNF_Tc` \ dicts ->
 613            let
 614                 rhs = mkHsDictApp ty_app (map instToId dicts)
 615            in
 616            returnNF_Tc (GenInst dicts rhs)
 617
 618       other     -> returnNF_Tc NoInstance
 619
 620 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
 621
 622 -- Methods
 623
 624 lookupInst inst@(Method _ id tys theta _ loc)
 625   = newDictsAtLoc loc theta             `thenNF_Tc` \ dicts ->
 626     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts)))
 627
 628 -- Literals
 629
 630 -- Look for short cuts first: if the literal is *definitely* a
 631 -- int, integer, float or a double, generate the real thing here.
 632 -- This is essential  (see nofib/spectral/nucleic).
 633 -- [Same shortcut as in newOverloadedLit, but we
 634 --  may have done some unification by now]
 635
 636 lookupInst inst@(LitInst u lit ty loc)
 637   | Just expr <- shortCutLit lit ty
 638   = returnNF_Tc (GenInst [] expr)       -- GenInst, not SimpleInst, because
 639                                         -- expr may be a constructor application
 640
 641 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
 642   = tcLookupId from_integer_name                `thenNF_Tc` \ from_integer ->
 643     newMethodAtLoc loc from_integer [ty]        `thenNF_Tc` \ (method_inst, method_id) ->
 644     returnNF_Tc (GenInst [method_inst]
 645                          (HsApp (HsVar method_id) (HsLit (HsInteger i))))
 646
 647
 648 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
 649   = tcLookupId from_rat_name                    `thenNF_Tc` \ from_rational ->
 650     newMethodAtLoc loc from_rational [ty]       `thenNF_Tc` \ (method_inst, method_id) ->
 651     let
 652         rational_ty  = tcFunArgTy (idType method_id)
 653         rational_lit = HsLit (HsRat f rational_ty)
 654     in
 655     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
 656 \end{code}
 657
 658 There is a second, simpler interface, when you want an instance of a
 659 class at a given nullary type constructor.  It just returns the
 660 appropriate dictionary if it exists.  It is used only when resolving
 661 ambiguous dictionaries.
 662
 663 \begin{code}
 664 lookupSimpleInst :: Class
 665                  -> [Type]                      -- Look up (c,t)
 666                  -> NF_TcM (Maybe ThetaType)    -- Here are the needed (c,t)s
 667
 668 lookupSimpleInst clas tys
 669   = getDOptsTc                  `thenNF_Tc` \ dflags ->
 670     tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 671     case lookupInstEnv dflags inst_env clas tys of
 672       FoundInst tenv dfun
 673         -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
 674         where
 675            (_, rho)  = tcSplitForAllTys (idType dfun)
 676            (theta,_) = tcSplitPhiTy rho
 677
 678       other  -> returnNF_Tc Nothing
 679 \end{code}