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