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