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(..), 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 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
 187         -- Our friend does the rest
 188    newMethodWithGivenTy orig id tys rho_ty
 189
 190
 191 newMethodWithGivenTy orig id tys rho_ty
 192  = tcGetSrcLoc                  `thenNF_Tc` \ loc ->
 193    tcGetUnique                  `thenNF_Tc` \ new_uniq ->
 194    let
 195         meth_inst = Method new_uniq id tys rho_ty orig loc
 196    in
 197    returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
 198
 199 newMethodAtLoc :: InstOrigin s -> SrcLoc -> Id -> [TcType s] -> NF_TcM s (Inst s, TcIdOcc s)
 200 newMethodAtLoc orig loc real_id tys     -- Local function, similar to newMethod but with
 201                                         -- slightly different interface
 202  =      -- Get the Id type and instantiate it at the specified types
 203    let
 204         (tyvars,rho) = splitForAllTy (idType real_id)
 205    in
 206    tcInstType (tyvars `zipEqual` tys) rho       `thenNF_Tc` \ rho_ty ->
 207    tcGetUnique                                  `thenNF_Tc` \ new_uniq ->
 208    let
 209         meth_inst = Method new_uniq (RealId real_id) tys rho_ty orig loc
 210    in
 211    returnNF_Tc (meth_inst, instToId meth_inst)
 212
 213 newOverloadedLit :: InstOrigin s
 214                  -> OverloadedLit
 215                  -> TcType s
 216                  -> NF_TcM s (LIE s, TcIdOcc s)
 217 newOverloadedLit orig lit ty
 218  = tcGetSrcLoc                  `thenNF_Tc` \ loc ->
 219    tcGetUnique                  `thenNF_Tc` \ new_uniq ->
 220    let
 221         lit_inst = LitInst new_uniq lit ty orig loc
 222    in
 223    returnNF_Tc (unitLIE lit_inst, instToId lit_inst)
 224 \end{code}
 225
 226
 227 \begin{code}
 228 instToId :: Inst s -> TcIdOcc s
 229 instToId (Dict uniq clas ty orig loc)
 230   = TcId (mkInstId uniq (mkDictTy clas ty) (mkShortName SLIT("dict") loc))
 231 instToId (Method uniq id tys rho_ty orig loc)
 232   = TcId (mkInstId uniq tau_ty (mkShortName (getOccurrenceName id) loc))
 233   where
 234     (_, tau_ty) = splitRhoTy rho_ty     -- NB The method Id has just the tau type
 235 instToId (LitInst uniq list ty orig loc)
 236   = TcId (mkInstId uniq ty (mkShortName SLIT("lit") loc))
 237 \end{code}
 238
 239 \begin{code}
 240 instType :: Inst s -> TcType s
 241 instType (Dict _ clas ty _ _)     = mkDictTy clas ty
 242 instType (LitInst _ _ ty _ _)     = ty
 243 instType (Method _ id tys ty _ _) = ty
 244 \end{code}
 245
 246
 247 Zonking
 248 ~~~~~~~
 249 Zonking makes sure that the instance types are fully zonked,
 250 but doesn't do the same for the Id in a Method.  There's no
 251 need, and it's a lot of extra work.
 252
 253 \begin{code}
 254 zonkInst :: Inst s -> NF_TcM s (Inst s)
 255 zonkInst (Dict uniq clas ty orig loc)
 256   = zonkTcType  ty                      `thenNF_Tc` \ new_ty ->
 257     returnNF_Tc (Dict uniq clas new_ty orig loc)
 258
 259 zonkInst (Method uniq id tys rho orig loc)              -- Doesn't zonk the id!
 260   = mapNF_Tc zonkTcType tys             `thenNF_Tc` \ new_tys ->
 261     zonkTcType rho                      `thenNF_Tc` \ new_rho ->
 262     returnNF_Tc (Method uniq id new_tys new_rho orig loc)
 263
 264 zonkInst (LitInst uniq lit ty orig loc)
 265   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 266     returnNF_Tc (LitInst uniq lit new_ty orig loc)
 267 \end{code}
 268
 269
 270 \begin{code}
 271 tyVarsOfInst :: Inst s -> TcTyVarSet s
 272 tyVarsOfInst (Dict _ _ ty _ _)        = tyVarsOfType  ty
 273 tyVarsOfInst (Method _ _ tys rho _ _) = tyVarsOfTypes tys
 274 tyVarsOfInst (LitInst _ _ ty _ _)     = tyVarsOfType  ty
 275 \end{code}
 276
 277 @matchesInst@ checks when two @Inst@s are instances of the same
 278 thing at the same type, even if their uniques differ.
 279
 280 \begin{code}
 281 matchesInst :: Inst s -> Inst s -> Bool
 282
 283 matchesInst (Dict _ clas1 ty1 _ _) (Dict _ clas2 ty2 _ _)
 284   = clas1 == clas2 && ty1 `eqSimpleTy` ty2
 285
 286 matchesInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _)
 287   =  id1 == id2
 288   && and (zipWith eqSimpleTy tys1 tys2)
 289   && length tys1 == length tys2
 290
 291 matchesInst (LitInst _ lit1 ty1 _ _) (LitInst _ lit2 ty2 _ _)
 292   = lit1 `eq` lit2 && ty1 `eqSimpleTy` ty2
 293   where
 294     (OverloadedIntegral   i1) `eq` (OverloadedIntegral   i2) = i1 == i2
 295     (OverloadedFractional f1) `eq` (OverloadedFractional f2) = f1 == f2
 296     _                         `eq` _                         = False
 297
 298 matchesInst other1 other2 = False
 299 \end{code}
 300
 301
 302 Predicates
 303 ~~~~~~~~~~
 304 \begin{code}
 305 isDict :: Inst s -> Bool
 306 isDict (Dict _ _ _ _ _) = True
 307 isDict other            = False
 308
 309 isTyVarDict :: Inst s -> Bool
 310 isTyVarDict (Dict _ _ ty _ _) = isTyVarTy ty
 311 isTyVarDict other             = False
 312 \end{code}
 313
 314 Two predicates which deal with the case where class constraints don't
 315 necessarily result in bindings.  The first tells whether an @Inst@
 316 must be witnessed by an actual binding; the second tells whether an
 317 @Inst@ can be generalised over.
 318
 319 \begin{code}
 320 instBindingRequired :: Inst s -> Bool
 321 instBindingRequired inst
 322   = case getInstOrigin inst of
 323         CCallOrigin _ _   -> False      -- No binding required
 324         LitLitOrigin  _   -> False
 325         OccurrenceOfCon _ -> False
 326         other             -> True
 327
 328 instCanBeGeneralised :: Inst s -> Bool
 329 instCanBeGeneralised inst
 330   = case getInstOrigin inst of
 331         CCallOrigin _ _ -> False        -- Can't be generalised
 332         LitLitOrigin  _ -> False        -- Can't be generalised
 333         other           -> True
 334 \end{code}
 335
 336
 337 Printing
 338 ~~~~~~~~
 339 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 340 relevant in error messages.
 341
 342 \begin{code}
 343 instance Outputable (Inst s) where
 344     ppr sty (LitInst uniq lit ty orig loc)
 345       = ppHang (ppSep [case lit of
 346                           OverloadedIntegral   i -> ppInteger i
 347                           OverloadedFractional f -> ppRational f,
 348                        ppStr "at",
 349                        ppr sty ty,
 350                        show_uniq sty uniq
 351                 ])
 352           4 (show_origin sty orig)
 353
 354     ppr sty (Dict uniq clas ty orig loc)
 355       = ppHang (ppSep [ppr sty clas,
 356                        ppStr "at",
 357                        ppr sty ty,
 358                        show_uniq sty uniq
 359                 ])
 360           4 (show_origin sty orig)
 361
 362     ppr sty (Method uniq id tys rho orig loc)
 363       = ppHang (ppSep [ppr sty id,
 364                        ppStr "at",
 365                        ppr sty tys,
 366                        show_uniq sty uniq
 367                 ])
 368           4 (show_origin sty orig)
 369
 370 show_uniq PprDebug uniq = ppr PprDebug uniq
 371 show_uniq sty      uniq = ppNil
 372
 373 show_origin sty orig    = ppBesides [ppLparen, pprOrigin sty orig, ppRparen]
 374 \end{code}
 375
 376 Printing in error messages
 377
 378 \begin{code}
 379 noInstanceErr inst sty = ppHang (ppPStr SLIT("No instance for:")) 4 (ppr sty inst)
 380 \end{code}
 381
 382 %************************************************************************
 383 %*                                                                      *
 384 \subsection[InstEnv-types]{Type declarations}
 385 %*                                                                      *
 386 %************************************************************************
 387
 388 \begin{code}
 389 type InstanceMapper = Class -> (ClassInstEnv, ClassOp -> SpecEnv)
 390 \end{code}
 391
 392 A @ClassInstEnv@ lives inside a class, and identifies all the instances
 393 of that class.  The @Id@ inside a ClassInstEnv mapping is the dfun for
 394 that instance.
 395
 396 There is an important consistency constraint between the @MatchEnv@s
 397 in and the dfun @Id@s inside them: the free type variables of the
 398 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
 399 type variables of the dfun.  Thus, the @ClassInstEnv@ for @Eq@ might
 400 contain the following entry:
 401 @
 402         [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
 403 @
 404 The "a" in the pattern must be one of the forall'd variables in
 405 the dfun type.
 406
 407 \begin{code}
 408 lookupInst :: Inst s
 409            -> TcM s ([Inst s],
 410                      (TcIdOcc s, TcExpr s))     -- The new binding
 411
 412 -- Dictionaries
 413
 414 lookupInst dict@(Dict _ clas ty orig loc)
 415   = case lookupMEnv matchTy (get_inst_env clas orig) ty of
 416       Nothing   -> 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 lookupClassInstAtSimpleType :: Class -> Type -> Maybe Id
 474
 475 lookupClassInstAtSimpleType clas ty
 476   = case (lookupMEnv matchTy (getClassInstEnv clas) ty) of
 477       Nothing       -> Nothing
 478       Just (dfun,_) -> ASSERT( null tyvars && null theta )
 479                        Just dfun
 480                     where
 481                        (tyvars, theta, _) = splitSigmaTy (idType dfun)
 482 \end{code}
 483
 484
 485 @mkInstSpecEnv@ is used to construct the @SpecEnv@ for a dfun.
 486 It does it by filtering the class's @InstEnv@.  All pretty shady stuff.
 487
 488 \begin{code}
 489 mkInstSpecEnv clas inst_ty inst_tvs inst_theta = panic "mkInstSpecEnv"
 490 \end{code}
 491
 492 \begin{pseudocode}
 493 mkInstSpecEnv :: Class                  -- class
 494               -> Type                   -- instance type
 495               -> [TyVarTemplate]        -- instance tyvars
 496               -> ThetaType              -- superclasses dicts
 497               -> SpecEnv                -- specenv for dfun of instance
 498
 499 mkInstSpecEnv clas inst_ty inst_tvs inst_theta
 500   = mkSpecEnv (catMaybes (map maybe_spec_info matches))
 501   where
 502     matches = matchMEnv matchTy (getClassInstEnv clas) inst_ty
 503
 504     maybe_spec_info (_, match_info, MkInstTemplate dfun _ [])
 505       = Just (SpecInfo (map (assocMaybe match_info) inst_tvs) (length inst_theta) dfun)
 506     maybe_spec_info (_, match_info, _)
 507       = Nothing
 508 \end{pseudocode}
 509
 510
 511 \begin{code}
 512 addClassInst
 513     :: ClassInstEnv             -- Incoming envt
 514     -> Type                     -- The instance type: inst_ty
 515     -> Id                       -- Dict fun id to apply. Free tyvars of inst_ty must
 516                                 -- be the same as the forall'd tyvars of the dfun id.
 517     -> MaybeErr
 518           ClassInstEnv          -- Success
 519           (Type, Id)            -- Offending overlap
 520
 521 addClassInst inst_env inst_ty dfun_id = insertMEnv matchTy inst_env inst_ty dfun_id
 522 \end{code}
 523
 524
 525
 526 %************************************************************************
 527 %*                                                                      *
 528 \subsection[Inst-origin]{The @InstOrigin@ type}
 529 %*                                                                      *
 530 %************************************************************************
 531
 532 The @InstOrigin@ type gives information about where a dictionary came from.
 533 This is important for decent error message reporting because dictionaries
 534 don't appear in the original source code.  Doubtless this type will evolve...
 535
 536 \begin{code}
 537 data InstOrigin s
 538   = OccurrenceOf (TcIdOcc s)    -- Occurrence of an overloaded identifier
 539   | OccurrenceOfCon Id          -- Occurrence of a data constructor
 540
 541   | InstanceDeclOrigin          -- Typechecking an instance decl
 542
 543   | LiteralOrigin       HsLit   -- Occurrence of a literal
 544
 545   | ArithSeqOrigin      RenamedArithSeqInfo -- [x..], [x..y] etc
 546
 547   | SignatureOrigin             -- A dict created from a type signature
 548
 549   | DoOrigin                    -- The monad for a do expression
 550
 551   | ClassDeclOrigin             -- Manufactured during a class decl
 552
 553   | DerivingOrigin      InstanceMapper
 554                         Class
 555                         TyCon
 556
 557         -- During "deriving" operations we have an ever changing
 558         -- mapping of classes to instances, so we record it inside the
 559         -- origin information.  This is a bit of a hack, but it works
 560         -- fine.  (Simon is to blame [WDP].)
 561
 562   | InstanceSpecOrigin  InstanceMapper
 563                         Class   -- in a SPECIALIZE instance pragma
 564                         Type
 565
 566         -- When specialising instances the instance info attached to
 567         -- each class is not yet ready, so we record it inside the
 568         -- origin information.  This is a bit of a hack, but it works
 569         -- fine.  (Patrick is to blame [WDP].)
 570
 571   | DefaultDeclOrigin           -- Related to a `default' declaration
 572
 573   | ValSpecOrigin       Name    -- in a SPECIALIZE pragma for a value
 574
 575         -- Argument or result of a ccall
 576         -- Dictionaries with this origin aren't actually mentioned in the
 577         -- translated term, and so need not be bound.  Nor should they
 578         -- be abstracted over.
 579
 580   | CCallOrigin         String                  -- CCall label
 581                         (Maybe RenamedHsExpr)   -- Nothing if it's the result
 582                                                 -- Just arg, for an argument
 583
 584   | LitLitOrigin        String  -- the litlit
 585
 586   | UnknownOrigin       -- Help! I give up...
 587 \end{code}
 588
 589 \begin{code}
 590 -- During deriving and instance specialisation operations
 591 -- we can't get the instances of the class from inside the
 592 -- class, because the latter ain't ready yet.  Instead we
 593 -- find a mapping from classes to envts inside the dict origin.
 594
 595 get_inst_env :: Class -> InstOrigin s -> ClassInstEnv
 596 get_inst_env clas (DerivingOrigin inst_mapper _ _)
 597   = fst (inst_mapper clas)
 598 get_inst_env clas (InstanceSpecOrigin inst_mapper _ _)
 599   = fst (inst_mapper clas)
 600 get_inst_env clas other_orig = getClassInstEnv clas
 601
 602
 603 pprOrigin :: PprStyle -> InstOrigin s -> Pretty
 604
 605 pprOrigin sty (OccurrenceOf id)
 606       = ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"),
 607                    ppr sty id, ppChar '\'']
 608 pprOrigin sty (OccurrenceOfCon id)
 609       = ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"),
 610                    ppr sty id, ppChar '\'']
 611 pprOrigin sty (InstanceDeclOrigin)
 612       = ppStr "in an instance declaration"
 613 pprOrigin sty (LiteralOrigin lit)
 614       = ppCat [ppStr "at an overloaded literal:", ppr sty lit]
 615 pprOrigin sty (ArithSeqOrigin seq)
 616       = ppCat [ppStr "at an arithmetic sequence:", ppr sty seq]
 617 pprOrigin sty (SignatureOrigin)
 618       = ppStr "in a type signature"
 619 pprOrigin sty (DoOrigin)
 620       = ppStr "in a do statement"
 621 pprOrigin sty (ClassDeclOrigin)
 622       = ppStr "in a class declaration"
 623 pprOrigin sty (DerivingOrigin _ clas tycon)
 624       = ppBesides [ppStr "in a `deriving' clause; class `",
 625                           ppr sty clas,
 626                           ppStr "'; offending type `",
 627                           ppr sty tycon,
 628                           ppStr "'"]
 629 pprOrigin sty (InstanceSpecOrigin _ clas ty)
 630       = ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"",
 631                    ppr sty clas, ppStr "\" type: ", ppr sty ty]
 632 pprOrigin sty (DefaultDeclOrigin)
 633       = ppStr "in a `default' declaration"
 634 pprOrigin sty (ValSpecOrigin name)
 635       = ppBesides [ppStr "in a SPECIALIZE user-pragma for `",
 636                    ppr sty name, ppStr "'"]
 637 pprOrigin sty (CCallOrigin clabel Nothing{-ccall result-})
 638       = ppBesides [ppStr "in the result of the _ccall_ to `",
 639                    ppStr clabel, ppStr "'"]
 640 pprOrigin sty (CCallOrigin clabel (Just arg_expr))
 641       = ppBesides [ppStr "in an argument in the _ccall_ to `",
 642                   ppStr clabel, ppStr "', namely: ", ppr sty arg_expr]
 643 pprOrigin sty (LitLitOrigin s)
 644       = ppBesides [ppStr "in this ``literal-literal'': ", ppStr s]
 645 pprOrigin sty UnknownOrigin
 646       = ppStr "in... oops -- I don't know where the overloading came from!"
 647 \end{code}
 648
 649
 650