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