ghc/compiler/typecheck/Inst.lhs

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