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