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 module Inst (
   8         LIE, emptyLIE, unitLIE, plusLIE, consLIE, zonkLIE, plusLIEs, mkLIE,
   9         pprInsts, pprInstsInFull,
  10
  11         Inst, OverloadedLit(..), pprInst,
  12
  13         InstanceMapper,
  14
  15         newDictFromOld, newDicts, newDictsAtLoc,
  16         newMethod, newMethodWithGivenTy, newOverloadedLit,
  17
  18         tyVarsOfInst, instLoc, getDictClassTys,
  19
  20         lookupInst, lookupSimpleInst, LookupInstResult(..),
  21
  22         isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor,
  23         instBindingRequired, instCanBeGeneralised,
  24
  25         zonkInst, instToId,
  26
  27         InstOrigin(..), pprOrigin
  28     ) where
  29
  30 #include "HsVersions.h"
  31
  32 import HsSyn    ( HsLit(..), HsExpr(..), MonoBinds )
  33 import RnHsSyn  ( RenamedArithSeqInfo, RenamedHsExpr )
  34 import TcHsSyn  ( TcExpr, TcIdOcc(..), TcIdBndr,
  35                   mkHsTyApp, mkHsDictApp, tcIdTyVars, zonkTcId
  36                 )
  37 import TcMonad
  38 import TcEnv    ( tcLookupGlobalValueByKey, tcLookupTyConByKey )
  39 import TcType   ( TcThetaType,
  40                   TcType, TcTauType, TcMaybe, TcTyVarSet,
  41                   tcInstType, zonkTcType, zonkTcTypes, tcSplitForAllTy,
  42                   zonkTcThetaType
  43                 )
  44 import Bag      ( emptyBag, unitBag, unionBags, unionManyBags,
  45                   listToBag, consBag, Bag )
  46 import Class    ( classInstEnv,
  47                   Class, ClassInstEnv
  48                 )
  49 import Id       ( idType, mkUserLocal, mkSysLocal, Id,
  50                   GenIdSet, elementOfIdSet
  51                 )
  52 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
  53 import Name     ( OccName(..), Name, occNameString, getOccName )
  54 import PprType  ( TyCon, pprConstraint )
  55 import SpecEnv  ( SpecEnv, matchSpecEnv, addToSpecEnv )
  56 import SrcLoc   ( SrcLoc )
  57 import Type     ( Type, ThetaType, instantiateTy, instantiateThetaTy, matchTys,
  58                   isTyVarTy, mkDictTy, splitForAllTys, splitSigmaTy,
  59                   splitRhoTy, tyVarsOfType, tyVarsOfTypes,
  60                   mkSynTy
  61                 )
  62 import TyVar    ( zipTyVarEnv, lookupTyVarEnv, unionTyVarSets )
  63 import TysPrim    ( intPrimTy )
  64 import TysWiredIn ( intDataCon, integerTy, isIntTy, isIntegerTy, inIntRange )
  65 import Unique   ( fromRationalClassOpKey, rationalTyConKey,
  66                   fromIntClassOpKey, fromIntegerClassOpKey, Unique
  67                 )
  68 import Maybes   ( MaybeErr, expectJust )
  69 import Util     ( thenCmp, zipWithEqual )
  70 import Outputable
  71 \end{code}
  72
  73 %************************************************************************
  74 %*                                                                      *
  75 \subsection[Inst-collections]{LIE: a collection of Insts}
  76 %*                                                                      *
  77 %************************************************************************
  78
  79 \begin{code}
  80 type LIE s = Bag (Inst s)
  81
  82 emptyLIE          = emptyBag
  83 unitLIE inst      = unitBag inst
  84 mkLIE insts       = listToBag insts
  85 plusLIE lie1 lie2 = lie1 `unionBags` lie2
  86 consLIE inst lie  = inst `consBag` lie
  87 plusLIEs lies     = unionManyBags lies
  88
  89 zonkLIE :: LIE s -> NF_TcM s (LIE s)
  90 zonkLIE lie = mapBagNF_Tc zonkInst lie
  91
  92 pprInsts :: [Inst s] -> SDoc
  93 pprInsts insts = parens (hsep (punctuate comma (map pprInst insts)))
  94
  95
  96 pprInstsInFull insts
  97   = vcat (map go insts)
  98   where
  99     go inst = quotes (ppr inst) <+> pprOrigin inst
 100 \end{code}
 101
 102 %************************************************************************
 103 %*                                                                      *
 104 \subsection[Inst-types]{@Inst@ types}
 105 %*                                                                      *
 106 %************************************************************************
 107
 108 An @Inst@ is either a dictionary, an instance of an overloaded
 109 literal, or an instance of an overloaded value.  We call the latter a
 110 ``method'' even though it may not correspond to a class operation.
 111 For example, we might have an instance of the @double@ function at
 112 type Int, represented by
 113
 114         Method 34 doubleId [Int] origin
 115
 116 \begin{code}
 117 data Inst s
 118   = Dict
 119         Unique
 120         Class           -- The type of the dict is (c ts), where
 121         [TcType s]      -- c is the class and ts the types;
 122         (InstOrigin s)
 123         SrcLoc
 124
 125   | Method
 126         Unique
 127
 128         (TcIdOcc s)     -- The overloaded function
 129                         -- This function will be a global, local, or ClassOpId;
 130                         --   inside instance decls (only) it can also be an InstId!
 131                         -- The id needn't be completely polymorphic.
 132                         -- You'll probably find its name (for documentation purposes)
 133                         --        inside the InstOrigin
 134
 135         [TcType s]      -- The types to which its polymorphic tyvars
 136                         --      should be instantiated.
 137                         -- These types must saturate the Id's foralls.
 138
 139         (TcThetaType s) -- The (types of the) dictionaries to which the function
 140                         -- must be applied to get the method
 141
 142         (TcTauType s)   -- The type of the method
 143
 144         (InstOrigin s)
 145         SrcLoc
 146
 147         -- INVARIANT: in (Method u f tys theta tau loc)
 148         --      type of (f tys dicts(from theta)) = tau
 149
 150   | LitInst
 151         Unique
 152         OverloadedLit
 153         (TcType s)      -- The type at which the literal is used
 154         (InstOrigin s)  -- Always a literal; but more convenient to carry this around
 155         SrcLoc
 156
 157 data OverloadedLit
 158   = OverloadedIntegral   Integer        -- The number
 159   | OverloadedFractional Rational       -- The number
 160 \end{code}
 161
 162 Ordering
 163 ~~~~~~~~
 164 @Insts@ are ordered by their class/type info, rather than by their
 165 unique.  This allows the context-reduction mechanism to use standard finite
 166 maps to do their stuff.
 167
 168 \begin{code}
 169 instance Ord (Inst s) where
 170   compare = cmpInst
 171
 172 instance Eq (Inst s) where
 173   (==) i1 i2 = case i1 `cmpInst` i2 of
 174                  EQ    -> True
 175                  other -> False
 176
 177 cmpInst  (Dict _ clas1 tys1 _ _) (Dict _ clas2 tys2 _ _)
 178   = (clas1 `compare` clas2) `thenCmp` (tys1 `compare` tys2)
 179 cmpInst (Dict _ _ _ _ _) other
 180   = LT
 181
 182
 183 cmpInst (Method _ _ _ _ _ _ _) (Dict _ _ _ _ _)
 184   = GT
 185 cmpInst (Method _ id1 tys1 _ _ _ _) (Method _ id2 tys2 _ _ _ _)
 186   = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
 187 cmpInst (Method _ _ _ _ _ _ _) other
 188   = LT
 189
 190 cmpInst (LitInst _ lit1 ty1 _ _) (LitInst _ lit2 ty2 _ _)
 191   = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2)
 192 cmpInst (LitInst _ _ _ _ _) other
 193   = GT
 194
 195 cmpOverLit (OverloadedIntegral   i1) (OverloadedIntegral   i2) = i1 `compare` i2
 196 cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2
 197 cmpOverLit (OverloadedIntegral _)    (OverloadedFractional _)  = LT
 198 cmpOverLit (OverloadedFractional _)  (OverloadedIntegral _)    = GT
 199 \end{code}
 200
 201
 202 Selection
 203 ~~~~~~~~~
 204 \begin{code}
 205 instOrigin (Dict   u clas tys    origin loc) = origin
 206 instOrigin (Method u clas ty _ _ origin loc) = origin
 207 instOrigin (LitInst u lit ty     origin loc) = origin
 208
 209 instLoc (Dict   u clas tys    origin loc) = loc
 210 instLoc (Method u clas ty _ _ origin loc) = loc
 211 instLoc (LitInst u lit ty     origin loc) = loc
 212
 213 getDictClassTys (Dict u clas tys _ _) = (clas, tys)
 214
 215 tyVarsOfInst :: Inst s -> TcTyVarSet s
 216 tyVarsOfInst (Dict _ _ tys _ _)        = tyVarsOfTypes  tys
 217 tyVarsOfInst (Method _ id tys _ _ _ _) = tyVarsOfTypes tys `unionTyVarSets` tcIdTyVars id
 218                                          -- The id might not be a RealId; in the case of
 219                                          -- locally-overloaded class methods, for example
 220 tyVarsOfInst (LitInst _ _ ty _ _)     = tyVarsOfType  ty
 221 \end{code}
 222
 223 Predicates
 224 ~~~~~~~~~~
 225 \begin{code}
 226 isDict :: Inst s -> Bool
 227 isDict (Dict _ _ _ _ _) = True
 228 isDict other            = False
 229
 230 isMethodFor :: GenIdSet (TcType s) -> Inst s -> Bool
 231 isMethodFor ids (Method uniq (TcId id) tys _ _ orig loc)
 232   = id `elementOfIdSet` ids
 233 isMethodFor ids inst
 234   = False
 235
 236 isTyVarDict :: Inst s -> Bool
 237 isTyVarDict (Dict _ _ tys _ _) = all isTyVarTy tys
 238 isTyVarDict other              = False
 239
 240 isStdClassTyVarDict (Dict _ clas [ty] _ _) = isStandardClass clas && isTyVarTy ty
 241 isStdClassTyVarDict other                  = False
 242 \end{code}
 243
 244 Two predicates which deal with the case where class constraints don't
 245 necessarily result in bindings.  The first tells whether an @Inst@
 246 must be witnessed by an actual binding; the second tells whether an
 247 @Inst@ can be generalised over.
 248
 249 \begin{code}
 250 instBindingRequired :: Inst s -> Bool
 251 instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas)
 252 instBindingRequired other               = True
 253
 254 instCanBeGeneralised :: Inst s -> Bool
 255 instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas)
 256 instCanBeGeneralised other               = True
 257 \end{code}
 258
 259
 260 Construction
 261 ~~~~~~~~~~~~
 262
 263 \begin{code}
 264 newDicts :: InstOrigin s
 265          -> TcThetaType s
 266          -> NF_TcM s (LIE s, [TcIdOcc s])
 267 newDicts orig theta
 268   = tcGetSrcLoc                         `thenNF_Tc` \ loc ->
 269     newDictsAtLoc orig loc theta        `thenNF_Tc` \ (dicts, ids) ->
 270     returnNF_Tc (listToBag dicts, ids)
 271
 272 -- Local function, similar to newDicts,
 273 -- but with slightly different interface
 274 newDictsAtLoc :: InstOrigin s
 275               -> SrcLoc
 276               -> TcThetaType s
 277               -> NF_TcM s ([Inst s], [TcIdOcc s])
 278 newDictsAtLoc orig loc theta =
 279  tcGetUniques (length theta)            `thenNF_Tc` \ new_uniqs ->
 280  let
 281   mk_dict u (clas, tys) = Dict u clas tys orig loc
 282   dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
 283  in
 284  returnNF_Tc (dicts, map instToId dicts)
 285
 286 newDictFromOld :: Inst s -> Class -> [TcType s] -> NF_TcM s (Inst s)
 287 newDictFromOld (Dict _ _ _ orig loc) clas tys
 288   = tcGetUnique       `thenNF_Tc` \ uniq ->
 289     returnNF_Tc (Dict uniq clas tys orig loc)
 290
 291
 292 newMethod :: InstOrigin s
 293           -> TcIdOcc s
 294           -> [TcType s]
 295           -> NF_TcM s (LIE s, TcIdOcc s)
 296 newMethod orig id tys
 297   =     -- Get the Id type and instantiate it at the specified types
 298     (case id of
 299        RealId id -> let (tyvars, rho) = splitForAllTys (idType id)
 300                     in
 301                     ASSERT( length tyvars == length tys)
 302                     tcInstType (zipTyVarEnv tyvars tys) rho
 303
 304        TcId   id -> tcSplitForAllTy (idType id)         `thenNF_Tc` \ (tyvars, rho) ->
 305                     returnNF_Tc (instantiateTy (zipTyVarEnv tyvars tys) rho)
 306     )                                           `thenNF_Tc` \ rho_ty ->
 307     let
 308         (theta, tau) = splitRhoTy rho_ty
 309     in
 310          -- Our friend does the rest
 311     newMethodWithGivenTy orig id tys theta tau
 312
 313
 314 newMethodWithGivenTy orig id tys theta tau
 315   = tcGetSrcLoc         `thenNF_Tc` \ loc ->
 316     tcGetUnique         `thenNF_Tc` \ new_uniq ->
 317     let
 318         meth_inst = Method new_uniq id tys theta tau orig loc
 319     in
 320     returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
 321
 322 newMethodAtLoc :: InstOrigin s -> SrcLoc
 323                -> Id -> [TcType s]
 324                -> NF_TcM s (Inst s, TcIdOcc s)
 325 newMethodAtLoc orig loc real_id tys     -- Local function, similar to newMethod but with
 326                                         -- slightly different interface
 327   =     -- Get the Id type and instantiate it at the specified types
 328     let
 329          (tyvars,rho) = splitForAllTys (idType real_id)
 330     in
 331     tcInstType (zipTyVarEnv tyvars tys) rho     `thenNF_Tc` \ rho_ty ->
 332     tcGetUnique                                 `thenNF_Tc` \ new_uniq ->
 333     let
 334         (theta, tau) = splitRhoTy rho_ty
 335         meth_inst    = Method new_uniq (RealId real_id) tys theta tau orig loc
 336     in
 337     returnNF_Tc (meth_inst, instToId meth_inst)
 338
 339 newOverloadedLit :: InstOrigin s
 340                  -> OverloadedLit
 341                  -> TcType s
 342                  -> NF_TcM s (TcExpr s, LIE s)
 343 newOverloadedLit orig (OverloadedIntegral i) ty
 344   | isIntTy ty && inIntRange i          -- Short cut for Int
 345   = returnNF_Tc (int_lit, emptyLIE)
 346
 347   | isIntegerTy ty                      -- Short cut for Integer
 348   = returnNF_Tc (integer_lit, emptyLIE)
 349
 350   where
 351     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
 352     integer_lit    = HsLitOut (HsInt i) integerTy
 353     int_lit        = HsApp (HsVar (RealId intDataCon)) intprim_lit
 354
 355 newOverloadedLit orig lit ty            -- The general case
 356   = tcGetSrcLoc                 `thenNF_Tc` \ loc ->
 357     tcGetUnique                 `thenNF_Tc` \ new_uniq ->
 358     let
 359         lit_inst = LitInst new_uniq lit ty orig loc
 360     in
 361     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 362 \end{code}
 363
 364
 365 \begin{code}
 366 instToId :: Inst s -> TcIdOcc s
 367 instToId (Dict u clas ty orig loc)
 368   = TcId (mkUserLocal occ u (mkDictTy clas ty) loc)
 369   where
 370     occ = VarOcc (SLIT("d.") _APPEND_ (occNameString (getOccName clas)))
 371
 372 instToId (Method u id tys theta tau orig loc)
 373   = TcId (mkUserLocal (getOccName id) u tau loc)
 374
 375 instToId (LitInst u list ty orig loc)
 376   = TcId (mkSysLocal SLIT("lit") u ty loc)
 377 \end{code}
 378
 379
 380 Zonking
 381 ~~~~~~~
 382 Zonking makes sure that the instance types are fully zonked,
 383 but doesn't do the same for the Id in a Method.  There's no
 384 need, and it's a lot of extra work.
 385
 386 \begin{code}
 387 zonkInst :: Inst s -> NF_TcM s (Inst s)
 388 zonkInst (Dict u clas tys orig loc)
 389   = zonkTcTypes tys                     `thenNF_Tc` \ new_tys ->
 390     returnNF_Tc (Dict u clas new_tys orig loc)
 391
 392 zonkInst (Method u id tys theta tau orig loc)
 393   = zonkTcId id                 `thenNF_Tc` \ new_id ->
 394       -- Essential to zonk the id in case it's a local variable
 395     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 396     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 397     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 398     returnNF_Tc (Method u new_id new_tys new_theta new_tau orig loc)
 399
 400 zonkInst (LitInst u lit ty orig loc)
 401   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 402     returnNF_Tc (LitInst u lit new_ty orig loc)
 403 \end{code}
 404
 405
 406 Printing
 407 ~~~~~~~~
 408 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 409 relevant in error messages.
 410
 411 \begin{code}
 412 instance Outputable (Inst s) where
 413     ppr inst = pprInst inst
 414
 415 pprInst (LitInst u lit ty orig loc)
 416   = hsep [case lit of
 417               OverloadedIntegral   i -> integer i
 418               OverloadedFractional f -> rational f,
 419            ptext SLIT("at"),
 420            ppr ty,
 421            show_uniq u]
 422
 423 pprInst (Dict u clas tys orig loc) = pprConstraint clas tys <+> show_uniq u
 424
 425 pprInst (Method u id tys _ _ orig loc)
 426   = hsep [ppr id, ptext SLIT("at"),
 427           interppSP tys,
 428           show_uniq u]
 429
 430 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 431 \end{code}
 432
 433
 434 %************************************************************************
 435 %*                                                                      *
 436 \subsection[InstEnv-types]{Type declarations}
 437 %*                                                                      *
 438 %************************************************************************
 439
 440 \begin{code}
 441 type InstanceMapper = Class -> ClassInstEnv
 442 \end{code}
 443
 444 A @ClassInstEnv@ lives inside a class, and identifies all the instances
 445 of that class.  The @Id@ inside a ClassInstEnv mapping is the dfun for
 446 that instance.
 447
 448 There is an important consistency constraint between the @MatchEnv@s
 449 in and the dfun @Id@s inside them: the free type variables of the
 450 @Type@ key in the @MatchEnv@ must be a subset of the universally-quantified
 451 type variables of the dfun.  Thus, the @ClassInstEnv@ for @Eq@ might
 452 contain the following entry:
 453 @
 454         [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a]
 455 @
 456 The "a" in the pattern must be one of the forall'd variables in
 457 the dfun type.
 458
 459 \begin{code}
 460 data LookupInstResult s
 461   = NoInstance
 462   | SimpleInst (TcExpr s)               -- Just a variable, type application, or literal
 463   | GenInst    [Inst s] (TcExpr s)      -- The expression and its needed insts
 464 lookupInst :: Inst s
 465            -> NF_TcM s (LookupInstResult s)
 466
 467 -- Dictionaries
 468
 469 lookupInst dict@(Dict _ clas tys orig loc)
 470   = case matchSpecEnv (classInstEnv clas) tys of
 471
 472       Just (tenv, dfun_id)
 473         -> let
 474                 (tyvars, rho) = splitForAllTys (idType dfun_id)
 475                 ty_args       = map (expectJust "Inst" . lookupTyVarEnv tenv) tyvars
 476                                 -- tenv should bind all the tyvars
 477            in
 478            tcInstType tenv rho          `thenNF_Tc` \ dfun_rho ->
 479            let
 480                 (theta, tau) = splitRhoTy dfun_rho
 481                 ty_app       = mkHsTyApp (HsVar (RealId dfun_id)) ty_args
 482            in
 483            if null theta then
 484                 returnNF_Tc (SimpleInst ty_app)
 485            else
 486            newDictsAtLoc orig loc theta `thenNF_Tc` \ (dicts, dict_ids) ->
 487            let
 488                 rhs = mkHsDictApp ty_app dict_ids
 489            in
 490            returnNF_Tc (GenInst dicts rhs)
 491
 492       Nothing   -> returnNF_Tc NoInstance
 493
 494 -- Methods
 495
 496 lookupInst inst@(Method _ id tys theta _ orig loc)
 497   = newDictsAtLoc orig loc theta        `thenNF_Tc` \ (dicts, dict_ids) ->
 498     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
 499
 500 -- Literals
 501
 502 lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc)
 503   | isIntTy ty && in_int_range                  -- Short cut for Int
 504   = returnNF_Tc (GenInst [] int_lit)
 505         -- GenInst, not SimpleInst, because int_lit is actually a constructor application
 506
 507   | isIntegerTy ty                              -- Short cut for Integer
 508   = returnNF_Tc (GenInst [] integer_lit)
 509
 510   | in_int_range                                -- It's overloaded but small enough to fit into an Int
 511   = tcLookupGlobalValueByKey fromIntClassOpKey  `thenNF_Tc` \ from_int ->
 512     newMethodAtLoc orig loc from_int [ty]       `thenNF_Tc` \ (method_inst, method_id) ->
 513     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
 514
 515   | otherwise                                   -- Alas, it is overloaded and a big literal!
 516   = tcLookupGlobalValueByKey fromIntegerClassOpKey      `thenNF_Tc` \ from_integer ->
 517     newMethodAtLoc orig loc from_integer [ty]           `thenNF_Tc` \ (method_inst, method_id) ->
 518     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
 519   where
 520     in_int_range   = inIntRange i
 521     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
 522     integer_lit    = HsLitOut (HsInt i) integerTy
 523     int_lit        = HsApp (HsVar (RealId intDataCon)) intprim_lit
 524
 525 lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc)
 526   = tcLookupGlobalValueByKey fromRationalClassOpKey     `thenNF_Tc` \ from_rational ->
 527
 528         -- The type Rational isn't wired in so we have to conjure it up
 529     tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon ->
 530     let
 531         rational_ty  = mkSynTy rational_tycon []
 532         rational_lit = HsLitOut (HsFrac f) rational_ty
 533     in
 534     newMethodAtLoc orig loc from_rational [ty]          `thenNF_Tc` \ (method_inst, method_id) ->
 535     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
 536 \end{code}
 537
 538 There is a second, simpler interface, when you want an instance of a
 539 class at a given nullary type constructor.  It just returns the
 540 appropriate dictionary if it exists.  It is used only when resolving
 541 ambiguous dictionaries.
 542
 543 \begin{code}
 544 lookupSimpleInst :: ClassInstEnv
 545                  -> Class
 546                  -> [Type]                      -- Look up (c,t)
 547                  -> NF_TcM s (Maybe ThetaType)          -- Here are the needed (c,t)s
 548
 549 lookupSimpleInst class_inst_env clas tys
 550   = case matchSpecEnv class_inst_env tys of
 551       Nothing    -> returnNF_Tc Nothing
 552
 553       Just (tenv, dfun)
 554         -> returnNF_Tc (Just (instantiateThetaTy tenv theta))
 555         where
 556            (_, theta, _) = splitSigmaTy (idType dfun)
 557 \end{code}
 558
 559
 560 \begin{code}
 561 addClassInst
 562     :: ClassInstEnv             -- Incoming envt
 563     -> [Type]                   -- The instance types: inst_tys
 564     -> Id                       -- Dict fun id to apply. Free tyvars of inst_ty must
 565                                 -- be the same as the forall'd tyvars of the dfun id.
 566     -> MaybeErr
 567           ClassInstEnv          -- Success
 568           ([Type], Id)          -- Offending overlap
 569
 570 addClassInst inst_env inst_tys dfun_id = addToSpecEnv inst_env inst_tys dfun_id
 571 \end{code}
 572
 573
 574
 575 %************************************************************************
 576 %*                                                                      *
 577 \subsection[Inst-origin]{The @InstOrigin@ type}
 578 %*                                                                      *
 579 %************************************************************************
 580
 581 The @InstOrigin@ type gives information about where a dictionary came from.
 582 This is important for decent error message reporting because dictionaries
 583 don't appear in the original source code.  Doubtless this type will evolve...
 584
 585 \begin{code}
 586 data InstOrigin s
 587   = OccurrenceOf (TcIdOcc s)    -- Occurrence of an overloaded identifier
 588   | OccurrenceOfCon Id          -- Occurrence of a data constructor
 589
 590   | RecordUpdOrigin
 591
 592   | DataDeclOrigin              -- Typechecking a data declaration
 593
 594   | InstanceDeclOrigin          -- Typechecking an instance decl
 595
 596   | LiteralOrigin       HsLit   -- Occurrence of a literal
 597
 598   | ArithSeqOrigin      RenamedArithSeqInfo -- [x..], [x..y] etc
 599
 600   | SignatureOrigin             -- A dict created from a type signature
 601   | Rank2Origin                 -- A dict created when typechecking the argument
 602                                 -- of a rank-2 typed function
 603
 604   | DoOrigin                    -- The monad for a do expression
 605
 606   | ClassDeclOrigin             -- Manufactured during a class decl
 607
 608   | InstanceSpecOrigin  Class   -- in a SPECIALIZE instance pragma
 609                         Type
 610
 611         -- When specialising instances the instance info attached to
 612         -- each class is not yet ready, so we record it inside the
 613         -- origin information.  This is a bit of a hack, but it works
 614         -- fine.  (Patrick is to blame [WDP].)
 615
 616   | ValSpecOrigin       Name    -- in a SPECIALIZE pragma for a value
 617
 618         -- Argument or result of a ccall
 619         -- Dictionaries with this origin aren't actually mentioned in the
 620         -- translated term, and so need not be bound.  Nor should they
 621         -- be abstracted over.
 622
 623   | CCallOrigin         String                  -- CCall label
 624                         (Maybe RenamedHsExpr)   -- Nothing if it's the result
 625                                                 -- Just arg, for an argument
 626
 627   | LitLitOrigin        String  -- the litlit
 628
 629   | UnknownOrigin       -- Help! I give up...
 630 \end{code}
 631
 632 \begin{code}
 633 pprOrigin :: Inst s -> SDoc
 634 pprOrigin inst
 635   = hsep [text "arising from", pp_orig orig, text "at", ppr locn]
 636   where
 637     (orig, locn) = case inst of
 638                         Dict _ _ _       orig loc -> (orig,loc)
 639                         Method _ _ _ _ _ orig loc -> (orig,loc)
 640                         LitInst _ _ _    orig loc -> (orig,loc)
 641
 642     pp_orig (OccurrenceOf id)
 643         = hsep [ptext SLIT("use of"), quotes (ppr id)]
 644     pp_orig (OccurrenceOfCon id)
 645         = hsep [ptext SLIT("use of"), quotes (ppr id)]
 646     pp_orig (LiteralOrigin lit)
 647         = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
 648     pp_orig (InstanceDeclOrigin)
 649         =  ptext SLIT("an instance declaration")
 650     pp_orig (ArithSeqOrigin seq)
 651         = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
 652     pp_orig (SignatureOrigin)
 653         =  ptext SLIT("a type signature")
 654     pp_orig (Rank2Origin)
 655         =  ptext SLIT("a function with an overloaded argument type")
 656     pp_orig (DoOrigin)
 657         =  ptext SLIT("a do statement")
 658     pp_orig (ClassDeclOrigin)
 659         =  ptext SLIT("a class declaration")
 660     pp_orig (InstanceSpecOrigin clas ty)
 661         = hsep [text "a SPECIALIZE instance pragma; class",
 662                 quotes (ppr clas), text "type:", ppr ty]
 663     pp_orig (ValSpecOrigin name)
 664         = hsep [ptext SLIT("a SPECIALIZE user-pragma for"), quotes (ppr name)]
 665     pp_orig (CCallOrigin clabel Nothing{-ccall result-})
 666         = hsep [ptext SLIT("the result of the _ccall_ to"), quotes (text clabel)]
 667     pp_orig (CCallOrigin clabel (Just arg_expr))
 668         = hsep [ptext SLIT("an argument in the _ccall_ to"), quotes (text clabel) <> comma,
 669                 text "namely", quotes (ppr arg_expr)]
 670     pp_orig (LitLitOrigin s)
 671         = hsep [ptext SLIT("the ``literal-literal''"), quotes (text s)]
 672     pp_orig (UnknownOrigin)
 673         = ptext SLIT("...oops -- I don't know where the overloading came from!")
 674 \end{code}