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 (getOccName id) u tau loc
 381         -- We used to call mkMethodOcc here, but that gives rise to bad
 382         -- error messages when we print the function name or pattern
 383         -- of an instance-decl binding.  Why? Because the binding is zapped
 384         -- to use the method name in place of the selector name.
 385         -- The way it is now, -ddump-xx output may look confusing, but
 386         -- you can always say -dppr-debug to get the uniques
 387
 388 instToIdBndr (LitInst u list ty orig loc)
 389   = mkSysLocal SLIT("lit") u ty
 390 \end{code}
 391
 392
 393 Zonking
 394 ~~~~~~~
 395 Zonking makes sure that the instance types are fully zonked,
 396 but doesn't do the same for the Id in a Method.  There's no
 397 need, and it's a lot of extra work.
 398
 399 \begin{code}
 400 zonkInst :: Inst -> NF_TcM s Inst
 401 zonkInst (Dict u clas tys orig loc)
 402   = zonkTcTypes tys                     `thenNF_Tc` \ new_tys ->
 403     returnNF_Tc (Dict u clas new_tys orig loc)
 404
 405 zonkInst (Method u id tys theta tau orig loc)
 406   = zonkId id                   `thenNF_Tc` \ new_id ->
 407         -- Essential to zonk the id in case it's a local variable
 408         -- Can't use zonkIdOcc because the id might itself be
 409         -- an InstId, in which case it won't be in scope
 410
 411     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 412     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 413     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 414     returnNF_Tc (Method u new_id new_tys new_theta new_tau orig loc)
 415
 416 zonkInst (LitInst u lit ty orig loc)
 417   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 418     returnNF_Tc (LitInst u lit new_ty orig loc)
 419 \end{code}
 420
 421
 422 Printing
 423 ~~~~~~~~
 424 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 425 relevant in error messages.
 426
 427 \begin{code}
 428 instance Outputable Inst where
 429     ppr inst = pprInst inst
 430
 431 pprInst (LitInst u lit ty orig loc)
 432   = hsep [case lit of
 433               OverloadedIntegral   i -> integer i
 434               OverloadedFractional f -> rational f,
 435            ptext SLIT("at"),
 436            ppr ty,
 437            show_uniq u]
 438
 439 pprInst (Dict u clas tys orig loc) = pprConstraint clas tys <+> show_uniq u
 440
 441 pprInst (Method u id tys _ _ orig loc)
 442   = hsep [ppr id, ptext SLIT("at"),
 443           brackets (interppSP tys),
 444           show_uniq u]
 445
 446 tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
 447 tidyInst env (LitInst u lit ty orig loc)
 448   = (env', LitInst u lit ty' orig loc)
 449   where
 450     (env', ty') = tidyOpenType env ty
 451
 452 tidyInst env (Dict u clas tys orig loc)
 453   = (env', Dict u clas tys' orig loc)
 454   where
 455     (env', tys') = tidyOpenTypes env tys
 456
 457 tidyInst env (Method u id tys theta tau orig loc)
 458   = (env', Method u id tys' theta tau orig loc)
 459                 -- Leave theta, tau alone cos we don't print them
 460   where
 461     (env', tys') = tidyOpenTypes env tys
 462
 463 tidyInsts env insts = mapAccumL tidyInst env insts
 464
 465 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 466 \end{code}
 467
 468
 469 %************************************************************************
 470 %*                                                                      *
 471 \subsection[InstEnv-types]{Type declarations}
 472 %*                                                                      *
 473 %************************************************************************
 474
 475 \begin{code}
 476 type InstanceMapper = Class -> ClassInstEnv
 477 \end{code}
 478
 479 A @ClassInstEnv@ lives inside a class, and identifies all the instances
 480 of that class.  The @Id@ inside a ClassInstEnv mapping is the dfun for
 481 that instance.
 482
 483 There is an important consistency constraint between the @MatchEnv@s
 484 in and the dfun @Id@s inside them: the free type variables of the
 485 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
 486 type variables of the dfun.  Thus, the @ClassInstEnv@ for @Eq@ might
 487 contain the following entry:
 488 @
 489         [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
 490 @
 491 The "a" in the pattern must be one of the forall'd variables in
 492 the dfun type.
 493
 494 \begin{code}
 495 data LookupInstResult s
 496   = NoInstance
 497   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 498   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 499
 500 lookupInst :: Inst
 501            -> NF_TcM s (LookupInstResult s)
 502
 503 -- Dictionaries
 504
 505 lookupInst dict@(Dict _ clas tys orig loc)
 506   = case lookupSpecEnv (ppr clas) (classInstEnv clas) tys of
 507
 508       Just (tenv, dfun_id)
 509         -> let
 510                 (tyvars, rho) = splitForAllTys (idType dfun_id)
 511                 ty_args       = map (expectJust "Inst" . lookupVarEnv tenv) tyvars
 512                                 -- tenv should bind all the tyvars
 513                 dfun_rho      = substTopTy tenv rho
 514                 (theta, tau)  = splitRhoTy dfun_rho
 515                 ty_app        = mkHsTyApp (HsVar dfun_id) ty_args
 516            in
 517            if null theta then
 518                 returnNF_Tc (SimpleInst ty_app)
 519            else
 520            newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
 521            let
 522                 rhs = mkHsDictApp ty_app dict_ids
 523            in
 524            returnNF_Tc (GenInst dicts rhs)
 525
 526       Nothing   -> returnNF_Tc NoInstance
 527
 528 -- Methods
 529
 530 lookupInst inst@(Method _ id tys theta _ orig loc)
 531   = newDictsAtLoc orig loc theta        `thenNF_Tc` \ (dicts, dict_ids) ->
 532     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
 533
 534 -- Literals
 535
 536 lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
 537   | isIntTy ty && in_int_range                  -- Short cut for Int
 538   = returnNF_Tc (GenInst [] int_lit)
 539         -- GenInst, not SimpleInst, because int_lit is actually a constructor application
 540
 541   | isIntegerTy ty                              -- Short cut for Integer
 542   = returnNF_Tc (GenInst [] integer_lit)
 543
 544   | in_int_range                                -- It's overloaded but small enough to fit into an Int
 545   = tcLookupValueByKey fromIntClassOpKey        `thenNF_Tc` \ from_int ->
 546     newMethodAtLoc orig loc from_int [ty]       `thenNF_Tc` \ (method_inst, method_id) ->
 547     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
 548
 549   | otherwise                                   -- Alas, it is overloaded and a big literal!
 550   = tcLookupValueByKey fromIntegerClassOpKey    `thenNF_Tc` \ from_integer ->
 551     newMethodAtLoc orig loc from_integer [ty]           `thenNF_Tc` \ (method_inst, method_id) ->
 552     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
 553   where
 554     in_int_range   = inIntRange i
 555     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
 556     integer_lit    = HsLitOut (HsInt i) integerTy
 557     int_lit        = HsCon intDataCon [] [intprim_lit]
 558
 559 -- similar idea for overloaded floating point literals: if the literal is
 560 -- *definitely* a float or a double, generate the real thing here.
 561 -- This is essential  (see nofib/spectral/nucleic).
 562
 563 lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
 564   | isFloatTy ty    = returnNF_Tc (GenInst [] float_lit)
 565   | isDoubleTy ty   = returnNF_Tc (GenInst [] double_lit)
 566
 567   | otherwise
 568           = tcLookupValueByKey fromRationalClassOpKey   `thenNF_Tc` \ from_rational ->
 569
 570         -- The type Rational isn't wired in so we have to conjure it up
 571     tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
 572     let
 573         rational_ty  = mkSynTy rational_tycon []
 574         rational_lit = HsLitOut (HsFrac f) rational_ty
 575     in
 576     newMethodAtLoc orig loc from_rational [ty]          `thenNF_Tc` \ (method_inst, method_id) ->
 577     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
 578
 579   where
 580     floatprim_lit  = HsLitOut (HsFloatPrim f) floatPrimTy
 581     float_lit      = HsCon floatDataCon [] [floatprim_lit]
 582     doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy
 583     double_lit     = HsCon doubleDataCon [] [doubleprim_lit]
 584
 585 \end{code}
 586
 587 There is a second, simpler interface, when you want an instance of a
 588 class at a given nullary type constructor.  It just returns the
 589 appropriate dictionary if it exists.  It is used only when resolving
 590 ambiguous dictionaries.
 591
 592 \begin{code}
 593 lookupSimpleInst :: ClassInstEnv
 594                  -> Class
 595                  -> [Type]                      -- Look up (c,t)
 596                  -> NF_TcM s (Maybe ThetaType)          -- Here are the needed (c,t)s
 597
 598 lookupSimpleInst class_inst_env clas tys
 599   = case lookupSpecEnv (ppr clas) class_inst_env tys of
 600       Nothing    -> returnNF_Tc Nothing
 601
 602       Just (tenv, dfun)
 603         -> returnNF_Tc (Just (substTopTheta tenv theta))
 604         where
 605            (_, theta, _) = splitSigmaTy (idType dfun)
 606 \end{code}
 607
 608
 609
 610 %************************************************************************
 611 %*                                                                      *
 612 \subsection[Inst-origin]{The @InstOrigin@ type}
 613 %*                                                                      *
 614 %************************************************************************
 615
 616 The @InstOrigin@ type gives information about where a dictionary came from.
 617 This is important for decent error message reporting because dictionaries
 618 don't appear in the original source code.  Doubtless this type will evolve...
 619
 620 \begin{code}
 621 data InstOrigin
 622   = OccurrenceOf TcId   -- Occurrence of an overloaded identifier
 623   | OccurrenceOfCon Id          -- Occurrence of a data constructor
 624
 625   | RecordUpdOrigin
 626
 627   | DataDeclOrigin              -- Typechecking a data declaration
 628
 629   | InstanceDeclOrigin          -- Typechecking an instance decl
 630
 631   | LiteralOrigin       HsLit   -- Occurrence of a literal
 632
 633   | PatOrigin RenamedPat
 634
 635   | ArithSeqOrigin      RenamedArithSeqInfo -- [x..], [x..y] etc
 636
 637   | SignatureOrigin             -- A dict created from a type signature
 638   | Rank2Origin                 -- A dict created when typechecking the argument
 639                                 -- of a rank-2 typed function
 640
 641   | DoOrigin                    -- The monad for a do expression
 642
 643   | ClassDeclOrigin             -- Manufactured during a class decl
 644
 645   | InstanceSpecOrigin  Class   -- in a SPECIALIZE instance pragma
 646                         Type
 647
 648         -- When specialising instances the instance info attached to
 649         -- each class is not yet ready, so we record it inside the
 650         -- origin information.  This is a bit of a hack, but it works
 651         -- fine.  (Patrick is to blame [WDP].)
 652
 653   | ValSpecOrigin       Name    -- in a SPECIALIZE pragma for a value
 654
 655         -- Argument or result of a ccall
 656         -- Dictionaries with this origin aren't actually mentioned in the
 657         -- translated term, and so need not be bound.  Nor should they
 658         -- be abstracted over.
 659
 660   | CCallOrigin         String                  -- CCall label
 661                         (Maybe RenamedHsExpr)   -- Nothing if it's the result
 662                                                 -- Just arg, for an argument
 663
 664   | LitLitOrigin        String  -- the litlit
 665
 666   | UnknownOrigin       -- Help! I give up...
 667 \end{code}
 668
 669 \begin{code}
 670 pprOrigin :: Inst -> SDoc
 671 pprOrigin inst
 672   = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
 673   where
 674     (orig, locn) = case inst of
 675                         Dict _ _ _       orig loc -> (orig,loc)
 676                         Method _ _ _ _ _ orig loc -> (orig,loc)
 677                         LitInst _ _ _    orig loc -> (orig,loc)
 678
 679     pp_orig (OccurrenceOf id)
 680         = hsep [ptext SLIT("use of"), quotes (ppr id)]
 681     pp_orig (OccurrenceOfCon id)
 682         = hsep [ptext SLIT("use of"), quotes (ppr id)]
 683     pp_orig (LiteralOrigin lit)
 684         = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
 685     pp_orig (PatOrigin pat)
 686         = hsep [ptext SLIT("the pattern"), quotes (ppr pat)]
 687     pp_orig (InstanceDeclOrigin)
 688         =  ptext SLIT("an instance declaration")
 689     pp_orig (ArithSeqOrigin seq)
 690         = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
 691     pp_orig (SignatureOrigin)
 692         =  ptext SLIT("a type signature")
 693     pp_orig (Rank2Origin)
 694         =  ptext SLIT("a function with an overloaded argument type")
 695     pp_orig (DoOrigin)
 696         =  ptext SLIT("a do statement")
 697     pp_orig (ClassDeclOrigin)
 698         =  ptext SLIT("a class declaration")
 699     pp_orig (InstanceSpecOrigin clas ty)
 700         = hsep [text "a SPECIALIZE instance pragma; class",
 701                 quotes (ppr clas), text "type:", ppr ty]
 702     pp_orig (ValSpecOrigin name)
 703         = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
 704     pp_orig (CCallOrigin clabel Nothing{-ccall result-})
 705         = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
 706     pp_orig (CCallOrigin clabel (Just arg_expr))
 707         = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
 708                 text "namely", quotes (ppr arg_expr)]
 709     pp_orig (LitLitOrigin s)
 710         = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
 711     pp_orig (UnknownOrigin)
 712         = ptext SLIT("...oops -- I don't know where the overloading came from!")
 713 \end{code}