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