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         getFunDeps, getFunDepsOfLIE,
  22         getIPs, getIPsOfLIE,
  23         getAllFunDeps, getAllFunDepsOfLIE,
  24         partitionLIEbyMeth,
  25
  26         lookupInst, lookupSimpleInst, LookupInstResult(..),
  27
  28         isDict, isTyVarDict, isStdClassTyVarDict, isMethodFor, notFunDep,
  29         instBindingRequired, instCanBeGeneralised,
  30
  31         zonkInst, zonkFunDeps, zonkTvFunDeps, instToId, instToIdBndr,
  32
  33         InstOrigin(..), InstLoc, pprInstLoc
  34     ) where
  35
  36 #include "HsVersions.h"
  37
  38 import HsSyn    ( HsLit(..), HsExpr(..) )
  39 import RnHsSyn  ( RenamedArithSeqInfo, RenamedHsExpr, RenamedPat )
  40 import TcHsSyn  ( TcExpr, TcId,
  41                   mkHsTyApp, mkHsDictApp, zonkId
  42                 )
  43 import TcMonad
  44 import TcEnv    ( TcIdSet, tcLookupValueByKey, tcLookupTyConByKey )
  45 import TcType   ( TcThetaType,
  46                   TcType, TcTauType, TcTyVarSet,
  47                   zonkTcTyVars, zonkTcType, zonkTcTypes,
  48                   zonkTcThetaType
  49                 )
  50 import Bag
  51 import Class    ( classInstEnv, Class )
  52 import FunDeps  ( instantiateFdClassTys )
  53 import Id       ( Id, idFreeTyVars, idType, mkUserLocal, mkSysLocal )
  54 import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
  55 import Name     ( OccName, Name, mkDictOcc, mkMethodOcc, getOccName, nameUnique )
  56 import PprType  ( pprPred )
  57 import InstEnv  ( InstEnv, lookupInstEnv )
  58 import SrcLoc   ( SrcLoc )
  59 import Type     ( Type, PredType(..), ThetaType,
  60                   mkTyVarTy, isTyVarTy, mkDictTy, mkPredTy,
  61                   splitForAllTys, splitSigmaTy,
  62                   splitRhoTy, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
  63                   mkSynTy, tidyOpenType, tidyOpenTypes
  64                 )
  65 import InstEnv  ( InstEnv )
  66 import Subst    ( emptyInScopeSet, mkSubst,
  67                   substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst
  68                 )
  69 import TyCon    ( TyCon )
  70 import Var      ( TyVar )
  71 import VarEnv   ( lookupVarEnv, TidyEnv,
  72                   lookupSubstEnv, SubstResult(..)
  73                 )
  74 import VarSet   ( elemVarSet, emptyVarSet, unionVarSet )
  75 import TysPrim    ( intPrimTy, floatPrimTy, doublePrimTy )
  76 import TysWiredIn ( intDataCon, isIntTy, inIntRange,
  77                     floatDataCon, isFloatTy,
  78                     doubleDataCon, isDoubleTy,
  79                     integerTy, isIntegerTy
  80                   )
  81 import Unique   ( fromRationalClassOpKey, rationalTyConKey,
  82                   fromIntClassOpKey, fromIntegerClassOpKey, Unique
  83                 )
  84 import Maybes   ( expectJust )
  85 import List     ( partition )
  86 import Maybe    ( catMaybes )
  87 import Util     ( thenCmp, zipWithEqual, mapAccumL )
  88 import Outputable
  89 \end{code}
  90
  91 %************************************************************************
  92 %*                                                                      *
  93 \subsection[Inst-collections]{LIE: a collection of Insts}
  94 %*                                                                      *
  95 %************************************************************************
  96
  97 \begin{code}
  98 type LIE = Bag Inst
  99
 100 isEmptyLIE        = isEmptyBag
 101 emptyLIE          = emptyBag
 102 unitLIE inst      = unitBag inst
 103 mkLIE insts       = listToBag insts
 104 plusLIE lie1 lie2 = lie1 `unionBags` lie2
 105 consLIE inst lie  = inst `consBag` lie
 106 plusLIEs lies     = unionManyBags lies
 107 lieToList         = bagToList
 108 listToLIE         = listToBag
 109
 110 zonkLIE :: LIE -> NF_TcM s LIE
 111 zonkLIE lie = mapBagNF_Tc zonkInst lie
 112
 113 pprInsts :: [Inst] -> SDoc
 114 pprInsts insts = parens (sep (punctuate comma (map pprInst insts)))
 115
 116
 117 pprInstsInFull insts
 118   = vcat (map go insts)
 119   where
 120     go inst = quotes (ppr inst) <+> pprInstLoc (instLoc inst)
 121 \end{code}
 122
 123 %************************************************************************
 124 %*                                                                      *
 125 \subsection[Inst-types]{@Inst@ types}
 126 %*                                                                      *
 127 %************************************************************************
 128
 129 An @Inst@ is either a dictionary, an instance of an overloaded
 130 literal, or an instance of an overloaded value.  We call the latter a
 131 ``method'' even though it may not correspond to a class operation.
 132 For example, we might have an instance of the @double@ function at
 133 type Int, represented by
 134
 135         Method 34 doubleId [Int] origin
 136
 137 \begin{code}
 138 data Inst
 139   = Dict
 140         Unique
 141         TcPredType
 142         InstLoc
 143
 144   | Method
 145         Unique
 146
 147         TcId    -- The overloaded function
 148                         -- This function will be a global, local, or ClassOpId;
 149                         --   inside instance decls (only) it can also be an InstId!
 150                         -- The id needn't be completely polymorphic.
 151                         -- You'll probably find its name (for documentation purposes)
 152                         --        inside the InstOrigin
 153
 154         [TcType]        -- The types to which its polymorphic tyvars
 155                         --      should be instantiated.
 156                         -- These types must saturate the Id's foralls.
 157
 158         TcThetaType     -- The (types of the) dictionaries to which the function
 159                         -- must be applied to get the method
 160
 161         TcTauType       -- The type of the method
 162
 163         InstLoc
 164
 165         -- INVARIANT: in (Method u f tys theta tau loc)
 166         --      type of (f tys dicts(from theta)) = tau
 167
 168   | LitInst
 169         Unique
 170         OverloadedLit
 171         TcType          -- The type at which the literal is used
 172         InstLoc
 173
 174   | FunDep
 175         Class           -- the class from which this arises
 176         [([TcType], [TcType])]
 177         InstLoc
 178
 179 data OverloadedLit
 180   = OverloadedIntegral   Integer        -- The number
 181   | OverloadedFractional Rational       -- The number
 182 \end{code}
 183
 184 Ordering
 185 ~~~~~~~~
 186 @Insts@ are ordered by their class/type info, rather than by their
 187 unique.  This allows the context-reduction mechanism to use standard finite
 188 maps to do their stuff.
 189
 190 \begin{code}
 191 instance Ord Inst where
 192   compare = cmpInst
 193 instance Ord PredType where
 194   compare = cmpPred
 195
 196 instance Eq Inst where
 197   (==) i1 i2 = case i1 `cmpInst` i2 of
 198                  EQ    -> True
 199                  other -> False
 200 instance Eq PredType where
 201   (==) p1 p2 = case p1 `cmpPred` p2 of
 202                  EQ    -> True
 203                  other -> False
 204
 205 cmpInst  (Dict _ pred1 _) (Dict _ pred2 _)
 206   = (pred1 `cmpPred` pred2)
 207 cmpInst (Dict _ _ _) other
 208   = LT
 209
 210 cmpInst (Method _ _ _ _ _ _) (Dict _ _ _)
 211   = GT
 212 cmpInst (Method _ id1 tys1 _ _ _) (Method _ id2 tys2 _ _ _)
 213   = (id1 `compare` id2) `thenCmp` (tys1 `compare` tys2)
 214 cmpInst (Method _ _ _ _ _ _) other
 215   = LT
 216
 217 cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _)
 218   = (lit1 `cmpOverLit` lit2) `thenCmp` (ty1 `compare` ty2)
 219 cmpInst (LitInst _ _ _ _) (FunDep _ _ _)
 220   = LT
 221 cmpInst (LitInst _ _ _ _) other
 222   = GT
 223
 224 cmpInst (FunDep clas1 fds1 _) (FunDep clas2 fds2 _)
 225   = (clas1 `compare` clas2) `thenCmp` (fds1 `compare` fds2)
 226 cmpInst (FunDep _ _ _) other
 227   = GT
 228
 229 cmpPred (Class c1 tys1) (Class c2 tys2)
 230   = (c1 `compare` c2) `thenCmp` (tys1 `compare` tys2)
 231 cmpPred (IParam n1 ty1) (IParam n2 ty2)
 232   = (n1 `compare` n2) `thenCmp` (ty1 `compare` ty2)
 233 cmpPred (Class _ _) (IParam _ _) = LT
 234 cmpPred _           _            = GT
 235
 236 cmpOverLit (OverloadedIntegral   i1) (OverloadedIntegral   i2) = i1 `compare` i2
 237 cmpOverLit (OverloadedFractional f1) (OverloadedFractional f2) = f1 `compare` f2
 238 cmpOverLit (OverloadedIntegral _)    (OverloadedFractional _)  = LT
 239 cmpOverLit (OverloadedFractional _)  (OverloadedIntegral _)    = GT
 240 \end{code}
 241
 242
 243 Selection
 244 ~~~~~~~~~
 245 \begin{code}
 246 instLoc (Dict   u pred      loc) = loc
 247 instLoc (Method u _ _ _ _   loc) = loc
 248 instLoc (LitInst u lit ty   loc) = loc
 249 instLoc (FunDep _ _         loc) = loc
 250
 251 getDictClassTys (Dict u (Class clas tys) _) = (clas, tys)
 252
 253 getFunDeps (FunDep clas fds _) = Just (clas, fds)
 254 getFunDeps _ = Nothing
 255
 256 getFunDepsOfLIE lie = catMaybes (map getFunDeps (lieToList lie))
 257
 258 getIPsOfPred (IParam n ty) = [(n, ty)]
 259 getIPsOfPred _             = []
 260 getIPsOfTheta theta = concatMap getIPsOfPred theta
 261
 262 getIPs (Dict u (IParam n ty) loc) = [(n, ty)]
 263 getIPs (Method u id _ theta t loc) = getIPsOfTheta theta
 264 getIPs _ = []
 265
 266 getIPsOfLIE lie = concatMap getIPs (lieToList lie)
 267
 268 getAllFunDeps (FunDep clas fds _) = fds
 269 getAllFunDeps inst = map (\(n,ty) -> ([], [ty])) (getIPs inst)
 270
 271 getAllFunDepsOfLIE lie = concat (map getAllFunDeps (lieToList lie))
 272
 273 partitionLIEbyMeth pred lie
 274   = foldlTc (partMethod pred) (emptyLIE, emptyLIE) insts
 275   where insts = lieToList lie
 276
 277 partMethod pred (ips, lie) m@(Method u id tys theta tau loc)
 278   = if null ips_ then
 279         returnTc (ips, consLIE m lie)
 280     else if null theta_ then
 281         returnTc (consLIE m ips, lie)
 282     else
 283         newMethodWith id tys theta_ tau loc         `thenTc` \ new_m2 ->
 284         let id_m1 = instToIdBndr new_m2
 285             new_m1 = Method u id_m1 {- tys -} [] ips_ tau loc in
 286         -- newMethodWith id_m1 tys ips_ tau loc     `thenTc` \ new_m1 ->
 287         returnTc (consLIE new_m1 ips, consLIE new_m2 lie)
 288   where (ips_, theta_) = partition pred theta
 289
 290 tyVarsOfInst :: Inst -> TcTyVarSet
 291 tyVarsOfInst (Dict _ pred _)         = tyVarsOfPred pred
 292 tyVarsOfInst (Method _ id tys _ _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
 293                                          -- The id might have free type variables; in the case of
 294                                          -- locally-overloaded class methods, for example
 295 tyVarsOfInst (LitInst _ _ ty _)      = tyVarsOfType  ty
 296 tyVarsOfInst (FunDep _ fds _)
 297   = foldr unionVarSet emptyVarSet (map tyVarsOfFd fds)
 298   where tyVarsOfFd (ts1, ts2) =
 299             tyVarsOfTypes ts1 `unionVarSet` tyVarsOfTypes ts2
 300
 301 tyVarsOfInsts insts
 302   = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
 303
 304 tyVarsOfLIE lie
 305   = foldr unionVarSet emptyVarSet (map tyVarsOfInst insts)
 306   where insts = lieToList lie
 307 \end{code}
 308
 309 Predicates
 310 ~~~~~~~~~~
 311 \begin{code}
 312 isDict :: Inst -> Bool
 313 isDict (Dict _ (Class _ _) _) = True
 314 isDict other          = False
 315
 316 isMethodFor :: TcIdSet -> Inst -> Bool
 317 isMethodFor ids (Method uniq id tys _ _ loc)
 318   = id `elemVarSet` ids
 319 isMethodFor ids inst
 320   = False
 321
 322 isTyVarDict :: Inst -> Bool
 323 isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys
 324 isTyVarDict other                    = False
 325
 326 isStdClassTyVarDict (Dict _ (Class clas [ty]) _)
 327   = isStandardClass clas && isTyVarTy ty
 328 isStdClassTyVarDict other
 329   = False
 330
 331 notFunDep :: Inst -> Bool
 332 notFunDep (FunDep _ _ _) = False
 333 notFunDep other          = True
 334 \end{code}
 335
 336 Two predicates which deal with the case where class constraints don't
 337 necessarily result in bindings.  The first tells whether an @Inst@
 338 must be witnessed by an actual binding; the second tells whether an
 339 @Inst@ can be generalised over.
 340
 341 \begin{code}
 342 instBindingRequired :: Inst -> Bool
 343 instBindingRequired (Dict _ (Class clas _) _) = not (isNoDictClass clas)
 344 instBindingRequired (Dict _ (IParam _ _) _)   = False
 345 instBindingRequired other                     = True
 346
 347 instCanBeGeneralised :: Inst -> Bool
 348 instCanBeGeneralised (Dict _ (Class clas _) _) = not (isCcallishClass clas)
 349 instCanBeGeneralised other                     = True
 350 \end{code}
 351
 352
 353 Construction
 354 ~~~~~~~~~~~~
 355
 356 \begin{code}
 357 newDicts :: InstOrigin
 358          -> TcThetaType
 359          -> NF_TcM s (LIE, [TcId])
 360 newDicts orig theta
 361   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 362     newDictsAtLoc loc theta     `thenNF_Tc` \ (dicts, ids) ->
 363     returnNF_Tc (listToBag dicts, ids)
 364
 365 newClassDicts :: InstOrigin
 366               -> [(Class,[TcType])]
 367               -> NF_TcM s (LIE, [TcId])
 368 newClassDicts orig theta
 369   = newDicts orig (map (uncurry Class) theta)
 370
 371 -- Local function, similar to newDicts,
 372 -- but with slightly different interface
 373 newDictsAtLoc :: InstLoc
 374               -> TcThetaType
 375               -> NF_TcM s ([Inst], [TcId])
 376 newDictsAtLoc loc theta =
 377  tcGetUniques (length theta)            `thenNF_Tc` \ new_uniqs ->
 378  let
 379   mk_dict u pred = Dict u pred loc
 380   dicts = zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta
 381  in
 382  returnNF_Tc (dicts, map instToId dicts)
 383
 384 newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM s Inst
 385 newDictFromOld (Dict _ _ loc) clas tys
 386   = tcGetUnique       `thenNF_Tc` \ uniq ->
 387     returnNF_Tc (Dict uniq (Class clas tys) loc)
 388
 389
 390 newMethod :: InstOrigin
 391           -> TcId
 392           -> [TcType]
 393           -> NF_TcM s (LIE, TcId)
 394 newMethod orig id tys
 395   =     -- Get the Id type and instantiate it at the specified types
 396     let
 397         (tyvars, rho) = splitForAllTys (idType id)
 398         rho_ty        = substTy (mkTyVarSubst tyvars tys) rho
 399         (theta, tau)  = splitRhoTy rho_ty
 400     in
 401     newMethodWithGivenTy orig id tys theta tau  `thenNF_Tc` \ meth_inst ->
 402     returnNF_Tc (unitLIE meth_inst, instToId meth_inst)
 403
 404 instOverloadedFun orig (HsVar v) arg_tys theta tau
 405   = newMethodWithGivenTy orig v arg_tys theta tau       `thenNF_Tc` \ inst ->
 406     instFunDeps orig theta                              `thenNF_Tc` \ fds ->
 407     returnNF_Tc (HsVar (instToId inst), mkLIE (inst : fds))
 408
 409 instFunDeps orig theta
 410   = tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 411     let ifd (Class clas tys) =
 412             let fds = instantiateFdClassTys clas tys in
 413             if null fds then Nothing else Just (FunDep clas fds loc)
 414         ifd _ = Nothing
 415     in returnNF_Tc (catMaybes (map ifd theta))
 416
 417 newMethodWithGivenTy orig id tys theta tau
 418   = tcGetInstLoc orig   `thenNF_Tc` \ loc ->
 419     newMethodWith id tys theta tau loc
 420
 421 newMethodWith id tys theta tau loc
 422   = tcGetUnique         `thenNF_Tc` \ new_uniq ->
 423     returnNF_Tc (Method new_uniq id tys theta tau loc)
 424
 425 newMethodAtLoc :: InstLoc
 426                -> Id -> [TcType]
 427                -> NF_TcM s (Inst, TcId)
 428 newMethodAtLoc loc real_id tys          -- Local function, similar to newMethod but with
 429                                         -- slightly different interface
 430   =     -- Get the Id type and instantiate it at the specified types
 431     tcGetUnique                                 `thenNF_Tc` \ new_uniq ->
 432     let
 433         (tyvars,rho) = splitForAllTys (idType real_id)
 434         rho_ty        = ASSERT( length tyvars == length tys )
 435                         substTy (mkTopTyVarSubst tyvars tys) rho
 436         (theta, tau)  = splitRhoTy rho_ty
 437         meth_inst     = Method new_uniq real_id tys theta tau loc
 438     in
 439     returnNF_Tc (meth_inst, instToId meth_inst)
 440 \end{code}
 441
 442 In newOverloadedLit we convert directly to an Int or Integer if we
 443 know that's what we want.  This may save some time, by not
 444 temporarily generating overloaded literals, but it won't catch all
 445 cases (the rest are caught in lookupInst).
 446
 447 \begin{code}
 448 newOverloadedLit :: InstOrigin
 449                  -> OverloadedLit
 450                  -> TcType
 451                  -> NF_TcM s (TcExpr, LIE)
 452 newOverloadedLit orig (OverloadedIntegral i) ty
 453   | isIntTy ty && inIntRange i          -- Short cut for Int
 454   = returnNF_Tc (int_lit, emptyLIE)
 455
 456   | isIntegerTy ty                      -- Short cut for Integer
 457   = returnNF_Tc (integer_lit, emptyLIE)
 458
 459   where
 460     intprim_lit    = HsLitOut (HsIntPrim i) intPrimTy
 461     integer_lit    = HsLitOut (HsInt i) integerTy
 462     int_lit        = HsCon intDataCon [] [intprim_lit]
 463
 464 newOverloadedLit orig lit ty            -- The general case
 465   = tcGetInstLoc orig           `thenNF_Tc` \ loc ->
 466     tcGetUnique                 `thenNF_Tc` \ new_uniq ->
 467     let
 468         lit_inst = LitInst new_uniq lit ty loc
 469     in
 470     returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst)
 471 \end{code}
 472
 473 \begin{code}
 474 newIPDict name ty loc
 475   = tcGetUnique         `thenNF_Tc` \ new_uniq ->
 476     let d = Dict new_uniq (IParam name ty) loc in
 477     returnNF_Tc d
 478 \end{code}
 479
 480 \begin{code}
 481 instToId :: Inst -> TcId
 482 instToId inst = instToIdBndr inst
 483
 484 instToIdBndr :: Inst -> TcId
 485 instToIdBndr (Dict u (Class clas ty) (_,loc,_))
 486   = mkUserLocal (mkDictOcc (getOccName clas)) u (mkDictTy clas ty) loc
 487 instToIdBndr (Dict u (IParam n ty) (_,loc,_))
 488 --  = mkUserLocal (mkIPOcc (getOccName n)) u (mkPredTy (IParam n ty)) loc
 489   = mkUserLocal (getOccName n) (nameUnique n) (mkPredTy (IParam n ty)) loc
 490 --  = mkVanillaId n ty
 491
 492 instToIdBndr (Method u id tys theta tau (_,loc,_))
 493   = mkUserLocal (mkMethodOcc (getOccName id)) u tau loc
 494
 495 instToIdBndr (LitInst u list ty loc)
 496   = mkSysLocal SLIT("lit") u ty
 497
 498 instToIdBndr (FunDep clas fds _)
 499   = panic "FunDep escaped!!!"
 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 zonkFunDeps fds = mapNF_Tc zonkFd fds
 543   where
 544   zonkFd (ts1, ts2)
 545     = zonkTcTypes ts1                   `thenNF_Tc` \ ts1' ->
 546       zonkTcTypes ts2                   `thenNF_Tc` \ ts2' ->
 547       returnNF_Tc (ts1', ts2')
 548
 549 zonkTvFunDeps fds = mapNF_Tc zonkFd fds
 550   where
 551   zonkFd (tvs1, tvs2)
 552     = zonkTcTyVars tvs1                 `thenNF_Tc` \ tvs1' ->
 553       zonkTcTyVars tvs2                 `thenNF_Tc` \ tvs2' ->
 554       returnNF_Tc (tvs1', tvs2')
 555 \end{code}
 556
 557
 558 Printing
 559 ~~~~~~~~
 560 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 561 relevant in error messages.
 562
 563 \begin{code}
 564 instance Outputable Inst where
 565     ppr inst = pprInst inst
 566
 567 pprInst (LitInst u lit ty loc)
 568   = hsep [case lit of
 569               OverloadedIntegral   i -> integer i
 570               OverloadedFractional f -> rational f,
 571            ptext SLIT("at"),
 572            ppr ty,
 573            show_uniq u]
 574
 575 pprInst (Dict u pred loc) = pprPred pred <+> show_uniq u
 576
 577 pprInst (Method u id tys _ _ loc)
 578   = hsep [ppr id, ptext SLIT("at"),
 579           brackets (interppSP tys),
 580           show_uniq u]
 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        = HsCon 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      = HsCon floatDataCon [] [floatprim_lit]
 739     doubleprim_lit = HsLitOut (HsDoublePrim f) doublePrimTy
 740     double_lit     = HsCon 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}