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