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