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