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,
  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      ( Bag, emptyBag, unitBag, unionBags, listToBag, consBag )
  45 import Class    ( Class(..), GenClass, ClassInstEnv(..), getClassInstEnv )
  46 import Id       ( GenId, idType, mkInstId )
  47 import MatchEnv ( lookupMEnv, insertMEnv )
  48 import Name     ( Name )
  49 import NameTypes( ShortName, mkShortName )
  50 import Outputable
  51 import PprType  ( GenClass, TyCon, GenType, GenTyVar )
  52 import PprStyle ( PprStyle(..) )
  53 import Pretty
  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
  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 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 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 (tyvars `zipEqual` tys) rho
 182         TcId   id -> let (tyvars, rho) = splitForAllTy (idType id)
 183                      in tcInstTcType (tyvars `zipEqual` tys) rho
 184    )                                            `thenNF_Tc` \ rho_ty ->
 185
 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 uniq clas ty orig loc)
 229   = TcId (mkInstId uniq (mkDictTy clas ty) (mkShortName SLIT("dict") loc))
 230 instToId (Method uniq id tys rho_ty orig loc)
 231   = TcId (mkInstId uniq tau_ty (mkShortName (getOccurrenceName id) loc))
 232   where
 233     (_, tau_ty) = splitRhoTy rho_ty     -- NB The method Id has just the tau type
 234 instToId (LitInst uniq list ty orig loc)
 235   = TcId (mkInstId uniq ty (mkShortName 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 uniq clas ty orig loc)
 255   = zonkTcType  ty                      `thenNF_Tc` \ new_ty ->
 256     returnNF_Tc (Dict uniq clas new_ty orig loc)
 257
 258 zonkInst (Method uniq 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 uniq id new_tys new_rho orig loc)
 262
 263 zonkInst (LitInst uniq lit ty orig loc)
 264   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 265     returnNF_Tc (LitInst uniq 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 (getClassInstEnv 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 (getClassInstEnv 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   | InstanceDeclOrigin          -- Typechecking an instance decl
 541
 542   | LiteralOrigin       HsLit   -- Occurrence of a literal
 543
 544   | ArithSeqOrigin      RenamedArithSeqInfo -- [x..], [x..y] etc
 545
 546   | SignatureOrigin             -- A dict created from a type signature
 547
 548   | DoOrigin                    -- The monad for a do expression
 549
 550   | ClassDeclOrigin             -- Manufactured during a class decl
 551
 552   | DerivingOrigin      InstanceMapper
 553                         Class
 554                         TyCon
 555
 556         -- During "deriving" operations we have an ever changing
 557         -- mapping of classes to instances, so we record it inside the
 558         -- origin information.  This is a bit of a hack, but it works
 559         -- fine.  (Simon is to blame [WDP].)
 560
 561   | InstanceSpecOrigin  InstanceMapper
 562                         Class   -- in a SPECIALIZE instance pragma
 563                         Type
 564
 565         -- When specialising instances the instance info attached to
 566         -- each class is not yet ready, so we record it inside the
 567         -- origin information.  This is a bit of a hack, but it works
 568         -- fine.  (Patrick is to blame [WDP].)
 569
 570   | DefaultDeclOrigin           -- Related to a `default' declaration
 571
 572   | ValSpecOrigin       Name    -- in a SPECIALIZE pragma for a value
 573
 574         -- Argument or result of a ccall
 575         -- Dictionaries with this origin aren't actually mentioned in the
 576         -- translated term, and so need not be bound.  Nor should they
 577         -- be abstracted over.
 578
 579   | CCallOrigin         String                  -- CCall label
 580                         (Maybe RenamedHsExpr)   -- Nothing if it's the result
 581                                                 -- Just arg, for an argument
 582
 583   | LitLitOrigin        String  -- the litlit
 584
 585   | UnknownOrigin       -- Help! I give up...
 586 \end{code}
 587
 588 \begin{code}
 589 -- During deriving and instance specialisation operations
 590 -- we can't get the instances of the class from inside the
 591 -- class, because the latter ain't ready yet.  Instead we
 592 -- find a mapping from classes to envts inside the dict origin.
 593
 594 get_inst_env :: Class -> InstOrigin s -> ClassInstEnv
 595 get_inst_env clas (DerivingOrigin inst_mapper _ _)
 596   = fst (inst_mapper clas)
 597 get_inst_env clas (InstanceSpecOrigin inst_mapper _ _)
 598   = fst (inst_mapper clas)
 599 get_inst_env clas other_orig = getClassInstEnv clas
 600
 601
 602 pprOrigin :: PprStyle -> InstOrigin s -> Pretty
 603
 604 pprOrigin sty (OccurrenceOf id)
 605       = ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"),
 606                    ppr sty id, ppChar '\'']
 607 pprOrigin sty (OccurrenceOfCon id)
 608       = ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"),
 609                    ppr sty id, ppChar '\'']
 610 pprOrigin sty (InstanceDeclOrigin)
 611       = ppStr "in an instance declaration"
 612 pprOrigin sty (LiteralOrigin lit)
 613       = ppCat [ppStr "at an overloaded literal:", ppr sty lit]
 614 pprOrigin sty (ArithSeqOrigin seq)
 615       = ppCat [ppStr "at an arithmetic sequence:", ppr sty seq]
 616 pprOrigin sty (SignatureOrigin)
 617       = ppStr "in a type signature"
 618 pprOrigin sty (DoOrigin)
 619       = ppStr "in a do statement"
 620 pprOrigin sty (ClassDeclOrigin)
 621       = ppStr "in a class declaration"
 622 pprOrigin sty (DerivingOrigin _ clas tycon)
 623       = ppBesides [ppStr "in a `deriving' clause; class `",
 624                           ppr sty clas,
 625                           ppStr "'; offending type `",
 626                           ppr sty tycon,
 627                           ppStr "'"]
 628 pprOrigin sty (InstanceSpecOrigin _ clas ty)
 629       = ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"",
 630                    ppr sty clas, ppStr "\" type: ", ppr sty ty]
 631 pprOrigin sty (DefaultDeclOrigin)
 632       = ppStr "in a `default' declaration"
 633 pprOrigin sty (ValSpecOrigin name)
 634       = ppBesides [ppStr "in a SPECIALIZE user-pragma for `",
 635                    ppr sty name, ppStr "'"]
 636 pprOrigin sty (CCallOrigin clabel Nothing{-ccall result-})
 637       = ppBesides [ppStr "in the result of the _ccall_ to `",
 638                    ppStr clabel, ppStr "'"]
 639 pprOrigin sty (CCallOrigin clabel (Just arg_expr))
 640       = ppBesides [ppStr "in an argument in the _ccall_ to `",
 641                   ppStr clabel, ppStr "', namely: ", ppr sty arg_expr]
 642 pprOrigin sty (LitLitOrigin s)
 643       = ppBesides [ppStr "in this ``literal-literal'': ", ppStr s]
 644 pprOrigin sty UnknownOrigin
 645       = ppStr "in... oops -- I don't know where the overloading came from!"
 646 \end{code}
 647
 648
 649