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