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 #include "HsVersions.h"
   8
   9 module Inst (
  10         Inst(..),       -- Visible only to TcSimplify
  11
  12         InstOrigin(..), OverloadedLit(..),
  13         SYN_IE(LIE), emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs,
  14
  15         SYN_IE(InstanceMapper),
  16
  17         newDicts, newDictsAtLoc, newMethod, newMethodWithGivenTy, newOverloadedLit,
  18
  19         instType, tyVarsOfInst, lookupInst, lookupSimpleInst,
  20
  21         isDict, isTyVarDict,
  22
  23         zonkInst, instToId,
  24
  25         matchesInst,
  26         instBindingRequired, instCanBeGeneralised,
  27
  28         pprInst
  29     ) where
  30
  31 IMP_Ubiq()
  32 IMPORT_1_3(Ratio(Rational))
  33
  34 import HsSyn    ( HsLit(..), HsExpr(..), HsBinds, Fixity,
  35                   InPat, OutPat, Stmt, Qualifier, Match,
  36                   ArithSeqInfo, HsType, Fake )
  37 import RnHsSyn  ( SYN_IE(RenamedArithSeqInfo), SYN_IE(RenamedHsExpr) )
  38 import TcHsSyn  ( TcIdOcc(..), SYN_IE(TcExpr), SYN_IE(TcIdBndr),
  39                   mkHsTyApp, mkHsDictApp, tcIdTyVars )
  40
  41 import TcMonad
  42 import TcEnv    ( tcLookupGlobalValueByKey, tcLookupTyConByKey )
  43 import TcType   ( SYN_IE(TcType), SYN_IE(TcRhoType), TcMaybe, SYN_IE(TcTyVarSet),
  44                   tcInstType, zonkTcType )
  45
  46 import Bag      ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag )
  47 import Class    ( classInstEnv,
  48                   SYN_IE(Class), GenClass, SYN_IE(ClassInstEnv), SYN_IE(ClassOp)
  49                 )
  50 import ErrUtils ( addErrLoc, SYN_IE(Error) )
  51 import Id       ( GenId, idType, mkInstId )
  52 import PrelInfo ( isCcallishClass, isNoDictClass )
  53 import MatchEnv ( lookupMEnv, insertMEnv )
  54 import Name     ( OccName(..), Name, mkLocalName, mkSysLocalName, occNameString )
  55 import Outputable
  56 import PprType  ( GenClass, TyCon, GenType, GenTyVar, pprParendGenType )
  57 import PprStyle ( PprStyle(..) )
  58 import Pretty
  59 import SpecEnv  ( SpecEnv )
  60 import SrcLoc   ( SrcLoc, noSrcLoc )
  61 import Type     ( GenType, eqSimpleTy, instantiateTy,
  62                   isTyVarTy, mkDictTy, splitForAllTy, splitSigmaTy,
  63                   splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes,
  64                   mkSynTy
  65                 )
  66 import TyVar    ( unionTyVarSets, GenTyVar )
  67 import TysPrim    ( intPrimTy )
  68 import TysWiredIn ( intDataCon, integerTy )
  69 import Unique   ( showUnique, fromRationalClassOpKey, rationalTyConKey,
  70                   fromIntClassOpKey, fromIntegerClassOpKey, Unique
  71                 )
  72 import Util     ( panic, zipEqual, zipWithEqual, assoc, assertPanic, pprTrace{-ToDo:rm-} )
  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 plusLIE lie1 lie2 = lie1 `unionBags` lie2
  87 consLIE inst lie  = inst `consBag` lie
  88 plusLIEs lies     = unionManyBags lies
  89
  90 zonkLIE :: LIE s -> NF_TcM s (LIE s)
  91 zonkLIE lie = mapBagNF_Tc zonkInst lie
  92 \end{code}
  93
  94 %************************************************************************
  95 %*                                                                      *
  96 \subsection[Inst-types]{@Inst@ types}
  97 %*                                                                      *
  98 %************************************************************************
  99
 100 An @Inst@ is either a dictionary, an instance of an overloaded
 101 literal, or an instance of an overloaded value.  We call the latter a
 102 ``method'' even though it may not correspond to a class operation.
 103 For example, we might have an instance of the @double@ function at
 104 type Int, represented by
 105
 106         Method 34 doubleId [Int] origin
 107
 108 \begin{code}
 109 data Inst s
 110   = Dict
 111         Unique
 112         Class           -- The type of the dict is (c t), where
 113         (TcType s)      -- c is the class and t the type;
 114         (InstOrigin s)
 115         SrcLoc
 116
 117   | Method
 118         Unique
 119
 120         (TcIdOcc s)     -- The overloaded function
 121                         -- This function will be a global, local, or ClassOpId;
 122                         --   inside instance decls (only) it can also be an InstId!
 123                         -- The id needn't be completely polymorphic.
 124                         -- You'll probably find its name (for documentation purposes)
 125                         --        inside the InstOrigin
 126
 127         [TcType s]      -- The types to which its polymorphic tyvars
 128                         --      should be instantiated.
 129                         -- These types must saturate the Id's foralls.
 130
 131         (TcRhoType s)   -- Cached: (type-of-id applied to inst_tys)
 132                         -- If this type is (theta => tau) then the type of the Method
 133                         -- is tau, and the method can be built by saying
 134                         --      id inst_tys dicts
 135                         -- where dicts are constructed from theta
 136
 137         (InstOrigin s)
 138         SrcLoc
 139
 140   | LitInst
 141         Unique
 142         OverloadedLit
 143         (TcType s)      -- The type at which the literal is used
 144         (InstOrigin s)  -- Always a literal; but more convenient to carry this around
 145         SrcLoc
 146
 147 data OverloadedLit
 148   = OverloadedIntegral   Integer        -- The number
 149   | OverloadedFractional Rational       -- The number
 150
 151 getInstOrigin (Dict   u clas ty     origin loc) = origin
 152 getInstOrigin (Method u clas ty rho origin loc) = origin
 153 getInstOrigin (LitInst u lit ty     origin loc) = origin
 154 \end{code}
 155
 156 Construction
 157 ~~~~~~~~~~~~
 158
 159 \begin{code}
 160 newDicts :: InstOrigin s
 161          -> [(Class, TcType s)]
 162          -> NF_TcM s (LIE s, [TcIdOcc s])
 163 newDicts orig theta
 164   = tcGetSrcLoc                         `thenNF_Tc` \ loc ->
 165     newDictsAtLoc orig loc theta        `thenNF_Tc` \ (dicts, ids) ->
 166     returnNF_Tc (listToBag dicts, ids)
 167 {-
 168     tcGetUniques (length theta)         `thenNF_Tc` \ new_uniqs ->
 169     let
 170         mk_dict u (clas, ty) = Dict u clas ty orig loc
 171         dicts = zipWithEqual "newDicts" mk_dict new_uniqs theta
 172     in
 173     returnNF_Tc (listToBag dicts, map instToId dicts)
 174 -}
 175
 176 -- Local function, similar to newDicts,
 177 -- but with slightly different interface
 178 newDictsAtLoc :: InstOrigin s
 179               -> SrcLoc
 180               -> [(Class, TcType s)]
 181               -> NF_TcM s ([Inst s], [TcIdOcc s])
 182 newDictsAtLoc orig loc theta =
 183  tcGetUniques (length theta)            `thenNF_Tc` \ new_uniqs ->
 184  let
 185   mk_dict u (clas, ty) = Dict u clas ty orig loc
 186   dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
 187  in
 188  returnNF_Tc (dicts, map instToId dicts)
 189
 190 newMethod :: InstOrigin s
 191           -> TcIdOcc s
 192           -> [TcType s]
 193           -> NF_TcM s (LIE s, TcIdOcc s)
 194 newMethod orig id tys
 195   =     -- Get the Id type and instantiate it at the specified types
 196     (case id of
 197        RealId id -> let (tyvars, rho) = splitForAllTy (idType id)
 198                     in
 199                     (if length tyvars /= length tys then pprTrace "newMethod" (ppr PprDebug (idType id)) else \x->x) $
 200                     tcInstType (zip{-Equal "newMethod"-} tyvars tys) rho
 201        TcId   id -> let (tyvars, rho) = splitForAllTy (idType id)
 202                     in returnNF_Tc (instantiateTy (zipEqual "newMethod(2)" tyvars tys) rho)
 203     )                                           `thenNF_Tc` \ rho_ty ->
 204          -- Our friend does the rest
 205     newMethodWithGivenTy orig id tys rho_ty
 206
 207
 208 newMethodWithGivenTy orig id tys rho_ty
 209   = tcGetSrcLoc         `thenNF_Tc` \ loc ->
 210     tcGetUnique         `thenNF_Tc` \ new_uniq ->
 211     let
 212         meth_inst = Method new_uniq id tys rho_ty orig loc
 213     in
 214     returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
 215
 216 newMethodAtLoc :: InstOrigin s -> SrcLoc -> Id -> [TcType s] -> NF_TcM s (Inst s, TcIdOcc s)
 217 newMethodAtLoc orig loc real_id tys     -- Local function, similar to newMethod but with
 218                                         -- slightly different interface
 219   =     -- Get the Id type and instantiate it at the specified types
 220     let
 221          (tyvars,rho) = splitForAllTy (idType real_id)
 222     in
 223     tcInstType (zipEqual "newMethodAtLoc" tyvars tys) rho `thenNF_Tc` \ rho_ty ->
 224     tcGetUnique                                           `thenNF_Tc` \ new_uniq ->
 225     let
 226         meth_inst = Method new_uniq (RealId real_id) tys rho_ty orig loc
 227     in
 228     returnNF_Tc (meth_inst, instToId meth_inst)
 229
 230 newOverloadedLit :: InstOrigin s
 231                  -> OverloadedLit
 232                  -> TcType s
 233                  -> NF_TcM s (LIE s, TcIdOcc s)
 234 newOverloadedLit orig lit ty
 235   = tcGetSrcLoc                 `thenNF_Tc` \ loc ->
 236     tcGetUnique                 `thenNF_Tc` \ new_uniq ->
 237     let
 238         lit_inst = LitInst new_uniq lit ty orig loc
 239     in
 240     returnNF_Tc (unitLIE lit_inst, instToId lit_inst)
 241 \end{code}
 242
 243
 244 \begin{code}
 245 instToId :: Inst s -> TcIdOcc s
 246 instToId (Dict u clas ty orig loc)
 247   = TcId (mkInstId u (mkDictTy clas ty) (mkLocalName u str loc))
 248   where
 249     str = VarOcc (SLIT("d.") _APPEND_ (occNameString (getOccName clas)))
 250
 251 instToId (Method u id tys rho_ty orig loc)
 252   = TcId (mkInstId u tau_ty (mkLocalName u str loc))
 253   where
 254     (_, tau_ty) = splitRhoTy rho_ty     -- NB The method Id has just the tau type
 255     str = VarOcc (SLIT("m.") _APPEND_ (occNameString (getOccName id)))
 256
 257 instToId (LitInst u list ty orig loc)
 258   = TcId (mkInstId u ty (mkSysLocalName u SLIT("lit") loc))
 259 \end{code}
 260
 261 \begin{code}
 262 instType :: Inst s -> TcType s
 263 instType (Dict _ clas ty _ _)     = mkDictTy clas ty
 264 instType (LitInst _ _ ty _ _)     = ty
 265 instType (Method _ id tys ty _ _) = ty
 266 \end{code}
 267
 268
 269 Zonking
 270 ~~~~~~~
 271 Zonking makes sure that the instance types are fully zonked,
 272 but doesn't do the same for the Id in a Method.  There's no
 273 need, and it's a lot of extra work.
 274
 275 \begin{code}
 276 zonkInst :: Inst s -> NF_TcM s (Inst s)
 277 zonkInst (Dict u clas ty orig loc)
 278   = zonkTcType  ty                      `thenNF_Tc` \ new_ty ->
 279     returnNF_Tc (Dict u clas new_ty orig loc)
 280
 281 zonkInst (Method u id tys rho orig loc)                 -- Doesn't zonk the id!
 282   = mapNF_Tc zonkTcType tys             `thenNF_Tc` \ new_tys ->
 283     zonkTcType rho                      `thenNF_Tc` \ new_rho ->
 284     returnNF_Tc (Method u id new_tys new_rho orig loc)
 285
 286 zonkInst (LitInst u lit ty orig loc)
 287   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 288     returnNF_Tc (LitInst u lit new_ty orig loc)
 289 \end{code}
 290
 291
 292 \begin{code}
 293 tyVarsOfInst :: Inst s -> TcTyVarSet s
 294 tyVarsOfInst (Dict _ _ ty _ _)        = tyVarsOfType  ty
 295 tyVarsOfInst (Method _ id tys rho _ _) = tyVarsOfTypes tys `unionTyVarSets` tcIdTyVars id
 296                                          -- The id might not be a RealId; in the case of
 297                                          -- locally-overloaded class methods, for example
 298 tyVarsOfInst (LitInst _ _ ty _ _)     = tyVarsOfType  ty
 299 \end{code}
 300
 301 @matchesInst@ checks when two @Inst@s are instances of the same
 302 thing at the same type, even if their uniques differ.
 303
 304 \begin{code}
 305 matchesInst :: Inst s -> Inst s -> Bool
 306
 307 matchesInst (Dict _ clas1 ty1 _ _) (Dict _ clas2 ty2 _ _)
 308   = clas1 == clas2 && ty1 `eqSimpleTy` ty2
 309
 310 matchesInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _)
 311   =  id1 == id2
 312   && and (zipWith eqSimpleTy tys1 tys2)
 313   && length tys1 == length tys2
 314
 315 matchesInst (LitInst _ lit1 ty1 _ _) (LitInst _ lit2 ty2 _ _)
 316   = lit1 `eq` lit2 && ty1 `eqSimpleTy` ty2
 317   where
 318     (OverloadedIntegral   i1) `eq` (OverloadedIntegral   i2) = i1 == i2
 319     (OverloadedFractional f1) `eq` (OverloadedFractional f2) = f1 == f2
 320     _                         `eq` _                         = False
 321
 322 matchesInst other1 other2 = False
 323 \end{code}
 324
 325
 326 Predicates
 327 ~~~~~~~~~~
 328 \begin{code}
 329 isDict :: Inst s -> Bool
 330 isDict (Dict _ _ _ _ _) = True
 331 isDict other            = False
 332
 333 isTyVarDict :: Inst s -> Bool
 334 isTyVarDict (Dict _ _ ty _ _) = isTyVarTy ty
 335 isTyVarDict other             = False
 336 \end{code}
 337
 338 Two predicates which deal with the case where class constraints don't
 339 necessarily result in bindings.  The first tells whether an @Inst@
 340 must be witnessed by an actual binding; the second tells whether an
 341 @Inst@ can be generalised over.
 342
 343 \begin{code}
 344 instBindingRequired :: Inst s -> Bool
 345 instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas)
 346 instBindingRequired other               = True
 347
 348 instCanBeGeneralised :: Inst s -> Bool
 349 instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas)
 350 instCanBeGeneralised other               = True
 351 \end{code}
 352
 353
 354 Printing
 355 ~~~~~~~~
 356 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 357 relevant in error messages.
 358
 359 \begin{code}
 360 instance Outputable (Inst s) where
 361     ppr sty inst = ppr_inst sty ppNil (\ o l -> ppNil) inst
 362
 363 pprInst sty hdr inst = ppr_inst sty hdr (\ o l -> pprOrigin hdr o l sty) inst
 364
 365 ppr_inst sty hdr ppr_orig (LitInst u lit ty orig loc)
 366   = ppHang (ppr_orig orig loc)
 367          4 (ppCat [case lit of
 368                       OverloadedIntegral   i -> ppInteger i
 369                       OverloadedFractional f -> ppRational f,
 370                    ppStr "at",
 371                    ppr sty ty,
 372                    show_uniq sty u])
 373
 374 ppr_inst sty hdr ppr_orig (Dict u clas ty orig loc)
 375   = ppHang (ppr_orig orig loc)
 376          4 (ppCat [ppr sty clas, pprParendGenType sty ty, show_uniq sty u])
 377
 378 ppr_inst sty hdr ppr_orig (Method u id tys rho orig loc)
 379   = ppHang (ppr_orig orig loc)
 380          4 (ppCat [ppr sty id, ppStr "at", interppSP sty tys, show_uniq sty u])
 381
 382 show_uniq PprDebug u = ppr PprDebug u
 383 show_uniq sty      u = ppNil
 384 \end{code}
 385
 386 Printing in error messages
 387
 388 \begin{code}
 389 noInstanceErr inst sty = ppHang (ppPStr SLIT("No instance for:")) 4 (ppr sty inst)
 390 \end{code}
 391
 392 %************************************************************************
 393 %*                                                                      *
 394 \subsection[InstEnv-types]{Type declarations}
 395 %*                                                                      *
 396 %************************************************************************
 397
 398 \begin{code}
 399 type InstanceMapper = Class -> (ClassInstEnv, ClassOp -> SpecEnv)
 400 \end{code}
 401
 402 A @ClassInstEnv@ lives inside a class, and identifies all the instances
 403 of that class.  The @Id@ inside a ClassInstEnv mapping is the dfun for
 404 that instance.
 405
 406 There is an important consistency constraint between the @MatchEnv@s
 407 in and the dfun @Id@s inside them: the free type variables of the
 408 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
 409 type variables of the dfun.  Thus, the @ClassInstEnv@ for @Eq@ might
 410 contain the following entry:
 411 @
 412         [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
 413 @
 414 The "a" in the pattern must be one of the forall'd variables in
 415 the dfun type.
 416
 417 \begin{code}
 418 lookupInst :: Inst s
 419            -> TcM s ([Inst s],
 420                      (TcIdOcc s, TcExpr s))     -- The new binding
 421
 422 -- Dictionaries
 423
 424 lookupInst dict@(Dict _ clas ty orig loc)
 425   = case lookupMEnv matchTy (get_inst_env clas orig) ty of
 426       Nothing   -> tcAddSrcLoc loc               $
 427                    tcAddErrCtxt (pprOrigin ""{-hdr-} orig loc) $
 428                    failTc (noInstanceErr dict)
 429
 430       Just (dfun_id, tenv)
 431         -> let
 432                 (tyvars, rho) = splitForAllTy (idType dfun_id)
 433                 ty_args       = map (assoc "lookupInst" tenv) tyvars
 434                 -- tenv should bind all the tyvars
 435            in
 436            tcInstType tenv rho          `thenNF_Tc` \ dfun_rho ->
 437            let
 438                 (theta, tau) = splitRhoTy dfun_rho
 439            in
 440            newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
 441            let
 442                 rhs = mkHsDictApp (mkHsTyApp (HsVar (RealId dfun_id)) ty_args) dict_ids
 443            in
 444            returnTc (dicts, (instToId dict, rhs))
 445
 446
 447 -- Methods
 448
 449 lookupInst inst@(Method _ id tys rho orig loc)
 450   = newDictsAtLoc orig loc theta        `thenNF_Tc` \ (dicts, dict_ids) ->
 451     returnTc (dicts, (instToId inst, mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
 452   where
 453     (theta,_) = splitRhoTy rho
 454
 455 -- Literals
 456
 457 lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
 458   | i >= toInteger minInt && i <= toInteger maxInt
 459   =     -- It's overloaded but small enough to fit into an Int
 460     tcLookupGlobalValueByKey fromIntClassOpKey  `thenNF_Tc` \ from_int ->
 461     newMethodAtLoc orig loc from_int [ty]               `thenNF_Tc` \ (method_inst, method_id) ->
 462     returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) int_lit))
 463
 464   | otherwise
 465   =     -- Alas, it is overloaded and a big literal!
 466     tcLookupGlobalValueByKey fromIntegerClassOpKey      `thenNF_Tc` \ from_integer ->
 467     newMethodAtLoc orig loc from_integer [ty]           `thenNF_Tc` \ (method_inst, method_id) ->
 468     returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsInt i) integerTy)))
 469   where
 470     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
 471     int_lit        = HsApp (HsVar (RealId intDataCon)) intprim_lit
 472
 473 lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
 474   = tcLookupGlobalValueByKey fromRationalClassOpKey     `thenNF_Tc` \ from_rational ->
 475
 476         -- The type Rational isn't wired in so we have to conjure it up
 477     tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
 478     let
 479         rational_ty  = mkSynTy rational_tycon []
 480         rational_lit = HsLitOut (HsFrac f) rational_ty
 481     in
 482     newMethodAtLoc orig loc from_rational [ty]          `thenNF_Tc` \ (method_inst, method_id) ->
 483     returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) rational_lit))
 484 \end{code}
 485
 486 There is a second, simpler interface, when you want an instance of a
 487 class at a given nullary type constructor.  It just returns the
 488 appropriate dictionary if it exists.  It is used only when resolving
 489 ambiguous dictionaries.
 490
 491 \begin{code}
 492 lookupSimpleInst :: ClassInstEnv
 493                  -> Class
 494                  -> Type                        -- Look up (c,t)
 495                  -> TcM s [(Class,Type)]        -- Here are the needed (c,t)s
 496
 497 lookupSimpleInst class_inst_env clas ty
 498   = case (lookupMEnv matchTy class_inst_env ty) of
 499       Nothing          -> failTc (noSimpleInst clas ty)
 500       Just (dfun,tenv) -> returnTc [(c,instantiateTy tenv t) | (c,t) <- theta]
 501                        where
 502                           (_, theta, _) = splitSigmaTy (idType dfun)
 503
 504 noSimpleInst clas ty sty
 505   = ppSep [ppStr "No instance for class", ppQuote (ppr sty clas),
 506            ppStr "at type", ppQuote (ppr sty ty)]
 507 \end{code}
 508
 509
 510 @mkInstSpecEnv@ is used to construct the @SpecEnv@ for a dfun.
 511 It does it by filtering the class's @InstEnv@.  All pretty shady stuff.
 512
 513 \begin{code}
 514 mkInstSpecEnv clas inst_ty inst_tvs inst_theta = panic "mkInstSpecEnv"
 515 \end{code}
 516
 517 \begin{pseudocode}
 518 mkInstSpecEnv :: Class                  -- class
 519               -> Type                   -- instance type
 520               -> [TyVarTemplate]        -- instance tyvars
 521               -> ThetaType              -- superclasses dicts
 522               -> SpecEnv                -- specenv for dfun of instance
 523
 524 mkInstSpecEnv clas inst_ty inst_tvs inst_theta
 525   = mkSpecEnv (catMaybes (map maybe_spec_info matches))
 526   where
 527     matches = matchMEnv matchTy (classInstEnv clas) inst_ty
 528
 529     maybe_spec_info (_, match_info, MkInstTemplate dfun _ [])
 530       = Just (SpecInfo (map (assocMaybe match_info) inst_tvs) (length inst_theta) dfun)
 531     maybe_spec_info (_, match_info, _)
 532       = Nothing
 533 \end{pseudocode}
 534
 535
 536 \begin{code}
 537 addClassInst
 538     :: ClassInstEnv             -- Incoming envt
 539     -> Type                     -- The instance type: inst_ty
 540     -> Id                       -- Dict fun id to apply. Free tyvars of inst_ty must
 541                                 -- be the same as the forall'd tyvars of the dfun id.
 542     -> MaybeErr
 543           ClassInstEnv          -- Success
 544           (Type, Id)            -- Offending overlap
 545
 546 addClassInst inst_env inst_ty dfun_id = insertMEnv matchTy inst_env inst_ty dfun_id
 547 \end{code}
 548
 549
 550
 551 %************************************************************************
 552 %*                                                                      *
 553 \subsection[Inst-origin]{The @InstOrigin@ type}
 554 %*                                                                      *
 555 %************************************************************************
 556
 557 The @InstOrigin@ type gives information about where a dictionary came from.
 558 This is important for decent error message reporting because dictionaries
 559 don't appear in the original source code.  Doubtless this type will evolve...
 560
 561 \begin{code}
 562 data InstOrigin s
 563   = OccurrenceOf (TcIdOcc s)    -- Occurrence of an overloaded identifier
 564   | OccurrenceOfCon Id          -- Occurrence of a data constructor
 565
 566   | RecordUpdOrigin
 567
 568   | DataDeclOrigin              -- Typechecking a data declaration
 569
 570   | InstanceDeclOrigin          -- Typechecking an instance decl
 571
 572   | LiteralOrigin       HsLit   -- Occurrence of a literal
 573
 574   | ArithSeqOrigin      RenamedArithSeqInfo -- [x..], [x..y] etc
 575
 576   | SignatureOrigin             -- A dict created from a type signature
 577
 578   | DoOrigin                    -- The monad for a do expression
 579
 580   | ClassDeclOrigin             -- Manufactured during a class decl
 581
 582 --      NO MORE!
 583 --  | DerivingOrigin    InstanceMapper
 584 --                      Class
 585 --                      TyCon
 586
 587         -- During "deriving" operations we have an ever changing
 588         -- mapping of classes to instances, so we record it inside the
 589         -- origin information.  This is a bit of a hack, but it works
 590         -- fine.  (Simon is to blame [WDP].)
 591
 592   | InstanceSpecOrigin  InstanceMapper
 593                         Class   -- in a SPECIALIZE instance pragma
 594                         Type
 595
 596         -- When specialising instances the instance info attached to
 597         -- each class is not yet ready, so we record it inside the
 598         -- origin information.  This is a bit of a hack, but it works
 599         -- fine.  (Patrick is to blame [WDP].)
 600
 601 --  | DefaultDeclOrigin         -- Related to a `default' declaration
 602
 603   | ValSpecOrigin       Name    -- in a SPECIALIZE pragma for a value
 604
 605         -- Argument or result of a ccall
 606         -- Dictionaries with this origin aren't actually mentioned in the
 607         -- translated term, and so need not be bound.  Nor should they
 608         -- be abstracted over.
 609
 610   | CCallOrigin         String                  -- CCall label
 611                         (Maybe RenamedHsExpr)   -- Nothing if it's the result
 612                                                 -- Just arg, for an argument
 613
 614   | LitLitOrigin        String  -- the litlit
 615
 616   | UnknownOrigin       -- Help! I give up...
 617 \end{code}
 618
 619 \begin{code}
 620 -- During deriving and instance specialisation operations
 621 -- we can't get the instances of the class from inside the
 622 -- class, because the latter ain't ready yet.  Instead we
 623 -- find a mapping from classes to envts inside the dict origin.
 624
 625 get_inst_env :: Class -> InstOrigin s -> ClassInstEnv
 626 -- get_inst_env clas (DerivingOrigin inst_mapper _ _)
 627 --  = fst (inst_mapper clas)
 628 get_inst_env clas (InstanceSpecOrigin inst_mapper _ _)
 629   = fst (inst_mapper clas)
 630 get_inst_env clas other_orig = classInstEnv clas
 631
 632
 633 pprOrigin :: String -> InstOrigin s -> SrcLoc -> Error
 634
 635 pprOrigin hdr orig locn
 636   = addErrLoc locn hdr $ \ sty ->
 637     case orig of
 638       OccurrenceOf id ->
 639         ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"),
 640                    ppr sty id, ppChar '\'']
 641       OccurrenceOfCon id ->
 642         ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"),
 643                    ppr sty id, ppChar '\'']
 644       InstanceDeclOrigin ->
 645         ppStr "in an instance declaration"
 646       LiteralOrigin lit ->
 647         ppCat [ppStr "at an overloaded literal:", ppr sty lit]
 648       ArithSeqOrigin seq ->
 649         ppCat [ppStr "at an arithmetic sequence:", ppr sty seq]
 650       SignatureOrigin ->
 651         ppStr "in a type signature"
 652       DoOrigin ->
 653         ppStr "in a do statement"
 654       ClassDeclOrigin ->
 655         ppStr "in a class declaration"
 656       InstanceSpecOrigin _ clas ty ->
 657         ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"",
 658                    ppr sty clas, ppStr "\" type: ", ppr sty ty]
 659       ValSpecOrigin name ->
 660         ppBesides [ppStr "in a SPECIALIZE user-pragma for `",
 661                    ppr sty name, ppStr "'"]
 662       CCallOrigin clabel Nothing{-ccall result-} ->
 663         ppBesides [ppStr "in the result of the _ccall_ to `",
 664                    ppStr clabel, ppStr "'"]
 665       CCallOrigin clabel (Just arg_expr) ->
 666         ppBesides [ppStr "in an argument in the _ccall_ to `",
 667                   ppStr clabel, ppStr "', namely: ", ppr sty arg_expr]
 668       LitLitOrigin s ->
 669         ppBesides [ppStr "in this ``literal-literal'': ", ppStr s]
 670       UnknownOrigin ->
 671         ppStr "in... oops -- I don't know where the overloading came from!"
 672 \end{code}