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