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,
  10
  11         Inst, OverloadedLit(..),
  12         pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts,
  13
  14         InstanceMapper,
  15
  16         newDictFromOld, newDicts, newDictsAtLoc,
  17         newMethod, newMethodWithGivenTy, newOverloadedLit, instOverloadedFun,
  18
  19         tyVarsOfInst, instLoc, getDictClassTys,
  20
  21         lookupInst, lookupSimpleInst, LookupInstResult(..),
  22
  23         isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor,
  24         instBindingRequired, instCanBeGeneralised,
  25
  26         zonkInst, instToId, instToIdBndr,
  27
  28         InstOrigin(..), pprOrigin
  29     ) where
  30
  31 #include "HsVersions.h"
  32
  33 import HsSyn    ( HsLit(..), HsExpr(..) )
  34 import RnHsSyn  ( RenamedArithSeqInfo, RenamedHsExpr, RenamedPat )
  35 import TcHsSyn  ( TcExpr, TcId,
  36                   mkHsTyApp, mkHsDictApp, zonkId
  37                 )
  38 import TcMonad
  39 import TcEnv    ( TcIdSet, tcLookupValueByKey, tcLookupTyConByKey )
  40 import TcType   ( TcThetaType,
  41                   TcType, TcTauType, TcTyVarSet,
  42                   zonkTcType, zonkTcTypes,
  43                   zonkTcThetaType
  44                 )
  45 import Bag
  46 import Class    ( classInstEnv, Class )
  47 import Id       ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
  48 import VarSet   ( elemVarSet )
  49 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
  50 import Name     ( OccName, Name, mkDictOcc, mkMethodOcc, getOccName )
  51 import PprType  ( pprConstraint )
  52 import InstEnv  ( InstEnv, lookupInstEnv )
  53 import SrcLoc   ( SrcLoc )
  54 import Type     ( Type, ThetaType,
  55                   mkTyVarTy, isTyVarTy, mkDictTy, splitForAllTys, splitSigmaTy,
  56                   splitRhoTy, tyVarsOfType, tyVarsOfTypes,
  57                   mkSynTy, tidyOpenType, tidyOpenTypes
  58                 )
  59 import InstEnv  ( InstEnv )
  60 import Subst    ( emptyInScopeSet, mkSubst,
  61                   substTy, substTheta, mkTyVarSubst, mkTopTyVarSubst
  62                 )
  63 import TyCon    ( TyCon )
  64 import Subst    ( mkTyVarSubst )
  65 import VarEnv   ( lookupVarEnv, TidyEnv,
  66                   lookupSubstEnv, SubstResult(..)
  67                 )
  68 import VarSet   ( unionVarSet )
  69 import TysPrim    ( intPrimTy, floatPrimTy, doublePrimTy )
  70 import TysWiredIn ( intDataCon, isIntTy, inIntRange,
  71                     floatDataCon, isFloatTy,
  72                     doubleDataCon, isDoubleTy,
  73                     integerTy, isIntegerTy
  74                   )
  75 import Unique   ( fromRationalClassOpKey, rationalTyConKey,
  76                   fromIntClassOpKey, fromIntegerClassOpKey, Unique
  77                 )
  78 import Maybes   ( expectJust )
  79 import Util     ( thenCmp, zipWithEqual, mapAccumL )
  80 import Outputable
  81 \end{code}
  82
  83 %************************************************************************
  84 %*                                                                      *
  85 \subsection[Inst-collections]{LIE: a collection of Insts}
  86 %*                                                                      *
  87 %************************************************************************
  88
  89 \begin{code}
  90 type LIE = Bag Inst
  91
  92 isEmptyLIE        = isEmptyBag
  93 emptyLIE          = emptyBag
  94 unitLIE inst      = unitBag inst
  95 mkLIE insts       = listToBag insts
  96 plusLIE lie1 lie2 = lie1 `unionBags` lie2
  97 consLIE inst lie  = inst `consBag` lie
  98 plusLIEs lies     = unionManyBags lies
  99
 100 zonkLIE :: LIE -> NF_TcM s 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) <+> pprOrigin 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         Unique
 131         Class           -- The type of the dict is (c ts), where
 132         [TcType]        -- c is the class and ts the types;
 133         InstOrigin
 134         SrcLoc
 135
 136   | Method
 137         Unique
 138
 139         TcId    -- The overloaded function
 140                         -- This function will be a global, local, or ClassOpId;
 141                         --   inside instance decls (only) it can also be an InstId!
 142                         -- The id needn't be completely polymorphic.
 143                         -- You'll probably find its name (for documentation purposes)
 144                         --        inside the InstOrigin
 145
 146         [TcType]        -- The types to which its polymorphic tyvars
 147                         --      should be instantiated.
 148                         -- These types must saturate the Id's foralls.
 149
 150         TcThetaType     -- The (types of the) dictionaries to which the function
 151                         -- must be applied to get the method
 152
 153         TcTauType       -- The type of the method
 154
 155         InstOrigin
 156         SrcLoc
 157
 158         -- INVARIANT: in (Method u f tys theta tau loc)
 159         --      type of (f tys dicts(from theta)) = tau
 160
 161   | LitInst
 162         Unique
 163         OverloadedLit
 164         TcType          -- The type at which the literal is used
 165         InstOrigin      -- Always a literal; but more convenient to carry this around
 166         SrcLoc
 167
 168 data OverloadedLit
 169   = OverloadedIntegral   Integer        -- The number
 170   | OverloadedFractional Rational       -- The number
 171 \end{code}
 172
 173 Ordering
 174 ~~~~~~~~
 175 @Insts@ are ordered by their class/type info, rather than by their
 176 unique.  This allows the context-reduction mechanism to use standard finite
 177 maps to do their stuff.
 178
 179 \begin{code}
 180 instance Ord Inst where
 181   compare = cmpInst
 182
 183 instance Eq Inst where
 184   (==) i1 i2 = case i1 `cmpInst` i2 of
 185                  EQ    -> True
 186                  other -> False
 187
 188 cmpInst  (Dict _ clas1 tys1 _ _) (Dict _ clas2 tys2 _ _)
 189   = (clas1 `compare` clas2) `thenCmp` (tys1 `compare` tys2)
 190 cmpInst (Dict _ _ _ _ _) other
 191   = LT
 192
 193
 194 cmpInst (Method _ _ _ _ _ _ _) (Dict _ _ _ _ _)
 195   = GT
 196 cmpInst (Method _ id1 tys1 _ _ _ _) (Method _ id2 tys2 _ _ _ _)
 197   = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
 198 cmpInst (Method _ _ _ _ _ _ _) other
 199   = LT
 200
 201 cmpInst (LitInst _ lit1 ty1 _ _) (LitInst _ lit2 ty2 _ _)
 202   = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2)
 203 cmpInst (LitInst _ _ _ _ _) other
 204   = GT
 205
 206 cmpOverLit (OverloadedIntegral   i1) (OverloadedIntegral   i2) = i1 `compare` i2
 207 cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2
 208 cmpOverLit (OverloadedIntegral _)    (OverloadedFractional _)  = LT
 209 cmpOverLit (OverloadedFractional _)  (OverloadedIntegral _)    = GT
 210 \end{code}
 211
 212
 213 Selection
 214 ~~~~~~~~~
 215 \begin{code}
 216 instOrigin (Dict   u clas tys    origin loc) = origin
 217 instOrigin (Method u clas ty _ _ origin loc) = origin
 218 instOrigin (LitInst u lit ty     origin loc) = origin
 219
 220 instLoc (Dict   u clas tys    origin loc) = loc
 221 instLoc (Method u clas ty _ _ origin loc) = loc
 222 instLoc (LitInst u lit ty     origin loc) = loc
 223
 224 getDictClassTys (Dict u clas tys _ _) = (clas, tys)
 225
 226 tyVarsOfInst :: Inst -> TcTyVarSet
 227 tyVarsOfInst (Dict _ _ tys _ _)        = tyVarsOfTypes  tys
 228 tyVarsOfInst (Method _ id tys _ _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 229                                          -- The id might have free type variables; in the case of
 230                                          -- locally-overloaded class methods, for example
 231 tyVarsOfInst (LitInst _ _ ty _ _)     = tyVarsOfType  ty
 232 \end{code}
 233
 234 Predicates
 235 ~~~~~~~~~~
 236 \begin{code}
 237 isDict :: Inst -> Bool
 238 isDict (Dict _ _ _ _ _) = True
 239 isDict other            = False
 240
 241 isMethodFor :: TcIdSet -> Inst -> Bool
 242 isMethodFor ids (Method uniq id tys _ _ orig loc)
 243   = id `elemVarSet` ids
 244 isMethodFor ids inst
 245   = False
 246
 247 isTyVarDict :: Inst -> Bool
 248 isTyVarDict (Dict _ _ tys _ _) = all isTyVarTy tys
 249 isTyVarDict other              = False
 250
 251 isStdClassTyVarDict (Dict _ clas [ty] _ _) = isStandardClass clas && isTyVarTy ty
 252 isStdClassTyVarDict other                  = False
 253 \end{code}
 254
 255 Two predicates which deal with the case where class constraints don't
 256 necessarily result in bindings.  The first tells whether an @Inst@
 257 must be witnessed by an actual binding; the second tells whether an
 258 @Inst@ can be generalised over.
 259
 260 \begin{code}
 261 instBindingRequired :: Inst -> Bool
 262 instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas)
 263 instBindingRequired other               = True
 264
 265 instCanBeGeneralised :: Inst -> Bool
 266 instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas)
 267 instCanBeGeneralised other               = True
 268 \end{code}
 269
 270
 271 Construction
 272 ~~~~~~~~~~~~
 273
 274 \begin{code}
 275 newDicts :: InstOrigin
 276          -> TcThetaType
 277          -> NF_TcM s (LIE, [TcId])
 278 newDicts orig theta
 279   = tcGetSrcLoc                         `thenNF_Tc` \ loc ->
 280     newDictsAtLoc orig loc theta        `thenNF_Tc` \ (dicts, ids) ->
 281     returnNF_Tc (listToBag dicts, ids)
 282
 283 -- Local function, similar to newDicts,
 284 -- but with slightly different interface
 285 newDictsAtLoc :: InstOrigin
 286               -> SrcLoc
 287               -> TcThetaType
 288               -> NF_TcM s ([Inst], [TcId])
 289 newDictsAtLoc orig loc theta =
 290  tcGetUniques (length theta)            `thenNF_Tc` \ new_uniqs ->
 291  let
 292   mk_dict u (clas, tys) = Dict u clas tys orig loc
 293   dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
 294  in
 295  returnNF_Tc (dicts, map instToId dicts)
 296
 297 newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM s Inst
 298 newDictFromOld (Dict _ _ _ orig loc) clas tys
 299   = tcGetUnique       `thenNF_Tc` \ uniq ->
 300     returnNF_Tc (Dict uniq clas tys orig loc)
 301
 302
 303 newMethod :: InstOrigin
 304           -> TcId
 305           -> [TcType]
 306           -> NF_TcM s (LIE, TcId)
 307 newMethod orig id tys
 308   =     -- Get the Id type and instantiate it at the specified types
 309     let
 310         (tyvars, rho) = splitForAllTys (idType id)
 311         rho_ty        = substTy (mkTyVarSubst tyvars tys) rho
 312         (theta, tau)  = splitRhoTy rho_ty
 313     in
 314     newMethodWithGivenTy orig id tys theta tau  `thenNF_Tc` \ meth_inst ->
 315     returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
 316
 317 instOverloadedFun orig (HsVar v) arg_tys theta tau
 318   = newMethodWithGivenTy orig v arg_tys theta tau       `thenNF_Tc` \ inst ->
 319     returnNF_Tc (HsVar (instToId inst), unitLIE inst)
 320
 321 newMethodWithGivenTy orig id tys theta tau
 322   = tcGetSrcLoc         `thenNF_Tc` \ loc ->
 323     tcGetUnique         `thenNF_Tc` \ new_uniq ->
 324     let
 325         meth_inst = Method new_uniq id tys theta tau orig loc
 326     in
 327     returnNF_Tc meth_inst
 328
 329 newMethodAtLoc :: InstOrigin -> SrcLoc
 330                -> Id -> [TcType]
 331                -> NF_TcM s (Inst, TcId)
 332 newMethodAtLoc orig loc real_id tys     -- Local function, similar to newMethod but with
 333                                         -- slightly different interface
 334   =     -- Get the Id type and instantiate it at the specified types
 335     tcGetUnique                                 `thenNF_Tc` \ new_uniq ->
 336     let
 337         (tyvars,rho) = splitForAllTys (idType real_id)
 338         rho_ty        = ASSERT( length tyvars == length tys )
 339                         substTy (mkTopTyVarSubst tyvars tys) rho
 340         (theta, tau)  = splitRhoTy rho_ty
 341         meth_inst     = Method new_uniq real_id tys theta tau orig loc
 342     in
 343     returnNF_Tc (meth_inst, instToId meth_inst)
 344 \end{code}
 345
 346 In newOverloadedLit we convert directly to an Int or Integer if we
 347 know that's what we want.  This may save some time, by not
 348 temporarily generating overloaded literals, but it won't catch all
 349 cases (the rest are caught in lookupInst).
 350
 351 \begin{code}
 352 newOverloadedLit :: InstOrigin
 353                  -> OverloadedLit
 354                  -> TcType
 355                  -> NF_TcM s (TcExpr, LIE)
 356 newOverloadedLit orig (OverloadedIntegral i) ty
 357   | isIntTy ty && inIntRange i          -- Short cut for Int
 358   = returnNF_Tc (int_lit, emptyLIE)
 359
 360   | isIntegerTy ty                      -- Short cut for Integer
 361   = returnNF_Tc (integer_lit, emptyLIE)
 362
 363   where
 364     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
 365     integer_lit    = HsLitOut (HsInt i) integerTy
 366     int_lit        = HsCon intDataCon [] [intprim_lit]
 367
 368 newOverloadedLit orig lit ty            -- The general case
 369   = tcGetSrcLoc                 `thenNF_Tc` \ loc ->
 370     tcGetUnique                 `thenNF_Tc` \ new_uniq ->
 371     let
 372         lit_inst = LitInst new_uniq lit ty orig loc
 373     in
 374     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 375 \end{code}
 376
 377
 378 \begin{code}
 379 instToId :: Inst -> TcId
 380 instToId inst = instToIdBndr inst
 381
 382 instToIdBndr :: Inst -> TcId
 383 instToIdBndr (Dict u clas ty orig loc)
 384   = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas ty) loc
 385
 386 instToIdBndr (Method u id tys theta tau orig loc)
 387   = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
 388
 389 instToIdBndr (LitInst u list ty orig loc)
 390   = mkSysLocal SLIT("lit") u ty
 391 \end{code}
 392
 393
 394 Zonking
 395 ~~~~~~~
 396 Zonking makes sure that the instance types are fully zonked,
 397 but doesn't do the same for the Id in a Method.  There's no
 398 need, and it's a lot of extra work.
 399
 400 \begin{code}
 401 zonkInst :: Inst -> NF_TcM s Inst
 402 zonkInst (Dict u clas tys orig loc)
 403   = zonkTcTypes tys                     `thenNF_Tc` \ new_tys ->
 404     returnNF_Tc (Dict u clas new_tys orig loc)
 405
 406 zonkInst (Method u id tys theta tau orig loc)
 407   = zonkId id                   `thenNF_Tc` \ new_id ->
 408         -- Essential to zonk the id in case it's a local variable
 409         -- Can't use zonkIdOcc because the id might itself be
 410         -- an InstId, in which case it won't be in scope
 411
 412     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 413     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 414     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 415     returnNF_Tc (Method u new_id new_tys new_theta new_tau orig loc)
 416
 417 zonkInst (LitInst u lit ty orig loc)
 418   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 419     returnNF_Tc (LitInst u lit new_ty orig loc)
 420 \end{code}
 421
 422
 423 Printing
 424 ~~~~~~~~
 425 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 426 relevant in error messages.
 427
 428 \begin{code}
 429 instance Outputable Inst where
 430     ppr inst = pprInst inst
 431
 432 pprInst (LitInst u lit ty orig loc)
 433   = hsep [case lit of
 434               OverloadedIntegral   i -> integer i
 435               OverloadedFractional f -> rational f,
 436            ptext SLIT("at"),
 437            ppr ty,
 438            show_uniq u]
 439
 440 pprInst (Dict u clas tys orig loc) = pprConstraint clas tys <+> show_uniq u
 441
 442 pprInst (Method u id tys _ _ orig loc)
 443   = hsep [ppr id, ptext SLIT("at"),
 444           brackets (interppSP tys),
 445           show_uniq u]
 446
 447 tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
 448 tidyInst env (LitInst u lit ty orig loc)
 449   = (env', LitInst u lit ty' orig loc)
 450   where
 451     (env', ty') = tidyOpenType env ty
 452
 453 tidyInst env (Dict u clas tys orig loc)
 454   = (env', Dict u clas tys' orig loc)
 455   where
 456     (env', tys') = tidyOpenTypes env tys
 457
 458 tidyInst env (Method u id tys theta tau orig loc)
 459   = (env', Method u id tys' theta tau orig loc)
 460                 -- Leave theta, tau alone cos we don't print them
 461   where
 462     (env', tys') = tidyOpenTypes env tys
 463
 464 tidyInsts env insts = mapAccumL tidyInst env insts
 465
 466 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 467 \end{code}
 468
 469
 470 %************************************************************************
 471 %*                                                                      *
 472 \subsection[InstEnv-types]{Type declarations}
 473 %*                                                                      *
 474 %************************************************************************
 475
 476 \begin{code}
 477 type InstanceMapper = Class -> InstEnv
 478 \end{code}
 479
 480 A @ClassInstEnv@ lives inside a class, and identifies all the instances
 481 of that class.  The @Id@ inside a ClassInstEnv mapping is the dfun for
 482 that instance.
 483
 484 There is an important consistency constraint between the @MatchEnv@s
 485 in and the dfun @Id@s inside them: the free type variables of the
 486 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
 487 type variables of the dfun.  Thus, the @ClassInstEnv@ for @Eq@ might
 488 contain the following entry:
 489 @
 490         [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
 491 @
 492 The "a" in the pattern must be one of the forall'd variables in
 493 the dfun type.
 494
 495 \begin{code}
 496 data LookupInstResult s
 497   = NoInstance
 498   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 499   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 500
 501 lookupInst :: Inst
 502            -> NF_TcM s (LookupInstResult s)
 503
 504 -- Dictionaries
 505
 506 lookupInst dict@(Dict _ clas tys orig loc)
 507   = case lookupInstEnv (ppr clas) (classInstEnv clas) tys of
 508
 509       Just (tenv, dfun_id)
 510         -> let
 511                 subst         = mkSubst (tyVarsOfTypes tys) tenv
 512                 (tyvars, rho) = splitForAllTys (idType dfun_id)
 513                 ty_args       = map subst_tv tyvars
 514                 dfun_rho      = substTy subst rho
 515                 (theta, tau)  = splitRhoTy dfun_rho
 516                 ty_app        = mkHsTyApp (HsVar dfun_id) ty_args
 517                 subst_tv tv   = case lookupSubstEnv tenv tv of
 518                                    Just (DoneTy ty)  -> ty
 519                                         -- tenv should bind all the tyvars
 520            in
 521            if null theta then
 522                 returnNF_Tc (SimpleInst ty_app)
 523            else
 524            newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
 525            let
 526                 rhs = mkHsDictApp ty_app dict_ids
 527            in
 528            returnNF_Tc (GenInst dicts rhs)
 529
 530       Nothing   -> returnNF_Tc NoInstance
 531
 532 -- Methods
 533
 534 lookupInst inst@(Method _ id tys theta _ orig loc)
 535   = newDictsAtLoc orig loc theta        `thenNF_Tc` \ (dicts, dict_ids) ->
 536     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
 537
 538 -- Literals
 539
 540 lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
 541   | isIntTy ty && in_int_range                  -- Short cut for Int
 542   = returnNF_Tc (GenInst [] int_lit)
 543         -- GenInst, not SimpleInst, because int_lit is actually a constructor application
 544
 545   | isIntegerTy ty                              -- Short cut for Integer
 546   = returnNF_Tc (GenInst [] integer_lit)
 547
 548   | in_int_range                                -- It's overloaded but small enough to fit into an Int
 549   = tcLookupValueByKey fromIntClassOpKey        `thenNF_Tc` \ from_int ->
 550     newMethodAtLoc orig loc from_int [ty]       `thenNF_Tc` \ (method_inst, method_id) ->
 551     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
 552
 553   | otherwise                                   -- Alas, it is overloaded and a big literal!
 554   = tcLookupValueByKey fromIntegerClassOpKey    `thenNF_Tc` \ from_integer ->
 555     newMethodAtLoc orig loc from_integer [ty]           `thenNF_Tc` \ (method_inst, method_id) ->
 556     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
 557   where
 558     in_int_range   = inIntRange i
 559     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
 560     integer_lit    = HsLitOut (HsInt i) integerTy
 561     int_lit        = HsCon intDataCon [] [intprim_lit]
 562
 563 -- similar idea for overloaded floating point literals: if the literal is
 564 -- *definitely* a float or a double, generate the real thing here.
 565 -- This is essential  (see nofib/spectral/nucleic).
 566
 567 lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
 568   | isFloatTy ty    = returnNF_Tc (GenInst [] float_lit)
 569   | isDoubleTy ty   = returnNF_Tc (GenInst [] double_lit)
 570
 571   | otherwise
 572           = tcLookupValueByKey fromRationalClassOpKey   `thenNF_Tc` \ from_rational ->
 573
 574         -- The type Rational isn't wired in so we have to conjure it up
 575     tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
 576     let
 577         rational_ty  = mkSynTy rational_tycon []
 578         rational_lit = HsLitOut (HsFrac f) rational_ty
 579     in
 580     newMethodAtLoc orig loc from_rational [ty]          `thenNF_Tc` \ (method_inst, method_id) ->
 581     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
 582
 583   where
 584     floatprim_lit  = HsLitOut (HsFloatPrim f) floatPrimTy
 585     float_lit      = HsCon floatDataCon [] [floatprim_lit]
 586     doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy
 587     double_lit     = HsCon doubleDataCon [] [doubleprim_lit]
 588
 589 \end{code}
 590
 591 There is a second, simpler interface, when you want an instance of a
 592 class at a given nullary type constructor.  It just returns the
 593 appropriate dictionary if it exists.  It is used only when resolving
 594 ambiguous dictionaries.
 595
 596 \begin{code}
 597 lookupSimpleInst :: InstEnv
 598                  -> Class
 599                  -> [Type]                      -- Look up (c,t)
 600                  -> NF_TcM s (Maybe ThetaType)          -- Here are the needed (c,t)s
 601
 602 lookupSimpleInst class_inst_env clas tys
 603   = case lookupInstEnv (ppr clas) class_inst_env tys of
 604       Nothing    -> returnNF_Tc Nothing
 605
 606       Just (tenv, dfun)
 607         -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
 608         where
 609            (_, theta, _) = splitSigmaTy (idType dfun)
 610 \end{code}
 611
 612
 613
 614 %************************************************************************
 615 %*                                                                      *
 616 \subsection[Inst-origin]{The @InstOrigin@ type}
 617 %*                                                                      *
 618 %************************************************************************
 619
 620 The @InstOrigin@ type gives information about where a dictionary came from.
 621 This is important for decent error message reporting because dictionaries
 622 don't appear in the original source code.  Doubtless this type will evolve...
 623
 624 \begin{code}
 625 data InstOrigin
 626   = OccurrenceOf TcId   -- Occurrence of an overloaded identifier
 627   | OccurrenceOfCon Id          -- Occurrence of a data constructor
 628
 629   | RecordUpdOrigin
 630
 631   | DataDeclOrigin              -- Typechecking a data declaration
 632
 633   | InstanceDeclOrigin          -- Typechecking an instance decl
 634
 635   | LiteralOrigin       HsLit   -- Occurrence of a literal
 636
 637   | PatOrigin RenamedPat
 638
 639   | ArithSeqOrigin      RenamedArithSeqInfo -- [x..], [x..y] etc
 640
 641   | SignatureOrigin             -- A dict created from a type signature
 642   | Rank2Origin                 -- A dict created when typechecking the argument
 643                                 -- of a rank-2 typed function
 644
 645   | DoOrigin                    -- The monad for a do expression
 646
 647   | ClassDeclOrigin             -- Manufactured during a class decl
 648
 649   | InstanceSpecOrigin  Class   -- in a SPECIALIZE instance pragma
 650                         Type
 651
 652         -- When specialising instances the instance info attached to
 653         -- each class is not yet ready, so we record it inside the
 654         -- origin information.  This is a bit of a hack, but it works
 655         -- fine.  (Patrick is to blame [WDP].)
 656
 657   | ValSpecOrigin       Name    -- in a SPECIALIZE pragma for a value
 658
 659         -- Argument or result of a ccall
 660         -- Dictionaries with this origin aren't actually mentioned in the
 661         -- translated term, and so need not be bound.  Nor should they
 662         -- be abstracted over.
 663
 664   | CCallOrigin         String                  -- CCall label
 665                         (Maybe RenamedHsExpr)   -- Nothing if it's the result
 666                                                 -- Just arg, for an argument
 667
 668   | LitLitOrigin        String  -- the litlit
 669
 670   | UnknownOrigin       -- Help! I give up...
 671 \end{code}
 672
 673 \begin{code}
 674 pprOrigin :: Inst -> SDoc
 675 pprOrigin inst
 676   = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
 677   where
 678     (orig, locn) = case inst of
 679                         Dict _ _ _       orig loc -> (orig,loc)
 680                         Method _ _ _ _ _ orig loc -> (orig,loc)
 681                         LitInst _ _ _    orig loc -> (orig,loc)
 682
 683     pp_orig (OccurrenceOf id)
 684         = hsep [ptext SLIT("use of"), quotes (ppr id)]
 685     pp_orig (OccurrenceOfCon id)
 686         = hsep [ptext SLIT("use of"), quotes (ppr id)]
 687     pp_orig (LiteralOrigin lit)
 688         = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
 689     pp_orig (PatOrigin pat)
 690         = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
 691     pp_orig (InstanceDeclOrigin)
 692         =  ptext SLIT("an instance declaration")
 693     pp_orig (ArithSeqOrigin seq)
 694         = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
 695     pp_orig (SignatureOrigin)
 696         =  ptext SLIT("a type signature")
 697     pp_orig (Rank2Origin)
 698         =  ptext SLIT("a function with an overloaded argument type")
 699     pp_orig (DoOrigin)
 700         =  ptext SLIT("a do statement")
 701     pp_orig (ClassDeclOrigin)
 702         =  ptext SLIT("a class declaration")
 703     pp_orig (InstanceSpecOrigin clas ty)
 704         = hsep [text "a SPECIALIZE instance pragma; class",
 705                 quotes (ppr clas), text "type:", ppr ty]
 706     pp_orig (ValSpecOrigin name)
 707         = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
 708     pp_orig (CCallOrigin clabel Nothing{-ccall result-})
 709         = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
 710     pp_orig (CCallOrigin clabel (Just arg_expr))
 711         = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
 712                 text "namely", quotes (ppr arg_expr)]
 713     pp_orig (LitLitOrigin s)
 714         = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
 715     pp_orig (UnknownOrigin)
 716         = ptext SLIT("...oops -- I don't know where the overloading came from!")
 717 \end{code}