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