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