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