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