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, TcIdOcc(..), TcIdBndr,
  36                   mkHsTyApp, mkHsDictApp, tcIdTyVars, zonkTcId
  37                 )
  38 import TcMonad
  39 import TcEnv    ( TcIdSet, tcLookupGlobalValueByKey, tcLookupTyConByKey,
  40                   tidyType, tidyTypes
  41                 )
  42 import TcType   ( TcThetaType,
  43                   TcType, TcTauType, TcTyVarSet,
  44                   zonkTcType, zonkTcTypes,
  45                   zonkTcThetaType
  46                 )
  47 import Bag
  48 import Class    ( classInstEnv,
  49                   Class, ClassInstEnv
  50                 )
  51 import Id       ( Id, idType, mkUserLocal, mkSysLocal )
  52 import VarSet   ( elemVarSet )
  53 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
  54 import Name     ( OccName(..), Name, occNameString, getOccName )
  55 import PprType  ( pprConstraint )
  56 import SpecEnv  ( SpecEnv, lookupSpecEnv )
  57 import SrcLoc   ( SrcLoc )
  58 import Type     ( Type, ThetaType, substTy,
  59                   isTyVarTy, mkDictTy, splitForAllTys, splitSigmaTy,
  60                   splitRhoTy, tyVarsOfType, tyVarsOfTypes,
  61                   mkSynTy, substFlexiTy, substFlexiTheta
  62                 )
  63 import TyCon    ( TyCon )
  64 import VarEnv   ( zipVarEnv, lookupVarEnv )
  65 import VarSet   ( unionVarSet )
  66 import TysPrim    ( intPrimTy, floatPrimTy, doublePrimTy )
  67 import TysWiredIn ( intDataCon, isIntTy, inIntRange,
  68                     floatDataCon, isFloatTy,
  69                     doubleDataCon, isDoubleTy,
  70                     integerTy, isIntegerTy
  71                   )
  72 import Unique   ( fromRationalClassOpKey, rationalTyConKey,
  73                   fromIntClassOpKey, fromIntegerClassOpKey, Unique
  74                 )
  75 import Maybes   ( expectJust )
  76 import Util     ( thenCmp, zipWithEqual, mapAccumL )
  77 import Outputable
  78 \end{code}
  79
  80 %************************************************************************
  81 %*                                                                      *
  82 \subsection[Inst-collections]{LIE: a collection of Insts}
  83 %*                                                                      *
  84 %************************************************************************
  85
  86 \begin{code}
  87 type LIE s = Bag (Inst s)
  88
  89 isEmptyLIE        = isEmptyBag
  90 emptyLIE          = emptyBag
  91 unitLIE inst      = unitBag inst
  92 mkLIE insts       = listToBag insts
  93 plusLIE lie1 lie2 = lie1 `unionBags` lie2
  94 consLIE inst lie  = inst `consBag` lie
  95 plusLIEs lies     = unionManyBags lies
  96
  97 zonkLIE :: LIE s -> NF_TcM s (LIE s)
  98 zonkLIE lie = mapBagNF_Tc zonkInst lie
  99
 100 pprInsts :: [Inst s] -> SDoc
 101 pprInsts insts = parens (hsep (punctuate comma (map pprInst insts)))
 102
 103
 104 pprInstsInFull insts
 105   = vcat (map go insts)
 106   where
 107     go inst = quotes (ppr inst) <+> pprOrigin inst
 108 \end{code}
 109
 110 %************************************************************************
 111 %*                                                                      *
 112 \subsection[Inst-types]{@Inst@ types}
 113 %*                                                                      *
 114 %************************************************************************
 115
 116 An @Inst@ is either a dictionary, an instance of an overloaded
 117 literal, or an instance of an overloaded value.  We call the latter a
 118 ``method'' even though it may not correspond to a class operation.
 119 For example, we might have an instance of the @double@ function at
 120 type Int, represented by
 121
 122         Method 34 doubleId [Int] origin
 123
 124 \begin{code}
 125 data Inst s
 126   = Dict
 127         Unique
 128         Class           -- The type of the dict is (c ts), where
 129         [TcType s]      -- c is the class and ts the types;
 130         (InstOrigin s)
 131         SrcLoc
 132
 133   | Method
 134         Unique
 135
 136         (TcIdOcc s)     -- The overloaded function
 137                         -- This function will be a global, local, or ClassOpId;
 138                         --   inside instance decls (only) it can also be an InstId!
 139                         -- The id needn't be completely polymorphic.
 140                         -- You'll probably find its name (for documentation purposes)
 141                         --        inside the InstOrigin
 142
 143         [TcType s]      -- The types to which its polymorphic tyvars
 144                         --      should be instantiated.
 145                         -- These types must saturate the Id's foralls.
 146
 147         (TcThetaType s) -- The (types of the) dictionaries to which the function
 148                         -- must be applied to get the method
 149
 150         (TcTauType s)   -- The type of the method
 151
 152         (InstOrigin s)
 153         SrcLoc
 154
 155         -- INVARIANT: in (Method u f tys theta tau loc)
 156         --      type of (f tys dicts(from theta)) = tau
 157
 158   | LitInst
 159         Unique
 160         OverloadedLit
 161         (TcType s)      -- The type at which the literal is used
 162         (InstOrigin s)  -- Always a literal; but more convenient to carry this around
 163         SrcLoc
 164
 165 data OverloadedLit
 166   = OverloadedIntegral   Integer        -- The number
 167   | OverloadedFractional Rational       -- The number
 168 \end{code}
 169
 170 Ordering
 171 ~~~~~~~~
 172 @Insts@ are ordered by their class/type info, rather than by their
 173 unique.  This allows the context-reduction mechanism to use standard finite
 174 maps to do their stuff.
 175
 176 \begin{code}
 177 instance Ord (Inst s) where
 178   compare = cmpInst
 179
 180 instance Eq (Inst s) where
 181   (==) i1 i2 = case i1 `cmpInst` i2 of
 182                  EQ    -> True
 183                  other -> False
 184
 185 cmpInst  (Dict _ clas1 tys1 _ _) (Dict _ clas2 tys2 _ _)
 186   = (clas1 `compare` clas2) `thenCmp` (tys1 `compare` tys2)
 187 cmpInst (Dict _ _ _ _ _) other
 188   = LT
 189
 190
 191 cmpInst (Method _ _ _ _ _ _ _) (Dict _ _ _ _ _)
 192   = GT
 193 cmpInst (Method _ id1 tys1 _ _ _ _) (Method _ id2 tys2 _ _ _ _)
 194   = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
 195 cmpInst (Method _ _ _ _ _ _ _) other
 196   = LT
 197
 198 cmpInst (LitInst _ lit1 ty1 _ _) (LitInst _ lit2 ty2 _ _)
 199   = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2)
 200 cmpInst (LitInst _ _ _ _ _) other
 201   = GT
 202
 203 cmpOverLit (OverloadedIntegral   i1) (OverloadedIntegral   i2) = i1 `compare` i2
 204 cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2
 205 cmpOverLit (OverloadedIntegral _)    (OverloadedFractional _)  = LT
 206 cmpOverLit (OverloadedFractional _)  (OverloadedIntegral _)    = GT
 207 \end{code}
 208
 209
 210 Selection
 211 ~~~~~~~~~
 212 \begin{code}
 213 instOrigin (Dict   u clas tys    origin loc) = origin
 214 instOrigin (Method u clas ty _ _ origin loc) = origin
 215 instOrigin (LitInst u lit ty     origin loc) = origin
 216
 217 instLoc (Dict   u clas tys    origin loc) = loc
 218 instLoc (Method u clas ty _ _ origin loc) = loc
 219 instLoc (LitInst u lit ty     origin loc) = loc
 220
 221 getDictClassTys (Dict u clas tys _ _) = (clas, tys)
 222
 223 tyVarsOfInst :: Inst s -> TcTyVarSet s
 224 tyVarsOfInst (Dict _ _ tys _ _)        = tyVarsOfTypes  tys
 225 tyVarsOfInst (Method _ id tys _ _ _ _) = tyVarsOfTypes tys `unionVarSet` tcIdTyVars id
 226                                          -- The id might not be a RealId; in the case of
 227                                          -- locally-overloaded class methods, for example
 228 tyVarsOfInst (LitInst _ _ ty _ _)     = tyVarsOfType  ty
 229 \end{code}
 230
 231 Predicates
 232 ~~~~~~~~~~
 233 \begin{code}
 234 isDict :: Inst s -> Bool
 235 isDict (Dict _ _ _ _ _) = True
 236 isDict other            = False
 237
 238 isMethodFor :: TcIdSet s -> Inst s -> Bool
 239 isMethodFor ids (Method uniq (TcId id) tys _ _ orig loc)
 240   = id `elemVarSet` ids
 241 isMethodFor ids inst
 242   = False
 243
 244 isTyVarDict :: Inst s -> Bool
 245 isTyVarDict (Dict _ _ tys _ _) = all isTyVarTy tys
 246 isTyVarDict other              = False
 247
 248 isStdClassTyVarDict (Dict _ clas [ty] _ _) = isStandardClass clas && isTyVarTy ty
 249 isStdClassTyVarDict other                  = False
 250 \end{code}
 251
 252 Two predicates which deal with the case where class constraints don't
 253 necessarily result in bindings.  The first tells whether an @Inst@
 254 must be witnessed by an actual binding; the second tells whether an
 255 @Inst@ can be generalised over.
 256
 257 \begin{code}
 258 instBindingRequired :: Inst s -> Bool
 259 instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas)
 260 instBindingRequired other               = True
 261
 262 instCanBeGeneralised :: Inst s -> Bool
 263 instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas)
 264 instCanBeGeneralised other               = True
 265 \end{code}
 266
 267
 268 Construction
 269 ~~~~~~~~~~~~
 270
 271 \begin{code}
 272 newDicts :: InstOrigin s
 273          -> TcThetaType s
 274          -> NF_TcM s (LIE s, [TcIdOcc s])
 275 newDicts orig theta
 276   = tcGetSrcLoc                         `thenNF_Tc` \ loc ->
 277     newDictsAtLoc orig loc theta        `thenNF_Tc` \ (dicts, ids) ->
 278     returnNF_Tc (listToBag dicts, ids)
 279
 280 -- Local function, similar to newDicts,
 281 -- but with slightly different interface
 282 newDictsAtLoc :: InstOrigin s
 283               -> SrcLoc
 284               -> TcThetaType s
 285               -> NF_TcM s ([Inst s], [TcIdOcc s])
 286 newDictsAtLoc orig loc theta =
 287  tcGetUniques (length theta)            `thenNF_Tc` \ new_uniqs ->
 288  let
 289   mk_dict u (clas, tys) = Dict u clas tys orig loc
 290   dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
 291  in
 292  returnNF_Tc (dicts, map instToId dicts)
 293
 294 newDictFromOld :: Inst s -> Class -> [TcType s] -> NF_TcM s (Inst s)
 295 newDictFromOld (Dict _ _ _ orig loc) clas tys
 296   = tcGetUnique       `thenNF_Tc` \ uniq ->
 297     returnNF_Tc (Dict uniq clas tys orig loc)
 298
 299
 300 newMethod :: InstOrigin s
 301           -> TcIdOcc s
 302           -> [TcType s]
 303           -> NF_TcM s (LIE s, TcIdOcc s)
 304 newMethod orig id tys
 305   =     -- Get the Id type and instantiate it at the specified types
 306     (case id of
 307        RealId id -> let
 308                         (tyvars, rho) = splitForAllTys (idType id)
 309                     in
 310                     ASSERT( length tyvars == length tys)
 311                     returnNF_Tc (substFlexiTy (zipVarEnv tyvars tys) rho)
 312
 313        TcId   id -> let
 314                         (tyvars, rho) = splitForAllTys (idType id)
 315                     in
 316                     returnNF_Tc (substTy (zipVarEnv tyvars tys) rho)
 317     )                                           `thenNF_Tc` \ rho_ty ->
 318     let
 319         (theta, tau) = splitRhoTy rho_ty
 320     in
 321     newMethodWithGivenTy orig id tys theta tau  `thenNF_Tc` \ meth_inst ->
 322     returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
 323
 324
 325 newMethodWithGivenTy orig id tys theta tau
 326   = tcGetSrcLoc         `thenNF_Tc` \ loc ->
 327     tcGetUnique         `thenNF_Tc` \ new_uniq ->
 328     let
 329         meth_inst = Method new_uniq id tys theta tau orig loc
 330     in
 331     returnNF_Tc meth_inst
 332
 333 newMethodAtLoc :: InstOrigin s -> SrcLoc
 334                -> Id -> [TcType s]
 335                -> NF_TcM s (Inst s, TcIdOcc s)
 336 newMethodAtLoc orig loc real_id tys     -- Local function, similar to newMethod but with
 337                                         -- slightly different interface
 338   =     -- Get the Id type and instantiate it at the specified types
 339     tcGetUnique                                 `thenNF_Tc` \ new_uniq ->
 340     let
 341         (tyvars,rho) = splitForAllTys (idType real_id)
 342         rho_ty        = ASSERT( length tyvars == length tys )
 343                         substFlexiTy (zipVarEnv tyvars tys) rho
 344         (theta, tau)  = splitRhoTy rho_ty
 345         meth_inst     = Method new_uniq (RealId real_id) tys theta tau orig loc
 346     in
 347     returnNF_Tc (meth_inst, instToId meth_inst)
 348 \end{code}
 349
 350 In newOverloadedLit we convert directly to an Int or Integer if we
 351 know that's what we want.  This may save some time, by not
 352 temporarily generating overloaded literals, but it won't catch all
 353 cases (the rest are caught in lookupInst).
 354
 355 \begin{code}
 356 newOverloadedLit :: InstOrigin s
 357                  -> OverloadedLit
 358                  -> TcType s
 359                  -> NF_TcM s (TcExpr s, LIE s)
 360 newOverloadedLit orig (OverloadedIntegral i) ty
 361   | isIntTy ty && inIntRange i          -- Short cut for Int
 362   = returnNF_Tc (int_lit, emptyLIE)
 363
 364   | isIntegerTy ty                      -- Short cut for Integer
 365   = returnNF_Tc (integer_lit, emptyLIE)
 366
 367   where
 368     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
 369     integer_lit    = HsLitOut (HsInt i) integerTy
 370     int_lit        = HsCon intDataCon [] [intprim_lit]
 371
 372 newOverloadedLit orig lit ty            -- The general case
 373   = tcGetSrcLoc                 `thenNF_Tc` \ loc ->
 374     tcGetUnique                 `thenNF_Tc` \ new_uniq ->
 375     let
 376         lit_inst = LitInst new_uniq lit ty orig loc
 377     in
 378     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 379 \end{code}
 380
 381
 382 \begin{code}
 383 instToId :: Inst s -> TcIdOcc s
 384 instToId inst = TcId (instToIdBndr inst)
 385
 386 instToIdBndr :: Inst s -> TcIdBndr s
 387 instToIdBndr (Dict u clas ty orig loc)
 388   = mkUserLocal occ u (mkDictTy clas ty)
 389   where
 390     occ = VarOcc (SLIT("d.") _APPEND_ (occNameString (getOccName clas)))
 391
 392 instToIdBndr (Method u id tys theta tau orig loc)
 393   = mkUserLocal (getOccName id) u tau
 394
 395 instToIdBndr (LitInst u list ty orig loc)
 396   = mkSysLocal u ty
 397 \end{code}
 398
 399
 400 Zonking
 401 ~~~~~~~
 402 Zonking makes sure that the instance types are fully zonked,
 403 but doesn't do the same for the Id in a Method.  There's no
 404 need, and it's a lot of extra work.
 405
 406 \begin{code}
 407 zonkInst :: Inst s -> NF_TcM s (Inst s)
 408 zonkInst (Dict u clas tys orig loc)
 409   = zonkTcTypes tys                     `thenNF_Tc` \ new_tys ->
 410     returnNF_Tc (Dict u clas new_tys orig loc)
 411
 412 zonkInst (Method u id tys theta tau orig loc)
 413   = zonkTcId id                 `thenNF_Tc` \ new_id ->
 414       -- Essential to zonk the id in case it's a local variable
 415     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 416     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 417     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 418     returnNF_Tc (Method u new_id new_tys new_theta new_tau orig loc)
 419
 420 zonkInst (LitInst u lit ty orig loc)
 421   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 422     returnNF_Tc (LitInst u lit new_ty orig loc)
 423 \end{code}
 424
 425
 426 Printing
 427 ~~~~~~~~
 428 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 429 relevant in error messages.
 430
 431 \begin{code}
 432 instance Outputable (Inst s) where
 433     ppr inst = pprInst inst
 434
 435 pprInst (LitInst u lit ty orig loc)
 436   = hsep [case lit of
 437               OverloadedIntegral   i -> integer i
 438               OverloadedFractional f -> rational f,
 439            ptext SLIT("at"),
 440            ppr ty,
 441            show_uniq u]
 442
 443 pprInst (Dict u clas tys orig loc) = pprConstraint clas tys <+> show_uniq u
 444
 445 pprInst (Method u id tys _ _ orig loc)
 446   = hsep [ppr id, ptext SLIT("at"),
 447           brackets (interppSP tys),
 448           show_uniq u]
 449
 450 tidyInst :: TidyTypeEnv s -> Inst s -> (TidyTypeEnv s, Inst s)
 451 tidyInst env (LitInst u lit ty orig loc)
 452   = (env', LitInst u lit ty' orig loc)
 453   where
 454     (env', ty') = tidyType env ty
 455
 456 tidyInst env (Dict u clas tys orig loc)
 457   = (env', Dict u clas tys' orig loc)
 458   where
 459     (env', tys') = tidyTypes env tys
 460
 461 tidyInst env (Method u id tys theta tau orig loc)
 462   = (env', Method u id tys' theta tau orig loc)
 463                 -- Leave theta, tau alone cos we don't print them
 464   where
 465     (env', tys') = tidyTypes env tys
 466
 467 tidyInsts env insts = mapAccumL tidyInst env insts
 468
 469 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 470 \end{code}
 471
 472
 473 %************************************************************************
 474 %*                                                                      *
 475 \subsection[InstEnv-types]{Type declarations}
 476 %*                                                                      *
 477 %************************************************************************
 478
 479 \begin{code}
 480 type InstanceMapper = Class -> ClassInstEnv
 481 \end{code}
 482
 483 A @ClassInstEnv@ lives inside a class, and identifies all the instances
 484 of that class.  The @Id@ inside a ClassInstEnv mapping is the dfun for
 485 that instance.
 486
 487 There is an important consistency constraint between the @MatchEnv@s
 488 in and the dfun @Id@s inside them: the free type variables of the
 489 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
 490 type variables of the dfun.  Thus, the @ClassInstEnv@ for @Eq@ might
 491 contain the following entry:
 492 @
 493         [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
 494 @
 495 The "a" in the pattern must be one of the forall'd variables in
 496 the dfun type.
 497
 498 \begin{code}
 499 data LookupInstResult s
 500   = NoInstance
 501   | SimpleInst (TcExpr s)               -- Just a variable, type application, or literal
 502   | GenInst    [Inst s] (TcExpr s)      -- The expression and its needed insts
 503
 504 lookupInst :: Inst s
 505            -> NF_TcM s (LookupInstResult s)
 506
 507 -- Dictionaries
 508
 509 lookupInst dict@(Dict _ clas tys orig loc)
 510   = case lookupSpecEnv (ppr clas) (classInstEnv clas) tys of
 511
 512       Just (tenv, dfun_id)
 513         -> let
 514                 (tyvars, rho) = splitForAllTys (idType dfun_id)
 515                 ty_args       = map (expectJust "Inst" . lookupVarEnv tenv) tyvars
 516                                 -- tenv should bind all the tyvars
 517                 dfun_rho      = substFlexiTy tenv rho
 518                 (theta, tau)  = splitRhoTy dfun_rho
 519                 ty_app        = mkHsTyApp (HsVar (RealId dfun_id)) ty_args
 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   = tcLookupGlobalValueByKey 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   = tcLookupGlobalValueByKey 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           = tcLookupGlobalValueByKey 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 :: ClassInstEnv
 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 lookupSpecEnv (ppr clas) class_inst_env tys of
 604       Nothing    -> returnNF_Tc Nothing
 605
 606       Just (tenv, dfun)
 607         -> returnNF_Tc (Just (substFlexiTheta 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 s
 626   = OccurrenceOf (TcIdOcc s)    -- 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 s -> 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}