ghc/compiler/typecheck/Inst.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   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,
   9         plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
  10
  11         Inst,
  12         pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts,
  13
  14         newDictFromOld, newDicts, newClassDicts, newDictsAtLoc,
  15         newMethod, newMethodWithGivenTy, newOverloadedLit,
  16         newIPDict, instOverloadedFun,
  17         instantiateFdClassTys, instFunDeps, instFunDepsOfTheta,
  18         newFunDepFromDict,
  19
  20         tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, instLoc, getDictClassTys,
  21         getDictPred_maybe, getMethodTheta_maybe,
  22         getFunDeps, getFunDepsOfLIE,
  23         getIPs, getIPsOfLIE,
  24         getAllFunDeps, getAllFunDepsOfLIE,
  25
  26         lookupInst, lookupSimpleInst, LookupInstResult(..),
  27
  28         isDict, isClassDict, isMethod,
  29         isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep,
  30         instBindingRequired, instCanBeGeneralised,
  31
  32         zonkInst, zonkInsts, zonkFunDeps, zonkTvFunDeps,
  33         instToId, instToIdBndr, ipToId,
  34
  35         InstOrigin(..), InstLoc, pprInstLoc
  36     ) where
  37
  38 #include "HsVersions.h"
  39
  40 import HsSyn    ( HsLit(..), HsOverLit(..), HsExpr(..) )
  41 import RnHsSyn  ( RenamedHsOverLit )
  42 import TcHsSyn  ( TcExpr, TcId,
  43                   mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
  44                 )
  45 import TcMonad
  46 import TcEnv    ( TcIdSet, tcGetInstEnv, lookupInstEnv, InstLookupResult(..),
  47                   tcLookupGlobalId
  48                 )
  49 import TcType   ( TcThetaType,
  50                   TcType, TcTauType, TcTyVarSet,
  51                   zonkTcTyVars, zonkTcType, zonkTcTypes,
  52                   zonkTcThetaType
  53                 )
  54 import Bag
  55 import Class    ( Class, FunDep )
  56 import FunDeps  ( instantiateFdClassTys )
  57 import Id       ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
  58 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
  59 import Name     ( mkDictOcc, mkMethodOcc, mkIPOcc, getOccName, nameUnique )
  60 import PprType  ( pprPred )
  61 import Type     ( Type, PredType(..),
  62                   isTyVarTy, mkDictTy, mkPredTy,
  63                   splitForAllTys, splitSigmaTy, funArgTy,
  64                   splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
  65                   tidyOpenType, tidyOpenTypes
  66                 )
  67 import Subst    ( emptyInScopeSet, mkSubst, mkInScopeSet,
  68                   substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst
  69                 )
  70 import Literal  ( inIntRange )
  71 import VarEnv   ( TidyEnv, lookupSubstEnv, SubstResult(..) )
  72 import VarSet   ( elemVarSet, emptyVarSet, unionVarSet )
  73 import TysWiredIn ( isIntTy,
  74                     floatDataCon, isFloatTy,
  75                     doubleDataCon, isDoubleTy,
  76                     isIntegerTy, voidTy
  77                   )
  78 import PrelNames( Unique, hasKey, fromIntClassOpKey, fromIntegerClassOpKey )
  79 import Maybe    ( catMaybes )
  80 import Util     ( thenCmp, zipWithEqual, mapAccumL )
  81 import Outputable
  82 \end{code}
  83
  84 %************************************************************************
  85 %*                                                                      *
  86 \subsection[Inst-collections]{LIE: a collection of Insts}
  87 %*                                                                      *
  88 %************************************************************************
  89
  90 \begin{code}
  91 type LIE = Bag Inst
  92
  93 isEmptyLIE        = isEmptyBag
  94 emptyLIE          = emptyBag
  95 unitLIE inst      = unitBag inst
  96 mkLIE insts       = listToBag insts
  97 plusLIE lie1 lie2 = lie1 `unionBags` lie2
  98 consLIE inst lie  = inst `consBag` lie
  99 plusLIEs lies     = unionManyBags lies
 100 lieToList         = bagToList
 101 listToLIE         = listToBag
 102
 103 zonkLIE :: LIE -> NF_TcM LIE
 104 zonkLIE lie = mapBagNF_Tc zonkInst lie
 105
 106 pprInsts :: [Inst] -> SDoc
 107 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
 108
 109
 110 pprInstsInFull insts
 111   = vcat (map go insts)
 112   where
 113     go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
 114 \end{code}
 115
 116 %************************************************************************
 117 %*                                                                      *
 118 \subsection[Inst-types]{@Inst@ types}
 119 %*                                                                      *
 120 %************************************************************************
 121
 122 An @Inst@ is either a dictionary, an instance of an overloaded
 123 literal, or an instance of an overloaded value.  We call the latter a
 124 ``method'' even though it may not correspond to a class operation.
 125 For example, we might have an instance of the @double@ function at
 126 type Int, represented by
 127
 128         Method 34 doubleId [Int] origin
 129
 130 \begin{code}
 131 data Inst
 132   = Dict
 133         Unique
 134         TcPredType
 135         InstLoc
 136
 137   | Method
 138         Unique
 139
 140         TcId    -- The overloaded function
 141                         -- This function will be a global, local, or ClassOpId;
 142                         --   inside instance decls (only) it can also be an InstId!
 143                         -- The id needn't be completely polymorphic.
 144                         -- You'll probably find its name (for documentation purposes)
 145                         --        inside the InstOrigin
 146
 147         [TcType]        -- The types to which its polymorphic tyvars
 148                         --      should be instantiated.
 149                         -- These types must saturate the Id's foralls.
 150
 151         TcThetaType     -- The (types of the) dictionaries to which the function
 152                         -- must be applied to get the method
 153
 154         TcTauType       -- The type of the method
 155
 156         InstLoc
 157
 158         -- INVARIANT: in (Method u f tys theta tau loc)
 159         --      type of (f tys dicts(from theta)) = tau
 160
 161   | LitInst
 162         Unique
 163         RenamedHsOverLit        -- The literal from the occurrence site
 164         TcType                  -- The type at which the literal is used
 165         InstLoc
 166
 167   | FunDep
 168         Unique
 169         Class           -- the class from which this arises
 170         [FunDep TcType]
 171         InstLoc
 172 \end{code}
 173
 174 Ordering
 175 ~~~~~~~~
 176 @Insts@ are ordered by their class/type info, rather than by their
 177 unique.  This allows the context-reduction mechanism to use standard finite
 178 maps to do their stuff.
 179
 180 \begin{code}
 181 instance Ord Inst where
 182   compare = cmpInst
 183
 184 instance Eq Inst where
 185   (==) i1 i2 = case i1 `cmpInst` i2 of
 186                  EQ    -> True
 187                  other -> False
 188
 189 cmpInst (Dict _ pred1 _)          (Dict _ pred2 _)          = (pred1 `compare` pred2)
 190 cmpInst (Dict _ _ _)              other                     = LT
 191
 192 cmpInst (Method _ _ _ _ _ _)      (Dict _ _ _)              = GT
 193 cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _) = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
 194 cmpInst (Method _ _ _ _ _ _)      other                     = LT
 195
 196 cmpInst (LitInst _ lit1 ty1 _)    (LitInst _ lit2 ty2 _)    = (lit1 `compare` lit2) `thenCmp` (ty1 `compare` ty2)
 197 cmpInst (LitInst _ _ _ _)         (FunDep _ _ _ _)          = LT
 198 cmpInst (LitInst _ _ _ _)         other                     = GT
 199
 200 cmpInst (FunDep _ clas1 fds1 _)   (FunDep _ clas2 fds2 _)   = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2)
 201 cmpInst (FunDep _ _ _ _)          other                     = GT
 202
 203 -- and they can only have HsInt or HsFracs in them.
 204 \end{code}
 205
 206
 207 Selection
 208 ~~~~~~~~~
 209 \begin{code}
 210 instLoc (Dict   u pred      loc) = loc
 211 instLoc (Method u _ _ _ _   loc) = loc
 212 instLoc (LitInst u lit ty   loc) = loc
 213 instLoc (FunDep _ _ _       loc) = loc
 214
 215 getDictPred_maybe (Dict _ p _) = Just p
 216 getDictPred_maybe _            = Nothing
 217
 218 getMethodTheta_maybe (Method _ _ _ theta _ _) = Just theta
 219 getMethodTheta_maybe _                        = Nothing
 220
 221 getDictClassTys (Dict u (Class clas tys) _) = (clas, tys)
 222
 223 getFunDeps (FunDep _ clas fds _) = Just (clas, fds)
 224 getFunDeps _ = Nothing
 225
 226 getFunDepsOfLIE lie = catMaybes (map getFunDeps (lieToList lie))
 227
 228 getIPsOfPred (IParam n ty) = [(n, ty)]
 229 getIPsOfPred _             = []
 230 getIPsOfTheta theta = concatMap getIPsOfPred theta
 231
 232 getIPs (Dict u (IParam n ty) loc) = [(n, ty)]
 233 getIPs (Method u id _ theta t loc) = getIPsOfTheta theta
 234 getIPs _ = []
 235
 236 getIPsOfLIE lie = concatMap getIPs (lieToList lie)
 237
 238 getAllFunDeps (FunDep _ clas fds _) = fds
 239 getAllFunDeps inst = map (\(n,ty) -> ([], [ty])) (getIPs inst)
 240
 241 getAllFunDepsOfLIE lie = concat (map getAllFunDeps (lieToList lie))
 242
 243 tyVarsOfInst :: Inst -> TcTyVarSet
 244 tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
 245 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 246                                          -- The id might have free type variables; in the case of
 247                                          -- locally-overloaded class methods, for example
 248 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
 249 tyVarsOfInst (FunDep _ _ fds _)
 250   = foldr unionVarSet emptyVarSet (map tyVarsOfFd fds)
 251   where tyVarsOfFd (ts1, ts2) =
 252             tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2
 253
 254 tyVarsOfInsts insts
 255   = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
 256
 257 tyVarsOfLIE lie
 258   = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
 259   where insts = lieToList lie
 260 \end{code}
 261
 262 Predicates
 263 ~~~~~~~~~~
 264 \begin{code}
 265 isDict :: Inst -> Bool
 266 isDict (Dict _ _ _) = True
 267 isDict other        = False
 268
 269 isClassDict :: Inst -> Bool
 270 isClassDict (Dict _ (Class _ _) _) = True
 271 isClassDict other                  = False
 272
 273 isMethod :: Inst -> Bool
 274 isMethod (Method _ _ _ _ _ _) = True
 275 isMethod other                = False
 276
 277 isMethodFor :: TcIdSet -> Inst -> Bool
 278 isMethodFor ids (Method uniq id tys _ _ loc) = id `elemVarSet` ids
 279 isMethodFor ids inst                         = False
 280
 281 isTyVarDict :: Inst -> Bool
 282 isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys
 283 isTyVarDict other                    = False
 284
 285 isStdClassTyVarDict (Dict _ (Class clas [ty]) _)
 286   = isStandardClass clas && isTyVarTy ty
 287 isStdClassTyVarDict other
 288   = False
 289
 290 notFunDep :: Inst -> Bool
 291 notFunDep (FunDep _ _ _ _) = False
 292 notFunDep other            = True
 293 \end{code}
 294
 295 Two predicates which deal with the case where class constraints don't
 296 necessarily result in bindings.  The first tells whether an @Inst@
 297 must be witnessed by an actual binding; the second tells whether an
 298 @Inst@ can be generalised over.
 299
 300 \begin{code}
 301 instBindingRequired :: Inst -> Bool
 302 instBindingRequired (Dict _ (Class clas _) _) = not (isNoDictClass clas)
 303 instBindingRequired (Dict _ (IParam _ _) _)   = False
 304 instBindingRequired other                     = True
 305
 306 instCanBeGeneralised :: Inst -> Bool
 307 instCanBeGeneralised (Dict _ (Class clas _) _) = not (isCcallishClass clas)
 308 instCanBeGeneralised other                     = True
 309 \end{code}
 310
 311
 312 Construction
 313 ~~~~~~~~~~~~
 314
 315 \begin{code}
 316 newDicts :: InstOrigin
 317          -> TcThetaType
 318          -> NF_TcM (LIE, [TcId])
 319 newDicts orig theta
 320   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 321     newDictsAtLoc loc theta     `thenNF_Tc` \ (dicts, ids) ->
 322     returnNF_Tc (listToBag dicts, ids)
 323
 324 newClassDicts :: InstOrigin
 325               -> [(Class,[TcType])]
 326               -> NF_TcM (LIE, [TcId])
 327 newClassDicts orig theta
 328   = newDicts orig (map (uncurry Class) theta)
 329
 330 -- Local function, similar to newDicts,
 331 -- but with slightly different interface
 332 newDictsAtLoc :: InstLoc
 333               -> TcThetaType
 334               -> NF_TcM ([Inst], [TcId])
 335 newDictsAtLoc loc theta =
 336  tcGetUniques (length theta)            `thenNF_Tc` \ new_uniqs ->
 337  let
 338   mk_dict u pred = Dict u pred loc
 339   dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
 340  in
 341  returnNF_Tc (dicts, map instToId dicts)
 342
 343 newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM Inst
 344 newDictFromOld (Dict _ _ loc) clas tys
 345   = tcGetUnique       `thenNF_Tc` \ uniq ->
 346     returnNF_Tc (Dict uniq (Class clas tys) loc)
 347
 348
 349 newMethod :: InstOrigin
 350           -> TcId
 351           -> [TcType]
 352           -> NF_TcM (LIE, TcId)
 353 newMethod orig id tys
 354   =     -- Get the Id type and instantiate it at the specified types
 355     let
 356         (tyvars, rho) = splitForAllTys (idType id)
 357         rho_ty        = substTy (mkTyVarSubst tyvars tys) rho
 358         (theta, tau)  = splitRhoTy rho_ty
 359     in
 360     newMethodWithGivenTy orig id tys theta tau  `thenNF_Tc` \ meth_inst ->
 361     returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
 362
 363 instOverloadedFun orig v arg_tys theta tau
 364 -- This is where we introduce new functional dependencies into the LIE
 365   = newMethodWithGivenTy orig v arg_tys theta tau       `thenNF_Tc` \ inst ->
 366     instFunDeps orig theta                              `thenNF_Tc` \ fds ->
 367     returnNF_Tc (instToId inst, mkLIE (inst : fds))
 368
 369 instFunDeps orig theta
 370   = tcGetUnique         `thenNF_Tc` \ uniq ->
 371     tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 372     let ifd (Class clas tys) =
 373             let fds = instantiateFdClassTys clas tys in
 374             if null fds then Nothing else Just (FunDep uniq clas fds loc)
 375         ifd _ = Nothing
 376     in returnNF_Tc (catMaybes (map ifd theta))
 377
 378 instFunDepsOfTheta theta
 379   = let ifd (Class clas tys) = instantiateFdClassTys clas tys
 380         ifd (IParam n ty)    = [([], [ty])]
 381     in concat (map ifd theta)
 382
 383 newMethodWithGivenTy orig id tys theta tau
 384   = tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 385     newMethodWith id tys theta tau loc
 386
 387 newMethodWith id tys theta tau loc
 388   = tcGetUnique         `thenNF_Tc` \ new_uniq ->
 389     returnNF_Tc (Method new_uniq id tys theta tau loc)
 390
 391 newMethodAtLoc :: InstLoc
 392                -> Id -> [TcType]
 393                -> NF_TcM (Inst, TcId)
 394 newMethodAtLoc loc real_id tys          -- Local function, similar to newMethod but with
 395                                         -- slightly different interface
 396   =     -- Get the Id type and instantiate it at the specified types
 397     tcGetUnique                                 `thenNF_Tc` \ new_uniq ->
 398     let
 399         (tyvars,rho) = splitForAllTys (idType real_id)
 400         rho_ty        = ASSERT( length tyvars == length tys )
 401                         substTy (mkTopTyVarSubst tyvars tys) rho
 402         (theta, tau)  = splitRhoTy rho_ty
 403         meth_inst     = Method new_uniq real_id tys theta tau loc
 404     in
 405     returnNF_Tc (meth_inst, instToId meth_inst)
 406 \end{code}
 407
 408 In newOverloadedLit we convert directly to an Int or Integer if we
 409 know that's what we want.  This may save some time, by not
 410 temporarily generating overloaded literals, but it won't catch all
 411 cases (the rest are caught in lookupInst).
 412
 413 \begin{code}
 414 newOverloadedLit :: InstOrigin
 415                  -> RenamedHsOverLit
 416                  -> TcType
 417                  -> NF_TcM (TcExpr, LIE)
 418 newOverloadedLit orig (HsIntegral i _) ty
 419   | isIntTy ty && inIntRange i          -- Short cut for Int
 420   = returnNF_Tc (int_lit, emptyLIE)
 421
 422   | isIntegerTy ty                      -- Short cut for Integer
 423   = returnNF_Tc (integer_lit, emptyLIE)
 424
 425   where
 426     int_lit     = HsLit (HsInt i)
 427     integer_lit = HsLit (HsInteger i)
 428
 429 newOverloadedLit orig lit ty            -- The general case
 430   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 431     tcGetUnique                 `thenNF_Tc` \ new_uniq ->
 432     let
 433         lit_inst = LitInst new_uniq lit ty loc
 434     in
 435     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 436 \end{code}
 437
 438 \begin{code}
 439 newFunDepFromDict dict
 440   | isClassDict dict
 441   = tcGetUnique         `thenNF_Tc` \ uniq ->
 442     let (clas, tys) = getDictClassTys dict
 443         fds = instantiateFdClassTys clas tys
 444         inst = FunDep uniq clas fds (instLoc dict)
 445     in
 446         if null fds then returnNF_Tc Nothing else returnNF_Tc (Just inst)
 447   | otherwise
 448   = returnNF_Tc Nothing
 449 \end{code}
 450
 451 \begin{code}
 452 newIPDict name ty loc
 453   = tcGetUnique         `thenNF_Tc` \ new_uniq ->
 454     let d = Dict new_uniq (IParam name ty) loc in
 455     returnNF_Tc d
 456 \end{code}
 457
 458 \begin{code}
 459 instToId :: Inst -> TcId
 460 instToId inst = instToIdBndr inst
 461
 462 instToIdBndr :: Inst -> TcId
 463 instToIdBndr (Dict u (Class clas tys) (_,loc,_))
 464   = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas tys) loc
 465 instToIdBndr (Dict u (IParam n ty) (_,loc,_))
 466   = ipToId n ty loc
 467
 468 instToIdBndr (Method u id tys theta tau (_,loc,_))
 469   = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
 470
 471 instToIdBndr (LitInst u list ty loc)
 472   = mkSysLocal SLIT("lit") u ty
 473
 474 instToIdBndr (FunDep u clas fds _)
 475   = mkSysLocal SLIT("FunDep") u voidTy
 476
 477 ipToId n ty loc
 478   = mkUserLocal (mkIPOcc (getOccName n)) (nameUnique n) (mkPredTy (IParam n ty)) loc
 479 \end{code}
 480
 481
 482 Zonking
 483 ~~~~~~~
 484 Zonking makes sure that the instance types are fully zonked,
 485 but doesn't do the same for the Id in a Method.  There's no
 486 need, and it's a lot of extra work.
 487
 488 \begin{code}
 489 zonkPred :: TcPredType -> NF_TcM TcPredType
 490 zonkPred (Class clas tys)
 491   = zonkTcTypes tys                     `thenNF_Tc` \ new_tys ->
 492     returnNF_Tc (Class clas new_tys)
 493 zonkPred (IParam n ty)
 494   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 495     returnNF_Tc (IParam n new_ty)
 496
 497 zonkInst :: Inst -> NF_TcM Inst
 498 zonkInst (Dict u pred loc)
 499   = zonkPred pred                       `thenNF_Tc` \ new_pred ->
 500     returnNF_Tc (Dict u new_pred loc)
 501
 502 zonkInst (Method u id tys theta tau loc)
 503   = zonkId id                   `thenNF_Tc` \ new_id ->
 504         -- Essential to zonk the id in case it's a local variable
 505         -- Can't use zonkIdOcc because the id might itself be
 506         -- an InstId, in which case it won't be in scope
 507
 508     zonkTcTypes tys             `thenNF_Tc` \ new_tys ->
 509     zonkTcThetaType theta       `thenNF_Tc` \ new_theta ->
 510     zonkTcType tau              `thenNF_Tc` \ new_tau ->
 511     returnNF_Tc (Method u new_id new_tys new_theta new_tau loc)
 512
 513 zonkInst (LitInst u lit ty loc)
 514   = zonkTcType ty                       `thenNF_Tc` \ new_ty ->
 515     returnNF_Tc (LitInst u lit new_ty loc)
 516
 517 zonkInst (FunDep u clas fds loc)
 518   = zonkFunDeps fds                     `thenNF_Tc` \ fds' ->
 519     returnNF_Tc (FunDep u clas fds' loc)
 520
 521 zonkInsts insts = mapNF_Tc zonkInst insts
 522
 523 zonkFunDeps fds = mapNF_Tc zonkFd fds
 524   where
 525   zonkFd (ts1, ts2)
 526     = zonkTcTypes ts1                   `thenNF_Tc` \ ts1' ->
 527       zonkTcTypes ts2                   `thenNF_Tc` \ ts2' ->
 528       returnNF_Tc (ts1', ts2')
 529
 530 zonkTvFunDeps fds = mapNF_Tc zonkFd fds
 531   where
 532   zonkFd (tvs1, tvs2)
 533     = zonkTcTyVars tvs1                 `thenNF_Tc` \ tvs1' ->
 534       zonkTcTyVars tvs2                 `thenNF_Tc` \ tvs2' ->
 535       returnNF_Tc (tvs1', tvs2')
 536 \end{code}
 537
 538
 539 Printing
 540 ~~~~~~~~
 541 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 542 relevant in error messages.
 543
 544 \begin{code}
 545 instance Outputable Inst where
 546     ppr inst = pprInst inst
 547
 548 pprInst (LitInst u lit ty loc)
 549   = hsep [ppr lit, ptext SLIT("at"), ppr ty, show_uniq u]
 550
 551 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 552
 553 pprInst m@(Method u id tys theta tau loc)
 554   = hsep [ppr id, ptext SLIT("at"),
 555           brackets (interppSP tys) {- ,
 556           ppr theta, ppr tau,
 557           show_uniq u,
 558           ppr (instToId m) -}]
 559
 560 pprInst (FunDep _ clas fds loc)
 561   = hsep [ppr clas, ppr fds]
 562
 563 tidyPred :: TidyEnv -> TcPredType -> (TidyEnv, TcPredType)
 564 tidyPred env (Class clas tys)
 565   = (env', Class clas tys')
 566   where
 567     (env', tys') = tidyOpenTypes env tys
 568 tidyPred env (IParam n ty)
 569   = (env', IParam n ty')
 570   where
 571     (env', ty') = tidyOpenType env ty
 572
 573 tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
 574 tidyInst env (LitInst u lit ty loc)
 575   = (env', LitInst u lit ty' loc)
 576   where
 577     (env', ty') = tidyOpenType env ty
 578
 579 tidyInst env (Dict u pred loc)
 580   = (env', Dict u pred' loc)
 581   where
 582     (env', pred') = tidyPred env pred
 583
 584 tidyInst env (Method u id tys theta tau loc)
 585   = (env', Method u id tys' theta tau loc)
 586                 -- Leave theta, tau alone cos we don't print them
 587   where
 588     (env', tys') = tidyOpenTypes env tys
 589
 590 -- this case shouldn't arise... (we never print fundeps)
 591 tidyInst env fd@(FunDep _ clas fds loc)
 592   = (env, fd)
 593
 594 tidyInsts env insts = mapAccumL tidyInst env insts
 595
 596 show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
 597 \end{code}
 598
 599
 600 %************************************************************************
 601 %*                                                                      *
 602 \subsection[InstEnv-types]{Type declarations}
 603 %*                                                                      *
 604 %************************************************************************
 605
 606 \begin{code}
 607 data LookupInstResult s
 608   = NoInstance
 609   | SimpleInst TcExpr           -- Just a variable, type application, or literal
 610   | GenInst    [Inst] TcExpr    -- The expression and its needed insts
 611
 612 lookupInst :: Inst
 613            -> NF_TcM (LookupInstResult s)
 614
 615 -- Dictionaries
 616
 617 lookupInst dict@(Dict _ (Class clas tys) loc)
 618   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 619     case lookupInstEnv inst_env clas tys of
 620
 621       FoundInst tenv dfun_id
 622         -> let
 623                 subst         = mkSubst (mkInScopeSet (tyVarsOfTypes tys)) tenv
 624                 (tyvars, rho) = splitForAllTys (idType dfun_id)
 625                 ty_args       = map subst_tv tyvars
 626                 dfun_rho      = substTy subst rho
 627                 (theta, _)    = splitRhoTy dfun_rho
 628                 ty_app        = mkHsTyApp (HsVar dfun_id) ty_args
 629                 subst_tv tv   = case lookupSubstEnv tenv tv of
 630                                    Just (DoneTy ty)  -> ty
 631                                         -- tenv should bind all the tyvars
 632            in
 633            if null theta then
 634                 returnNF_Tc (SimpleInst ty_app)
 635            else
 636            newDictsAtLoc loc theta      `thenNF_Tc` \ (dicts, dict_ids) ->
 637            let
 638                 rhs = mkHsDictApp ty_app dict_ids
 639            in
 640            returnNF_Tc (GenInst dicts rhs)
 641
 642       other     -> returnNF_Tc NoInstance
 643 lookupInst dict@(Dict _ _ loc) = returnNF_Tc NoInstance
 644
 645 -- Methods
 646
 647 lookupInst inst@(Method _ id tys theta _ loc)
 648   = newDictsAtLoc loc theta             `thenNF_Tc` \ (dicts, dict_ids) ->
 649     returnNF_Tc (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) dict_ids))
 650
 651 -- Literals
 652
 653 lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
 654   | isIntTy ty && in_int_range                  -- Short cut for Int
 655   = returnNF_Tc (GenInst [] int_lit)
 656         -- GenInst, not SimpleInst, because int_lit is actually a constructor application
 657
 658   | isIntegerTy ty                              -- Short cut for Integer
 659   = returnNF_Tc (GenInst [] integer_lit)
 660
 661   | in_int_range                                -- It's overloaded but small enough to fit into an Int
 662   && from_integer_name `hasKey` fromIntegerClassOpKey   -- And it's the built-in prelude fromInteger
 663                                                         -- (i.e. no funny business with user-defined
 664                                                         --  packages of numeric classes)
 665   =     -- So we can use the Prelude fromInt
 666     tcLookupGlobalId fromIntClassOpName `thenNF_Tc` \ from_int ->
 667     newMethodAtLoc loc from_int [ty]            `thenNF_Tc` \ (method_inst, method_id) ->
 668     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
 669
 670   | otherwise                                   -- Alas, it is overloaded and a big literal!
 671   = tcLookupGlobalId from_integer_name          `thenNF_Tc` \ from_integer ->
 672     newMethodAtLoc loc from_integer [ty]        `thenNF_Tc` \ (method_inst, method_id) ->
 673     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
 674   where
 675     in_int_range   = inIntRange i
 676     integer_lit    = HsLit (HsInteger i)
 677     int_lit        = HsLit (HsInt i)
 678
 679 -- similar idea for overloaded floating point literals: if the literal is
 680 -- *definitely* a float or a double, generate the real thing here.
 681 -- This is essential  (see nofib/spectral/nucleic).
 682
 683 lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
 684   | isFloatTy ty    = returnNF_Tc (GenInst [] float_lit)
 685   | isDoubleTy ty   = returnNF_Tc (GenInst [] double_lit)
 686
 687   | otherwise
 688   = tcLookupGlobalId from_rat_name              `thenNF_Tc` \ from_rational ->
 689     newMethodAtLoc loc from_rational [ty]       `thenNF_Tc` \ (method_inst, method_id) ->
 690     let
 691         rational_ty  = funArgTy (idType method_id)
 692         rational_lit = HsLit (HsRat f rational_ty)
 693     in
 694     returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit))
 695
 696   where
 697     floatprim_lit  = HsLit (HsFloatPrim f)
 698     float_lit      = mkHsConApp floatDataCon [] [floatprim_lit]
 699     doubleprim_lit = HsLit (HsDoublePrim f)
 700     double_lit     = mkHsConApp doubleDataCon [] [doubleprim_lit]
 701
 702 -- there are no `instances' of functional dependencies or implicit params
 703
 704 lookupInst _  = returnNF_Tc NoInstance
 705
 706 \end{code}
 707
 708 There is a second, simpler interface, when you want an instance of a
 709 class at a given nullary type constructor.  It just returns the
 710 appropriate dictionary if it exists.  It is used only when resolving
 711 ambiguous dictionaries.
 712
 713 \begin{code}
 714 lookupSimpleInst :: Class
 715                  -> [Type]                              -- Look up (c,t)
 716                  -> NF_TcM (Maybe [(Class,[Type])])     -- Here are the needed (c,t)s
 717
 718 lookupSimpleInst clas tys
 719   = tcGetInstEnv                `thenNF_Tc` \ inst_env ->
 720     case lookupInstEnv inst_env clas tys of
 721       FoundInst tenv dfun
 722         -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
 723         where
 724            (_, theta, _) = splitSigmaTy (idType dfun)
 725            theta' = map (\(Class clas tys) -> (clas,tys)) theta
 726
 727       other  -> returnNF_Tc Nothing
 728 \end{code}
 729
 730