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