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       = 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
 352     ppr sty (Dict uniq clas ty orig loc)
 353       = ppSep [ppr sty clas,
 354                ppStr "at",
 355                ppr sty ty,
 356                show_uniq sty uniq
 357         ]
 358
 359     ppr sty (Method uniq id tys rho orig loc)
 360       = ppSep [ppr sty id,
 361                ppStr "at",
 362                ppr sty tys,
 363                show_uniq sty uniq
 364         ]
 365
 366 show_uniq PprDebug uniq = ppr PprDebug uniq
 367 show_uniq sty      uniq = ppNil
 368
 369 \end{code}
 370
 371 Printing in error messages
 372
 373 \begin{code}
 374 noInstanceErr inst sty = ppHang (ppPStr SLIT("No instance for:")) 4 (ppr sty inst)
 375 \end{code}
 376
 377 %************************************************************************
 378 %*                                                                      *
 379 \subsection[InstEnv-types]{Type declarations}
 380 %*                                                                      *
 381 %************************************************************************
 382
 383 \begin{code}
 384 type InstanceMapper = Class -> (ClassInstEnv, ClassOp -> SpecEnv)
 385 \end{code}
 386
 387 A @ClassInstEnv@ lives inside a class, and identifies all the instances
 388 of that class.  The @Id@ inside a ClassInstEnv mapping is the dfun for
 389 that instance.
 390
 391 There is an important consistency constraint between the @MatchEnv@s
 392 in and the dfun @Id@s inside them: the free type variables of the
 393 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
 394 type variables of the dfun.  Thus, the @ClassInstEnv@ for @Eq@ might
 395 contain the following entry:
 396 @
 397         [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
 398 @
 399 The "a" in the pattern must be one of the forall'd variables in
 400 the dfun type.
 401
 402 \begin{code}
 403 lookupInst :: Inst s
 404            -> TcM s ([Inst s],
 405                      (TcIdOcc s, TcExpr s))     -- The new binding
 406
 407 -- Dictionaries
 408
 409 lookupInst dict@(Dict _ clas ty orig loc)
 410   = case lookupMEnv matchTy (get_inst_env clas orig) ty of
 411       Nothing   -> tcAddSrcLoc loc               $
 412                    tcAddErrCtxt (pprOrigin orig) $
 413                    failTc (noInstanceErr dict)
 414
 415       Just (dfun_id, tenv)
 416         -> let
 417                 (tyvars, rho) = splitForAllTy (idType dfun_id)
 418                 ty_args       = map (assoc "lookupInst" tenv) tyvars
 419                 -- tenv should bind all the tyvars
 420            in
 421            tcInstType tenv rho          `thenNF_Tc` \ dfun_rho ->
 422            let
 423                 (theta, tau) = splitRhoTy dfun_rho
 424            in
 425            newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
 426            let
 427                 rhs = mkHsDictApp (mkHsTyApp (HsVar (RealId dfun_id)) ty_args) dict_ids
 428            in
 429            returnTc (dicts, (instToId dict, rhs))
 430
 431
 432 -- Methods
 433
 434 lookupInst inst@(Method _ id tys rho orig loc)
 435   = newDictsAtLoc orig loc theta        `thenNF_Tc` \ (dicts, dict_ids) ->
 436     returnTc (dicts, (instToId inst, mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
 437   where
 438     (theta,_) = splitRhoTy rho
 439
 440 -- Literals
 441
 442 lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
 443   | i >= toInteger minInt && i <= toInteger maxInt
 444   =     -- It's overloaded but small enough to fit into an Int
 445     tcLookupGlobalValueByKey fromIntClassOpKey  `thenNF_Tc` \ from_int ->
 446     newMethodAtLoc orig loc from_int [ty]               `thenNF_Tc` \ (method_inst, method_id) ->
 447     returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) int_lit))
 448
 449   | otherwise
 450   =     -- Alas, it is overloaded and a big literal!
 451     tcLookupGlobalValueByKey fromIntegerClassOpKey      `thenNF_Tc` \ from_integer ->
 452     newMethodAtLoc orig loc from_integer [ty]           `thenNF_Tc` \ (method_inst, method_id) ->
 453     returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsInt i) ty)))
 454   where
 455     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
 456     int_lit        = HsApp (HsVar (RealId intDataCon)) intprim_lit
 457
 458 lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
 459   = tcLookupGlobalValueByKey fromRationalClassOpKey     `thenNF_Tc` \ from_rational ->
 460     newMethodAtLoc orig loc from_rational [ty]          `thenNF_Tc` \ (method_inst, method_id) ->
 461     returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsFrac f) ty)))
 462 \end{code}
 463
 464 There is a second, simpler interface, when you want an instance of a
 465 class at a given nullary type constructor.  It just returns the
 466 appropriate dictionary if it exists.  It is used only when resolving
 467 ambiguous dictionaries.
 468
 469 \begin{code}
 470 lookupClassInstAtSimpleType :: Class -> Type -> Maybe Id
 471
 472 lookupClassInstAtSimpleType clas ty
 473   = case (lookupMEnv matchTy (classInstEnv clas) ty) of
 474       Nothing       -> Nothing
 475       Just (dfun,_) -> ASSERT( null tyvars && null theta )
 476                        Just dfun
 477                     where
 478                        (tyvars, theta, _) = splitSigmaTy (idType dfun)
 479 \end{code}
 480
 481
 482 @mkInstSpecEnv@ is used to construct the @SpecEnv@ for a dfun.
 483 It does it by filtering the class's @InstEnv@.  All pretty shady stuff.
 484
 485 \begin{code}
 486 mkInstSpecEnv clas inst_ty inst_tvs inst_theta = panic "mkInstSpecEnv"
 487 \end{code}
 488
 489 \begin{pseudocode}
 490 mkInstSpecEnv :: Class                  -- class
 491               -> Type                   -- instance type
 492               -> [TyVarTemplate]        -- instance tyvars
 493               -> ThetaType              -- superclasses dicts
 494               -> SpecEnv                -- specenv for dfun of instance
 495
 496 mkInstSpecEnv clas inst_ty inst_tvs inst_theta
 497   = mkSpecEnv (catMaybes (map maybe_spec_info matches))
 498   where
 499     matches = matchMEnv matchTy (classInstEnv clas) inst_ty
 500
 501     maybe_spec_info (_, match_info, MkInstTemplate dfun _ [])
 502       = Just (SpecInfo (map (assocMaybe match_info) inst_tvs) (length inst_theta) dfun)
 503     maybe_spec_info (_, match_info, _)
 504       = Nothing
 505 \end{pseudocode}
 506
 507
 508 \begin{code}
 509 addClassInst
 510     :: ClassInstEnv             -- Incoming envt
 511     -> Type                     -- The instance type: inst_ty
 512     -> Id                       -- Dict fun id to apply. Free tyvars of inst_ty must
 513                                 -- be the same as the forall'd tyvars of the dfun id.
 514     -> MaybeErr
 515           ClassInstEnv          -- Success
 516           (Type, Id)            -- Offending overlap
 517
 518 addClassInst inst_env inst_ty dfun_id = insertMEnv matchTy inst_env inst_ty dfun_id
 519 \end{code}
 520
 521
 522
 523 %************************************************************************
 524 %*                                                                      *
 525 \subsection[Inst-origin]{The @InstOrigin@ type}
 526 %*                                                                      *
 527 %************************************************************************
 528
 529 The @InstOrigin@ type gives information about where a dictionary came from.
 530 This is important for decent error message reporting because dictionaries
 531 don't appear in the original source code.  Doubtless this type will evolve...
 532
 533 \begin{code}
 534 data InstOrigin s
 535   = OccurrenceOf (TcIdOcc s)    -- Occurrence of an overloaded identifier
 536   | OccurrenceOfCon Id          -- Occurrence of a data constructor
 537
 538   | RecordUpdOrigin
 539
 540   | DataDeclOrigin              -- Typechecking a data declaration
 541
 542   | InstanceDeclOrigin          -- Typechecking an instance decl
 543
 544   | LiteralOrigin       HsLit   -- Occurrence of a literal
 545
 546   | ArithSeqOrigin      RenamedArithSeqInfo -- [x..], [x..y] etc
 547
 548   | SignatureOrigin             -- A dict created from a type signature
 549
 550   | DoOrigin                    -- The monad for a do expression
 551
 552   | ClassDeclOrigin             -- Manufactured during a class decl
 553
 554   | DerivingOrigin      InstanceMapper
 555                         Class
 556                         TyCon
 557
 558         -- During "deriving" operations we have an ever changing
 559         -- mapping of classes to instances, so we record it inside the
 560         -- origin information.  This is a bit of a hack, but it works
 561         -- fine.  (Simon is to blame [WDP].)
 562
 563   | InstanceSpecOrigin  InstanceMapper
 564                         Class   -- in a SPECIALIZE instance pragma
 565                         Type
 566
 567         -- When specialising instances the instance info attached to
 568         -- each class is not yet ready, so we record it inside the
 569         -- origin information.  This is a bit of a hack, but it works
 570         -- fine.  (Patrick is to blame [WDP].)
 571
 572   | DefaultDeclOrigin           -- Related to a `default' declaration
 573
 574   | ValSpecOrigin       Name    -- in a SPECIALIZE pragma for a value
 575
 576         -- Argument or result of a ccall
 577         -- Dictionaries with this origin aren't actually mentioned in the
 578         -- translated term, and so need not be bound.  Nor should they
 579         -- be abstracted over.
 580
 581   | CCallOrigin         String                  -- CCall label
 582                         (Maybe RenamedHsExpr)   -- Nothing if it's the result
 583                                                 -- Just arg, for an argument
 584
 585   | LitLitOrigin        String  -- the litlit
 586
 587   | UnknownOrigin       -- Help! I give up...
 588 \end{code}
 589
 590 \begin{code}
 591 -- During deriving and instance specialisation operations
 592 -- we can't get the instances of the class from inside the
 593 -- class, because the latter ain't ready yet.  Instead we
 594 -- find a mapping from classes to envts inside the dict origin.
 595
 596 get_inst_env :: Class -> InstOrigin s -> ClassInstEnv
 597 get_inst_env clas (DerivingOrigin inst_mapper _ _)
 598   = fst (inst_mapper clas)
 599 get_inst_env clas (InstanceSpecOrigin inst_mapper _ _)
 600   = fst (inst_mapper clas)
 601 get_inst_env clas other_orig = classInstEnv clas
 602
 603
 604 pprOrigin :: InstOrigin s -> PprStyle -> Pretty
 605
 606 pprOrigin (OccurrenceOf id) sty
 607       = ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"),
 608                    ppr sty id, ppChar '\'']
 609 pprOrigin (OccurrenceOfCon id) sty
 610       = ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"),
 611                    ppr sty id, ppChar '\'']
 612 pprOrigin (InstanceDeclOrigin) sty
 613       = ppStr "in an instance declaration"
 614 pprOrigin (LiteralOrigin lit) sty
 615       = ppCat [ppStr "at an overloaded literal:", ppr sty lit]
 616 pprOrigin (ArithSeqOrigin seq) sty
 617       = ppCat [ppStr "at an arithmetic sequence:", ppr sty seq]
 618 pprOrigin (SignatureOrigin) sty
 619       = ppStr "in a type signature"
 620 pprOrigin (DoOrigin) sty
 621       = ppStr "in a do statement"
 622 pprOrigin (ClassDeclOrigin) sty
 623       = ppStr "in a class declaration"
 624 pprOrigin (DerivingOrigin _ clas tycon) sty
 625       = ppBesides [ppStr "in a `deriving' clause; class `",
 626                           ppr sty clas,
 627                           ppStr "'; offending type `",
 628                           ppr sty tycon,
 629                           ppStr "'"]
 630 pprOrigin (InstanceSpecOrigin _ clas ty) sty
 631       = ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"",
 632                    ppr sty clas, ppStr "\" type: ", ppr sty ty]
 633 pprOrigin (DefaultDeclOrigin) sty
 634       = ppStr "in a `default' declaration"
 635 pprOrigin (ValSpecOrigin name) sty
 636       = ppBesides [ppStr "in a SPECIALIZE user-pragma for `",
 637                    ppr sty name, ppStr "'"]
 638 pprOrigin (CCallOrigin clabel Nothing{-ccall result-}) sty
 639       = ppBesides [ppStr "in the result of the _ccall_ to `",
 640                    ppStr clabel, ppStr "'"]
 641 pprOrigin (CCallOrigin clabel (Just arg_expr)) sty
 642       = ppBesides [ppStr "in an argument in the _ccall_ to `",
 643                   ppStr clabel, ppStr "', namely: ", ppr sty arg_expr]
 644 pprOrigin (LitLitOrigin s) sty
 645       = ppBesides [ppStr "in this ``literal-literal'': ", ppStr s]
 646 pprOrigin UnknownOrigin sty
 647       = ppStr "in... oops -- I don't know where the overloading came from!"
 648 \end{code}
 649
 650
 651