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